Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added init script for chicken-install stuff for guix

This commit is contained in:
retropikzel 2024-05-17 17:34:02 +03:00
parent 5c327c8095
commit 75213ab432
12 changed files with 151 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -13,6 +13,8 @@ import
test/import test/import
pffi-define pffi-define
test/pffi-define test/pffi-define
size-of
test/size-of
retropikzel/pffi/*/*.c retropikzel/pffi/*/*.c
retropikzel/pffi/*/*.o* retropikzel/pffi/*/*.o*
retropikzel/pffi/*/*.so retropikzel/pffi/*/*.so

16
Makefile
View File

@ -1,4 +1,4 @@
.PHONY: test/import.scm test/import.scm test/pffi-define.scm .PHONY: test/import.scm test/import.scm test/pffi-define.scm test/size-of.scm
VERSION=v0-1-0 VERSION=v0-1-0
SASH=sash -c -r7 -L . SASH=sash -c -r7 -L .
@ -32,8 +32,8 @@ build-main-chicken:
${CHICKEN} -sJ retropikzel.pffi.${VERSION}.main.scm ${CHICKEN} -sJ retropikzel.pffi.${VERSION}.main.scm
build-main-gambit: build-main-gambit:
#${GAMBIT} -obj retropikzel/pffi/${VERSION}/gambit.scm ${GAMBIT} -obj retropikzel/pffi/${VERSION}/gambit.scm
#${GAMBIT} -obj retropikzel/pffi/${VERSION}/main.sld ${GAMBIT} -obj retropikzel/pffi/${VERSION}/main.sld
#cp retropikzel/pffi/${VERSION}/*.o* test/ #cp retropikzel/pffi/${VERSION}/*.o* test/
build-main-gerbil: build-main-gerbil:
@ -60,24 +60,26 @@ test/import.scm: clean build
#${RACKET} $@ #${RACKET} $@
${STKLOS} $@ ${STKLOS} $@
${KAWA} $@ ${KAWA} $@
#${CYCLONE} $@ && test/import ${CYCLONE} $@ && test/import
#${GAMBIT} -exe $@ && ./test/import #${GAMBIT} -exe $@ && ./test/import
${CHICKEN} $@ && ./test/import ${CHICKEN} $@ && ./test/import
#${GERBIL} $@ #${GERBIL} $@
test/import.scm: clean build
${GAMBIT} -exe $@ && ./test/import
test/pffi-define.scm: clean build test/pffi-define.scm: clean build
${SASH} $@ ${SASH} $@
${GUILE} $@ ${GUILE} $@
${KAWA} $@ ${KAWA} $@
${CHICKEN} -L -lcurl $@ && ./test/pffi-define
test/pffi-define.scm: clean build test/pffi-define.scm: clean build
${CHICKEN} $@ && ./test/pffi-define ${CYCLONE} -CLNK -lcurl $@ && test/pffi-define
test/size-of.scm: test/size-of.scm:
${SASH} $@ ${SASH} $@
${GUILE} $@ ${GUILE} $@
#${RACKET} $@
#${STKLOS} $@
${KAWA} $@ ${KAWA} $@
test/pointer-set-get.scm: test/pointer-set-get.scm:

7
guix-chicken-init.sh Normal file
View File

@ -0,0 +1,7 @@
#!/usr/bin/env bash
export CHICKEN_INSTALL_REPOSITORY=${HOME}/eggs/lib/chicken/5
export CHICKEN_REPOSITORY_PATH=${CHICKEN_REPOSITORY_PATH}:${HOME}/eggs/lib/chicken/5
chicken-install -init ${HOME}/eggs/lib/chicken/5
chicken-install r7rs

81
retropikzel/pffi/v0-1-0/chicken.scm
View File

