coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
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>
This commit is contained in:
giles
2026-04-03 08:29:57 +00:00
parent 67c4a6a14d
commit d4244b47bf
3 changed files with 263 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

198
spec/tests/test-r7rs.sx Normal file
View File

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