Support Typed Jerboa record handles
ober
72a8415a8a118d707b1fdd0a56117d6536d83e8a
--- a/docs/jerboa-to-rust.md +++ b/docs/jerboa-to-rust.md @@ -234,10 +234,12 @@ 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`. `String` and `Bytes` arguments can cross this boundary for scalar-return functions as bytevector-plus-length pairs, with -`String` using UTF-8 conversion. Non-scalar returns and owned values still wait -for opaque handles and conversion records. ABI wrappers catch Rust panics before -they cross Chez FFI and currently return conservative default scalar values; -structured error returns are still future work. +`String` using UTF-8 conversion. Same-module record and variant values can cross +exported typed function boundaries as opaque `u64` handles stored in a generated +Rust registry and tagged by the generated Jerboa wrappers. Other non-scalar +returns, cross-module owned values, and conversion records remain future work. +ABI wrappers catch Rust panics before they cross Chez FFI and currently return +conservative default values; structured error returns are still future work. ## Generics @@ -298,29 +300,30 @@ At the C ABI boundary, references cannot cross directly. Use opaque handles. Dynamic Jerboa cannot safely hold raw Rust references. Use opaque handles: ```rust -#[repr(C)] -pub struct JtHandle { - id: u64, -} +type JtHandle = u64; ``` -Runtime registry: +Current landing uses a generated module-local registry for same-module records +and variants: ```rust -struct Registry { - next_id: u64, - values: HashMap<u64, Box<dyn Any>>, -} +static JT_HANDLES: OnceLock<Mutex<HashMap<u64, Box<dyn Any + Send>>>> = + OnceLock::new(); ``` -MVP can use a global mutex registry. Later versions can use typed handle tables -per module or pass runtime contexts explicitly. +Values are stored on return and cloned back into owned Rust values when a later +typed export receives the handle as an argument. Generated Jerboa wrappers tag +the raw id with the typed record or variant name and reject mismatched handles +before calling FFI. + +Later versions can use typed handle tables per module or pass runtime contexts +explicitly. Handle requirements: -- Type tag +- Runtime type tag - Ownership state -- Optional destructor +- Destructor integration - Debug name - Generation counter to catch stale handles @@ -580,14 +583,17 @@ Second module: typed `rope`. `bytevector-length` support landed as checked `(String -> Nat)` and `(Bytes -> Nat)` builtins. - Generate wrappers. Initial scalar `.ss` wrappers plus `String` and `Bytes` - argument wrappers landed; record, variant, string/bytes return, option, - result, and handle conversions remain future work. + argument wrappers landed. Same-module record and variant values now cross the + wrapper boundary as opaque handles. String/bytes return, option, result, and + richer handle conversions remain future work. ### Milestone 3: Records and Variants - Generate Rust structs and enums. - Generate constructors and accessors. - Support pattern matching. +- Pass same-module records and variants through exported typed function + boundaries as opaque handles. - Support equality and debug output. ### Milestone 4: First Real Module @@ -598,7 +604,7 @@ Second module: typed `rope`. ### Milestone 5: Resource Types -- Add opaque handle registry. +- Add owned resource handle registry. - Add linear resource checking. - Add Rust `Drop` integration. - Add boundary tests for stale and double-close handles. --- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -164,6 +164,10 @@ Current landing: through unsigned code points, and pass `String` arguments as UTF-8 bytevector-plus-length pairs and `Bytes` arguments as bytevector-plus-length pairs for scalar-return functions. +- Exported typed `def` functions can now cross records and variants through an + opaque `u64` handle registry when the record or variant type is declared in + the same typed module. Generated Scheme wrappers tag handles by typed name and + reject wrong-handle calls before FFI. - `make typed-wrapper-smoke` builds the primitive Rust fixture, generates its wrapper, loads the cdylib, and calls the generated Jerboa functions through Chez FFI. It also checks that bad dynamic calls are rejected by generated @@ -821,7 +825,8 @@ Minimum excluded features: `Bytes` argument bytevector conversions landed at the wrapper boundary. - Generate Jerboa wrappers. Initial `.ss` wrapper generation landed for scalar ABI-safe exported functions, plus `String` and `Bytes` arguments with - scalar returns. + scalar returns. Same-module record and variant values can cross exported + typed `def` boundaries as opaque handles. ### Milestone 4: First Real Module --- a/lib/jerboa/typed/rust.ss +++ b/lib/jerboa/typed/rust.ss @@ -312,9 +312,20 @@ (memq type '(Unit Bool Char Int Nat Fixnum Float)) #t)) + (def (abi-handle-type? type) + (and (symbol? type) + (or (lookup-name type (*rust-record-env*)) + (lookup-name type (*rust-variant-env*))) + #t)) + + (def (abi-safe-return-type? type) + (or (abi-safe-type? type) + (abi-handle-type? type))) + (def (abi-safe-param-type? type) (or (abi-safe-type? type) - (memq type '(String Bytes)))) + (memq type '(String Bytes)) + (abi-handle-type? type))) (def (abi-rust-type type) (case type @@ -325,10 +336,13 @@ [(Nat) "u64"] [(Fixnum) "isize"] [(Float) "f64"] - [else (error 'typed-rust "unsupported ABI type" type)])) + [else + (if (abi-handle-type? type) + "u64" + (error 'typed-rust "unsupported ABI type" type))])) (def (abi-safe-def? def) - (and (abi-safe-type? (typed-def-return-type def)) + (and (abi-safe-return-type? (typed-def-return-type def)) (let loop ([params (typed-def-params def)]) (cond [(null? params) #t] @@ -360,11 +374,71 @@ (string-append name "_ptr: *const u8") (string-append name "_len: usize"))] [else - (list - (string-append - name - ": " - (abi-rust-type (typed-param-type param))))]))) + (if (abi-handle-type? (typed-param-type param)) + (list (string-append name "_handle: u64")) + (list + (string-append + name + ": " + (abi-rust-type (typed-param-type param)))))]))) + + (def (emit-handle-registry port) + (write-line port 0 "use std::any::Any;") + (write-line port 0 "use std::collections::HashMap;") + (write-line port 0 "use std::sync::atomic::{AtomicU64, Ordering};") + (write-line port 0 "use std::sync::{Mutex, OnceLock};") + (newline port) + (write-line port 0 "static JT_HANDLES: OnceLock<Mutex<HashMap<u64, std::boxed::Box<dyn Any + Send>>>> = OnceLock::new();") + (write-line port 0 "static JT_NEXT_HANDLE: AtomicU64 = AtomicU64::new(1);") + (newline port) + (write-line port 0 "fn jt_handles() -> &'static Mutex<HashMap<u64, std::boxed::Box<dyn Any + Send>>> {") + (write-line port 1 "JT_HANDLES.get_or_init(|| Mutex::new(HashMap::new()))") + (write-line port 0 "}") + (newline port) + (write-line port 0 "fn jt_store_handle<T: Any + Send>(value: T) -> u64 {") + (write-line port 1 "let id = JT_NEXT_HANDLE.fetch_add(1, Ordering::Relaxed);") + (write-line port 1 "if let Ok(mut handles) = jt_handles().lock() {") + (write-line port 2 "handles.insert(id, std::boxed::Box::new(value));") + (write-line port 2 "id") + (write-line port 1 "} else {") + (write-line port 2 "0") + (write-line port 1 "}") + (write-line port 0 "}") + (newline port) + (write-line port 0 "fn jt_clone_handle<T: Any + Clone>(id: u64) -> Option<T> {") + (write-line port 1 "let handles = jt_handles().lock().ok()?;") + (write-line port 1 "handles.get(&id).and_then(|value| value.downcast_ref::<T>().cloned())") + (write-line port 0 "}") + (newline port) + (write-line port 0 "#[unsafe(no_mangle)]") + (write-line port 0 "pub extern \"C\" fn jt_handle_drop(id: u64) -> bool {") + (write-line port 1 "if let Ok(mut handles) = jt_handles().lock() {") + (write-line port 2 "handles.remove(&id).is_some()") + (write-line port 1 "} else {") + (write-line port 2 "false") + (write-line port 1 "}") + (write-line port 0 "}") + (newline port)) + + (def (abi-def-uses-handles? def) + (or (abi-handle-type? (typed-def-return-type def)) + (let loop ([params (typed-def-params def)]) + (cond + [(null? params) #f] + [(abi-handle-type? (typed-param-type (car params))) #t] + [else (loop (cdr params))])))) + + (def (module-needs-handle-registry? module) + (let loop ([decls (typed-module-declarations module)]) + (cond + [(null? decls) #f] + [(and (typed-def? (car decls)) + (exported-def? module (car decls)) + (abi-safe-def? (car decls)) + (abi-def-uses-handles? (car decls))) + #t] + [else + (loop (cdr decls))]))) (def (emit-abi-param-conversion param port) (let ([name (rust-symbol-name (typed-param-name param))]) @@ -401,12 +475,24 @@ "String::from_utf8_lossy(bytes).into_owned()" "bytes.to_vec()")) (write-line port 2 "};")] - [else #f]))) + [else + (when (abi-handle-type? (typed-param-type param)) + (write-line port 2 + (string-append + "let " + name + " = jt_clone_handle::<" + (rust-type (typed-param-type param)) + ">(" + name + "_handle).unwrap_or_else(|| panic!(\"invalid typed handle\"));")))]))) (def (abi-return-expression def call) - (case (typed-def-return-type def) - [(Char) (string-append "(" call " as u32)")] - [else call])) + (let ([return-type (typed-def-return-type def)]) + (cond + [(eq? return-type 'Char) (string-append "(" call " as u32)")] + [(abi-handle-type? return-type) (string-append "jt_store_handle(" call ")")] + [else call]))) (def (abi-default-expression type) (case type @@ -417,7 +503,10 @@ [(Nat) "0u64"] [(Fixnum) "0isize"] [(Float) "0.0f64"] - [else (error 'typed-rust "unsupported ABI default type" type)])) + [else + (if (abi-handle-type? type) + "0u64" + (error 'typed-rust "unsupported ABI default type" type))])) (def (emit-abi-wrapper module def port) (when (abi-safe-def? def) @@ -740,6 +829,8 @@ (newline port)) (def (emit-module-declarations module port) + (when (module-needs-handle-registry? module) + (emit-handle-registry port)) (for-each (lambda (decl) (emit-declaration decl port)) --- a/lib/jerboa/typed/wrapper.ss +++ b/lib/jerboa/typed/wrapper.ss @@ -19,7 +19,6 @@ (jerboa typed checker) (only (jerboa typed rust) rust-symbol-name - abi-safe-def? abi-wrapper-name)) (def (emit-to-string thunk) @@ -81,11 +80,6 @@ [(Float) 'double] [else (error 'typed-wrapper "unsupported ABI type" type)])) - (def (abi-chez-argument-types type) - (case type - [(String Bytes) '(u8* size_t)] - [else (list (abi-chez-type type))])) - (def (typed-module-wrapper-file-name module) (string-append (join-strings @@ -97,13 +91,62 @@ (and (memq (typed-def-name def) (typed-module-exports module)) #t)) + (def (module-handle-type? module type) + (and (symbol? type) + (let loop ([decls (typed-module-declarations module)]) + (cond + [(null? decls) #f] + [(and (typed-record? (car decls)) + (eq? type (typed-record-name (car decls)))) + #t] + [(and (typed-variant? (car decls)) + (eq? type (typed-variant-name (car decls)))) + #t] + [else (loop (cdr decls))])))) + + (def (abi-wrapper-scalar-type? type) + (and (symbol? type) + (memq type '(Unit Bool Char Int Nat Fixnum Float)) + #t)) + + (def (wrapper-safe-return-type? module type) + (or (abi-wrapper-scalar-type? type) + (module-handle-type? module type))) + + (def (wrapper-safe-param-type? module type) + (or (abi-wrapper-scalar-type? type) + (memq type '(String Bytes)) + (module-handle-type? module type))) + + (def (wrapper-safe-def? module def) + (and (wrapper-safe-return-type? module (typed-def-return-type def)) + (let loop ([params (typed-def-params def)]) + (cond + [(null? params) #t] + [(wrapper-safe-param-type? module (typed-param-type (car params))) + (loop (cdr params))] + [else #f])))) + + (def (abi-chez-return-type module type) + (if (module-handle-type? module type) + 'unsigned-64 + (abi-chez-type type))) + + (def (abi-chez-argument-types module type) + (case type + [(String Bytes) '(u8* size_t)] + [else + (if (module-handle-type? module type) + '(unsigned-64) + (list (abi-chez-type type)))])) + (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))) + (wrapper-safe-def? module (car rest))) (loop (cdr rest) (cons (car rest) out))] [else (loop (cdr rest) out)]))) @@ -111,7 +154,7 @@ (string->symbol (string-append "%" (rust-symbol-name (typed-def-name def))))) - (def (param-check-expression param) + (def (param-check-expression module param) (let ([name (datum->code (typed-param-name param))]) (case (typed-param-type param) [(Bool) (string-append "(boolean? " name ")")] @@ -122,15 +165,23 @@ [(Float) (string-append "(real? " name ")")] [(String) (string-append "(string? " name ")")] [(Bytes) (string-append "(bytevector? " name ")")] - [else (error 'typed-wrapper "unsupported ABI parameter type" - (typed-param-type param))]))) - - (def (emit-param-check def param port) + [else + (if (module-handle-type? module (typed-param-type param)) + (string-append + "(%typed-rust-handle? " + name + " " + (quoted-symbol-code (typed-param-type param)) + ")") + (error 'typed-wrapper "unsupported ABI parameter type" + (typed-param-type param)))]))) + + (def (emit-param-check module 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))) + (string-append "(unless " (param-check-expression module param))) (write-line port 2 (string-append "(error " @@ -158,7 +209,7 @@ [(string-param? (car rest)) #t] [else (loop (cdr rest))]))) - (def (wrapper-argument-expressions param) + (def (wrapper-argument-expressions module param) (let ([name (datum->code (typed-param-name param))]) (case (typed-param-type param) [(Char) (list (string-append "(char->integer " name ")"))] @@ -171,22 +222,36 @@ (list name (string-append "(bytevector-length " name ")"))] - [else (list name)]))) + [else + (if (module-handle-type? module (typed-param-type param)) + (list (string-append "(%typed-rust-handle-id " name ")")) + (list name))]))) - (def (wrapper-call-expression def) + (def (wrapper-call-expression module def) (string-append "(" (datum->code (ffi-binding-name def)) - (let ([args (append-map wrapper-argument-expressions (typed-def-params def))]) + (let ([args (append-map + (lambda (param) + (wrapper-argument-expressions module param)) + (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 ")")] + (def (wrapper-return-expression module def) + (let ([call (wrapper-call-expression module def)] + [return-type (typed-def-return-type def)]) + (cond + [(eq? return-type 'Char) (string-append "(integer->char " call ")")] + [(module-handle-type? module return-type) + (string-append + "(%typed-rust-make-handle " + (quoted-symbol-code return-type) + " " + call + ")")] [else call]))) (def (emit-ffi-binding module def port) @@ -203,15 +268,15 @@ (append-map (lambda (param) (map datum->code - (abi-chez-argument-types (typed-param-type param)))) + (abi-chez-argument-types module (typed-param-type param)))) (typed-def-params def)) " ") ") " - (datum->code (abi-chez-type (typed-def-return-type def))) + (datum->code (abi-chez-return-type module (typed-def-return-type def))) "))")) (newline port)) - (def (emit-wrapper-def def port) + (def (emit-wrapper-def module def port) (let ([params (typed-def-params def)]) (write-line port 0 (string-append @@ -229,7 +294,7 @@ ")")) (for-each (lambda (param) - (emit-param-check def param port)) + (emit-param-check module def param port)) params) (if (has-string-param? params) (begin @@ -253,9 +318,9 @@ [else (loop (cdr rest) out)]))) " ") ")")) - (write-line port 2 (wrapper-return-expression def)) + (write-line port 2 (wrapper-return-expression module def)) (write-line port 1 ")")) - (write-line port 1 (wrapper-return-expression def))) + (write-line port 1 (wrapper-return-expression module def))) (write-line port 0 ")") (newline port))) @@ -281,6 +346,19 @@ (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) + (write-line port 0 "(def (%typed-rust-make-handle type id)") + (write-line port 1 "(vector 'typed-handle type id))") + (newline port) + (write-line port 0 "(def (%typed-rust-handle? value type)") + (write-line port 1 "(and (vector? value)") + (write-line port 2 "(= (vector-length value) 3)") + (write-line port 2 "(eq? (vector-ref value 0) 'typed-handle)") + (write-line port 2 "(eq? (vector-ref value 1) type)") + (write-line port 2 "(%typed-rust-uint64? (vector-ref value 2))))") + (newline port) + (write-line port 0 "(def (%typed-rust-handle-id value)") + (write-line port 1 "(vector-ref value 2))") (newline port)) (def (emit-module-wrapper module port) @@ -291,7 +369,7 @@ (wrapper-defs module)) (for-each (lambda (def) - (emit-wrapper-def def port)) + (emit-wrapper-def module def port)) (wrapper-defs module))) (def (typed-module->jerboa-wrapper-string module) --- a/tests/fixtures/typed/rust-basic.ss +++ b/tests/fixtures/typed/rust-basic.ss @@ -1,5 +1,13 @@ (typed-library (sample typed rust-basic) - (export zero add-one positive? choose greeting double-add text-length bytes-length) + (export zero add-one positive? choose greeting double-add text-length bytes-length + make-box box-value make-some token-size) + + (record Box + ((value : Nat))) + + (variant Token + (Some (value : Nat)) + (Empty)) (def (zero) : Nat 0) @@ -24,4 +32,18 @@ (string-length text)) (def (bytes-length (data : Bytes)) : Nat - (bytevector-length data))) + (bytevector-length data)) + + (def (make-box (value : Nat)) : Box + (make-Box value)) + + (def (box-value (b : Box)) : Nat + (Box-value b)) + + (def (make-some (value : Nat)) : Token + (Some value)) + + (def (token-size (token : Token)) : Nat + (match token + ((Some value) value) + ((Empty) 0)))) --- a/tests/test-typed-rust.ss +++ b/tests/test-typed-rust.ss @@ -20,6 +20,15 @@ (begin (set! fail (+ fail 1)) (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) +(define (substring? haystack needle) + (let ([hlen (string-length haystack)] + [nlen (string-length needle)]) + (let loop ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? (substring haystack i (+ i nlen)) needle) #t] + [else (loop (+ i 1))])))) + (define calc-form '(typed-library (sample typed calc) (export zero add-one) @@ -76,7 +85,7 @@ (define ops-form '(typed-library (sample typed ops) - (export pane-id make-insert make-noop edit-size) + (export) (record Pane ((id : Nat) (mut focused? : Bool))) @@ -97,6 +106,28 @@ (define ops-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\npub fn pane_id(pane: Pane) -> u64 {\n (pane).id\n}\n\npub fn make_insert(at: u64, text: String) -> EditOp {\n EditOp::Insert { at: at, text: text }\n}\n\npub fn make_noop() -> EditOp {\n EditOp::Noop\n}\n\npub fn edit_size(op: EditOp) -> u64 {\n match op { EditOp::Insert { at, text } => at, EditOp::Noop => 0u64, }\n}\n\n") +(define handle-form + '(typed-library (sample typed handles) + (export make-box box-value make-some token-size) + (record Box + ((value : Nat))) + (variant Token + (Some (value : Nat)) + (Empty)) + (def (make-box (value : Nat)) : Box + (make-Box value)) + (def (box-value (b : Box)) : Nat + (Box-value b)) + (def (make-some (value : Nat)) : Token + (Some value)) + (def (token-size (token : Token)) : Nat + (match token + ((Some value) value) + ((Empty) 0))))) + +(define handle-rust + (typed-library-form->rust-string handle-form)) + (printf "--- Typed Jerboa Rust emitter tests ---~%") (test "rust symbol sanitizes" @@ -127,6 +158,25 @@ (typed-library-form->rust-string ops-form) ops-rust) +(test "rust emits handle registry for record and variant ABI" + (and (substring? handle-rust "fn jt_store_handle<T: Any + Send>(value: T) -> u64") + (substring? handle-rust "fn jt_clone_handle<T: Any + Clone>(id: u64) -> Option<T>") + (substring? handle-rust "std::boxed::Box<dyn Any + Send>") + (substring? handle-rust "pub extern \"C\" fn jt_handle_drop(id: u64) -> bool")) + #t) + +(test "rust emits handle-return ABI wrappers" + (and (substring? handle-rust "pub extern \"C\" fn jt_sample_typed_handles_make_box(value: u64) -> u64") + (substring? handle-rust "jt_store_handle(make_box(value))") + (substring? handle-rust "jt_store_handle(make_some(value))")) + #t) + +(test "rust emits handle-argument ABI wrappers" + (and (substring? handle-rust "pub extern \"C\" fn jt_sample_typed_handles_box_value(b_handle: u64) -> u64") + (substring? handle-rust "let b = jt_clone_handle::<Box>(b_handle).unwrap_or_else(|| panic!(\"invalid typed handle\"));") + (substring? handle-rust "let token = jt_clone_handle::<Token>(token_handle).unwrap_or_else(|| panic!(\"invalid typed handle\"));")) + #t) + (printf "~%Typed Rust emitter: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1)) --- a/tests/test-typed-wrapper-e2e.ss +++ b/tests/test-typed-wrapper-e2e.ss @@ -38,6 +38,10 @@ (check "double-add" (= (double-add 20) 41)) (check "text-length" (= (text-length "hello") 5)) (check "bytes-length" (= (bytes-length (make-bytevector 7 0)) 7)) +(check "record handle round trip" + (= (box-value (make-box 17)) 17)) +(check "variant handle round trip" + (= (token-size (make-some 23)) 23)) (check "add-one rejects non-Nat" (raises? (lambda () (add-one "not a number")))) (check "choose rejects non-Bool" @@ -46,6 +50,10 @@ (raises? (lambda () (text-length (make-bytevector 3 0))))) (check "bytes-length rejects non-Bytes" (raises? (lambda () (bytes-length "not bytes")))) +(check "record handle rejects wrong type" + (raises? (lambda () (box-value (make-some 7))))) +(check "variant handle rejects wrong type" + (raises? (lambda () (token-size (make-box 7))))) (printf "~%Typed wrapper FFI smoke: ~a passed, ~a failed~%" pass fail) (when (> fail 0) --- a/tests/test-typed-wrappers.ss +++ b/tests/test-typed-wrappers.ss @@ -40,7 +40,7 @@ (+ 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") + ";; 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 (%typed-rust-make-handle type id)\n (vector 'typed-handle type id))\n\n(def (%typed-rust-handle? value type)\n (and (vector? value)\n (= (vector-length value) 3)\n (eq? (vector-ref value 0) 'typed-handle)\n (eq? (vector-ref value 1) type)\n (%typed-rust-uint64? (vector-ref value 2))))\n\n(def (%typed-rust-handle-id value)\n (vector-ref value 2))\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") (define string-form '(typed-library (sample typed text) @@ -60,6 +60,28 @@ (define bytes-wrapper (typed-library-form->jerboa-wrapper-string bytes-form)) +(define handle-form + '(typed-library (sample typed handles) + (export make-box box-value make-some token-size) + (record Box + ((value : Nat))) + (variant Token + (Some (value : Nat)) + (Empty)) + (def (make-box (value : Nat)) : Box + (make-Box value)) + (def (box-value (b : Box)) : Nat + (Box-value b)) + (def (make-some (value : Nat)) : Token + (Some value)) + (def (token-size (token : Token)) : Nat + (match token + ((Some value) value) + ((Empty) 0))))) + +(define handle-wrapper + (typed-library-form->jerboa-wrapper-string handle-form)) + (printf "--- Typed Jerboa wrapper tests ---~%") (test "wrapper maps Unit to void" @@ -112,6 +134,27 @@ "(%bytes_length data (bytevector-length data))") #t) +(test "wrapper returns record and variant handles" + (and (substring? handle-wrapper + "(%typed-rust-make-handle 'Box (%make_box value))") + (substring? handle-wrapper + "(%typed-rust-make-handle 'Token (%make_some value))")) + #t) + +(test "wrapper validates handle parameters" + (and (substring? handle-wrapper + "(unless (%typed-rust-handle? b 'Box)") + (substring? handle-wrapper + "(unless (%typed-rust-handle? token 'Token)")) + #t) + +(test "wrapper passes handle ids" + (and (substring? handle-wrapper + "(%box_value (%typed-rust-handle-id b))") + (substring? handle-wrapper + "(%token_size (%typed-rust-handle-id token))")) + #t) + (printf "~%Typed wrapper: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1))