From c3736015f8b5133d3fbcabe85aaf12c2c148fd38 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Tue, 30 Apr 2024 23:28:06 +0300 Subject: [PATCH] Started adding racket support --- Makefile | 22 ++ manifest.scm | 1 + retropikzel/pffi/v0.1.0/main.rkt | 504 +++++++++++++++++++++++++++++++ retropikzel/pffi/v0.1.0/main.scm | 198 ++++++++---- test/hello.scm | 8 + 5 files changed, 677 insertions(+), 56 deletions(-) create mode 100644 retropikzel/pffi/v0.1.0/main.rkt create mode 100644 test/hello.scm diff --git a/Makefile b/Makefile index 856b7f5..a51698d 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,27 @@ +VERSION=v0.1.0 +RACKETEXE=${HOME}/.wine/drive_c/Program Files/Racket/racket.exe + test-sagittatius-sdl2: sash -r7 -L . test/sdl2.scm test-guile-sdl2: guile --debug --r7rs -L . test/sdl2.scm + +build-rkt: + echo "#lang r7rs" > retropikzel/pffi/${VERSION}/main.rkt + cat retropikzel/pffi/${VERSION}/main.scm >> retropikzel/pffi/${VERSION}/main.rkt + +test-racket-load: build-rkt + racket -I r7rs retropikzel/pffi/${VERSION}/main.rkt + +test-racket-load-wine: build-rkt + wine64 ${RACKETEXE} -I r7rs retropikzel/pffi/${VERSION}/main.rkt + +test-racket-hello: build-rkt + racket -I r7rs -S $(shell pwd) -f test/hello.scm + +test-racket-hello-wine: build-rkt + wine64 ${RACKETEXE} -I r7rs -S $(shell pwd) -f test/hello.scm + +test-racket-sdl2: build-rkt + racket -I r7rs -S $(shell pwd) -f test/sdl2.scm diff --git a/manifest.scm b/manifest.scm index 43d7b30..571c817 100644 --- a/manifest.scm +++ b/manifest.scm @@ -4,6 +4,7 @@ (specifications->manifest (list "guile" + "racket-minimal" "sdl2" "sdl2-image" "sdl2-ttf" diff --git a/retropikzel/pffi/v0.1.0/main.rkt b/retropikzel/pffi/v0.1.0/main.rkt new file mode 100644 index 0000000..ec7acc0 --- /dev/null +++ b/retropikzel/pffi/v0.1.0/main.rkt @@ -0,0 +1,504 @@ +#lang r7rs +(define-library + (retropikzel pffi v0.1.0 main) + (cond-expand + (sagittarius + (import (scheme base) + (scheme write) + (scheme file) + (scheme process-context) + (sagittarius ffi) + (sagittarius))) + (guile + (import (scheme base) + (scheme write) + (scheme file) + (scheme process-context) + (rnrs bytevectors) + (system foreign) + (system foreign-library))) + (racket + (import (scheme base) + (scheme write) + (scheme file) + (scheme process-context) + (only (racket base) + system-type) + (compatibility mlist) + (ffi unsafe))) + (else (error "Implementation not supported by r7rs-pffi"))) + (export pffi-call + pffi-types + pffi-size-of + pffi-pointer-allocate + pffi-pointer-null + pffi-string->pointer + pffi-pointer->string + pffi-pointer->bytevector + pffi-pointer-free + pffi-pointer? + pffi-pointer-null? + pffi-shared-object-load + pffi-shared-object-auto-load + pffi-pointer-set! + pffi-pointer-get + pffi-pointer-deref) + (begin + + (define library-version "v0.1.0") + + (define platform-file-extension + (cond-expand + (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) + (guile "") + (windows ".dll") + (else ".so"))) + + (define platform-version-file-extension + (cond-expand + (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0")) + (guile "") + (windows ".dll") + (else ".so.0"))) + + (define platform-lib-prefix + (cond-expand + (racket (if (equal? (system-type 'os) 'windows) "" "lib")) + (windows "") + (else "lib"))) + + (define pffi-types + '(int8 + uint8 + int16 + uint16 + int32 + uint32 + int64 + uint64 + intptr + uintptr + char + unsigned-char + short + unsigned-short + int + unsigned-int + long + unsigned-long + float + double + pointer)) + + (define string-split + (lambda (str mark) + (let* ((str-l (string->list str)) + (res (list)) + (last-index 0) + (index 0) + (splitter (lambda (c) + (cond ((char=? c mark) + (begin + (set! res (append res (list (string-copy str last-index index)))) + (set! last-index (+ index 1)))) + ((equal? (length str-l) (+ index 1)) + (set! res (append res (list (string-copy str last-index (+ index 1))))))) + (set! index (+ index 1))))) + (for-each splitter str-l) + res))) + + (define auto-load-paths + (append + (cond-expand + (racket (if (equal? (system-type 'os) 'windows) + (append + (if (get-environment-variable "SYSTEM") + (list (get-environment-variable "SYSTEM")) + (list)) + (if (get-environment-variable "WINDIR") + (list (get-environment-variable "WINDIR")) + (list)) + (list ".") + (string-split (get-environment-variable "PATH") #\;)) + (append + (list (if (get-environment-variable "GUIX_ENVIRONMENT") + (string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib") + "")) + (if (get-environment-variable "LD_LOAD_PATH") + (list) ;(string-split (get-environment-variable "LD_LOAD_PATH") #\:) + (list)) + (list "/lib/x86_64-linux-gnu" + "/usr/lib/x86_64-linux-gnu" + "/usr/local/lib")))) + (windows + (append + (if (get-environment-variable "SYSTEM") + (list (get-environment-variable "SYSTEM")) + (list)) + (if (get-environment-variable "WINDIR") + (list (get-environment-variable "WINDIR")) + (list)) + (list ".") + (string-split (get-environment-variable "PATH") #\;))) + (else + (append + (list (if (get-environment-variable "GUIX_ENVIRONMENT") + (string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib") + "")) + (if (get-environment-variable "LD_LOAD_PATH") + (list) ;(string-split (get-environment-variable "LD_LOAD_PATH") #\:) + (list)) + (list "/lib/x86_64-linux-gnu" + "/usr/lib/x86_64-linux-gnu" + "/usr/local/lib")))))) + + + + + + (define memorysession #f) + (define linker #f) + (define symbol-lookup #f) + (define kebab-case->snake-case + (lambda (str) (string-map (lambda (c) (if (char=? c #\-) #\_ c)) str))) + + (define pffi-type->native-type + (lambda (type) + (cond-expand + (sagittarius + (cond ((equal? type 'int8) 'int8_t) + ((equal? type 'uint8) 'uint8_t) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32_t) + ((equal? type 'uint32) 'uint32_t) + ((equal? type 'int64) 'int64_t) + ((equal? type 'uint64) 'uint64_t) + ((equal? type 'intptr) 'intptr_t) + ((equal? type 'uintptr) 'uintptr_t) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) '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) 'void*) + ((equal? type 'void) 'void) + (else (error "pffi-type->native-type -- No such pffi type" type)))) + (guile + (cond ((equal? type 'int8) int8) + ((equal? type 'uint8) uint8) + ((equal? type 'int16) int16) + ((equal? type 'uint16) uint16) + ((equal? type 'int32) int32) + ((equal? type 'uint32) uint32) + ((equal? type 'int64) int64) + ((equal? type 'uint64) uint64) + ;((equal? type 'intptr) intptr) + ;((equal? type 'uintptr) uintptr) + ;((equal? type 'char) char) + ((equal? type 'char) int) + ;((equal? type 'unsigned-char) char) + ;((equal? type 'unsigned-char) int) + ((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) '*) + ((equal? type 'void) void) + (else (error "pffi-type->native-type -- No such pffi type" type)))) + (racket + (cond ((equal? type 'int8) _int8) + ((equal? type 'uint8) _uint8) + ((equal? type 'int16) _int16) + ((equal? type 'uint16) _uint16) + ((equal? type 'int32) _int32) + ((equal? type 'uint32) _uint32) + ((equal? type 'int64) _int64) + ((equal? type 'uint64) _uint64) + ;((equal? type 'intptr) intptr) + ;((equal? type 'uintptr) uintptr) + ;((equal? type 'char) _int32) + ((equal? type 'char) _int) + ((equal? type 'unsigned-char) _int) + ((equal? type 'short) _short) + ((equal? type 'unsigned-short) _ushort) + ((equal? type 'int) _int) + ((equal? type 'unsigned-int) _uint) + ((equal? type 'long) _long) + ((equal? type 'unsigned-long) _ulong) + ((equal? type 'float) _float) + ((equal? type 'double) _double) + ((equal? type 'pointer) _pointer) + ((equal? type 'void) _void) + (else (error "pffi-type->native-type -- No such pffi type" type))))))) + + (define pffi-pointer? + (lambda (object) + (cond-expand (sagittarius (pointer? object)) + (guile (pointer? object)) + (racket (cpointer? object))))) + + (define pffi-call + (lambda (shared-object name type arguments) + (let ((types (map pffi-type->native-type (map car arguments))) + (vals (map cdr arguments))) + (cond-expand + (sagittarius + (apply (make-c-function shared-object + (pffi-type->native-type type) + name + types) + vals)) + (guile + (apply + (foreign-library-function shared-object + (symbol->string name) + #:return-type (pffi-type->native-type type) + #:arg-types types) + vals)) + (racket + (apply (get-ffi-obj name + shared-object + (_cprocedure (mlist->list types) + (pffi-type->native-type type))) + vals)))))) + + (define pffi-size-of + (lambda (type) + (cond-expand + (sagittarius + (cond ((eq? type 'int8) (cond-expand (sagittarius size-of-int8_t))) + ((eq? type 'uint8) (cond-expand (sagittarius size-of-uint8_t))) + ((eq? type 'int16) (cond-expand (sagittarius size-of-int16_t))) + ((eq? type 'uint16) (cond-expand (sagittarius size-of-uint16_t))) + ((eq? type 'int32) (cond-expand (sagittarius size-of-int32_t))) + ((eq? type 'uint32) (cond-expand (sagittarius size-of-uint32_t))) + ((eq? type 'int64) (cond-expand (sagittarius size-of-int64_t))) + ((eq? type 'uint64) (cond-expand (sagittarius size-of-uint64_t))) + ((eq? type 'intptr) (cond-expand (sagittarius size-of-intptr_t))) + ((eq? type 'uintptr) (cond-expand (sagittarius size-of-uintptr_t))) + ((eq? type 'char) (cond-expand (sagittarius size-of-char))) + ((eq? type 'unsigned-char) (cond-expand (sagittarius size-of-char))) + ((eq? type 'short) (cond-expand (sagittarius size-of-short))) + ((eq? type 'unsigned-short) (cond-expand (sagittarius size-of-unsigned-short))) + ((eq? type 'int) (cond-expand (sagittarius size-of-int))) + ((eq? type 'unsigned-int) (cond-expand (sagittarius size-of-unsigned-int))) + ((eq? type 'long) (cond-expand (sagittarius size-of-long))) + ((eq? type 'unsigned-long) (cond-expand (sagittarius size-of-unsigned-long))) + ((eq? type 'float) (cond-expand (sagittarius size-of-float))) + ((eq? type 'double) (cond-expand (sagittarius size-of-double))) + ((eq? type 'pointer) (cond-expand (sagittarius size-of-void*))) + (else (error "Can not get size of unknown type" type)))) + (guile (sizeof (pffi-type->native-type type))) + (racket (ctype-sizeof (pffi-type->native-type type)))))) + + (define pffi-pointer-allocate + (lambda (size) + (cond-expand + (sagittarius (allocate-pointer size)) + (guile (bytevector->pointer (make-bytevector size 0))) + (racket (malloc size))))) + + (define pffi-pointer-null + (lambda () + (cond-expand + (sagittarius (integer->pointer 0)) + (guile (make-pointer 0)) + (racket #f)))) + + (define pffi-string->pointer + (lambda (string-content) + (cond-expand (sagittarius (bytevector->pointer (string->utf8 (string-copy string-content)))) + (guile (string->pointer string-content)) + (racket (cast string-content _string _pointer))))) + + (define pffi-pointer->string + (lambda (pointer) + (cond-expand (sagittarius (pointer->string pointer)) + (guile (pointer->string pointer)) + (racket (cast pointer _pointer _string))))) + + (define pffi-pointer->bytevector + (lambda (pointer size) + (cond-expand (sagittarius (pointer->bytevector pointer size)) + (guile (pointer->bytevector pointer size)) + (racket (cast pointer _pointer _bytes))))) + + (define pffi-shared-object-load + (lambda (path) + (cond-expand (sagittarius (open-shared-library path)) + (guile (load-foreign-library path #:lazy? #f)) + (racket (ffi-lib path))))) + + (define pffi-shared-object-auto-load + (lambda (object-name additional-paths) + (let* ((paths (append auto-load-paths additional-paths)) + (shared-object #f)) + (for-each + (lambda (path) + (if (not shared-object) + (let ((object-path + (string-append path + "/" + object-name + platform-file-extension)) + (object-version-path + (string-append path + "/" + object-name + platform-version-file-extension)) + (object-lib-path + (string-append path + "/" + platform-lib-prefix + object-name + platform-file-extension)) + (object-version-lib-path + (string-append path + "/" + platform-lib-prefix + object-name + platform-version-file-extension))) + (cond + ((file-exists? object-path) + (set! shared-object (pffi-shared-object-load object-path))) + ((file-exists? object-version-path) + (set! shared-object (pffi-shared-object-load object-version-path))) + ((file-exists? object-lib-path) + (set! shared-object (pffi-shared-object-load object-lib-path))) + ((file-exists? object-version-lib-path) + (set! shared-object (pffi-shared-object-load object-version-lib-path))))))) + paths) + (if (not shared-object) + (error "Could not load shared object" object-name) + shared-object)))) + + (define pffi-pointer-free + (lambda (pointer) + (cond-expand (sagittarius (c-free pointer)) + (guile #t) + (racket (free pointer))))) + + (define pffi-pointer-null? + (lambda (pointer) + (cond-expand (sagittarius (null-pointer? pointer)) + (guile (null-pointer? pointer)) + (racket (not pointer) ; #f is the null pointer on racket + )))) + + (define pffi-pointer-set! + (lambda (pointer type offset value) + (cond-expand + (sagittarius + (let ((p pointer)) + (cond ((equal? type 'int8) (pointer-set-c-int8_t! p offset value)) + ((equal? type 'uint8) (pointer-set-c-uint8_t! p offset value)) + ((equal? type 'int16) (pointer-set-c-int16_t! p offset value)) + ((equal? type 'uint16) (pointer-set-c-uint16_t! p offset value)) + ((equal? type 'int32) (pointer-set-c-int32_t! p offset value)) + ((equal? type 'uint32) (pointer-set-c-uint32_t! p offset value)) + ((equal? type 'int64) (pointer-set-c-int64_t! p offset value)) + ((equal? type 'uint64) (pointer-set-c-uint64_t! p offset value)) + ((equal? type 'intptr) (pointer-set-c-intptr_t! p offset value)) + ((equal? type 'uintptr) (pointer-set-c-uintptr_t! p offset value)) + ((equal? type 'char) (pointer-set-c-char! p offset value)) + ((equal? type 'short) (pointer-set-c-short! p offset value)) + ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! p offset value)) + ((equal? type 'int) (pointer-set-c-int! p offset value)) + ((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! p offset value)) + ((equal? type 'long) (pointer-set-c-long! p offset value)) + ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! p offset value)) + ((equal? type 'float) (pointer-set-c-float! p offset value)) + ((equal? type 'double) (pointer-set-c-double! p offset value)) + ((equal? type 'void) (pointer-set-c-void*! p offset value))))) + (guile (let ((p (pointer->bytevector pointer (+ offset 100))) + (native-type (pffi-type->native-type type))) + (cond ((equal? native-type int8) (bytevector-s8-set! p offset value)) + ((equal? native-type uint8) (bytevector-u8-set! p offset value)) + ((equal? native-type int16) (bytevector-s16-set! p offset value (native-endianness))) + ((equal? native-type uint16) (bytevector-u16-set! p offset value (native-endianness))) + ((equal? native-type int32) (bytevector-s32-set! p offset value (native-endianness))) + ((equal? native-type uint32) (bytevector-u32-set! p offset value (native-endianness))) + ((equal? native-type int64) (bytevector-s64-set! p offset value (native-endianness))) + ((equal? native-type uint64) (bytevector-u64-set! p offset value (native-endianness))) + ;((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset)) + ;((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset)) + ((equal? native-type char) (string-set! (pointer->string pointer) offset value)) + ;((equal? native-type 'short) (pointer-set-c-short p offset value)) + ;((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset)) + ((equal? native-type int) (bytevector-sint-set! p offset value (native-endianness) (pffi-size-of type))) + ((equal? native-type unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (pffi-size-of type))) + ;((equal? native-type 'long) (pointer-ref-c-long p offset)) + ;((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset)) + ;((equal? native-type 'float) (pointer-ref-c-float p offset)) + ;((equal? native-type 'double) (pointer-ref-c-double p offset)) + ;((equal? native-type '*) (pointer-ref-c-void* p offset)) + ))) + (racket (ptr-set! pointer type offset value))))) + + (define pffi-pointer-get + (lambda (pointer type offset) + (cond-expand + (sagittarius + (let ((p pointer) + (native-type (pffi-type->native-type type))) + (cond ((equal? native-type 'int8_t) (pointer-ref-c-int8_t p offset)) + ((equal? native-type 'uint8_t) (pointer-ref-c-uint8_t p offset)) + ((equal? native-type 'int16_t) (pointer-ref-c-int16_t p offset)) + ((equal? native-type 'uint16_t) (pointer-ref-c-uint16_t p offset)) + ((equal? native-type 'int32_t) (pointer-ref-c-int32_t p offset)) + ((equal? native-type 'uint32_t) (pointer-ref-c-uint32_t p offset)) + ((equal? native-type 'int64_t) (pointer-ref-c-int64_t p offset)) + ((equal? native-type 'uint64_t) (pointer-ref-c-uint64_t p offset)) + ((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset)) + ((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset)) + ((equal? native-type 'char) (pointer-ref-c-char p offset)) + ((equal? native-type 'short) (pointer-set-c-short p offset value)) + ((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset)) + ((equal? native-type 'int) (pointer-ref-c-int p offset)) + ((equal? native-type 'unsigned-int) (pointer-ref-c-unsigned-int p offset)) + ((equal? native-type 'long) (pointer-ref-c-long p offset)) + ((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset)) + ((equal? native-type 'float) (pointer-ref-c-float p offset)) + ((equal? native-type 'double) (pointer-ref-c-double p offset)) + ((equal? native-type 'void*) (pointer-ref-c-void* p offset))))) + (guile + (let ((p (pointer->bytevector pointer (+ offset 100))) + (native-type (pffi-type->native-type type))) + (cond ((equal? native-type int8) (bytevector-s8-ref p offset)) + ((equal? native-type uint8) (bytevector-u8-ref p offset)) + ((equal? native-type int16) (bytevector-s16-ref p offset (native-endianness))) + ((equal? native-type uint16) (bytevector-u16-ref p offset (native-endianness))) + ((equal? native-type int32) (bytevector-s32-ref p offset (native-endianness))) + ((equal? native-type uint32) (bytevector-u32-ref p offset (native-endianness))) + ((equal? native-type int64) (bytevector-s64-ref p offset (native-endianness))) + ((equal? native-type uint64) (bytevector-u64-ref p offset (native-endianness))) + ;((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset)) + ;((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset)) + ((equal? native-type char) (string-ref (pointer->string pointer) offset)) + ;((equal? native-type 'short) (pointer-set-c-short p offset value)) + ;((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset)) + ((equal? native-type int) (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type))) + ((equal? native-type unsigned-int) (bytevector-uint-ref p offset (native-endianness) (pffi-size-of type))) + ;((equal? native-type 'long) (pointer-ref-c-long p offset)) + ;((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset)) + ;((equal? native-type 'float) (pointer-ref-c-float p offset)) + ;((equal? native-type 'double) (pointer-ref-c-double p offset)) + ;((equal? native-type '*) (pointer-ref-c-void* p offset)) + ))) + (racket (ptr-ref pointer type offset))))) + + (define pffi-pointer-deref + (lambda (pointer) + (cond-expand (sagittarius (deref pointer 0)) + (guile (dereference-pointer pointer)) + (racket #t)))))) diff --git a/retropikzel/pffi/v0.1.0/main.scm b/retropikzel/pffi/v0.1.0/main.scm index 520aafe..f5b1ae5 100644 --- a/retropikzel/pffi/v0.1.0/main.scm +++ b/retropikzel/pffi/v0.1.0/main.scm @@ -1,6 +1,13 @@ (define-library (retropikzel pffi v0.1.0 main) (cond-expand + (sagittarius + (import (scheme base) + (scheme write) + (scheme file) + (scheme process-context) + (sagittarius ffi) + (sagittarius))) (guile (import (scheme base) (scheme write) @@ -9,17 +16,18 @@ (rnrs bytevectors) (system foreign) (system foreign-library))) - (sagittarius + (racket (import (scheme base) (scheme write) (scheme file) (scheme process-context) - (sagittarius ffi) - (sagittarius))) + (only (racket base) + system-type) + (compatibility mlist) + (ffi unsafe))) (else (error "Implementation not supported by r7rs-pffi"))) (export pffi-call pffi-types - pffi-type-sizes pffi-size-of pffi-pointer-allocate pffi-pointer-null @@ -38,6 +46,26 @@ (define library-version "v0.1.0") + (define platform-file-extension + (cond-expand + (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) + (guile "") + (windows ".dll") + (else ".so"))) + + (define platform-version-file-extension + (cond-expand + (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0")) + (guile "") + (windows ".dll") + (else ".so.0"))) + + (define platform-lib-prefix + (cond-expand + (racket (if (equal? (system-type 'os) 'windows) "" "lib")) + (windows "") + (else "lib"))) + (define pffi-types '(int8 uint8 @@ -81,6 +109,26 @@ (define auto-load-paths (append (cond-expand + (racket (if (equal? (system-type 'os) 'windows) + (append + (if (get-environment-variable "SYSTEM") + (list (get-environment-variable "SYSTEM")) + (list)) + (if (get-environment-variable "WINDIR") + (list (get-environment-variable "WINDIR")) + (list)) + (list ".") + (string-split (get-environment-variable "PATH") #\;)) + (append + (list (if (get-environment-variable "GUIX_ENVIRONMENT") + (string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib") + "")) + (if (get-environment-variable "LD_LOAD_PATH") + (list) ;(string-split (get-environment-variable "LD_LOAD_PATH") #\:) + (list)) + (list "/lib/x86_64-linux-gnu" + "/usr/lib/x86_64-linux-gnu" + "/usr/local/lib")))) (windows (append (if (get-environment-variable "SYSTEM") @@ -105,11 +153,7 @@ - (define platform-file-extension - (cond-expand - (guile "") - (windows ".dll") - (else ".so"))) + (define memorysession #f) (define linker #f) @@ -158,7 +202,7 @@ ;((equal? type 'char) char) ((equal? type 'char) int) ;((equal? type 'unsigned-char) char) - ((equal? type 'unsigned-char) int) + ;((equal? type 'unsigned-char) int) ((equal? type 'short) short) ((equal? type 'unsigned-short) unsigned-short) ((equal? type 'int) int) @@ -170,12 +214,37 @@ ((equal? type 'pointer) '*) ((equal? type 'void) void) (else (error "pffi-type->native-type -- No such pffi type" type)))) - ))) + (racket + (cond ((equal? type 'int8) _int8) + ((equal? type 'uint8) _uint8) + ((equal? type 'int16) _int16) + ((equal? type 'uint16) _uint16) + ((equal? type 'int32) _int32) + ((equal? type 'uint32) _uint32) + ((equal? type 'int64) _int64) + ((equal? type 'uint64) _uint64) + ;((equal? type 'intptr) intptr) + ;((equal? type 'uintptr) uintptr) + ;((equal? type 'char) _int32) + ((equal? type 'char) _int) + ((equal? type 'unsigned-char) _int) + ((equal? type 'short) _short) + ((equal? type 'unsigned-short) _ushort) + ((equal? type 'int) _int) + ((equal? type 'unsigned-int) _uint) + ((equal? type 'long) _long) + ((equal? type 'unsigned-long) _ulong) + ((equal? type 'float) _float) + ((equal? type 'double) _double) + ((equal? type 'pointer) _pointer) + ((equal? type 'void) _void) + (else (error "pffi-type->native-type -- No such pffi type" type))))))) (define pffi-pointer? (lambda (object) (cond-expand (sagittarius (pointer? object)) - (guile (pointer? object))))) + (guile (pointer? object)) + (racket (cpointer? object))))) (define pffi-call (lambda (shared-object name type arguments) @@ -194,12 +263,17 @@ (symbol->string name) #:return-type (pffi-type->native-type type) #:arg-types types) - vals)))))) + vals)) + (racket + (apply (get-ffi-obj name + shared-object + (_cprocedure (mlist->list types) + (pffi-type->native-type type))) + vals)))))) (define pffi-size-of (lambda (type) (cond-expand - (guile (sizeof (pffi-type->native-type type))) (sagittarius (cond ((eq? type 'int8) (cond-expand (sagittarius size-of-int8_t))) ((eq? type 'uint8) (cond-expand (sagittarius size-of-uint8_t))) @@ -222,39 +296,47 @@ ((eq? type 'float) (cond-expand (sagittarius size-of-float))) ((eq? type 'double) (cond-expand (sagittarius size-of-double))) ((eq? type 'pointer) (cond-expand (sagittarius size-of-void*))) - (else (error "Can not get size of unknown type" type))))))) + (else (error "Can not get size of unknown type" type)))) + (guile (sizeof (pffi-type->native-type type))) + (racket (ctype-sizeof (pffi-type->native-type type)))))) (define pffi-pointer-allocate (lambda (size) (cond-expand (sagittarius (allocate-pointer size)) - (guile (bytevector->pointer (make-bytevector size 0)))))) + (guile (bytevector->pointer (make-bytevector size 0))) + (racket (malloc size))))) (define pffi-pointer-null (lambda () (cond-expand (sagittarius (integer->pointer 0)) - (guile (make-pointer 0))))) + (guile (make-pointer 0)) + (racket #f)))) (define pffi-string->pointer (lambda (string-content) (cond-expand (sagittarius (bytevector->pointer (string->utf8 (string-copy string-content)))) - (guile (string->pointer string-content))))) + (guile (string->pointer string-content)) + (racket (cast string-content _string _pointer))))) (define pffi-pointer->string (lambda (pointer) (cond-expand (sagittarius (pointer->string pointer)) - (guile (pointer->string pointer))))) + (guile (pointer->string pointer)) + (racket (cast pointer _pointer _string))))) (define pffi-pointer->bytevector (lambda (pointer size) (cond-expand (sagittarius (pointer->bytevector pointer size)) - (guile (pointer->bytevector pointer size))))) + (guile (pointer->bytevector pointer size)) + (racket (cast pointer _pointer _bytes))))) (define pffi-shared-object-load (lambda (path) (cond-expand (sagittarius (open-shared-library path)) - (guile (load-foreign-library path #:lazy? #f))))) + (guile (load-foreign-library path #:lazy? #f)) + (racket (ffi-lib path))))) (define pffi-shared-object-auto-load (lambda (object-name additional-paths) @@ -267,24 +349,24 @@ (string-append path "/" object-name - (cond-expand (windows ".dll") (else ".so")))) + platform-file-extension)) (object-version-path (string-append path "/" object-name - (cond-expand (windows ".dll") (else ".so.0")))) + platform-version-file-extension)) (object-lib-path (string-append path "/" - (cond-expand (windows "") (else "lib")) + platform-lib-prefix object-name - (cond-expand (windows ".dll") (else ".so")))) + platform-file-extension)) (object-version-lib-path (string-append path "/" - (cond-expand (windows "") (else "lib")) + platform-lib-prefix object-name - (cond-expand (windows ".dll") (else ".so.0"))))) + platform-version-file-extension))) (cond ((file-exists? object-path) (set! shared-object (pffi-shared-object-load object-path))) @@ -302,12 +384,15 @@ (define pffi-pointer-free (lambda (pointer) (cond-expand (sagittarius (c-free pointer)) - (guile #t)))) + (guile #t) + (racket (free pointer))))) (define pffi-pointer-null? (lambda (pointer) (cond-expand (sagittarius (null-pointer? pointer)) - (guile (null-pointer? pointer))))) + (guile (null-pointer? pointer)) + (racket (not pointer) ; #f is the null pointer on racket + )))) (define pffi-pointer-set! (lambda (pointer type offset value) @@ -335,29 +420,29 @@ ((equal? type 'double) (pointer-set-c-double! p offset value)) ((equal? type 'void) (pointer-set-c-void*! p offset value))))) (guile (let ((p (pointer->bytevector pointer (+ offset 100))) - (native-type (pffi-type->native-type type))) - (cond ((equal? native-type int8) (bytevector-s8-set! p offset value)) - ((equal? native-type uint8) (bytevector-u8-set! p offset value)) - ((equal? native-type int16) (bytevector-s16-set! p offset value (native-endianness))) - ((equal? native-type uint16) (bytevector-u16-set! p offset value (native-endianness))) - ((equal? native-type int32) (bytevector-s32-set! p offset value (native-endianness))) - ((equal? native-type uint32) (bytevector-u32-set! p offset value (native-endianness))) - ((equal? native-type int64) (bytevector-s64-set! p offset value (native-endianness))) - ((equal? native-type uint64) (bytevector-u64-set! p offset value (native-endianness))) - ;((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset)) - ;((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset)) - ((equal? native-type char) (string-set! (pointer->string pointer) offset value)) - ;((equal? native-type 'short) (pointer-set-c-short p offset value)) - ;((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset)) - ((equal? native-type int) (bytevector-sint-set! p offset value (native-endianness) (pffi-size-of type))) - ((equal? native-type unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (pffi-size-of type))) - ;((equal? native-type 'long) (pointer-ref-c-long p offset)) - ;((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset)) - ;((equal? native-type 'float) (pointer-ref-c-float p offset)) - ;((equal? native-type 'double) (pointer-ref-c-double p offset)) - ;((equal? native-type '*) (pointer-ref-c-void* p offset)) - - )))))) + (native-type (pffi-type->native-type type))) + (cond ((equal? native-type int8) (bytevector-s8-set! p offset value)) + ((equal? native-type uint8) (bytevector-u8-set! p offset value)) + ((equal? native-type int16) (bytevector-s16-set! p offset value (native-endianness))) + ((equal? native-type uint16) (bytevector-u16-set! p offset value (native-endianness))) + ((equal? native-type int32) (bytevector-s32-set! p offset value (native-endianness))) + ((equal? native-type uint32) (bytevector-u32-set! p offset value (native-endianness))) + ((equal? native-type int64) (bytevector-s64-set! p offset value (native-endianness))) + ((equal? native-type uint64) (bytevector-u64-set! p offset value (native-endianness))) + ;((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset)) + ;((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset)) + ((equal? native-type char) (string-set! (pointer->string pointer) offset value)) + ;((equal? native-type 'short) (pointer-set-c-short p offset value)) + ;((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset)) + ((equal? native-type int) (bytevector-sint-set! p offset value (native-endianness) (pffi-size-of type))) + ((equal? native-type unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (pffi-size-of type))) + ;((equal? native-type 'long) (pointer-ref-c-long p offset)) + ;((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset)) + ;((equal? native-type 'float) (pointer-ref-c-float p offset)) + ;((equal? native-type 'double) (pointer-ref-c-double p offset)) + ;((equal? native-type '*) (pointer-ref-c-void* p offset)) + ))) + (racket (ptr-set! pointer type offset value))))) (define pffi-pointer-get (lambda (pointer type offset) @@ -388,7 +473,7 @@ (guile (let ((p (pointer->bytevector pointer (+ offset 100))) (native-type (pffi-type->native-type type))) - (cond ((equal? native-type int8) (bytevector-s8-ref p offset)) + (cond ((equal? native-type int8) (bytevector-s8-ref p offset)) ((equal? native-type uint8) (bytevector-u8-ref p offset)) ((equal? native-type int16) (bytevector-s16-ref p offset (native-endianness))) ((equal? native-type uint16) (bytevector-u16-ref p offset (native-endianness))) @@ -408,10 +493,11 @@ ;((equal? native-type 'float) (pointer-ref-c-float p offset)) ;((equal? native-type 'double) (pointer-ref-c-double p offset)) ;((equal? native-type '*) (pointer-ref-c-void* p offset)) - - )))))) + ))) + (racket (ptr-ref pointer type offset))))) (define pffi-pointer-deref (lambda (pointer) (cond-expand (sagittarius (deref pointer 0)) - (guile (dereference-pointer pointer))))))) + (guile (dereference-pointer pointer)) + (racket #t)))))) diff --git a/test/hello.scm b/test/hello.scm new file mode 100644 index 0000000..653c8a0 --- /dev/null +++ b/test/hello.scm @@ -0,0 +1,8 @@ +(import (scheme base) + (scheme write) + (retropikzel pffi v0.1.0 main)) + +(display "Hello") +(newline) + +