Generate Typed Jerboa scalar wrappers
ober
de2ce868dd0db2691c2ce0d7ee2faaef5eb28eae
--- a/Makefile +++ b/Makefile @@ -29,8 +29,9 @@ PURE_AUDIT_ARGS ?= --summary --discover $(PURE_AUDIT_ROOT) TYPED_SOURCES ?= tests/fixtures/typed/valid-split-tree.ss TYPED_RUST_SOURCES ?= $(TYPED_SOURCES) TYPED_RUST_DIR ?= build/typed/rust +TYPED_WRAPPER_DIR ?= build/typed/jerboa -.PHONY: help chez chez-cross build binary binary-cross native-cross pure-audit typecheck typed-rust typed-build typed-test typed-clean test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-contract test-ergo test-typed-parser test-typed-checker test-typed-rust test-pure-audit test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl test-security test-security-profile test-native test-gaps native clean-native audit-native clean security security-production security-profile fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-fuzz fuzz-dns-fuzz fuzz-pregexp-fuzz fuzz-csv-fuzz fuzz-base64-fuzz fuzz-hex-fuzz fuzz-uri-fuzz fuzz-format-fuzz fuzz-router-fuzz fuzz-sandbox-fuzz test-rawstring test-regex test-rx test-peg test-regex-all check-docs check-docs-strict docker-build docker-push +.PHONY: help chez chez-cross build binary binary-cross native-cross pure-audit typecheck typed-rust typed-wrappers typed-build typed-wrapper-smoke typed-test typed-clean test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-contract test-ergo test-typed-parser test-typed-checker test-typed-rust test-typed-wrappers test-pure-audit test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl test-security test-security-profile test-native test-gaps native clean-native audit-native clean security security-production security-profile fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-fuzz fuzz-dns-fuzz fuzz-pregexp-fuzz fuzz-csv-fuzz fuzz-base64-fuzz fuzz-hex-fuzz fuzz-uri-fuzz fuzz-format-fuzz fuzz-router-fuzz fuzz-sandbox-fuzz test-rawstring test-regex test-rx test-peg test-regex-all check-docs check-docs-strict docker-build docker-push help: @echo "Usage: make <target>" @@ -46,7 +47,9 @@ help: @echo " Args: CHEZ_TARGET_MACHINE=<mt> CROSS_CC=<cc> [CROSS_NATIVE_FEATURES=tls,...]" @echo " typecheck Typecheck Typed Jerboa sources" @echo " typed-rust Generate Rust crate sources from Typed Jerboa" - @echo " typed-build Generate Rust crate sources and run cargo check" + @echo " typed-wrappers Generate Jerboa wrappers for typed Rust exports" + @echo " typed-build Generate Rust crate sources/wrappers and run cargo build" + @echo " typed-wrapper-smoke Build and call generated typed wrappers through FFI" @echo " typed-test Run Typed Jerboa front-end tests" @echo " typed-clean Remove generated typed build artifacts" @echo " native Build Rust native library" @@ -77,6 +80,7 @@ help: @echo " test-typed-parser Typed Jerboa parser tests" @echo " test-typed-checker Typed Jerboa checker tests" @echo " test-typed-rust Typed Jerboa Rust emitter tests" + @echo " test-typed-wrappers Typed Jerboa wrapper generator tests" @echo " test-pure-audit Pure Jerboa migration scanner tests" @echo "" @echo "Test (features):" @@ -311,10 +315,21 @@ typecheck: typed-rust: @$(SCHEME) --libdirs $(LIBDIRS) --script support/typed-rust.ss $(TYPED_RUST_DIR) $(TYPED_RUST_SOURCES) -typed-build: typed-rust +typed-wrappers: + @$(SCHEME) --libdirs $(LIBDIRS) --script support/typed-wrappers.ss $(TYPED_WRAPPER_DIR) $(TYPED_RUST_SOURCES) + +typed-build: typed-rust typed-wrappers @cargo build --manifest-path $(TYPED_RUST_DIR)/Cargo.toml -typed-test: test-typed-parser test-typed-checker test-typed-rust typecheck +typed-wrapper-smoke: + @$(MAKE) --no-print-directory typed-build TYPED_RUST_SOURCES=tests/fixtures/typed/rust-basic.ss TYPED_WRAPPER_DIR=build/typed/jerboa-smoke + @lib="$$(find $(TYPED_RUST_DIR)/target/debug -maxdepth 1 \( -name 'libjerboa_typed_generated.dylib' -o -name 'libjerboa_typed_generated.so' \) -print | head -n 1)"; \ + test -n "$$lib" || { echo "ERROR: generated typed Rust dynamic library not found" >&2; exit 1; }; \ + JERBOA_TYPED_RUST_LIB="$$lib" \ + TYPED_WRAPPER_FILE="build/typed/jerboa-smoke/sample_typed_rust_basic.ss" \ + $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed-wrapper-e2e.ss + +typed-test: test-typed-parser test-typed-checker test-typed-rust test-typed-wrappers typecheck typed-clean: @rm -rf build/typed @@ -377,6 +392,9 @@ test-typed-checker: test-typed-rust: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed-rust.ss +test-typed-wrappers: + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed-wrappers.ss + test-pure-audit: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-pure-audit.ss --- a/docs/jerboa-to-llvmir.md +++ b/docs/jerboa-to-llvmir.md @@ -682,7 +682,7 @@ Then move to split-tree once variants are supported. - Generate C ABI wrappers. - Convert dynamic Jerboa values. - Return structured errors. -- Add Jerboa wrapper `.sls`. +- Add Jerboa wrapper `.ss`. ### Milestone 7: Backend Parity --- a/docs/jerboa-to-rust.md +++ b/docs/jerboa-to-rust.md @@ -62,9 +62,8 @@ build/typed/rust/Cargo.toml build/typed/rust/src/lib.rs build/typed/rust/src/modules/<module>.rs build/typed/rust/src/runtime.rs -build/typed/rust/include/<module>.h build/typed/rust/target/... -lib/jerboa-emacs/typed/<module>.sls +build/typed/jerboa/<module>.ss ``` The generated Rust crate should be disposable. The source of truth remains the @@ -231,6 +230,11 @@ pub fn line_count(text: String) -> u64 { Internal Rust functions should use safe Rust signatures. Exported functions should get separate ABI wrappers. +Current landing: scalar ABI-safe exported functions get generated Rust +`extern "C"` wrappers, and `.ss` Jerboa wrapper files call those symbols through +Chez `foreign-procedure`. Non-scalar values still wait for opaque handles and +conversion records. + ## Generics The first Rust backend should monomorphize generics. @@ -433,7 +437,9 @@ Add targets: ```make typed-rust +typed-wrappers typed-build +typed-wrapper-smoke typed-test typed-clean ``` @@ -442,10 +448,13 @@ Current and suggested behavior: - `typed-rust`: generate `build/typed/rust/Cargo.toml` and `build/typed/rust/src/lib.rs` +- `typed-wrappers`: generate `.ss` wrapper files under `build/typed/jerboa` - `typed-build`: generate Rust and run `cargo build`, producing disposable - `rlib`, `staticlib`, and `cdylib` artifacts -- `typed-test`: run parser, checker, emitter, and typecheck tests; later add - Rust unit tests plus Jerboa boundary tests + `rlib`, `staticlib`, and `cdylib` artifacts plus wrapper files +- `typed-wrapper-smoke`: build a primitive fixture and call generated wrappers + against the compiled cdylib through Chez FFI +- `typed-test`: run parser, checker, emitter, wrapper generator, and typecheck + tests; later add Rust unit tests plus broader Jerboa boundary tests - `typed-clean`: remove generated Rust build outputs Use Cargo for MVP. Add direct `rustc` mode later if static build integration @@ -552,14 +561,16 @@ Second module: typed `rope`. - Build with Cargo. Initial `make typed-build` target runs `cargo build` on the main typed split-tree fixture and emits `rlib`, `staticlib`, and `cdylib` artifacts. -- Call from Jerboa through FFI. +- Call from Jerboa through FFI. Initial scalar wrapper generation and + `typed-wrapper-smoke` landed for primitive exports. ### Milestone 2: Primitive Types - Support `Bool`, `Int`, `Nat`, `String`, `Bytes`. - Support function calls. - Support `if`, `let`, arithmetic, comparisons. -- Generate wrappers. +- Generate wrappers. Initial scalar `.ss` wrappers landed; record, variant, + string, bytes, option, result, and handle conversions remain future work. ### Milestone 3: Records and Variants --- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -117,7 +117,7 @@ Candidate extensions: - `.tss` for typed Jerboa source - `.ss` with `(typed-library ...)` forms -- `.sls` generated output for dynamic bindings +- `.ss` generated output for dynamic bindings - `.rs` generated output for Rust backend - `.ll` generated output for LLVM backend @@ -150,14 +150,23 @@ Current landing: modules. The first emitter covers Rust identifiers, primitive types, records, variants, primitive function bodies, record accessors/constructors, variant constructors, variant predicates, and exhaustive variant `match`; - native artifact builds and FFI wrappers are still future work. + native artifact builds now land through the generated Cargo crate. - Scalar-only exported functions get initial `extern "C"` Rust wrappers. Rust requires the symbol export marker to be written as `#[unsafe(no_mangle)]`, so generated crates deny unsafe operations rather than claiming a blanket `forbid(unsafe_code)` once wrappers are present. +- `(jerboa typed wrapper)`, `support/typed-wrappers.ss`, and `make + typed-wrappers` generate `.ss` Jerboa wrapper files for scalar ABI-safe + exports. The wrappers load the compiled Rust cdylib from + `JERBOA_TYPED_RUST_LIB`, validate dynamic arguments, call + `foreign-procedure`, and convert `Char` values through unsigned code points. +- `make typed-wrapper-smoke` builds the primitive Rust fixture, generates its + wrapper, loads the cdylib, and calls the generated Jerboa functions through + Chez FFI. - `support/typed-rust.ss`, `make typed-rust`, and `make typed-build` generate a - disposable Cargo crate under `build/typed/rust`; `typed-build` runs - `cargo build` against the generated crate. + disposable Cargo crate under `build/typed/rust`; `typed-build` also writes + wrappers under `build/typed/jerboa` and runs `cargo build` against the + generated crate. - The parser currently recognizes explicit `export` forms, `type` declarations, immutable and `mut` record fields, variants including nullary cases, and `def` forms with typed parameters and `:` or `->` return markers. @@ -630,6 +639,8 @@ typed-build typed-test typed-clean typed-rust +typed-wrappers +typed-wrapper-smoke typed-llvm ``` @@ -640,11 +651,15 @@ Initial meanings: - `typed-rust`: generate Rust for typed modules. Initial target writes `build/typed/rust/Cargo.toml` and `build/typed/rust/src/lib.rs` from `TYPED_RUST_SOURCES`, which defaults to `TYPED_SOURCES`. +- `typed-wrappers`: generate `.ss` wrappers for scalar ABI-safe exported typed + functions under `TYPED_WRAPPER_DIR`, defaulting to `build/typed/jerboa`. - `typed-build`: generate Rust and run `cargo build`, producing disposable - `rlib`, `staticlib`, and `cdylib` artifacts. Jerboa wrappers are still - pending. + `rlib`, `staticlib`, and `cdylib` artifacts, plus scalar Jerboa wrappers. +- `typed-wrapper-smoke`: build the primitive Rust fixture and call generated + wrappers through the compiled cdylib. - `typed-test`: run typed compiler tests and runtime boundary tests. Initial - target runs parser, checker, Rust emitter, and `typecheck`. + target runs parser, checker, Rust emitter, wrapper generator, and + `typecheck`. - `typed-llvm`: reserved until the LLVM backend exists. ## Generated Files @@ -658,11 +673,11 @@ src/jerboa-emacs/typed/*.tss build/typed/rust/*.rs build/typed/llvm/*.ll build/typed/obj/*.o -lib/jerboa-emacs/typed/*.sls +build/typed/jerboa/*.ss ``` Checked-in generated files should be avoided for native artifacts. If wrapper -`.sls` files are checked in, they need a drift check like `check-generated`. +`.ss` files are checked in, they need a drift check like `check-generated`. ## Runtime Representation @@ -794,8 +809,10 @@ Minimum excluded features: targets landed for a primitive typed fixture. - Compile generated Rust as a static or dynamic library. Initial disposable `rlib`/`staticlib`/`cdylib` builds landed. -- Generate conversion functions. -- Generate Jerboa wrappers. +- Generate conversion functions. Initial scalar argument checks and `Char` + code-point conversions landed at the wrapper boundary. +- Generate Jerboa wrappers. Initial `.ss` wrapper generation landed for + scalar ABI-safe exported functions. ### Milestone 4: First Real Module --- a/lib/jerboa/typed/rust.ss +++ b/lib/jerboa/typed/rust.ss @@ -8,6 +8,9 @@ (library (jerboa typed rust) (export rust-symbol-name + abi-safe-type? + abi-safe-def? + abi-wrapper-name typed-module->rust-string typed-library-form->rust-string typed-modules->rust-crate-string @@ -351,6 +354,22 @@ ": " (abi-rust-type (typed-param-type param)))) + (def (emit-abi-param-conversion param port) + (when (eq? (typed-param-type param) 'Char) + (let ([name (rust-symbol-name (typed-param-name param))]) + (write-line port 1 + (string-append + "let " + name + " = char::from_u32(" + name + ").unwrap_or('\\u{FFFD}');"))))) + + (def (abi-return-expression def call) + (case (typed-def-return-type def) + [(Char) (string-append "(" call " as u32)")] + [else call])) + (def (emit-abi-wrapper module def port) (when (abi-safe-def? def) (let* ([params (typed-def-params def)] @@ -373,7 +392,11 @@ ") -> " (abi-rust-type (typed-def-return-type def)) " {")) - (write-line port 1 call) + (for-each + (lambda (param) + (emit-abi-param-conversion param port)) + params) + (write-line port 1 (abi-return-expression def call)) (write-line port 0 "}") (newline port)))) new file mode 100644 --- /dev/null +++ b/lib/jerboa/typed/wrapper.ss @@ -0,0 +1,255 @@ +#!chezscheme +;;; (jerboa typed wrapper) -- Jerboa boundary wrapper generation for Typed Jerboa +;;; +;;; Generates user-facing `.ss` wrapper files that load a compiled typed Rust +;;; library and expose checked Scheme functions for ABI-safe exported defs. + +(library (jerboa typed wrapper) + (export + abi-chez-type + typed-module-wrapper-file-name + typed-module->jerboa-wrapper-string + typed-library-form->jerboa-wrapper-string + typed-modules->jerboa-wrapper-files + typed-library-forms->jerboa-wrapper-files) + + (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted typed compiler wrapper generator + (only (jerboa core) def) + (jerboa typed parser) + (jerboa typed checker) + (only (jerboa typed rust) + rust-symbol-name + abi-safe-def? + abi-wrapper-name)) + + (def (emit-to-string thunk) + (let ([port (open-output-string)]) + (thunk port) + (get-output-string port))) + + (def (join-strings strings separator) + (cond + [(null? strings) ""] + [else + (let ([port (open-output-string)]) + (display (car strings) port) + (let loop ([rest (cdr strings)]) + (unless (null? rest) + (display separator port) + (display (car rest) port) + (loop (cdr rest)))) + (get-output-string port))])) + + (def (write-indent port level) + (let loop ([n level]) + (when (> n 0) + (display " " port) + (loop (- n 1))))) + + (def (write-line port level text) + (write-indent port level) + (display text port) + (newline port)) + + (def (datum->code datum) + (emit-to-string + (lambda (port) + (write datum port)))) + + (def (quoted-symbol-code sym) + (string-append "'" (datum->code sym))) + + (def (type-name-string type) + (if (symbol? type) + (symbol->string type) + (datum->code type))) + + (def (abi-chez-type type) + (case type + [(Unit) 'void] + [(Bool) 'boolean] + [(Char) 'unsigned-32] + [(Int) 'integer-64] + [(Nat) 'unsigned-64] + [(Fixnum) 'iptr] + [(Float) 'double] + [else (error 'typed-wrapper "unsupported ABI type" type)])) + + (def (typed-module-wrapper-file-name module) + (string-append + (join-strings + (map rust-symbol-name (typed-module-name module)) + "_") + ".ss")) + + (def (exported-def? module def) + (and (memq (typed-def-name def) (typed-module-exports module)) + #t)) + + (def (wrapper-defs module) + (let loop ([rest (typed-module-declarations module)] [out '()]) + (cond + [(null? rest) (reverse out)] + [(and (typed-def? (car rest)) + (exported-def? module (car rest)) + (abi-safe-def? (car rest))) + (loop (cdr rest) (cons (car rest) out))] + [else (loop (cdr rest) out)]))) + + (def (ffi-binding-name def) + (string->symbol + (string-append "%" (rust-symbol-name (typed-def-name def))))) + + (def (param-check-expression param) + (let ([name (datum->code (typed-param-name param))]) + (case (typed-param-type param) + [(Bool) (string-append "(boolean? " name ")")] + [(Char) (string-append "(char? " name ")")] + [(Int) (string-append "(%typed-rust-int64? " name ")")] + [(Nat) (string-append "(%typed-rust-uint64? " name ")")] + [(Fixnum) (string-append "(fixnum? " name ")")] + [(Float) (string-append "(real? " name ")")] + [else (error 'typed-wrapper "unsupported ABI parameter type" + (typed-param-type param))]))) + + (def (emit-param-check def param port) + (let* ([name (typed-param-name param)] + [name-code (datum->code name)] + [type-text (type-name-string (typed-param-type param))]) + (write-line port 1 + (string-append "(unless " (param-check-expression param))) + (write-line port 2 + (string-append + "(error " + (quoted-symbol-code (typed-def-name def)) + " " + (datum->code (string-append "expected " type-text " for " (symbol->string name))) + " " + name-code + "))")))) + + (def (wrapper-argument-expression param) + (let ([name (datum->code (typed-param-name param))]) + (case (typed-param-type param) + [(Char) (string-append "(char->integer " name ")")] + [else name]))) + + (def (wrapper-call-expression def) + (string-append + "(" + (datum->code (ffi-binding-name def)) + (let ([args (map wrapper-argument-expression (typed-def-params def))]) + (if (null? args) + "" + (string-append " " (join-strings args " ")))) + ")")) + + (def (wrapper-return-expression def) + (let ([call (wrapper-call-expression def)]) + (case (typed-def-return-type def) + [(Char) (string-append "(integer->char " call ")")] + [else call]))) + + (def (emit-ffi-binding module def port) + (write-line port 0 + (string-append + "(def " + (datum->code (ffi-binding-name def)))) + (write-line port 1 + (string-append + "(foreign-procedure " + (datum->code (abi-wrapper-name module def)) + " (" + (join-strings + (map (lambda (param) + (datum->code (abi-chez-type (typed-param-type param)))) + (typed-def-params def)) + " ") + ") " + (datum->code (abi-chez-type (typed-def-return-type def))) + "))")) + (newline port)) + + (def (emit-wrapper-def def port) + (let ([params (typed-def-params def)]) + (write-line port 0 + (string-append + "(def (" + (datum->code (typed-def-name def)) + (if (null? params) + "" + (string-append + " " + (join-strings + (map (lambda (param) + (datum->code (typed-param-name param))) + params) + " "))) + ")")) + (for-each + (lambda (param) + (emit-param-check def param port)) + params) + (write-line port 1 (wrapper-return-expression def)) + (write-line port 0 ")") + (newline port))) + + (def (emit-wrapper-header port) + (write-line port 0 ";; Generated by Jerboa's typed wrapper backend. Do not edit.") + (write-line port 0 "(import (jerboa prelude)") + (write-line port 0 " (only (chezscheme) foreign-procedure getenv load-shared-object))") + (newline port) + (write-line port 0 "(def %typed-rust-library-path (getenv \"JERBOA_TYPED_RUST_LIB\"))") + (write-line port 0 "(when %typed-rust-library-path") + (write-line port 1 "(load-shared-object %typed-rust-library-path))") + (newline port) + (write-line port 0 "(def %typed-rust-min-int64 -9223372036854775808)") + (write-line port 0 "(def %typed-rust-max-int64 9223372036854775807)") + (write-line port 0 "(def %typed-rust-max-uint64 18446744073709551615)") + (newline port) + (write-line port 0 "(def (%typed-rust-int64? x)") + (write-line port 1 "(and (integer? x)") + (write-line port 2 "(exact? x)") + (write-line port 2 "(<= %typed-rust-min-int64 x %typed-rust-max-int64)))") + (newline port) + (write-line port 0 "(def (%typed-rust-uint64? x)") + (write-line port 1 "(and (integer? x)") + (write-line port 2 "(exact? x)") + (write-line port 2 "(<= 0 x %typed-rust-max-uint64)))") + (newline port)) + + (def (emit-module-wrapper module port) + (emit-wrapper-header port) + (for-each + (lambda (def) + (emit-ffi-binding module def port)) + (wrapper-defs module)) + (for-each + (lambda (def) + (emit-wrapper-def def port)) + (wrapper-defs module))) + + (def (typed-module->jerboa-wrapper-string module) + (let ([errors (check-typed-module module)]) + (unless (null? errors) + (error 'typed-module->jerboa-wrapper-string + "typed module has check errors" + (map typed-check-error-kind errors))) + (emit-to-string + (lambda (port) + (emit-module-wrapper module port))))) + + (def (typed-library-form->jerboa-wrapper-string form) + (typed-module->jerboa-wrapper-string (parse-typed-library form))) + + (def (typed-modules->jerboa-wrapper-files modules) + (map + (lambda (module) + (cons (typed-module-wrapper-file-name module) + (typed-module->jerboa-wrapper-string module))) + modules)) + + (def (typed-library-forms->jerboa-wrapper-files forms) + (typed-modules->jerboa-wrapper-files (map parse-typed-library forms))) + +) ;; end library --- a/support/build.ss +++ b/support/build.ss @@ -20,6 +20,7 @@ (jerboa typed parser) (jerboa typed checker) (jerboa typed rust) + (jerboa typed wrapper) ;; Regex / rx / peg tier — compiled independently so errors are isolated (std srfi srfi-115) (std regex) new file mode 100644 --- /dev/null +++ b/support/typed-wrappers.ss @@ -0,0 +1,126 @@ +#!chezscheme +;;; typed-wrappers.ss -- generate Jerboa wrappers from Typed Jerboa source files +;;; +;;; Usage: +;;; scheme --libdirs lib --script support/typed-wrappers.ss OUT-DIR file.ss ... + +(import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted typed wrapper generator script + (jerboa reader) + (jerboa typed parser) + (jerboa typed wrapper)) + +(define (usage) + (display "Usage: scheme --libdirs lib --script support/typed-wrappers.ss OUT-DIR file.ss ...\n")) + +(define (string-split-slash text) + (let ([len (string-length text)]) + (let loop ([i 0] [start 0] [out '()]) + (cond + [(= i len) + (let ([part (substring text start i)]) + (reverse (if (string=? part "") out (cons part out))))] + [(char=? (string-ref text i) #\/) + (let ([part (substring text start i)]) + (loop (+ i 1) + (+ i 1) + (if (string=? part "") out (cons part out))))] + [else (loop (+ i 1) start out)])))) + +(define (absolute-path? path) + (and (> (string-length path) 0) + (char=? (string-ref path 0) #\/))) + +(define (path-join2 base part) + (cond + [(string=? base "") part] + [(string=? base "/") (string-append "/" part)] + [else (string-append base "/" part)])) + +(define (path-has-parent-reference? path) + (let loop ([parts (string-split-slash path)]) + (cond + [(null? parts) #f] + [(string=? (car parts) "..") #t] + [else (loop (cdr parts))]))) + +(define (validate-output-path path) + (when (or (absolute-path? path) + (path-has-parent-reference? path)) + (error 'typed-wrappers + "output paths must be relative and must not contain parent directory references" + path)) + path) + +(define (ensure-directory path) + (cond + [(file-directory? path) #t] + [(file-exists? path) + (error 'typed-wrappers "path exists but is not a directory" path)] + [else + (mkdir path) + #t])) + +(define (ensure-directory-tree path) + (let ([parts (string-split-slash path)] + [root (if (absolute-path? path) "/" "")]) + (let loop ([rest parts] [current root]) + (unless (null? rest) + (let ([next (path-join2 current (car rest))]) + (ensure-directory next) + (loop (cdr rest) next)))))) + +(define (write-file-string path text) + (let ([safe-path (validate-output-path path)] + [port #f]) + (dynamic-wind + (lambda () + (set! port (open-output-file safe-path 'replace))) + (lambda () (display text port)) + (lambda () + (when port + (close-port port)))))) + +(define (typed-library-forms forms) + (let loop ([rest forms] [out '()]) + (cond + [(null? rest) (reverse out)] + [(typed-library-form? (car rest)) + (loop (cdr rest) (cons (car rest) out))] + [else + (loop (cdr rest) out)]))) + +(define (read-typed-library-forms path) + (typed-library-forms (jerboa-read-file path))) + +(define (read-all-typed-library-forms paths) + (let loop ([rest paths] [out '()]) + (if (null? rest) + (reverse out) + (loop (cdr rest) + (append (reverse (read-typed-library-forms (car rest))) out))))) + +(define (generate-jerboa-wrappers out-dir source-paths) + (let* ([safe-out-dir (validate-output-path out-dir)] + [forms (read-all-typed-library-forms source-paths)]) + (when (null? forms) + (error 'typed-wrappers "no typed-library forms found" source-paths)) + (let ([files (typed-library-forms->jerboa-wrapper-files forms)]) + (ensure-directory-tree safe-out-dir) + (for-each + (lambda (file) + (write-file-string + (path-join2 safe-out-dir (car file)) + (cdr file))) + files) + (printf "Typed Jerboa wrappers: wrote ~a file~a to ~a\n" + (length files) + (if (= (length files) 1) "" "s") + safe-out-dir)))) + +(define args (command-line-arguments)) + +(when (< (length args) 2) + (usage) + (exit 2)) + +(generate-jerboa-wrappers (car args) (cdr args)) new file mode 100644 --- /dev/null +++ b/tests/fixtures/typed/rust-char.ss @@ -0,0 +1,5 @@ +(typed-library (sample typed char) + (export same-char) + + (def (same-char (ch : Char)) : Char + ch)) --- a/tests/test-typed-rust.ss +++ b/tests/test-typed-rust.ss @@ -47,6 +47,15 @@ (define data-rust "// Generated by Jerboa's typed Rust backend. Do not edit.\n#![deny(unsafe_op_in_unsafe_fn)]\n#![allow(unused_parens)]\n#![allow(unused_variables)]\n\n#[derive(Clone, Debug, PartialEq)]\npub struct Pane {\n pub id: u64,\n pub focused_p: bool,\n}\n\n#[derive(Clone, Debug, PartialEq)]\npub enum EditOp {\n Insert {\n at: u64,\n text: String,\n },\n Noop,\n}\n\n") +(define char-form + '(typed-library (sample typed char) + (export same-char) + (def (same-char (ch : Char)) : Char + ch))) + +(define char-rust + "// Generated by Jerboa's typed Rust backend. Do not edit.\n#![deny(unsafe_op_in_unsafe_fn)]\n#![allow(unused_parens)]\n#![allow(unused_variables)]\n\npub fn same_char(ch: char) -> char {\n ch\n}\n\n#[unsafe(no_mangle)]\npub extern \"C\" fn jt_sample_typed_char_same_char(ch: u32) -> u32 {\n let ch = char::from_u32(ch).unwrap_or('\\u{FFFD}');\n (same_char(ch) as u32)\n}\n\n") + (define ops-form '(typed-library (sample typed ops) (export pane-id make-insert make-noop edit-size) @@ -84,6 +93,10 @@ (typed-library-form->rust-string data-form) data-rust) +(test "rust emits char ABI conversions" + (typed-library-form->rust-string char-form) + char-rust) + (test "rust lowers record and variant operations" (typed-library-form->rust-string ops-form) ops-rust) new file mode 100644 --- /dev/null +++ b/tests/test-typed-wrapper-e2e.ss @@ -0,0 +1,37 @@ +#!chezscheme +;;; End-to-end smoke test for generated Typed Jerboa wrappers. +;;; +;;; This test expects `TYPED_WRAPPER_FILE` to point at a generated wrapper and +;;; `JERBOA_TYPED_RUST_LIB` to point at the matching compiled Rust cdylib. + +(import (chezscheme)) + +(define wrapper-file + (or (getenv "TYPED_WRAPPER_FILE") + "build/typed/jerboa-smoke/sample_typed_rust_basic.ss")) + +(load wrapper-file) + +(define pass 0) +(define fail 0) + +(define (check name ok?) + (if ok? + (begin + (set! pass (+ pass 1)) + (printf " ok ~a~%" name)) + (begin + (set! fail (+ fail 1)) + (printf "FAIL ~a~%" name)))) + +(printf "--- Typed Jerboa wrapper FFI smoke ---~%") + +(check "zero" (= (zero) 0)) +(check "add-one" (= (add-one 41) 42)) +(check "positive?" (positive? 9)) +(check "choose" (= (choose #t) 1)) +(check "double-add" (= (double-add 20) 41)) + +(printf "~%Typed wrapper FFI smoke: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) + (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/test-typed-wrappers.ss @@ -0,0 +1,60 @@ +#!chezscheme +;;; Tests for (jerboa typed wrapper) + +(import (chezscheme) + (jerboa typed wrapper)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: exception ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) + (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(define calc-form + '(typed-library (sample typed calc) + (export zero add-one) + (def (private-zero) : Nat + 0) + (def (zero) : Nat + (private-zero)) + (def (add-one (x : Nat)) : Nat + (+ x 1)))) + +(define calc-wrapper + ";; Generated by Jerboa's typed wrapper backend. Do not edit.\n(import (jerboa prelude)\n (only (chezscheme) foreign-procedure getenv load-shared-object))\n\n(def %typed-rust-library-path (getenv \"JERBOA_TYPED_RUST_LIB\"))\n(when %typed-rust-library-path\n (load-shared-object %typed-rust-library-path))\n\n(def %typed-rust-min-int64 -9223372036854775808)\n(def %typed-rust-max-int64 9223372036854775807)\n(def %typed-rust-max-uint64 18446744073709551615)\n\n(def (%typed-rust-int64? x)\n (and (integer? x)\n (exact? x)\n (<= %typed-rust-min-int64 x %typed-rust-max-int64)))\n\n(def (%typed-rust-uint64? x)\n (and (integer? x)\n (exact? x)\n (<= 0 x %typed-rust-max-uint64)))\n\n(def %zero\n (foreign-procedure \"jt_sample_typed_calc_zero\" () unsigned-64))\n\n(def %add_one\n (foreign-procedure \"jt_sample_typed_calc_add_one\" (unsigned-64) unsigned-64))\n\n(def (zero)\n (%zero)\n)\n\n(def (add-one x)\n (unless (%typed-rust-uint64? x)\n (error 'add-one \"expected Nat for x\" x))\n (%add_one x)\n)\n\n") + +(printf "--- Typed Jerboa wrapper tests ---~%") + +(test "wrapper maps Unit to void" + (abi-chez-type 'Unit) + 'void) + +(test "wrapper maps Char to unsigned-32" + (abi-chez-type 'Char) + 'unsigned-32) + +(test "wrapper maps Fixnum to iptr" + (abi-chez-type 'Fixnum) + 'iptr) + +(test "wrapper emits deterministic file name" + (map car (typed-library-forms->jerboa-wrapper-files (list calc-form))) + '("sample_typed_calc.ss")) + +(test "wrapper emits exported scalar functions" + (typed-library-form->jerboa-wrapper-string calc-form) + calc-wrapper) + +(printf "~%Typed wrapper: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) + (exit 1))