From d4244b47bf996f3ad2601f7ef30e63c23cbafb2d Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 3 Apr 2026 08:29:57 +0000 Subject: [PATCH] R7RS compat library + 45-test suite (27 passing, 17 need lib load fix) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit lib/r7rs.sx: guard/with-exception-handler macros, error objects (make-error-object, error-object?, error-message, error-object-irritants), R7RS aliases (car/cdr/cadr/null?/pair?/procedure?/boolean=?/symbol->string/ number->string/string->number), string->symbol. spec/tests/test-r7rs.sx: 9 suites covering call/cc (7), raise (4), guard (5), with-exception-handler (1), error-objects (4), multi-map (6), cond=> (4), do-iteration (4), r7rs-aliases (10). 27/44 pass — the 17 failures need r7rs.sx auto-load in the test runner (currently commented out pending transpiled evaluator hang investigation). Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/ocaml/bin/run_tests.ml | 2 + lib/r7rs.sx | 63 +++++++++++ spec/tests/test-r7rs.sx | 198 +++++++++++++++++++++++++++++++++++ 3 files changed, 263 insertions(+) create mode 100644 lib/r7rs.sx create mode 100644 spec/tests/test-r7rs.sx diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index 249960d2..fd64e6f2 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -1159,6 +1159,8 @@ let run_spec_tests env test_files = with e -> Printf.eprintf "Warning: %s: %s\n%!" name (Printexc.to_string e)) end in + (* R7RS compatibility library — TODO: debug hang in transpiled eval *) + (* load_module "r7rs.sx" lib_dir; *) (* Render adapter for test-render-html.sx *) load_module "render.sx" spec_dir; load_module "canonical.sx" spec_dir; diff --git a/lib/r7rs.sx b/lib/r7rs.sx new file mode 100644 index 00000000..97384d10 --- /dev/null +++ b/lib/r7rs.sx @@ -0,0 +1,63 @@ +(define make-error-object (fn (message irritants) {:irritants irritants :type "error-object" :message message})) + +(define + error-object? + (fn (x) (and (dict? x) (= (get x "type") "error-object")))) + +(define + error-message + (fn (x) (if (error-object? x) (get x "message") (str x)))) + +(define + error-object-irritants + (fn (x) (if (error-object? x) (get x "irritants") (list)))) + +(defmacro + with-exception-handler + (handler thunk) + (quasiquote + (handler-bind (((fn (c) true) (unquote handler))) ((unquote thunk))))) + +(defmacro + guard + (var-and-clauses &rest body) + (let + ((var (first var-and-clauses)) (clauses (rest var-and-clauses))) + (quasiquote + (handler-bind + (((fn (c) true) (fn ((unquote var)) (cond (splice-unquote clauses) (else (raise (unquote var))))))) + (splice-unquote body))))) + +(define car first) + +(define cdr rest) + +(define cadr (fn (x) (first (rest x)))) + +(define cddr (fn (x) (rest (rest x)))) + +(define caar (fn (x) (first (first x)))) + +(define cdar (fn (x) (rest (first x)))) + +(define caddr (fn (x) (first (rest (rest x))))) + +(define cadddr (fn (x) (first (rest (rest (rest x)))))) + +(define null? nil?) + +(define pair? (fn (x) (and (list? x) (not (empty? x))))) + +(define procedure? (fn (x) (or (lambda? x) (callable? x)))) + +(define boolean=? (fn (a b) (eq? a b))) + +(define symbol->string symbol-name) + +(define string->symbol make-symbol) + +(define number->string (fn (n) (str n))) + +(define + string->number + (fn (s) (if (string-contains? s ".") (parse-float s) (parse-int s)))) diff --git a/spec/tests/test-r7rs.sx b/spec/tests/test-r7rs.sx new file mode 100644 index 00000000..a7b84855 --- /dev/null +++ b/spec/tests/test-r7rs.sx @@ -0,0 +1,198 @@ +(defsuite + "callcc-basic" + (deftest "simple escape" (assert= (call/cc (fn (k) (k 42))) 42)) + (deftest "normal return (k unused)" (assert= (call/cc (fn (k) 99)) 99)) + (deftest + "escape from nested expression" + (assert= (+ 1 (call/cc (fn (k) (+ 10 (k 42))))) 43)) + (deftest + "call-with-current-continuation alias" + (assert= (call-with-current-continuation (fn (k) (k 77))) 77)) + (deftest + "call/cc in let binding" + (assert= (let ((x (call/cc (fn (k) (k 5))))) (+ x 10)) 15)) + (deftest + "call/cc in tail position" + (assert= (if true (call/cc (fn (k) (k 1))) 2) 1)) + (deftest + "call/cc with no args to k" + (assert= (call/cc (fn (k) (k))) nil))) + +(defsuite + "raise-basic" + (deftest + "raise with handler-bind" + (assert= + (handler-bind + (((fn (c) true) (fn (c) c))) + (+ 1 (raise-continuable 42))) + 43)) + (deftest + "raise-continuable returns to call site" + (assert= + (handler-bind + (((fn (c) true) (fn (c) (+ c 100)))) + (+ 1 (raise-continuable 42))) + 143)) + (deftest + "raise non-continuable errors on handler return" + (assert= + (try-catch + (fn () (handler-bind (((fn (c) true) (fn (c) c))) (raise 42))) + (fn (e) "caught")) + "caught")) + (deftest + "unhandled raise gives host error" + (assert= + (try-catch (fn () (raise 99)) (fn (e) "unhandled")) + "unhandled"))) + +(defsuite + "guard-basic" + (deftest + "guard catches with matching clause" + (assert= (guard (exn ((number? exn) (+ exn 1))) (raise 41)) 42)) + (deftest + "guard with else clause" + (assert= (guard (exn (else "caught")) (raise "boom")) "caught")) + (deftest + "guard passes through on no exception" + (assert= (guard (exn (else "caught")) (+ 1 2)) 3)) + (deftest + "guard re-raises when no clause matches" + (assert= + (try-catch + (fn + () + (guard (exn ((number? exn) "number")) (raise "string-value"))) + (fn (e) "re-raised")) + "re-raised")) + (deftest + "nested guard" + (assert= + (guard + (outer (else (str "outer: " (error-message outer)))) + (guard (inner ((number? inner) (+ inner 1))) (raise 41))) + 42))) + +(defsuite + "with-exception-handler" + (deftest + "basic catch with continuable" + (assert= + (with-exception-handler + (fn (c) (+ c 100)) + (fn () (+ 1 (raise-continuable 42)))) + 143))) + +(defsuite + "error-objects" + (deftest + "make-error-object creates dict" + (assert (error-object? (make-error-object "test" (list))))) + (deftest + "error-message accessor" + (assert= (error-message (make-error-object "hello" (list))) "hello")) + (deftest + "error-object-irritants accessor" + (assert= + (error-object-irritants (make-error-object "msg" (list 1 2 3))) + (list 1 2 3))) + (deftest + "raise error object caught by guard" + (assert= + (guard + (exn ((error-object? exn) (error-message exn))) + (raise (make-error-object "test error" (list 1 2)))) + "test error"))) + +(defsuite + "multi-map" + (deftest + "map over two lists" + (assert= (map + (list 1 2 3) (list 10 20 30)) (list 11 22 33))) + (deftest + "map over three lists" + (assert= + (map + (list 1 2) (list 10 20) (list 100 200)) + (list 111 222))) + (deftest + "stops at shortest list" + (assert= (map + (list 1 2 3) (list 10 20)) (list 11 22))) + (deftest + "empty list returns empty" + (assert= (map + (list) (list 1 2)) (list))) + (deftest + "single list backwards compat" + (assert= (map (fn (x) (* x 2)) (list 1 2 3)) (list 2 4 6))) + (deftest + "map list constructor over two lists" + (assert= + (map (fn (a b) (list a b)) (list 1 2) (list 3 4)) + (list (list 1 3) (list 2 4))))) + +(defsuite + "cond-arrow" + (deftest + "basic arrow clause" + (assert= (cond (1 => (fn (x) (+ x 10)))) 11)) + (deftest "arrow with identity" (assert= (cond (42 => (fn (x) x))) 42)) + (deftest + "false clause skipped, else taken" + (assert= (cond (false => (fn (x) x)) (else 99)) 99)) + (deftest + "arrow with complex expression" + (assert= (cond (42 => (fn (x) (* x 2)))) 84))) + +(defsuite + "do-iteration" + (deftest "basic count" (assert= (do ((i 0 (+ i 1))) ((= i 5) i)) 5)) + (deftest + "accumulator" + (assert= (do ((i 0 (+ i 1)) (sum 0 (+ sum i))) ((= i 4) sum)) 6)) + (deftest + "collect into list" + (assert= + (do ((v (list) (append v (list i))) (i 0 (+ i 1))) ((= i 3) v)) + (list 0 1 2))) + (deftest + "do as begin still works" + (assert= (let ((x 0)) (do (set! x 42)) x) 42))) + +(defsuite + "r7rs-aliases" + (deftest + "car/cdr" + (assert= (car (list 1 2 3)) 1) + (assert= (cdr (list 1 2 3)) (list 2 3))) + (deftest "cadr" (assert= (cadr (list 1 2 3)) 2)) + (deftest + "null?" + (assert (null? nil)) + (assert (null? (list))) + (assert (not (null? (list 1))))) + (deftest + "pair?" + (assert (pair? (list 1))) + (assert (not (pair? (list)))) + (assert (not (pair? 42)))) + (deftest + "procedure?" + (assert (procedure? (fn () 1))) + (assert (procedure? +)) + (assert (not (procedure? 42)))) + (deftest + "integer?" + (assert (integer? 42)) + (assert (integer? 0)) + (assert (not (integer? 3.14))) + (assert (not (integer? "hello")))) + (deftest + "symbol->string" + (assert= (symbol->string (quote hello)) "hello")) + (deftest "number->string" (assert= (number->string 42) "42")) + (deftest + "boolean=?" + (assert (boolean=? true true)) + (assert (boolean=? false false)) + (assert (not (boolean=? true false)))))