From f335b2ce4cb8cdfc7d2c9c20bb75fd92aa7900a5 Mon Sep 17 00:00:00 2001 From: Retropikzel Date: Thu, 7 Nov 2024 16:34:22 +0000 Subject: [PATCH] Added most of the support for mosh, some bugs remain and couple of unimplemented procedures. Got Gerbil to load files. --- Makefile | 9 +++ gerbil.pkg | 1 + retropikzel/r7rs-pffi.sld | 18 ++--- retropikzel/r7rs-pffi/mosh.scm | 117 ++++++++++++++++++++++++++++++++- test.scm | 8 ++- 5 files changed, 140 insertions(+), 13 deletions(-) create mode 100644 gerbil.pkg diff --git a/Makefile b/Makefile index d14e5c2..64b13b7 100644 --- a/Makefile +++ b/Makefile @@ -38,6 +38,15 @@ test-gambit: clean test-gauche: gosh -r7 -A . test.scm +GERBIL_LIB=gxc -O +GERBIL=GERBIL_LOADPATH=. gxi --lang r7rs +test-gerbil-podman-amd64: + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/gerbil bash -c "cd /workdir && ${GERBIL_LIB} retropikzel/r7rs-pffi.sld" + podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/gerbil bash -c "cd /workdir && ${GERBIL} test.scm" + +test-gerbil: + gxi --lang r7rs test.scm + GUILE=guile --r7rs --fresh-auto-compile -L . test-guile-podman-amd64: podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/guile bash -c "cd /workdir && ${GUILE} test.scm" diff --git a/gerbil.pkg b/gerbil.pkg new file mode 100644 index 0000000..39dcdf2 --- /dev/null +++ b/gerbil.pkg @@ -0,0 +1 @@ +(prelude: :scheme/r7rs) diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld index 36af13c..2ed9560 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/retropikzel/r7rs-pffi.sld @@ -111,17 +111,17 @@ pffi-shared-object-load pffi-pointer-null pffi-pointer-null? - ;pffi-define - ;pffi-define-callback - ;pffi-pointer-allocate + 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 - ;pffi-string->pointer - ;pffi-pointer->string - ;pffi-pointer-free - ;pffi-pointer? - ;pffi-pointer-set! - ;pffi-pointer-get ) (cond-expand (chibi (include "r7rs-pffi/chibi.scm")) diff --git a/retropikzel/r7rs-pffi/mosh.scm b/retropikzel/r7rs-pffi/mosh.scm index 11918a6..e9c54bc 100644 --- a/retropikzel/r7rs-pffi/mosh.scm +++ b/retropikzel/r7rs-pffi/mosh.scm @@ -29,9 +29,122 @@ (define pffi-pointer-null (lambda () - #f)) ; TODO + pointer-null)) (define pffi-pointer-null? (lambda (pointer) - (if (equal? pointer #f) #t #f))) ; TODO + (pointer-null? pointer))) +(define pffi-pointer-allocate + (lambda (size) + (malloc size))) + +(define pffi-pointer? + (lambda (object) + (pointer? object))) + +(define pffi-pointer-free + (lambda (pointer) + (free pointer))) + +(define pffi-pointer-set! + (lambda (pointer type offset value) + (cond ((equal? type 'int8) (pointer-set-c-int8! pointer offset value)) + ((equal? type 'uint8) (pointer-set-c-uint8! pointer offset value)) + ((equal? type 'int16) (pointer-set-c-int16! pointer offset value)) + ((equal? type 'uint16) (pointer-set-c-uint16! pointer offset value)) + ((equal? type 'int32) (pointer-set-c-int32! pointer offset value)) + ((equal? type 'uint32) (pointer-set-c-uint32! pointer offset value)) + ((equal? type 'int64) (pointer-set-c-int64! pointer offset value)) + ((equal? type 'uint64) (pointer-set-c-uint64! pointer offset value)) + ((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value))) + ((equal? type 'short) (pointer-set-c-short! pointer offset value)) + ((equal? type 'unsigned-short) (pointer-set-c-short! pointer offset value)) ;; FIXME + ((equal? type 'int) (pointer-set-c-int! pointer offset value)) + ((equal? type 'unsigned-int) (pointer-set-c-int! pointer offset value)) ;; FIXME + ((equal? type 'long) (pointer-set-c-long! pointer offset value)) + ((equal? type 'unsigned-long) (pointer-set-c-long! pointer offset value)) ;; FIXME + ((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 pffi-pointer-get + (lambda (pointer type offset) + (cond ((equal? type 'int8) (pointer-ref-c-int8 pointer offset)) + ((equal? type 'uint8) (pointer-ref-c-uint8 pointer offset)) + ((equal? type 'int16) (pointer-ref-c-int16 pointer offset)) + ((equal? type 'uint16) (pointer-ref-c-uint16 pointer offset)) + ((equal? type 'int32) (pointer-ref-c-int32 pointer offset)) + ((equal? type 'uint32) (pointer-ref-c-uint32 pointer offset)) + ((equal? type 'int64) (pointer-ref-c-int64 pointer offset)) + ((equal? type 'uint64) (pointer-ref-c-uint64 pointer offset)) + ((equal? type 'char) (integer->char (pointer-ref-c-signed-char pointer offset))) + ((equal? type 'short) (pointer-ref-c-signed-short pointer offset)) + ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset)) + ((equal? type 'int) (pointer-ref-c-signed-int pointer offset)) + ((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset)) + ((equal? type 'long) (pointer-ref-c-signed-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 pffi-string->pointer + (lambda (string-content) + (let ((pointer (pffi-pointer-allocate (+ (string-length string-content) 1))) + (index 0)) + (string-for-each + (lambda (c) + (pffi-pointer-set! pointer 'char (* index (pffi-size-of 'char)) c) + (set! index (+ index 1))) + string-content) + pointer))) + +(define pffi-pointer->string + (lambda (pointer) + (pointer->string pointer))) + +(define pffi-type->native-type + (lambda (type) + (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 '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 'string) 'char*) + ((equal? type 'void) 'void) + ((equal? type 'callback) 'callback) + (else (error "pffi-type->native-type -- No such pffi type" type))))) + +(define-syntax pffi-define + (syntax-rules () + ((pffi-define scheme-name shared-object c-name return-type argument-types) + (define scheme-name + (make-c-function shared-object + (pffi-type->native-type return-type) + c-name + (map pffi-type->native-type argument-types)))))) + +(define-syntax pffi-define-callback + (syntax-rules () + ((_ scheme-name return-type argument-types procedure) + (define scheme-name + (make-c-callback (pffi-type->native-type return-type) + (map pffi-type->native-type argument-types) + procedure))))) diff --git a/test.scm b/test.scm index 94ef558..bd49e38 100644 --- a/test.scm +++ b/test.scm @@ -187,7 +187,6 @@ (debug null-pointer) (assert equal? (pffi-pointer-null? null-pointer) #t) -#| ;; pffi-pointer-null? (print-header 'pffi-pointer-null?) @@ -226,6 +225,7 @@ (pffi-pointer-free pointer-to-be-freed) (debug pointer-to-be-freed) +#| ;; pffi-pointer-set! and pffi-pointer-get 1/2 (print-header "pffi-pointer-set! and pffi-pointer-get 1/2") @@ -270,6 +270,8 @@ (debug (pffi-pointer-get set-pointer 'double offset)) (assert = (pffi-pointer-get set-pointer 'double offset) 1.5) +|# + ;; pffi-string->pointer (print-header 'pffi-string->pointer) @@ -321,6 +323,7 @@ (debug (pffi-pointer-get hello-string-pointer 'char 4)) (assert char=? (pffi-pointer-get hello-string-pointer 'char 4) #\o) +#| ;; pffi-pointer-set! and pffi-pointer-get 2/2 (print-header "pffi-pointer-set! and pffi-pointer-get 2/2") @@ -347,6 +350,8 @@ (pffi-pointer-set! set-pointer 'pointer offset (pffi-string->pointer string-to-be-set)) (assert string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR") +|# + ;; pffi-define (print-header 'pffi-define) @@ -391,4 +396,3 @@ (newline) (exit 0) -|#