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

Progress

This commit is contained in:
retropikzel 2025-03-22 14:41:28 +02:00
parent 9018ab0960
commit a0b316b47b
7 changed files with 268 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
Makefile
View File

@ -1,10 +1,10 @@
.PHONY=libtest.o libtest.so libtest.a documentation
.PHONY=libtest.o tests/libtest.so libtest.a documentation
CC=gcc
DOCKER=docker run -it -v ${PWD}:/workdir
DOCKER_INIT=cd /workdir && make clean &&
VERSION=$(shell grep "version:" README.md | awk '{split\($0,a\); print a[2];}')
all: chibi gauche libtest.so libtest.o libtest.a
all: chibi gauche tests/libtest.so libtest.o libtest.a
# apt-get install pandoc weasyprint
docs:
@ -42,27 +42,30 @@ jenkinsfile:
libtest.o: src/libtest.c
${CC} -o libtest.o -fPIC -c src/libtest.c -I./include
libtest.so: src/libtest.c
${CC} -o libtest.so -shared -fPIC src/libtest.c -I./include
tests/libtest.so: src/libtest.c
${CC} -o tests/libtest.so -shared -fPIC src/libtest.c -I./include
libtest.a: libtest.o src/libtest.c
ar rcs libtest.a libtest.o
test-interpreter-compliance: libtest.so
test-interpreter-compliance: tests/libtest.so
SCHEME=${SCHEME} script-r7rs -I . tests/compliance.scm
test-interpreter-compliance-docker:
docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME}
docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} script-r7rs -I . tests/compliance.scm"
test-compile-library: libtest.so libtest.a libtest.o
test-compile-library: tests/libtest.so libtest.a libtest.o
SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld
test-compiler-compliance: test-compile-library
SCHEME=${SCHEME} CFLAGS="-I./include -L." LDFLAGS="-ltest libtest.o" compile-r7rs -I . tests/compliance.scm
test-compiler-compliance-compile: test-compile-library
SCHEME=${SCHEME} CFLAGS="-I../include -L.." LDFLAGS="-ltest" compile-r7rs -I . tests/compliance.scm
./tests/compliance
test-compiler-compliance-docker: libtest.so libtest.a
test-compiler-compliance: test-compiler-compliance-compile
./tests/compliance
test-compiler-compliance-docker: tests/libtest.so libtest.a
docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME}
docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld"
docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs -I . compliance.scm && ./test"

2
include/libtest.h
View File

@ -13,3 +13,5 @@ int color_check_by_value(struct color color);
int test_check(struct test* test);
int test_check_by_value(struct test test);
struct test* test_new();
void takes_no_args();
int takes_no_args_returns_int();

27
retropikzel/pffi.sld
View File

@ -140,23 +140,23 @@
pffi-size-of
pffi-type?
pffi-align-of
pffi-load
;pffi-pointer-null
;pffi-pointer-null?
;pffi-pointer-allocate
;pffi-pointer-address
;pffi-pointer?
;pffi-pointer-free
;pffi-pointer-set!
;pffi-pointer-get
;pffi-string->pointer
;pffi-pointer->string
pffi-define-library
pffi-pointer-null
pffi-pointer-null?
pffi-pointer-allocate
pffi-pointer-address
pffi-pointer?
pffi-pointer-free
pffi-pointer-set!
pffi-pointer-get
pffi-string->pointer
pffi-pointer->string
pffi-struct-make
pffi-struct-pointer
pffi-struct-offset-get
pffi-struct-get
pffi-struct-set!
;pffi-define
pffi-define
;pffi-define-callback
))
(gauche
@ -540,4 +540,5 @@
(ypsilon (include "pffi/ypsilon.scm")))
(include "pffi/shared/struct.scm")
(include "pffi/shared/union.scm")
(include "pffi/shared/main.scm"))
(include "pffi/shared/main.scm")
)

166
retropikzel/pffi/gambit.scm
View File