@ -3,7 +3,9 @@
(import (scheme base) (import (scheme base)
(scheme write) (scheme write)
(scheme file) (scheme file)
(scheme process-context)) (scheme process-context)
(chicken foreign)
(chicken syntax))
(export pffi-shared-object-load (export pffi-shared-object-load
pffi-define pffi-define
pffi-size-of pffi-size-of
@ -22,16 +24,73 @@
(define pffi-type->native-type (define pffi-type->native-type
(lambda (type) (lambda (type)
(error "Not defined"))) (cond ((equal? type 'int8) 'byte)
((equal? type 'uint8) 'unsigned-byte)
((equal? type 'int16) 'int16_t)
((equal? type 'uint16) 'uint16_t)
((equal? type 'int32) 'int32)
((equal? type 'uint32) 'unsigned-int32)
((equal? type 'int64) 'integer-64)
((equal? type 'uint64) 'unsigned-integer64)
((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'unsigned-char)
((equal? type 'short) 'short)
((equal? type 'unsigned-short) 'unsigned-short)
((equal? type 'int) 'int)
((equal? type 'unsigned-int) 'unsigned-int)
((equal? type 'long) 'long)
((equal? type 'unsigned-long) 'unsigned-long)
((equal? type 'float) 'float)
((equal? type 'double) 'double)
((equal? type 'pointer) 'c-pointer)
((equal? type 'string) 'c-string)
((equal? type 'void) 'void)
(else (error "pffi-type->native-type -- No such pffi type" type)))) )
(define pffi-pointer? (define pffi-pointer?
(lambda (object) (lambda (object)
(error "Not defined"))) (error "Not defined")))
(define-syntax pffi-define (define-syntax pffi-define
(syntax-rules () (er-macro-transformer
((pffi-define scheme-name shared-object c-name return-type argument-types) (lambda (expr rename compare)
(error "Not defined")))) (let* ((pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) 'byte)
((equal? type 'uint8) 'unsigned-byte)
((equal? type 'int16) 'int16_t)
((equal? type 'uint16) 'uint16_t)
((equal? type 'int32) 'int32)
((equal? type 'uint32) 'unsigned-int32)
((equal? type 'int64) 'integer-64)
((equal? type 'uint64) 'unsigned-integer64)
((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'unsigned-char)
((equal? type 'short) 'short)
((equal? type 'unsigned-short) 'unsigned-short)
((equal? type 'int) 'int)
((equal? type 'unsigned-int) 'unsigned-int)
((equal? type 'long) 'long)
((equal? type 'unsigned-long) 'unsigned-long)
((equal? type 'float) 'float)
((equal? type 'double) 'double)
((equal? type 'pointer) 'c-pointer)
((equal? type 'string) 'c-string)
((equal? type 'void) 'void)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(scheme-name (car (cdr expr)))
(c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
(argument-types
(let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
(if (null? types)
'()
(map pffi-type->native-type (map car (map cdr types)))))))
(if (null? argument-types)
`(define ,scheme-name
(foreign-lambda ,return-type ,c-name))
`(define ,scheme-name
(foreign-lambda ,return-type ,c-name ,@ argument-types)))))))
(define pffi-size-of (define pffi-size-of
(lambda (type) (lambda (type)
@ -57,9 +116,15 @@
(lambda (pointer size) (lambda (pointer size)
(error "Not defined"))) (error "Not defined")))
(define pffi-shared-object-load (define-syntax pffi-shared-object-load
(lambda (header path) (er-macro-transformer
(error "Not defined"))) (lambda (expr rename compare)
(let* ((headers (cdr (car (cdr expr)))))
`(begin
,@ (map
(lambda (header)
`(foreign-declare ,(string-append "#include <" header ">")))
headers))))))
(define pffi-pointer-free (define pffi-pointer-free
(lambda (pointer) (lambda (pointer)

61
retropikzel/pffi/v0-1-0/cyclone.sld
View File

@ -55,15 +55,44 @@
(define-syntax pffi-define (define-syntax pffi-define
(syntax-rules () (er-macro-transformer
((pffi-define msg) (lambda (expr rename compare)
;(define-c t "(void *data, int argc, closure _, object k, object h)" "puts(string_str(h));") (let* ((pffi-type->native-type
;(c-define puts int "puts" string) (lambda (type)
(c-code "char* buffer[1000]; fgets(buffer, 1000, stdin); puts(buffer);") (cond ((equal? type 'int8) 'byte)
#t ((equal? type 'uint8) 'unsigned-byte)
) ((equal? type 'int16) 'int16_t)
) ((equal? type 'uint16) 'uint16_t)
) ((equal? type 'int32) 'int32)
((equal? type 'uint32) 'unsigned-int32)
((equal? type 'int64) 'integer-64)
((equal? type 'uint64) 'unsigned-integer64)
((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'unsigned-char)
((equal? type 'short) 'short)
((equal? type 'unsigned-short) 'unsigned-short)
((equal? type 'int) 'int)
((equal? type 'unsigned-int) 'unsigned-int)
((equal? type 'long) 'long)
((equal? type 'unsigned-long) 'unsigned-long)
((equal? type 'float) 'float)
((equal? type 'double) 'double)
((equal? type 'pointer) 'c-pointer)
((equal? type 'string) 'c-string)
((equal? type 'void) 'void)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(scheme-name (car (cdr expr)))
(c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
(argument-types
(let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
(if (null? types)
'()
(map pffi-type->native-type (map car (map cdr types)))))))
(if (null? argument-types)
`(c-define ,scheme-name ,return-type ,c-name)
`(c-define ,scheme-name
,return-type ,c-name ,@ argument-types))))))
(define pffi-size-of (define pffi-size-of
@ -90,12 +119,14 @@
(lambda (pointer size) (lambda (pointer size)
(error "Not defined"))) (error "Not defined")))
(define-syntax pffi-shared-object-load (define-syntax pffi-shared-object-load
(syntax-rules () (er-macro-transformer
((when headers shared-object additional-paths) (lambda (expr rename compare)
`(begin
,@ (map
))) (lambda (header)
`(include-c-header ,(string-append "<" header ">")))
(cdr (car (cdr expr))))))))
(define pffi-pointer-free (define pffi-pointer-free
(lambda (pointer) (lambda (pointer)

1
retropikzel/pffi/v0-1-0/main.rkt
View File

@ -201,6 +201,7 @@
((pffi-shared-object-auto-load headers object-name additional-paths) ((pffi-shared-object-auto-load headers object-name additional-paths)
(cond-expand (cond-expand
(cyclone (pffi-shared-object-load headers object-path)) (cyclone (pffi-shared-object-load headers object-path))
(chicken (pffi-shared-object-load headers object-path))
(else (else
(let* ((paths (append auto-load-paths additional-paths)) (let* ((paths (append auto-load-paths additional-paths))
(shared-object #f)) (shared-object #f))

1
retropikzel/pffi/v0-1-0/main.scm
View File

@ -200,6 +200,7 @@
((pffi-shared-object-auto-load headers object-name additional-paths) ((pffi-shared-object-auto-load headers object-name additional-paths)
(cond-expand (cond-expand
(cyclone (pffi-shared-object-load headers object-path)) (cyclone (pffi-shared-object-load headers object-path))
(chicken (pffi-shared-object-load headers object-path))
(else (else
(let* ((paths (append auto-load-paths additional-paths)) (let* ((paths (append auto-load-paths additional-paths))
(shared-object #f)) (shared-object #f))

1
retropikzel/pffi/v0-1-0/main.sld
View File

@ -200,6 +200,7 @@
((pffi-shared-object-auto-load headers object-name additional-paths) ((pffi-shared-object-auto-load headers object-name additional-paths)
(cond-expand (cond-expand
(cyclone (pffi-shared-object-load headers object-path)) (cyclone (pffi-shared-object-load headers object-path))
(chicken (pffi-shared-object-load headers object-path))
(else (else
(let* ((paths (append auto-load-paths additional-paths)) (let* ((paths (append auto-load-paths additional-paths))
(shared-object #f)) (shared-object #f))

2
retropikzel/pffi/v0-1-0/sagittarius.scm
View File

@ -32,8 +32,6 @@
((equal? type 'uint32) 'uint32_t) ((equal? type 'uint32) 'uint32_t)
((equal? type 'int64) 'int64_t) ((equal? type 'int64) 'int64_t)
((equal? type 'uint64) 'uint64_t) ((equal? type 'uint64) 'uint64_t)
((equal? type 'intptr) 'intptr_t)
((equal? type 'uintptr) 'uintptr_t)
((equal? type 'char) 'char) ((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'char) ((equal? type 'unsigned-char) 'char)
((equal? type 'short) 'short) ((equal? type 'short) 'short)

16
test.scm
View File

@ -6,10 +6,12 @@
(cyclone foreign)) (cyclone foreign))
(define-syntax while (define-syntax pffi-shared-object-load
(syntax-rules () (er-macro-transformer
((while condition . body) (lambda (expr rename compare)
(let loop () (let* ((headers (cdr (car (cdr expr)))))
(cond (condition `(begin
(begin . body) ,@ (map
(loop))))))) (lambda (header)
`(include-c-header ,(string-append "<" header ">")))
headers))))))

2
test/pffi-define.scm
View File

@ -9,7 +9,7 @@
(display libcurl) (display libcurl)
(newline) (newline)
(pffi-define curl-version libcurl 'curl_version 'string (list)) (pffi-define 'curl-version libcurl 'curl_version 'string (list))
(display "=================") (display "=================")
(newline) (newline)

2
test/size-of.scm
View File

@ -1,6 +1,6 @@
(import (scheme base) (import (scheme base)
(scheme write) (scheme write)
(retropikzel pffi v0.1.0 main)) (retropikzel pffi v0-1-0 main))
(display 'int8) (display 'int8)
(display " ") (display " ")