Layers 4-5: FFI translation macros and module path mapping
ober
4ce9271c43a2f1e81571d18b07b5cfef3b14dcb7
--- a/Makefile +++ b/Makefile @@ -1,9 +1,9 @@ SCHEME = scheme LIBDIRS = lib -.PHONY: test test-reader test-core test-runtime test-stdlib clean +.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules clean -test: test-reader test-core test-runtime test-stdlib +test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-reader: $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-reader.ss @@ -23,6 +23,16 @@ test-stdlib: $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-stdlib.ss; \ fi +test-ffi: + @if [ -f tests/test-ffi.ss ]; then \ + $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-ffi.ss; \ + fi + +test-modules: + @if [ -f tests/test-modules.ss ]; then \ + $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-modules.ss; \ + fi + clean: find lib -name "*.so" -delete 2>/dev/null || true find lib -name "*.wpo" -delete 2>/dev/null || true new file mode 100644 --- /dev/null +++ b/lib/jerboa/ffi.sls @@ -0,0 +1,125 @@ +#!chezscheme +;;; jerboa/ffi -- FFI translation macros +;;; +;;; Translates Gerbil/Gambit FFI forms to Chez Scheme equivalents: +;;; c-lambda → foreign-procedure +;;; c-declare → load-shared-object + foreign-procedure +;;; define-c-lambda → named foreign-procedure binding +;;; begin-ffi → begin with FFI body +;;; +;;; Type mapping: Gambit FFI types → Chez foreign types + +(library (jerboa ffi) + (export c-lambda define-c-lambda + begin-ffi c-declare + ffi-type-map + load-shared-object*) + (import (chezscheme)) + + ;; FFI type translation: Gambit/Gerbil type → Chez type + ;; Used at expand time by macros + (meta define (translate-ffi-type type) + (case type + [(int) 'int] + [(unsigned-int unsigned) 'unsigned] + [(int8) 'integer-8] + [(unsigned-int8 uint8) 'unsigned-8] + [(int16) 'integer-16] + [(unsigned-int16 uint16) 'unsigned-16] + [(int32) 'integer-32] + [(unsigned-int32 uint32) 'unsigned-32] + [(int64) 'integer-64] + [(unsigned-int64 uint64) 'unsigned-64] + [(float) 'float] + [(double) 'double] + [(char) 'char] + [(bool boolean) 'boolean] + [(void) 'void] + [(char-string nonnull-char-string char* nonnull-char*) 'string] + [(scheme-object) 'scheme-object] + [(size-t) 'size_t] + [(ssize-t) 'ssize_t] + [(short) 'short] + [(unsigned-short) 'unsigned-short] + [(long) 'long] + [(unsigned-long) 'unsigned-long] + [else + ;; Handle pointer types + (if (and (pair? type) (eq? (car type) 'pointer)) + 'void* + (if (and (pair? type) (eq? (car type) 'nonnull-pointer)) + 'void* + ;; Pass through — may be a Chez type already + type))])) + + ;; Runtime helper: load-shared-object with search + (define (load-shared-object* name) + (load-shared-object name)) + + ;; Type mapping table for runtime use + (define ffi-type-map + '((int . int) + (unsigned-int . unsigned) + (int64 . integer-64) + (uint64 . unsigned-64) + (double . double) + (float . float) + (bool . boolean) + (char-string . string) + (nonnull-char-string . string) + (void . void) + (scheme-object . scheme-object) + (size-t . size_t))) + + ;; c-lambda: inline FFI call + ;; (c-lambda (arg-types ...) ret-type "c_function_name") + ;; → (foreign-procedure "c_function_name" (chez-types ...) chez-ret-type) + (define-syntax c-lambda + (lambda (stx) + (syntax-case stx () + [(k (arg-type ...) ret-type c-name) + (string? (syntax->datum #'c-name)) + (let ([chez-arg-types (map (lambda (t) (translate-ffi-type (syntax->datum t))) + (syntax->list #'(arg-type ...)))] + [chez-ret-type (translate-ffi-type (syntax->datum #'ret-type))]) + (with-syntax ([(ct ...) (datum->syntax #'k chez-arg-types)] + [rt (datum->syntax #'k chez-ret-type)]) + #'(foreign-procedure c-name (ct ...) rt)))]))) + + ;; define-c-lambda: named FFI binding + ;; (define-c-lambda name (arg-types ...) ret-type "c_func") + ;; → (define name (foreign-procedure "c_func" ...)) + (define-syntax define-c-lambda + (lambda (stx) + (syntax-case stx () + [(k name (arg-type ...) ret-type c-name) + #'(define name (c-lambda (arg-type ...) ret-type c-name))] + ;; Shorthand: use the scheme name as the C name + [(k name (arg-type ...) ret-type) + (identifier? #'name) + (let ([c-name-str (symbol->string (syntax->datum #'name))]) + (with-syntax ([cn (datum->syntax #'k c-name-str)]) + #'(define name (c-lambda (arg-type ...) ret-type cn))))]))) + + ;; begin-ffi: wrapper for FFI declarations + ;; (begin-ffi (exported-names ...) body ...) + ;; → (begin body ...) + ;; In Gerbil, begin-ffi compiles C code; in Chez we rely on + ;; pre-compiled shared objects loaded via load-shared-object + (define-syntax begin-ffi + (syntax-rules () + [(_ (export-name ...) body ...) + (begin body ...)] + [(_ body ...) + (begin body ...)])) + + ;; c-declare: C code declarations + ;; In Gerbil/Gambit, this embeds C code. In Chez, C code must be + ;; pre-compiled to a shared library. This macro is a no-op but + ;; serves as documentation of what C code is expected. + (define-syntax c-declare + (syntax-rules () + [(_ c-code) + (void)])) + + ) ;; end library --- a/lib/jerboa/reader.sls +++ b/lib/jerboa/reader.sls @@ -646,9 +646,31 @@ (char=? (string-ref s (fx- (string-length s) 1)) #\:)) (let ((kw-name (substring s 0 (fx- (string-length s) 1)))) (annotate rs (string->keyword kw-name) loc))) + ;; :package/module/... → (package module ...) + ;; Gerbil module path syntax + ((and (fx> (string-length s) 1) + (char=? (string-ref s 0) #\:)) + (let ((path (substring s 1 (string-length s)))) + (annotate rs (module-path->list path) loc))) (else (annotate rs sym loc))))))))) + ;; Convert "std/sort" → (std sort), "std/text/json" → (std text json) + (define (module-path->list path) + (let ((parts (string-split-simple path #\/))) + (map string->symbol parts))) + + (define (string-split-simple str ch) + (let ((len (string-length str))) + (let loop ((i 0) (start 0) (acc '())) + (cond + ((fx= i len) + (reverse (cons (substring str start len) acc))) + ((char=? (string-ref str i) ch) + (loop (fx+ i 1) (fx+ i 1) (cons (substring str start i) acc))) + (else + (loop (fx+ i 1) start acc)))))) + (define (read-symbol-chars rs prefix-char) (let loop ((chars (if prefix-char (list prefix-char) '()))) (let ((ch (reader-peek rs))) new file mode 100644 --- /dev/null +++ b/tests/test-ffi.ss @@ -0,0 +1,64 @@ +#!chezscheme +;;; test-ffi.ss -- Tests for FFI translation macros + +(import (chezscheme) + (jerboa ffi)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + [(_ expr => expected) + (let ([result expr] + [exp expected]) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") + (write 'expr) + (display " => ") + (write result) + (display " expected ") + (write exp) + (newline))))])) + +;;; ---- FFI type mapping ---- + +;; c-lambda creates a foreign-procedure +;; We can test that c-lambda expands and produces a procedure for libc functions +(load-shared-object "libc.so.6") + +;; Test c-lambda with a real C function +(let ([my-getpid (c-lambda () int "getpid")]) + (check (procedure? my-getpid) => #t) + (check (> (my-getpid) 0) => #t)) + +;; Test define-c-lambda +(define-c-lambda my-getuid () unsigned-int "getuid") +(check (procedure? my-getuid) => #t) +(check (>= (my-getuid) 0) => #t) + +;; Test c-lambda with string types +(let ([my-strlen (c-lambda (char-string) int "strlen")]) + (check (my-strlen "hello") => 5) + (check (my-strlen "") => 0)) + +;; Test c-declare is a no-op (doesn't error) +(c-declare "/* this is ignored in Chez mode */") + +;; Test begin-ffi is a passthrough +(begin-ffi (test-val) + (define test-val 42)) +(check test-val => 42) + +;;; ---- Summary ---- +(newline) +(display "FFI tests: ") +(display pass-count) +(display " passed, ") +(display fail-count) +(display " failed") +(newline) +(when (> fail-count 0) (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/test-modules.ss @@ -0,0 +1,71 @@ +#!chezscheme +;;; test-modules.ss -- Tests for module path mapping + +(import (chezscheme) + (jerboa reader)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + [(_ expr => expected) + (let ([result expr] + [exp expected]) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") + (write 'expr) + (display " => ") + (write result) + (display " expected ") + (write exp) + (newline))))])) + +(define (read-one str) + (car (jerboa-read-string str))) + +;;; ---- Module path mapping ---- + +;; :std/sort → (std sort) +(check (read-one ":std/sort") => '(std sort)) + +;; :std/text/json → (std text json) +(check (read-one ":std/text/json") => '(std text json)) + +;; :std/misc/string → (std misc string) +(check (read-one ":std/misc/string") => '(std misc string)) + +;; :myapp/core → (myapp core) +(check (read-one ":myapp/core") => '(myapp core)) + +;; :gerbil/core → (gerbil core) +(check (read-one ":gerbil/core") => '(gerbil core)) + +;; Test in import context +(check (read-one "(import :std/sort :std/text/json)") + => '(import (std sort) (std text json))) + +;; Keywords still work (keyword: syntax) +(check (let ([v (read-one "name:")]) + (and (symbol? v) + (let ([s (symbol->string v)]) + (and (> (string-length s) 2) + (char=? (string-ref s 0) #\#) + (char=? (string-ref s 1) #\:))))) + => #t) + +;; Regular colon in middle of symbol is just a symbol +(check (read-one "foo:bar") => 'foo:bar) + +;;; ---- Summary ---- +(newline) +(display "Module tests: ") +(display pass-count) +(display " passed, ") +(display fail-count) +(display " failed") +(newline) +(when (> fail-count 0) (exit 1))