diff --git a/README.md b/README.md index 8b1fd8b..1cb6015 100644 --- a/README.md +++ b/README.md @@ -36,7 +36,6 @@ conforming to some specification. - [Gauche](#compiling-the-library-gauche) - [Dependencies](#dependencies) - [Chibi](#dependencies-chibi) - - [Chicken](#dependencies-chicken) - [Gauche](#dependencies-gauche) - [Racket](#dependencies-racket) - [Kawa](#dependencies-kawa) @@ -123,7 +122,7 @@ For roadmap to 1.0.0 see [issues](https://todo.sr.ht/~retropikzel/r7rs-pffi?sear | | pffi-init | pffi-size-of | pffi-define-library | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-address | pffi-pointer? | pffi-pointer-set! | pffi-pointer-get | pffi-define | pffi-define-callback | |--------------|:---------:|:------------:|:-------------------:|:-----------------:|:------------------:|:--------------------:|:-------------:|:-----------------:|:----------------:|:-----------:|:--------------------:| | Chibi | X | X | X | X | X | X | X | X | X | X | | -| Chicken-5 | X | X | X | X | X | X | X | X | X | X | X | +| Chicken | X | X | X | X | X | X | X | X | X | X | X | | Cyclone | X | X | X | X | X | | X | X | X | X | | | Gambit | X | X | | | | X | | | | | | | Gauche | X | X | X | X | X | X | X | X | X | X | | @@ -234,13 +233,6 @@ Debian/Ubuntu/Mint install with: apt install libffi-dev -#### Chicken - - -Needs [r7rs egg](https://wiki.call-cc.org/eggref/5/r7rs), install with: - - chicken-install r7rs - #### Gauche diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index eae7be1..77e8c15 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -10,23 +10,13 @@ (chibi ast) (chibi)) (include-shared "pffi/chibi-pffi")) - (chicken-5 - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme process-context) - (chicken foreign) - (chicken locative) - (chicken syntax) - (chicken memory) - (chicken random))) - (chicken6 + (chicken (import (scheme base) (scheme write) (scheme char) (scheme file) (scheme process-context) + (chicken base) (chicken foreign) (chicken locative) (chicken syntax) @@ -146,39 +136,38 @@ (only (core) define-macro syntax-case))) (else (error "Unsupported implementation"))) (export pffi-init - pffi-size-of - pffi-type? - pffi-align-of - 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-define-struct - pffi-struct-pointer - pffi-struct-offset-get - pffi-struct-get - pffi-struct-set! - pffi-struct-dereference - pffi-array-allocate - pffi-array? - pffi-pointer->array - pffi-array-get - pffi-array-set! - pffi-list->array - pffi-array->list - pffi-define - pffi-define-callback) + pffi-size-of + pffi-type? + pffi-align-of + 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-define-struct + pffi-struct-pointer + pffi-struct-offset-get + pffi-struct-get + pffi-struct-set! + pffi-struct-dereference + pffi-array-allocate + pffi-array? + pffi-pointer->array + pffi-array-get + pffi-array-set! + pffi-list->array + pffi-array->list + pffi-define + pffi-define-callback) (cond-expand (chibi (include "pffi/chibi.scm")) - (chicken-5 (include "pffi/chicken5.scm")) - (chicken-6 (include "chicken6.scm")) + (chicken (include-relative "pffi/chicken.scm")) (cyclone (include "pffi/cyclone.scm")) (gambit (include "pffi/gambit.scm")) (gauche (include "pffi/gauche.scm")) diff --git a/retropikzel/pffi/chicken5.scm b/retropikzel/pffi/chicken.scm similarity index 100% rename from retropikzel/pffi/chicken5.scm rename to retropikzel/pffi/chicken.scm diff --git a/retropikzel/pffi/chicken6.scm b/retropikzel/pffi/chicken6.scm deleted file mode 100644 index 2a813f9..0000000 --- a/retropikzel/pffi/chicken6.scm +++ /dev/null @@ -1,249 +0,0 @@ -(define 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 'void) 'void) - ((equal? type 'callback) 'c-pointer) - (else (error "pffi-type->native-type -- No such pffi type" type)))) ) - -(define pffi-pointer? - (lambda (object) - (pointer? object))) - -(define-syntax pffi-define - (er-macro-transformer - (lambda (expr rename compare) - (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 'void) 'void) - ((equal? type 'callback) 'c-pointer) - (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-safe-lambda ,return-type ,c-name)) - `(define ,scheme-name - (foreign-safe-lambda ,return-type ,c-name ,@ argument-types))))))) - -(define-syntax pffi-define-callback - (er-macro-transformer - (lambda (expr rename compare) - (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 'void) 'void) - ((equal? type 'callback) 'c-pointer) - (else (error "pffi-type->native-type -- No such pffi type" type))))) - (scheme-name (car (cdr expr))) - (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr expr))))))) - (argument-types - (let ((types (cdr (car (cdr (cdr (cdr expr))))))) - (if (null? types) - '() - (map pffi-type->native-type (map car (map cdr types)))))) - (argument-names (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))) - (arguments (map - (lambda (name type) - `(,name ,type)) - argument-types argument-names)) - (procedure-body (cdr (cdr (car (cdr (cdr (cdr (cdr expr))))))))) - `(begin (define-external ,(cons 'external_123456789 arguments) - ,return-type - (begin ,@ procedure-body)) - (define ,scheme-name (location external_123456789))))))) - -(define size-of-type - (lambda (type) - (cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int)) - ((equal? type 'uint8) (foreign-value "sizeof(uint8_t)" int)) - ((equal? type 'int16) (foreign-value "sizeof(int16_t)" int)) - ((equal? type 'uint16) (foreign-value "sizeof(uint16_t)" int)) - ((equal? type 'int32) (foreign-value "sizeof(int32_t)" int)) - ((equal? type 'uint32) (foreign-value "sizeof(uint32_t)" int)) - ((equal? type 'int64) (foreign-value "sizeof(int64_t)" int)) - ((equal? type 'uint64) (foreign-value "sizeof(uint64_t)" int)) - ((equal? type 'char) (foreign-value "sizeof(char)" int)) - ((equal? type 'unsigned-char) (foreign-value "sizeof(unsigned char)" int)) - ((equal? type 'short) (foreign-value "sizeof(short)" int)) - ((equal? type 'unsigned-short) (foreign-value "sizeof(unsigned short)" int)) - ((equal? type 'int) (foreign-value "sizeof(int)" int)) - ((equal? type 'unsigned-int) (foreign-value "sizeof(unsigned int)" int)) - ((equal? type 'long) (foreign-value "sizeof(long)" int)) - ((equal? type 'unsigned-long) (foreign-value "sizeof(unsigned long)" int)) - ((equal? type 'float) (foreign-value "sizeof(float)" int)) - ((equal? type 'double) (foreign-value "sizeof(double)" int)) - ((equal? type 'pointer) (foreign-value "sizeof(void*)" int)) - (else #f))))) - -(define pffi-pointer-allocate - (lambda (size) - (allocate size))) - -(define pffi-pointer-address - (lambda (pointer) - (pointer->address pointer))) - -(define pffi-pointer-dereference - (lambda (pointer) - (pointer->address pointer))) - -(define pffi-pointer-null - (lambda () - (address->pointer 0))) - -;(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) -;(pffi-define puts #f 'puts 'int (list 'pointer)) -;(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int)) - -#;(define pffi-string->pointer - (lambda (string-content) - (let* ((size (string-length string-content)) - (pointer (pffi-pointer-allocate (+ size 1)))) - (memset pointer 0 (+ size 1)) - (strncpy-ps pointer (location string-content) size) - ;(puts pointer) - pointer))) - -#;(define pffi-string->pointer - (foreign-lambda* c-pointer - ((c-string str)) - "C_return((void*)str);")) - - -;(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) -;(pffi-define strlen #f 'strlen 'int (list 'pointer)) - -#;(define pffi-pointer->string - (foreign-lambda* c-string - ((c-pointer p)) - "C_return((char*)p);")) - -(define-syntax pffi-shared-object-load - (er-macro-transformer - (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 - (lambda (pointer) - (if (not (pointer? pointer)) - (error "pffi-pointer-free -- Argument is not pointer" pointer)) - (free pointer))) - -(define pffi-pointer-null? - (lambda (pointer) - (if (and (not (pointer? pointer)) - pointer) - #f - (or (not pointer) ; #f counts as null pointer on Chicken - (= (pointer->address pointer) 0))))) - -(define pffi-pointer-set! - (lambda (pointer type offset value) - (cond - ((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value)) - ((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value)) - ((equal? type 'int16) (pointer-s16-set! (pointer+ pointer offset) value)) - ((equal? type 'uint16) (pointer-u16-set! (pointer+ pointer offset) value)) - ((equal? type 'int32) (pointer-s32-set! (pointer+ pointer offset) value)) - ((equal? type 'uint32) (pointer-u32-set! (pointer+ pointer offset) value)) - ((equal? type 'int64) (pointer-s64-set! (pointer+ pointer offset) value)) - ((equal? type 'uint64) (pointer-u64-set! (pointer+ pointer offset) value)) - ((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) (char->integer value))) - ((equal? type 'short) (pointer-s8-set! (pointer+ pointer offset) value)) - ((equal? type 'unsigned-short) (pointer-u8-set! (pointer+ pointer offset) value)) - ((equal? type 'int) (pointer-s32-set! (pointer+ pointer offset) value)) - ((equal? type 'unsigned-int) (pointer-u32-set! (pointer+ pointer offset) value)) - ((equal? type 'long) (pointer-s32-set! (pointer+ pointer offset) value)) - ((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value)) - ((equal? type 'float) (pointer-f32-set! (pointer+ pointer offset) value)) - ((equal? type 'double) (pointer-f64-set! (pointer+ pointer offset) value)) - ((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address value)))))) - -(define pffi-pointer-get - (lambda (pointer type offset) - (cond - ((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset))) - ((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset))) - ((equal? type 'int16) (pointer-s16-ref (pointer+ pointer offset))) - ((equal? type 'uint16) (pointer-u16-ref (pointer+ pointer offset))) - ((equal? type 'int32) (pointer-s32-ref (pointer+ pointer offset))) - ((equal? type 'uint32) (pointer-u32-ref (pointer+ pointer offset))) - ((equal? type 'int64) (pointer-s64-ref (pointer+ pointer offset))) - ((equal? type 'uint64) (pointer-u64-ref (pointer+ pointer offset))) - ((equal? type 'char) (integer->char (pointer-s8-ref (pointer+ pointer offset)))) - ((equal? type 'short) (pointer-s8-ref (pointer+ pointer offset))) - ((equal? type 'unsigned-short) (pointer-u8-ref (pointer+ pointer offset))) - ((equal? type 'int) (pointer-s32-ref (pointer+ pointer offset))) - ((equal? type 'unsigned-int) (pointer-u32-ref (pointer+ pointer offset))) - ((equal? type 'long) (pointer-s32-ref (pointer+ pointer offset))) - ((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset))) - ((equal? type 'float) (pointer-f32-ref (pointer+ pointer offset))) - ((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset))) - ((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset))))))) -