R7RS compat library + 45-test suite (27 passing, 17 need lib load fix)

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) <noreply@anthropic.com>

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;

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))))

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)))))