@ -1,5 +1,11 @@
(c-declare "#include <stdlib.h>")
(c-declare "#include <stdint.h>")
(define-macro
(pffi-init)
`(begin (c-define-type pointer (pointer void))
(c-define-type callback (pointer void))))
(define size-of-int8_t (c-lambda () int "___return(sizeof(int8_t));"))
(define size-of-uint8_t (c-lambda () int "___return(sizeof(uint8_t));"))
(define size-of-int16_t (c-lambda () int "___return(sizeof(int16_t));"))
@ -45,19 +51,157 @@
((eq? type 'void) (size-of-void*))
(else (error "Can not get size of unknown type" type)))))
#;(define-macro
(include-c-headers headers)
`(c-declare ,(apply string-append
(define-macro
(pffi-define-library name headers object-name . options)
`(begin (define ,name #t)
(c-declare ,(apply string-append
(map
(lambda (header)
(string-append "#include <" header ">" (string #\newline)))
(list "stdio.h")))))
(cdr headers))))))
(define pointer? (c-lambda ((pointer void)) bool "___return(1);"))
(define pffi-pointer?
(lambda (object)
(call-with-current-continuation
(lambda (k)
(with-exception-handler
(lambda (x) #f)
(lambda () (pointer? object)))))))
(define pffi-pointer-null (c-lambda () (pointer void) "void* p = NULL; ___return(p);"))
(define pointer-null? (c-lambda ((pointer void)) bool "if(___arg1 == NULL) { ___return(1); } else { ___return(0); }"))
(define pffi-pointer-null?
(lambda (pointer)
(and (pffi-pointer? pointer)
(pointer-null? pointer))))
(define pffi-pointer-allocate (c-lambda (int) (pointer void) "void* p = malloc(___arg1); ___return(p);"))
(define pffi-pointer-address (c-lambda ((pointer void)) ptrdiff_t "void* p = ___arg1; ___return((intptr_t)&p);"))
(define pffi-pointer-free (c-lambda ((pointer void)) void "free(___arg1);"))
(define pointer-set-c-int8_t! (c-lambda ((pointer void) int int8) void "*(int8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-uint8_t! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-int16_t! (c-lambda ((pointer void) int int16) void "*(int16_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-uint16_t! (c-lambda ((pointer void) int unsigned-int16) void "*(uint16_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-int32_t! (c-lambda ((pointer void) int int32) void "*(int32_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-uint32_t! (c-lambda ((pointer void) int unsigned-int32) void "*(uint32_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-int64_t! (c-lambda ((pointer void) int int64) void "*(int64_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-uint64_t! (c-lambda ((pointer void) int unsigned-int64) void "*(uint64_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-char! (c-lambda ((pointer void) int char) void "*((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-short! (c-lambda ((pointer void) int short) void "*(short*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-unsigned-short! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned short*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-int! (c-lambda ((pointer void) int int) void "*(int*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-unsigned-int! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned int*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-long! (c-lambda ((pointer void) int long) void "*(long*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-unsigned-long! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned long*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-float! (c-lambda ((pointer void) int float) void "*(float*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-double! (c-lambda ((pointer void) int double) void "*(double*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-pointer! (c-lambda ((pointer void) int (pointer void)) void "{ char* p = (char*)___arg1 + ___arg2; *(char**)p = ___arg3; }"))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value))
((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value))
((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value))
((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
((equal? type 'char) (pointer-set-c-char! pointer offset value))
((equal? type 'short) (pointer-set-c-short! pointer offset value))
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
((equal? type 'int) (pointer-set-c-int! pointer offset value))
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value))
((equal? type 'long) (pointer-set-c-long! pointer offset value))
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
((equal? type 'float) (pointer-set-c-float! pointer offset value))
((equal? type 'double) (pointer-set-c-double! pointer offset value))
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
(define pointer-ref-c-int8_t (c-lambda ((pointer void) int) int8 "___return(*(int8_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-uint8_t (c-lambda ((pointer void) int) unsigned-int8 "___return(*(uint8_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-int16_t (c-lambda ((pointer void) int) int16 "___return(*(int16_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-uint16_t (c-lambda ((pointer void) int) unsigned-int16 "___return(*(uint16_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-int32_t (c-lambda ((pointer void) int) int32 "___return(*(int32_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-uint32_t (c-lambda ((pointer void) int) unsigned-int32 "___return(*(uint32_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-int64_t (c-lambda ((pointer void) int) int64 "___return(*(int64_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-uint64_t (c-lambda ((pointer void) int) unsigned-int64 "___return(*(uint64_t*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-char (c-lambda ((pointer void) int) char "___return(*((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-short (c-lambda ((pointer void) int) short "___return(*(short*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-unsigned-short (c-lambda ((pointer void) int) unsigned-short "___return(*(unsigned short*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-int (c-lambda ((pointer void) int) int "___return(*(int*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-unsigned-int (c-lambda ((pointer void) int) unsigned-int "___return(*(unsigned int*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-long (c-lambda ((pointer void) int) long "___return(*(long*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-unsigned-long (c-lambda ((pointer void) int) unsigned-long "___return(*(unsigned long*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-float (c-lambda ((pointer void) int) float "___return(*(float*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-double (c-lambda ((pointer void) int) double "___return(*(double*)((char*)___arg1 + ___arg2));"))
(define pointer-ref-c-pointer (c-lambda ((pointer void) int) (pointer void) " char* p = (char*)___arg1 + ___arg2; ___return(*(char**)p);"))
(define pffi-pointer-get
(lambda (pointer type offset)
(cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
((equal? type 'int16) (pointer-ref-c-int16_t pointer offset))
((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset))
((equal? type 'int32) (pointer-ref-c-int32_t pointer offset))
((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
((equal? type 'char) (pointer-ref-c-char pointer offset))
((equal? type 'short) (pointer-ref-c-short pointer offset))
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
((equal? type 'int) (pointer-ref-c-int pointer offset))
((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
((equal? type 'long) (pointer-ref-c-long pointer offset))
((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
((equal? type 'float) (pointer-ref-c-float pointer offset))
((equal? type 'double) (pointer-ref-c-double pointer offset))
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
(define-macro
(pffi-shared-object-auto-load headers object-name . options)
`(c-declare ,(apply string-append
(map
(lambda (header)
(string-append "#include <" header ">" (string #\newline)))
(cdr headers)))))
(pffi-define scheme-name shared-object c-name return-type argument-types)
(display "HERE: ")
(write argument-types)
(newline)
(write (equal? '(list) argument-types))
(newline)
(letrec* ((native-argument-types
(if (equal? '(list) argument-types)
(list)
(let ((types (map cdr (cdr argument-types))))
(if (null? types) types (map car types)))))
(native-return-type (car (cdr return-type)))
(c-arguments (lambda (index argument-count result)
(if (> index argument-count)
result
(c-arguments (+ index 1)
argument-count
(string-append result
"___arg"
(number->string index)
(if (< index argument-count)
", "
""))))))
(c-code (string-append
(if (equal? 'void (cadr return-type)) "" "___return(")
(symbol->string (cadr c-name))
"(" (c-arguments 1 (- (length argument-types) 1) "") ")"
(if (equal? 'void (cadr return-type)) "" ")")
";")))
(write `(define ,scheme-name
(c-lambda ,native-argument-types
,native-return-type
,c-code)))
(newline)
`(define ,scheme-name
(c-lambda ,native-argument-types
,native-return-type
,c-code))))

8
retropikzel/pffi/shared/main.scm
View File

@ -6,8 +6,8 @@
'(import (chicken foreign)
(chicken memory))
#t))))
(else
(define pffi-init(lambda () #t))))
(gambit #t)
(else (define pffi-init (lambda () #t))))
(define pffi-type?
(lambda (object)
@ -89,12 +89,12 @@
(cond-expand
(gambit #t)
((or chicken cyclone)
(define-syntax pffi-load
(define-syntax pffi-define-library
(syntax-rules ()
((_ headers object-name . options)
(pffi-shared-object-load headers)))))
(else
(define pffi-load
(define pffi-define-library
(lambda (headers object-name . options)
(let* ((additional-paths (if (assoc 'additional-paths options)
(cdr (assoc 'additional-paths options))

8
src/libtest.c
View File

@ -273,3 +273,11 @@ EXPORT struct test* test_new() {
t->n = 14;
return t;
}
EXPORT void takes_no_args() {
puts("I take no arguments :)");
}
EXPORT int takes_no_args_returns_int() {
return 0;
}

78
tests/compliance.scm
View File

@ -28,6 +28,23 @@
(set! assert-tag tag)
(set! count 0)))
(cond-expand
(gambit
(define assert
(lambda (check value-a value-b)
(let ((result (apply check (list value-a value-b))))
(set! count (+ count 1))
(if (not result) (display "FAIL ") (display "PASS "))
(display "[")
(display assert-tag)
(display " - ")
(display count)
(display "]")
(display ": ")
(write (list 'check 'value-a 'value-b))
(newline)
(when (not result) (exit 1))))))
(else
(define-syntax assert
(syntax-rules ()
((_ check value-a value-b)
@ -42,7 +59,7 @@
(display ": ")
(write (list 'check 'value-a 'value-b))
(newline)
(when (not result) (exit 1))))))
(when (not result) (exit 1))))))))
(define-syntax debug
(syntax-rules ()
@ -106,8 +123,6 @@
(debug (pffi-type? 'callback))
(assert equal? (pffi-type? 'callback) #t)
(pffi-init)
;; pffi-size-of
(print-header 'pffi-size-of)
@ -384,27 +399,27 @@
(assert equal? (number? align-pointer) #t)
(assert = align-pointer 8)))
;; pffi-load
;; pffi-define-library
(print-header 'pffi-load)
(print-header 'pffi-define-library)
(define libc-stdlib
(cond-expand
(windows (pffi-load (list "stdlib.h") "ucrtbase"))
(else (pffi-load (list "stdlib.h")
"c"
'(additional-versions . ("0" "6"))))))
(pffi-define-library libc-stdlib
(list "stdlib.h")
(cond-expand (windows "ucrtbase") (else "c"))
'(additional-versions . ("0" "6")))
(debug libc-stdlib)
(define c-testlib
(cond-expand
(windows (pffi-load (list "libtest.h")
(pffi-define-library libc-stdio
(list "stdio.h")
(cond-expand (windows "ucrtbase") (else "c"))
'(additional-versions . ("0" "6")))
(debug libc-stdio)
(pffi-define-library c-testlib
(list "libtest.h")
"test"
'(additional-paths . ("."))))
(else (pffi-load (list "libtest.h")
"test"
'(additional-paths . ("."))))))
'(additional-paths . (".")))
(debug c-testlib)
@ -477,12 +492,20 @@
(debug offset)
(debug value)
(cond-expand
(gambit
(define test-type
(lambda (type)
(begin
(pffi-pointer-set! set-pointer type offset value)
(assert = (pffi-pointer-get set-pointer type offset) value)))))
(else
(define-syntax test-type
(syntax-rules ()
((_ type)
(begin
(pffi-pointer-set! set-pointer type offset value)
(assert = (pffi-pointer-get set-pointer type offset) value)))))
(assert = (pffi-pointer-get set-pointer type offset) value)))))))
(test-type 'int8)
(test-type 'uint8)
@ -656,14 +679,6 @@
(pffi-define c-atoi libc-stdlib 'atoi 'int (list 'pointer))
(assert = (c-atoi (pffi-string->pointer "100")) 100)
(define libc-stdio
(cond-expand
; FIXME Check that windows so file is correct
(windows (pffi-load (list "stdio.h") "ucrtbase"))
(else (pffi-load (list "stdio.h")
"c"
'(additional-versions . ("0" "6"))))))
(pffi-define c-fopen libc-stdio 'fopen 'pointer (list 'pointer 'pointer))
(define output-file (c-fopen (pffi-string->pointer "testfile.test")
(pffi-string->pointer "w")))
@ -682,6 +697,15 @@
(lambda () (read-line)))
"Hello world") #t)
(pffi-define c-takes-no-args c-testlib 'takes_no_args 'void (list))
(debug c-takes-no-args)
(c-takes-no-args)
(pffi-define c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int (list))
(debug c-takes-no-args)
(define takes-no-args-returns-int-result (c-takes-no-args-returns-int))
(assert equal? (= takes-no-args-returns-int-result 0) #t)
;; pffi-struct-get
(print-header 'pffi-struct-get)