diff --git a/Makefile b/Makefile index c191936..bddb79d 100644 --- a/Makefile +++ b/Makefile @@ -31,15 +31,15 @@ test-cyclone: clean ${CYCLONE} test.scm ./test -GAMBIT_LIB=gsc -dynamic -GAMBIT_CC=gsc -exe . -nopreload +GAMBIT_LIB=gsc -:search=. +GAMBIT_CC=gsc -exe ./ -nopreload test-gambit-podman-amd64: clean - podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/gambit bash -c "cd /workdir && ${GAMBIT_LIB} retropikzel/r7rs-pffi.sld; echo $$?" - podman run --arch=amd64 run -it -v ${PWD}:/workdir schemers/gambit bash -c "cd /workdir && ${GAMBIT_CC} test.scm; echo $$?" + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/gambit bash -c "cd /workdir && ${GAMBIT_LIB} retropikzel/r7rs-pffi; echo $$?" + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/gambit bash -c "cd /workdir && ${GAMBIT_CC} test.scm; echo $$?" podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/gambit bash -c "cd /workdir && ./test -:search=.; echo $$?" test-gambit: clean - ${GAMBIT_LIB} retropikzel/r7rs-pffi.sld; echo $$? + ${GAMBIT_LIB} retropikzel/r7rs-pffi; echo $$? ${GAMBIT_CC} test.scm; echo $$? ./test -:search=.; echo $$? diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld index 3efa784..8a569f1 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/retropikzel/r7rs-pffi.sld @@ -34,7 +34,8 @@ (scheme write) (scheme char) (scheme file) - (scheme process-context))) + (scheme process-context) + (only (gambit) c-declare c-lambda c-define))) (gauche (import (scheme base) (scheme write) @@ -112,17 +113,17 @@ pffi-size-of pffi-shared-object-auto-load pffi-shared-object-load - pffi-pointer-null - pffi-pointer-null? - pffi-pointer-allocate - pffi-pointer? - pffi-pointer-free - pffi-pointer-set! - pffi-pointer-get - pffi-string->pointer - pffi-pointer->string - pffi-define - pffi-define-callback + ;pffi-pointer-null + ;pffi-pointer-null? + ;pffi-pointer-allocate + ;pffi-pointer? + ;pffi-pointer-free + ;pffi-pointer-set! + ;pffi-pointer-get + ;pffi-string->pointer + ;pffi-pointer->string + ;pffi-define + ;pffi-define-callback ;pffi-pointer-address ;pffi-pointer-dereference ) diff --git a/retropikzel/r7rs-pffi/gambit.scm b/retropikzel/r7rs-pffi/gambit.scm index 1eb808c..57802b3 100644 --- a/retropikzel/r7rs-pffi/gambit.scm +++ b/retropikzel/r7rs-pffi/gambit.scm @@ -2,105 +2,54 @@ (define pffi-init (lambda () #t)) -#| -(define pffi-type->native-type - (lambda (type) - (cond ((equal? type 'int8) int8) - ((equal? type 'uint8) unsigned-int8) - ((equal? type 'int16) int16) - ((equal? type 'uint16) unsigned-int16) - ((equal? type 'int32) int32) - ((equal? type 'uint32) unsigned-int32) - ((equal? type 'int64) int64) - ((equal? type 'uint64) unsigned-int64) - ((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) pointer) - ((equal? type 'void) void) - ((equal? type 'callback) pointer) - (else (error "pffi-type->native-type -- No such pffi type" type))))) - -(define pffi-pointer? - (lambda (object) - (error "Not defined"))) - -#;(define-syntax pffi-define - (syntax-rules () - ((_ scheme-name shared-object c-name return-type argument-types) - (define scheme-name - #f - #;(c-lambda argument-types return-type c-name) - - )))) - -(define pffi-define-callback - (lambda (scheme-name shared-object c-name return-type argument-types) - (error "Not defined"))) - ;(c-declare "int size_of_int8() { return sizeof(int8_t);}") ;(define size-of-int8 (c-lambda () int "__return(sizeof(int8_t));")) ;(define int8-size ((c-lambda () int "__return(sizeof(int8_t));"))) ;(define int8-size (c-lambda () int "__return(1);")) -|# +(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));")) +(define size-of-uint16_t (c-lambda () int "___return(sizeof(uint16_t));")) +(define size-of-int32_t (c-lambda () int "___return(sizeof(int32_t));")) +(define size-of-uint32_t (c-lambda () int "___return(sizeof(uint32_t));")) +(define size-of-int64_t (c-lambda () int "___return(sizeof(int64_t));")) +(define size-of-uint64_t (c-lambda () int "___return(sizeof(uint64_t));")) +(define size-of-char (c-lambda () int "___return(sizeof(char));")) +(define size-of-unsigned-char (c-lambda () int "___return(sizeof(unsigned char));")) +(define size-of-short (c-lambda () int "___return(sizeof(short));")) +(define size-of-unsigned-short (c-lambda () int "___return(sizeof(unsigned short));")) +(define size-of-int (c-lambda () int "___return(sizeof(int));")) +(define size-of-unsigned-int (c-lambda () int "___return(sizeof(unsigned int));")) +(define size-of-long (c-lambda () int "___return(sizeof(long));")) +(define size-of-unsigned-long (c-lambda () int "___return(sizeof(unsigned long));")) +(define size-of-float (c-lambda () int "___return(sizeof(float));")) +(define size-of-double (c-lambda () int "___return(sizeof(double));")) +(define size-of-void* (c-lambda () int "___return(sizeof(void*));")) + + (define pffi-size-of (lambda (type) - (cond ((equal? type 'int8) (c-lambda () int "___return(sizeof(int8_t));")) - (else (error "pffi-size-of -- No such pffi type" type))))) + (cond ((eq? type 'int8) (size-of-int8_t)) + ((eq? type 'uint8) (size-of-uint8_t)) + ((eq? type 'int16) (size-of-int16_t)) + ((eq? type 'uint16) (size-of-uint16_t)) + ((eq? type 'int32) (size-of-int32_t)) + ((eq? type 'uint32) (size-of-uint32_t)) + ((eq? type 'int64) (size-of-int64_t)) + ((eq? type 'uint64) (size-of-uint64_t)) + ((eq? type 'char) (size-of-char)) + ((eq? type 'unsigned-char) (size-of-char)) + ((eq? type 'short) (size-of-short)) + ((eq? type 'unsigned-short) (size-of-unsigned-short)) + ((eq? type 'int) (size-of-int)) + ((eq? type 'unsigned-int) (size-of-unsigned-int)) + ((eq? type 'long) (size-of-long)) + ((eq? type 'unsigned-long) (size-of-unsigned-long)) + ((eq? type 'float) (size-of-float)) + ((eq? type 'double) (size-of-double)) + ((eq? type 'pointer) (size-of-void*)) + (else (error "Can not get size of unknown type" type))))) - -#| -#;(define-syntax pffi-pointer-allocate - (syntax-rules - ((pffi-pointer-allocate size) - (c-declare (string-append "malloc(" (number->string size) ")"))))) - -#;(define-syntax pffi-pointer-null - (syntax-rules - ((pffi-pointer-null) - (c-declare "NULL")))) - -(define pffi-string->pointer - (lambda (string-content) - string-content)) - -(define pffi-pointer->string - (lambda (pointer) - pointer)) - -#;(define-syntax pffi-shared-object-load - (syntax-rules () - ((pffi-shared-object-load headers) - (c-declare (apply string-append - (map (lambda (header) - (string-append "#include <" header ">")))))))) - -(define pffi-pointer-free - (lambda (pointer) - (error "Not defined"))) - -(define pffi-pointer-null? - (lambda (pointer) - (error "Not defined"))) - -(define pffi-pointer-set! - (lambda (pointer type offset value) - (let ((p pointer)) - (error "Not defined")))) - -(define pffi-pointer-get - (lambda (pointer type offset) - (error "Not defined"))) - -(define pffi-pointer-deref - (lambda (pointer) - (error "Not defined"))) -|# +(define-macro (pffi-shared-object-load headers) + `(c-declare ,(string-append "#include "))) diff --git a/retropikzel/r7rs-pffi/sagittarius.scm b/retropikzel/r7rs-pffi/sagittarius.scm index c8c21a8..9cef412 100644 --- a/retropikzel/r7rs-pffi/sagittarius.scm +++ b/retropikzel/r7rs-pffi/sagittarius.scm @@ -96,7 +96,7 @@ (pointer->string pointer))) (define pffi-shared-object-load - (lambda (header path) + (lambda (headers path) (open-shared-library path))) (define pffi-pointer-free diff --git a/test.scm b/test.scm index dbfc288..8621411 100644 --- a/test.scm +++ b/test.scm @@ -179,6 +179,7 @@ (debug libc-stdlib) +#| ;; pffi-pointer-null (print-header 'pffi-pointer-null) @@ -397,4 +398,5 @@ (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2)))) (newline) +|# (exit 0)