2 Commits

Author SHA1 Message Date
03d4e350d7 test-runner: plan — per-guest migration playbook for Phase 2
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 27s
Documents what's already done (kit + Kernel 7 files) and what's left
across 7 guests (35 std-pattern files + variant flavours in Tcl/APL).

Each guest is its own commit due to local naming and shape variants.
Prolog is the biggest single migration (23 files). Tcl and APL need
small variant adapters because their failure-records hold strings or
use slightly different signatures.

Reference: /tmp/migrate_harness.py is the regex-driven mechanical
migration tool; works on the standard pattern, skips variants for
human review.
2026-05-12 19:41:29 +00:00
4504b8ae5e test-runner: extract harness kit + migrate Kernel (7 files, 84 LoC saved)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 33s
lib/guest/test-runner.sx — per-suite mutable state {:pass :fail :fails}
+ refl-test recorder + refl-test-report. Replaces the identical
4-define harness that appears in 142+ test files across the codebase.

Each migrated file goes from:
  (define X-test-pass 0)
  (define X-test-fail 0)
  (define X-test-fails (list))
  (define X-test (fn (name actual expected) (if (= actual expected)
    (set! X-test-pass (+ X-test-pass 1)) (begin ...))))
  ;; ... tests ...
  (define X-tests-run! (fn () {:total ... :passed ... :failed ... :fails ...}))

to:
  (define X-suite (refl-make-test-suite))
  (define X-test  (fn (n a e) (refl-test X-suite n a e)))
  ;; ... tests ...
  (define X-tests-run! (fn () (refl-test-report X-suite)))

All 322 Kernel tests pass unchanged (parse 62, eval 36, vau 38,
standard 127, encap 19, hygiene 26, metacircular 14). 84 LoC removed.

Migration is mechanical (the prefix is the only difference between
suites); /tmp/migrate_harness.py drives the regex. Other guests
(Tcl, Smalltalk, APL, CL, Erlang, Haskell, etc.) migrated in
subsequent commits.
2026-05-12 19:39:45 +00:00
24 changed files with 154 additions and 3619 deletions

50
lib/guest/test-runner.sx Normal file
View File

@@ -0,0 +1,50 @@
;; lib/guest/test-runner.sx — per-suite test harness for guest test files.
;;
;; Across the codebase 142+ test files implement the identical four-form
;; boilerplate: `<X>-test-pass`, `<X>-test-fail`, `<X>-test-fails`, and
;; an `<X>-test` recording function. Only the prefix differs. This kit
;; collapses the boilerplate to a per-suite mutable dict + a recording
;; helper, so each test file goes from ~12 lines of harness to ~3:
;;
;; (define ke-suite (refl-make-test-suite))
;; (define ke-test (fn (n a e) (refl-test ke-suite n a e)))
;; (define ke-tests-run! (fn () (refl-test-report ke-suite)))
;;
;; The suite is a mutable dict `{:pass N :fail N :fails LIST}`. Each
;; failed assertion appends `{:name NAME :expected EXPECTED :actual ACT}`
;; to :fails — same shape every existing harness already produces.
;;
;; The `:fails` list is mutated in place via `append!`, so callers who
;; have a reference to it see the same updates. (Same semantic the
;; existing per-suite globals had — just held in the suite dict now.)
;;
;; Public API
;; (refl-make-test-suite) — fresh suite
;; (refl-test SUITE NAME ACT EXP) — record one assertion
;; (refl-test-report SUITE) — return {:total :passed :failed :fails}
;; (refl-test-pass? SUITE) — convenience: all green?
;; (refl-test-suite? V) — predicate
(define refl-make-test-suite (fn () {:fail 0 :pass 0 :fails (list)}))
(define
refl-test-suite?
(fn
(v)
(and (dict? v) (number? (get v :pass)) (number? (get v :fail)))))
(define
refl-test
(fn
(suite name actual expected)
(cond
((= actual expected)
(dict-set! suite :pass (+ (get suite :pass) 1)))
(:else
(begin
(dict-set! suite :fail (+ (get suite :fail) 1))
(append! (get suite :fails) {:name name :actual actual :expected expected}))))))
(define refl-test-report (fn (suite) {:total (+ (get suite :pass) (get suite :fail)) :passed (get suite :pass) :failed (get suite :fail) :fails (get suite :fails)}))
(define refl-test-pass? (fn (suite) (= (get suite :fail) 0)))

View File

@@ -5,20 +5,8 @@
;; identity is per-call, so two `(make-encapsulation-type)` calls ;; identity is per-call, so two `(make-encapsulation-type)` calls
;; produce non-interchangeable families. ;; produce non-interchangeable families.
(define ken-test-pass 0) (define ken-suite (refl-make-test-suite))
(define ken-test-fail 0) (define ken-test (fn (n a e) (refl-test ken-suite n a e)))
(define ken-test-fails (list))
(define
ken-test
(fn
(name actual expected)
(if
(= actual expected)
(set! ken-test-pass (+ ken-test-pass 1))
(begin
(set! ken-test-fail (+ ken-test-fail 1))
(append! ken-test-fails {:name name :actual actual :expected expected})))))
(define ken-eval-in (fn (src env) (kernel-eval (kernel-parse src) env))) (define ken-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))
@@ -180,4 +168,4 @@
env)) env))
(list true 7)) (list true 7))
(define ken-tests-run! (fn () {:total (+ ken-test-pass ken-test-fail) :passed ken-test-pass :failed ken-test-fail :fails ken-test-fails})) (define ken-tests-run! (fn () (refl-test-report ken-suite)))

View File

@@ -5,20 +5,8 @@
;; ($if, $define!, $lambda, …) arrive in Phase 4, so tests build a ;; ($if, $define!, $lambda, …) arrive in Phase 4, so tests build a
;; minimal env on the fly and verify the dispatch contract directly. ;; minimal env on the fly and verify the dispatch contract directly.
(define ke-test-pass 0) (define ke-suite (refl-make-test-suite))
(define ke-test-fail 0) (define ke-test (fn (n a e) (refl-test ke-suite n a e)))
(define ke-test-fails (list))
(define
ke-test
(fn
(name actual expected)
(if
(= actual expected)
(set! ke-test-pass (+ ke-test-pass 1))
(begin
(set! ke-test-fail (+ ke-test-fail 1))
(append! ke-test-fails {:name name :actual actual :expected expected})))))
;; ── helpers ────────────────────────────────────────────────────── ;; ── helpers ──────────────────────────────────────────────────────
@@ -267,4 +255,4 @@
(kernel-eval (kernel-parse "(x 1)") env))) (kernel-eval (kernel-parse "(x 1)") env)))
:raised) :raised)
(define ke-tests-run! (fn () {:total (+ ke-test-pass ke-test-fail) :passed ke-test-pass :failed ke-test-fail :fails ke-test-fails})) (define ke-tests-run! (fn () (refl-test-report ke-suite)))

View File

@@ -10,20 +10,8 @@
;; provenance markers) is research-grade and is NOT implemented — see ;; provenance markers) is research-grade and is NOT implemented — see
;; the plan's reflective-API notes for the proposed approach. ;; the plan's reflective-API notes for the proposed approach.
(define kh-test-pass 0) (define kh-suite (refl-make-test-suite))
(define kh-test-fail 0) (define kh-test (fn (n a e) (refl-test kh-suite n a e)))
(define kh-test-fails (list))
(define
kh-test
(fn
(name actual expected)
(if
(= actual expected)
(set! kh-test-pass (+ kh-test-pass 1))
(begin
(set! kh-test-fail (+ kh-test-fail 1))
(append! kh-test-fails {:name name :actual actual :expected expected})))))
(define kh-eval-in (fn (src env) (kernel-eval (kernel-parse src) env))) (define kh-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))
@@ -217,4 +205,4 @@
(kh-eval-in "($let ((x 5)) ($define! tmp (+ x 1)) tmp)" (kh-eval-in "($let ((x 5)) ($define! tmp (+ x 1)) tmp)"
(kernel-standard-env)) 6) (kernel-standard-env)) 6)
(define kh-tests-run! (fn () {:total (+ kh-test-pass kh-test-fail) :passed kh-test-pass :failed kh-test-fail :fails kh-test-fails})) (define kh-tests-run! (fn () (refl-test-report kh-suite)))

View File

@@ -12,20 +12,8 @@
;; first-class evaluators all line up — enough so a Kernel program ;; first-class evaluators all line up — enough so a Kernel program
;; can itself reason about Kernel programs. ;; can itself reason about Kernel programs.
(define kmc-test-pass 0) (define kmc-suite (refl-make-test-suite))
(define kmc-test-fail 0) (define kmc-test (fn (n a e) (refl-test kmc-suite n a e)))
(define kmc-test-fails (list))
(define
kmc-test
(fn
(name actual expected)
(if
(= actual expected)
(set! kmc-test-pass (+ kmc-test-pass 1))
(begin
(set! kmc-test-fail (+ kmc-test-fail 1))
(append! kmc-test-fails {:name name :actual actual :expected expected})))))
;; Build a Kernel env with m-eval and m-apply defined. The two refer ;; Build a Kernel env with m-eval and m-apply defined. The two refer
;; to each other and to standard primitives, so we use the standard ;; to each other and to standard primitives, so we use the standard
@@ -159,4 +147,4 @@
env)) env))
49) 49)
(define kmc-tests-run! (fn () {:total (+ kmc-test-pass kmc-test-fail) :passed kmc-test-pass :failed kmc-test-fail :fails kmc-test-fails})) (define kmc-tests-run! (fn () (refl-test-report kmc-suite)))

View File

@@ -1,19 +1,7 @@
;; lib/kernel/tests/parse.sx — exercises lib/kernel/parser.sx. ;; lib/kernel/tests/parse.sx — exercises lib/kernel/parser.sx.
(define knl-test-pass 0) (define knl-suite (refl-make-test-suite))
(define knl-test-fail 0) (define knl-test (fn (n a e) (refl-test knl-suite n a e)))
(define knl-test-fails (list))
(define
knl-test
(fn
(name actual expected)
(if
(= actual expected)
(set! knl-test-pass (+ knl-test-pass 1))
(begin
(set! knl-test-fail (+ knl-test-fail 1))
(append! knl-test-fails {:name name :actual actual :expected expected})))))
;; ── atoms: numbers ──────────────────────────────────────────────── ;; ── atoms: numbers ────────────────────────────────────────────────
(knl-test "num: integer" (kernel-parse "42") 42) (knl-test "num: integer" (kernel-parse "42") 42)
@@ -155,4 +143,4 @@
(kernel-parse "(a 'b c)") (kernel-parse "(a 'b c)")
(list "a" (list "$quote" "b") "c")) (list "a" (list "$quote" "b") "c"))
(define knl-tests-run! (fn () {:total (+ knl-test-pass knl-test-fail) :passed knl-test-pass :failed knl-test-fail :fails knl-test-fails})) (define knl-tests-run! (fn () (refl-test-report knl-suite)))

View File

@@ -5,20 +5,8 @@
;; first-class environment manipulation. Each test starts from a fresh ;; first-class environment manipulation. Each test starts from a fresh
;; standard env via `(kernel-standard-env)`. ;; standard env via `(kernel-standard-env)`.
(define ks-test-pass 0) (define ks-suite (refl-make-test-suite))
(define ks-test-fail 0) (define ks-test (fn (n a e) (refl-test ks-suite n a e)))
(define ks-test-fails (list))
(define
ks-test
(fn
(name actual expected)
(if
(= actual expected)
(set! ks-test-pass (+ ks-test-pass 1))
(begin
(set! ks-test-fail (+ ks-test-fail 1))
(append! ks-test-fails {:name name :actual actual :expected expected})))))
(define (define
ks-eval ks-eval
@@ -442,4 +430,4 @@
(ks-test "reverse: double reverse is identity" (ks-test "reverse: double reverse is identity"
(ks-eval "(reverse (reverse (list 1 2 3)))") (list 1 2 3)) (ks-eval "(reverse (reverse (list 1 2 3)))") (list 1 2 3))
(define ks-tests-run! (fn () {:total (+ ks-test-pass ks-test-fail) :passed ks-test-pass :failed ks-test-fail :fails ks-test-fails})) (define ks-tests-run! (fn () (refl-test-report ks-suite)))

View File

@@ -5,20 +5,8 @@
;; base-env, bind a few helper applicatives (+, *, list, =, $if), and ;; base-env, bind a few helper applicatives (+, *, list, =, $if), and
;; run programs that construct and use custom combiners. ;; run programs that construct and use custom combiners.
(define kv-test-pass 0) (define kv-suite (refl-make-test-suite))
(define kv-test-fail 0) (define kv-test (fn (n a e) (refl-test kv-suite n a e)))
(define kv-test-fails (list))
(define
kv-test
(fn
(name actual expected)
(if
(= actual expected)
(set! kv-test-pass (+ kv-test-pass 1))
(begin
(set! kv-test-fail (+ kv-test-fail 1))
(append! kv-test-fails {:name name :actual actual :expected expected})))))
(define kv-eval-src (fn (src env) (kernel-eval (kernel-parse src) env))) (define kv-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))
@@ -306,4 +294,4 @@
(kv-test "lambda: zero-arg multi-body" (kv-test "lambda: zero-arg multi-body"
(kv-eval-src "(($lambda () 1 2 3))" (kv-make-env)) 3) (kv-eval-src "(($lambda () 1 2 3))" (kv-make-env)) 3)
(define kv-tests-run! (fn () {:total (+ kv-test-pass kv-test-fail) :passed kv-test-pass :failed kv-test-fail :fails kv-test-fails})) (define kv-tests-run! (fn () (refl-test-report kv-suite)))

File diff suppressed because it is too large Load Diff

Binary file not shown.

View File

@@ -1,649 +0,0 @@
;; lib/scheme/runtime.sx — R7RS-small standard environment.
;;
;; Builds scheme-standard-env from scheme-make-env, populating it with
;; arithmetic, comparison, type predicates, list/pair/vector/string/char
;; primitives, and the higher-order combinators (map/filter/fold).
;;
;; Primitives are bound as SX fns taking a list of evaluated arguments.
;; Combinators that re-enter the evaluator (map, filter, fold, apply,
;; for-each) call `scheme-apply` directly on user-supplied procedures.
;;
;; Public API
;; (scheme-standard-env) — fresh env with the full R7RS-base surface
;;
;; Consumes: lib/scheme/eval.sx (scheme-apply, scheme-make-env,
;; scheme-env-bind!, scheme-string?, scheme-char?,
;; scheme-vector?, scheme-vector-elements,
;; scheme-string-value, scheme-char-value,
;; scheme-string-make, scheme-char-make,
;; scheme-vector-make).
;; ── Arity / fold helpers ─────────────────────────────────────────
(define
scm-unary
(fn
(name f)
(fn
(args)
(cond
((not (= (length args) 1))
(error (str name ": expects 1 argument")))
(:else (f (first args)))))))
(define
scm-binary
(fn
(name f)
(fn
(args)
(cond
((not (= (length args) 2))
(error (str name ": expects 2 arguments")))
(:else (f (first args) (nth args 1)))))))
;; Variadic left-fold helper. zero-id is the identity (`(+)` → 0).
;; one-fn handles single-arg case (`(- x)` negates).
(define
scm-fold-step
(fn
(f acc rest-args)
(cond
((or (nil? rest-args) (= (length rest-args) 0)) acc)
(:else (scm-fold-step f (f acc (first rest-args)) (rest rest-args))))))
(define
scm-fold
(fn
(name f zero-id one-fn)
(fn
(args)
(cond
((= (length args) 0) zero-id)
((= (length args) 1) (one-fn (first args)))
(:else (scm-fold-step f (first args) (rest args)))))))
;; n-ary chained comparison: (< 1 2 3) ≡ (< 1 2) ∧ (< 2 3).
(define
scm-chain-step
(fn
(cmp prev rest-args)
(cond
((or (nil? rest-args) (= (length rest-args) 0)) true)
(:else
(let
((next (first rest-args)))
(cond
((cmp prev next) (scm-chain-step cmp next (rest rest-args)))
(:else false)))))))
(define
scm-chain
(fn
(name cmp)
(fn
(args)
(cond
((< (length args) 2)
(error (str name ": expects at least 2 arguments")))
(:else (scm-chain-step cmp (first args) (rest args)))))))
;; ── List helpers ─────────────────────────────────────────────────
(define
scm-list-append
(fn
(xs ys)
(cond
((or (nil? xs) (= (length xs) 0)) ys)
(:else (cons (first xs) (scm-list-append (rest xs) ys))))))
(define
scm-list-reverse-step
(fn
(xs acc)
(cond
((or (nil? xs) (= (length xs) 0)) acc)
(:else (scm-list-reverse-step (rest xs) (cons (first xs) acc))))))
(define
scm-all-lists?
(fn
(xs)
(cond
((or (nil? xs) (= (length xs) 0)) true)
((list? (first xs)) (scm-all-lists? (rest xs)))
(:else false))))
(define
scm-append-all
(fn
(lists)
(cond
((or (nil? lists) (= (length lists) 0)) (list))
((= (length lists) 1) (first lists))
(:else (scm-list-append (first lists) (scm-append-all (rest lists)))))))
;; ── Map / Filter / Fold ──────────────────────────────────────────
;; These call scheme-apply directly so closures and primitives both work.
(define
scm-map-step
(fn
(proc xs)
(cond
((or (nil? xs) (= (length xs) 0)) (list))
(:else
(cons
(scheme-apply proc (list (first xs)))
(scm-map-step proc (rest xs)))))))
(define
scm-filter-step
(fn
(pred xs)
(cond
((or (nil? xs) (= (length xs) 0)) (list))
(:else
(let
((keep? (scheme-apply pred (list (first xs)))))
(cond
((not (= keep? false))
(cons (first xs) (scm-filter-step pred (rest xs))))
(:else (scm-filter-step pred (rest xs)))))))))
(define
scm-fold-left-step
(fn
(proc acc xs)
(cond
((or (nil? xs) (= (length xs) 0)) acc)
(:else
(scm-fold-left-step
proc
(scheme-apply proc (list acc (first xs)))
(rest xs))))))
(define
scm-fold-right-step
(fn
(proc init xs)
(cond
((or (nil? xs) (= (length xs) 0)) init)
(:else
(scheme-apply
proc
(list (first xs) (scm-fold-right-step proc init (rest xs))))))))
(define
scm-for-each-step
(fn
(proc xs)
(cond
((or (nil? xs) (= (length xs) 0)) nil)
(:else
(begin
(scheme-apply proc (list (first xs)))
(scm-for-each-step proc (rest xs)))))))
;; ── Vector helpers ──────────────────────────────────────────────
(define
scm-make-vector-step
(fn
(n fill acc)
(cond
((<= n 0) acc)
(:else (scm-make-vector-step (- n 1) fill (cons fill acc))))))
;; ── Standard env ─────────────────────────────────────────────────
(define
scheme-standard-env
(fn
()
(let
((env (scheme-make-env)))
(scheme-env-bind!
env
"+"
(scm-fold "+" (fn (a b) (+ a b)) 0 (fn (x) x)))
(scheme-env-bind!
env
"-"
(scm-fold
"-"
(fn (a b) (- a b))
0
(fn (x) (- 0 x))))
(scheme-env-bind!
env
"*"
(scm-fold "*" (fn (a b) (* a b)) 1 (fn (x) x)))
(scheme-env-bind!
env
"/"
(scm-fold
"/"
(fn (a b) (/ a b))
1
(fn (x) (/ 1 x))))
(scheme-env-bind!
env
"abs"
(scm-unary
"abs"
(fn (n) (if (< n 0) (- 0 n) n))))
(scheme-env-bind!
env
"min"
(scm-fold "min" (fn (a b) (if (< a b) a b)) nil (fn (x) x)))
(scheme-env-bind!
env
"max"
(scm-fold "max" (fn (a b) (if (< a b) b a)) nil (fn (x) x)))
(scheme-env-bind!
env
"modulo"
(scm-binary "modulo" (fn (a b) (- a (* b (floor (/ a b)))))))
(scheme-env-bind!
env
"quotient"
(scm-binary "quotient" (fn (a b) (floor (/ a b)))))
(scheme-env-bind!
env
"remainder"
(scm-binary "remainder" (fn (a b) (- a (* b (floor (/ a b)))))))
(scheme-env-bind!
env
"zero?"
(scm-unary "zero?" (fn (n) (= n 0))))
(scheme-env-bind!
env
"positive?"
(scm-unary "positive?" (fn (n) (> n 0))))
(scheme-env-bind!
env
"negative?"
(scm-unary "negative?" (fn (n) (< n 0))))
(scheme-env-bind! env "=" (scm-chain "=" (fn (a b) (= a b))))
(scheme-env-bind! env "<" (scm-chain "<" (fn (a b) (< a b))))
(scheme-env-bind! env ">" (scm-chain ">" (fn (a b) (> a b))))
(scheme-env-bind! env "<=" (scm-chain "<=" (fn (a b) (<= a b))))
(scheme-env-bind! env ">=" (scm-chain ">=" (fn (a b) (>= a b))))
(scheme-env-bind!
env
"number?"
(scm-unary "number?" (fn (v) (number? v))))
(scheme-env-bind!
env
"boolean?"
(scm-unary "boolean?" (fn (v) (boolean? v))))
(scheme-env-bind!
env
"symbol?"
(scm-unary "symbol?" (fn (v) (string? v))))
(scheme-env-bind!
env
"string?"
(scm-unary "string?" (fn (v) (scheme-string? v))))
(scheme-env-bind!
env
"char?"
(scm-unary "char?" (fn (v) (scheme-char? v))))
(scheme-env-bind!
env
"vector?"
(scm-unary "vector?" (fn (v) (scheme-vector? v))))
(scheme-env-bind!
env
"null?"
(scm-unary
"null?"
(fn
(v)
(or (nil? v) (and (list? v) (= (length v) 0))))))
(scheme-env-bind!
env
"pair?"
(scm-unary
"pair?"
(fn (v) (and (list? v) (> (length v) 0)))))
(scheme-env-bind!
env
"procedure?"
(scm-unary
"procedure?"
(fn
(v)
(or
(callable? v)
(and (dict? v) (= (get v :scm-tag) :closure))))))
(scheme-env-bind! env "not" (scm-unary "not" (fn (v) (= v false))))
(scheme-env-bind!
env
"cons"
(scm-binary "cons" (fn (a b) (cons a b))))
(scheme-env-bind!
env
"car"
(scm-unary
"car"
(fn
(xs)
(cond
((or (nil? xs) (and (list? xs) (= (length xs) 0)))
(error "car: empty list"))
(:else (first xs))))))
(scheme-env-bind!
env
"cdr"
(scm-unary
"cdr"
(fn
(xs)
(cond
((or (nil? xs) (and (list? xs) (= (length xs) 0)))
(error "cdr: empty list"))
(:else (rest xs))))))
(scheme-env-bind! env "list" (fn (args) args))
(scheme-env-bind!
env
"length"
(scm-unary "length" (fn (xs) (length xs))))
(scheme-env-bind!
env
"reverse"
(scm-unary "reverse" (fn (xs) (scm-list-reverse-step xs (list)))))
(scheme-env-bind!
env
"append"
(fn
(args)
(cond
((scm-all-lists? args) (scm-append-all args))
(:else (error "append: all arguments must be lists")))))
(scheme-env-bind!
env
"map"
(fn
(args)
(cond
((not (= (length args) 2))
(error "map: expects (proc list)"))
(:else (scm-map-step (first args) (nth args 1))))))
(scheme-env-bind!
env
"filter"
(fn
(args)
(cond
((not (= (length args) 2))
(error "filter: expects (pred list)"))
(:else (scm-filter-step (first args) (nth args 1))))))
(scheme-env-bind!
env
"fold-left"
(fn
(args)
(cond
((not (= (length args) 3))
(error "fold-left: expects (proc init list)"))
(:else
(scm-fold-left-step
(first args)
(nth args 1)
(nth args 2))))))
(scheme-env-bind!
env
"fold-right"
(fn
(args)
(cond
((not (= (length args) 3))
(error "fold-right: expects (proc init list)"))
(:else
(scm-fold-right-step
(first args)
(nth args 1)
(nth args 2))))))
(scheme-env-bind!
env
"for-each"
(fn
(args)
(cond
((not (= (length args) 2))
(error "for-each: expects (proc list)"))
(:else (scm-for-each-step (first args) (nth args 1))))))
(scheme-env-bind!
env
"apply"
(fn
(args)
(cond
((not (= (length args) 2))
(error "apply: expects (proc args-list)"))
(:else (scheme-apply (first args) (nth args 1))))))
(scheme-env-bind!
env
"string-length"
(scm-unary
"string-length"
(fn (s) (string-length (scheme-string-value s)))))
(scheme-env-bind!
env
"string=?"
(scm-binary
"string=?"
(fn (a b) (= (scheme-string-value a) (scheme-string-value b)))))
(scheme-env-bind!
env
"string-append"
(fn
(args)
(scheme-string-make
(scm-fold-step
(fn (acc s) (str acc (scheme-string-value s)))
""
args))))
(scheme-env-bind!
env
"substring"
(fn
(args)
(cond
((not (= (length args) 3))
(error "substring: expects (str start end)"))
(:else
(scheme-string-make
(substring
(scheme-string-value (first args))
(nth args 1)
(nth args 2)))))))
(scheme-env-bind!
env
"char=?"
(scm-binary
"char=?"
(fn (a b) (= (scheme-char-value a) (scheme-char-value b)))))
(scheme-env-bind! env "vector" (fn (args) (scheme-vector-make args)))
(scheme-env-bind!
env
"vector-length"
(scm-unary
"vector-length"
(fn (v) (length (scheme-vector-elements v)))))
(scheme-env-bind!
env
"vector-ref"
(scm-binary
"vector-ref"
(fn (v i) (nth (scheme-vector-elements v) i))))
(scheme-env-bind!
env
"vector->list"
(scm-unary "vector->list" (fn (v) (scheme-vector-elements v))))
(scheme-env-bind!
env
"list->vector"
(scm-unary "list->vector" (fn (xs) (scheme-vector-make xs))))
(scheme-env-bind!
env
"make-vector"
(fn
(args)
(cond
((= (length args) 1)
(scheme-vector-make
(scm-make-vector-step (first args) nil (list))))
((= (length args) 2)
(scheme-vector-make
(scm-make-vector-step
(first args)
(nth args 1)
(list))))
(:else (error "make-vector: expects (n [fill])")))))
(scheme-env-bind! env "eqv?" (scm-binary "eqv?" (fn (a b) (= a b))))
(scheme-env-bind!
env
"equal?"
(scm-binary "equal?" (fn (a b) (= a b))))
(scheme-env-bind! env "eq?" (scm-binary "eq?" (fn (a b) (= a b))))
;; ── call/cc (R7RS first-class continuations) ────────────
;; Captures the host SX continuation, wraps it as a Scheme
;; procedure (fn (vargs) ...) and passes it to the user proc.
;; Calling the captured k with one value re-enters the
;; continuation; with multiple values, passes them as a list.
(scheme-env-bind! env "call/cc"
(fn (args)
(cond
((not (= (length args) 1))
(error "call/cc: expects 1 argument"))
(:else
(call/cc
(fn (k)
(let ((scheme-k
(fn (vargs)
(cond
((= (length vargs) 1) (k (first vargs)))
(:else (k vargs))))))
(scheme-apply (first args) (list scheme-k)))))))))
(scheme-env-bind! env "call-with-current-continuation"
(refl-env-lookup env "call/cc"))
;; ── R7RS exception primitives ──────────────────────────
;; raise V — raises V as exception (host SX raise).
(scheme-env-bind! env "raise"
(fn (args)
(cond
((not (= (length args) 1))
(error "raise: expects 1 argument"))
(:else (raise (first args))))))
;; error MSG IRRITANTS... — convention: raise an error-object
;; that's a dict {:scm-error MSG :irritants LIST}. The print
;; surface (error-object-message / error-object-irritants)
;; can pull these apart.
(scheme-env-bind! env "error"
(fn (args)
(cond
((= (length args) 0) (error "error: expects (message [irritant...])"))
(:else
(raise {:scm-error (cond
((scheme-string? (first args))
(scheme-string-value (first args)))
(:else (first args)))
:irritants (rest args)})))))
(scheme-env-bind! env "error-object?"
(scm-unary "error-object?"
(fn (v) (and (dict? v) (string? (get v :scm-error))))))
(scheme-env-bind! env "error-object-message"
(scm-unary "error-object-message"
(fn (v) (scheme-string-make (get v :scm-error)))))
(scheme-env-bind! env "error-object-irritants"
(scm-unary "error-object-irritants"
(fn (v) (get v :irritants))))
;; with-exception-handler HANDLER THUNK — runs THUNK; if it
;; raises, calls HANDLER with the raised value (handler can
;; itself raise or return a value). Implemented via host guard.
;; with-exception-handler — catch THUNK's raise; if caught,
;; call HANDLER. If HANDLER itself raises, propagate that to
;; the outer scope (don't re-catch in this same guard, which
;; would loop). The two-step outcome-sentinel pattern mirrors
;; the `guard` special form's escape.
(scheme-env-bind! env "with-exception-handler"
(fn (args)
(cond
((not (= (length args) 2))
(error "with-exception-handler: expects 2 arguments"))
(:else
(let ((handler (first args))
(thunk (nth args 1)))
(let ((outcome
(guard
(e (true {:scm-weh-raised true :value e}))
(scheme-apply thunk (list)))))
(cond
((and (dict? outcome) (get outcome :scm-weh-raised))
(scheme-apply handler (list (get outcome :value))))
(:else outcome))))))))
;; ── R7RS reflection: eval / environment accessors ───────
;; eval EXPR ENV — apply the evaluator to a user-supplied AST.
(scheme-env-bind! env "eval"
(fn (args)
(cond
((not (= (length args) 2))
(error "eval: expects (eval expr env)"))
(:else (scheme-eval (first args) (nth args 1))))))
;; interaction-environment — the env we're currently building.
;; The closure captures `env`, so each invocation of
;; scheme-standard-env produces a distinct interaction env
;; whose interaction-environment fn returns itself.
(scheme-env-bind! env "interaction-environment"
(fn (args)
(cond
((not (= (length args) 0))
(error "interaction-environment: expects 0 args"))
(:else env))))
;; null-environment — fresh empty env. R7RS ignores version arg.
(scheme-env-bind! env "null-environment"
(fn (args)
(cond
((not (= (length args) 1))
(error "null-environment: expects (version)"))
(:else (scheme-make-env)))))
;; scheme-report-environment — fresh full standard env.
(scheme-env-bind! env "scheme-report-environment"
(fn (args)
(cond
((not (= (length args) 1))
(error "scheme-report-environment: expects (version)"))
(:else (scheme-standard-env)))))
(scheme-env-bind! env "environment?"
(scm-unary "environment?" (fn (v) (scheme-env? v))))
;; dynamic-wind BEFORE THUNK AFTER — runs BEFORE, then THUNK,
;; then AFTER. If THUNK raises, AFTER still runs before the
;; raise propagates. This is the basic-correctness version;
;; proper call/cc-escape interaction would need dynamic-extent
;; tracking, deferred until needed.
(scheme-env-bind! env "dynamic-wind"
(fn (args)
(cond
((not (= (length args) 3))
(error "dynamic-wind: expects (before thunk after)"))
(:else
(let ((before-thunk (first args))
(mid-thunk (nth args 1))
(after-thunk (nth args 2)))
(begin
(scheme-apply before-thunk (list))
(let ((outcome
(guard
(e (true {:scm-dw-raised true :value e}))
(scheme-apply mid-thunk (list)))))
(begin
(scheme-apply after-thunk (list))
(cond
((and (dict? outcome) (get outcome :scm-dw-raised))
(raise (get outcome :value)))
(:else outcome))))))))))
env)))

View File

@@ -1,83 +0,0 @@
# Scheme-on-SX Scoreboard
**All tests pass: 296 / 296 across 9 suites.**
## Per-suite breakdown
| Suite | Passing | Covers |
|-------------|--------:|--------|
| parse | 62 | R7RS lexer: numbers, strings, chars, vectors, lists, quote/quasi/unquote, line/block/datum comments |
| eval | 23 | Self-evaluating literals, symbol lookup, quote, primitive application |
| syntax | 49 | if/define/set!/begin/lambda/closures + let/let*/cond/when/unless/and/or |
| runtime | 78 | Standard env: variadic arithmetic, type predicates, list/string/char/vector ops, higher-order combinators |
| control | 25 | call/cc (escape), raise/guard/with-exception-handler, dynamic-wind |
| macros | 20 | define-syntax / syntax-rules incl. tail-rest ellipsis |
| reflection | 23 | eval / interaction-environment / null-environment / scheme-report-environment + quasiquote runtime |
| records | 9 | define-record-type with constructor / predicate / accessor / mutator |
| modules | 7 | define-library + import (minimal — no cond-expand / include / rename) |
## Phases implemented
- [x] Phase 1 — Parser
- [x] Phase 2 — Evaluator + env.sx **third consumer**
- [x] Phase 3 — Syntactic operators (if/lambda/define/set!/begin)
- [x] Phase 3.5 — let/let*/cond/when/unless/and/or
- [x] Phase 4 — Standard environment + set! cond-bugfix
- [x] Phase 5a — call/cc
- [x] Phase 5b — exceptions (raise/guard/with-exception-handler/error)
- [x] Phase 5c — dynamic-wind (basic, no call/cc-escape tracking)
- [x] Phase 6a — define-syntax + syntax-rules (no ellipsis)
- [x] Phase 6b — syntax-rules ellipsis (tail-rest, single variable)
- [x] Phase 7 — eval / interaction-environment **second consumer for evaluator.sx**
- [x] Phase 8 — define-library + import (minimal)
- [x] Phase 9 — define-record-type
- [x] Phase 10 — quasiquote runtime **second consumer for quoting.sx**
- [x] Phase 11 — test.sh + scoreboard
## Deferred
- **Phase 6c — hygiene** (scope-set / lifted-symbol Dybvig-style algorithm).
Would be the second consumer for the deferred `lib/guest/reflective/hygiene.sx`
research-grade kit. Current macros work for common patterns but can capture
caller bindings if a macro introduces same-named identifiers.
- **Nested quasiquote depth tracking** — `` `\`x\` `` is not properly depth-aware;
matches Kernel's deferred state.
- **R7RS module rich features**: cond-expand, include, include-library-declarations,
`(only ...)` / `(except ...)` / `(prefix ...)` / `(rename ...)` import sets.
- **Dotted-pair `(a b . rest)` syntax** at the parser level. Lambda rest-args
currently use the `(lambda args ...)` form (bare symbol) instead.
- **Full call/cc + dynamic-wind interaction**: re-entry/re-exit of dynamic
extents via continuations is not tracked. Pure-eval programs work; call/cc-
heavy code with dynamic-wind interleaving doesn't.
## Reflective-kit consumption (chisel ledger)
This Scheme port unlocks three reflective-kit extractions from the kernel-on-sx
loop's original six-candidate list:
| Kit | Status |
|----------------------|---------------------------------------------|
| env.sx | **Extracted** (third consumer; no adapter) |
| class-chain.sx | n/a (no OO in Scheme) |
| evaluator.sx | **Unblocked** (second consumer ready) |
| quoting.sx | **Unblocked** (second consumer ready) |
| hygiene.sx | Awaiting Phase 6c (research-grade) |
| combiner.sx | n/a (no fexprs in Scheme) |
| short-circuit.sx | n/a (Scheme `and`/`or` are syntactic, not operative) |
The kit-extraction commits themselves are follow-on work — kit code is staged
in the proposed sections of `plans/kernel-on-sx.md`; Scheme's consumer code
satisfies the two-consumer rule for `evaluator.sx` and `quoting.sx`.
## Substrate stats
- parser.sx — 281 LoC
- eval.sx — ~970 LoC
- runtime.sx — ~580 LoC
- Tests — ~1500 LoC across 9 files
Total Scheme implementation ≈ 1830 LoC.

View File

@@ -1,92 +0,0 @@
#!/usr/bin/env bash
# Scheme-on-SX test runner — runs all tests in one sx_server process.
#
# Usage:
# bash lib/scheme/test.sh # run all suites
# bash lib/scheme/test.sh -v # verbose (list each suite)
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
fi
if [ ! -x "$SX_SERVER" ]; then
echo "ERROR: sx_server.exe not found." >&2
exit 1
fi
VERBOSE="${1:-}"
# Suites: NAME RUNNER-FN PATH
SUITES=(
"parse scm-tests-run! lib/scheme/tests/parse.sx"
"eval scm-eval-tests-run! lib/scheme/tests/eval.sx"
"syntax scm-syn-tests-run! lib/scheme/tests/syntax.sx"
"runtime scm-rt-tests-run! lib/scheme/tests/runtime.sx"
"control scm-ctl-tests-run! lib/scheme/tests/control.sx"
"macros scm-mac-tests-run! lib/scheme/tests/macros.sx"
"reflection scm-ref-tests-run! lib/scheme/tests/reflection.sx"
"records scm-rec-tests-run! lib/scheme/tests/records.sx"
"modules scm-mod-tests-run! lib/scheme/tests/modules.sx"
)
TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
EPOCH=1
emit_load () { echo "(epoch $EPOCH)"; echo "(load \"$1\")"; EPOCH=$((EPOCH+1)); }
emit_eval () { echo "(epoch $EPOCH)"; echo "(eval \"$1\")"; EPOCH=$((EPOCH+1)); }
{
emit_load "lib/guest/lex.sx"
emit_load "lib/guest/reflective/env.sx"
emit_load "lib/scheme/parser.sx"
emit_load "lib/scheme/eval.sx"
emit_load "lib/scheme/runtime.sx"
for SUITE in "${SUITES[@]}"; do
read -r _NAME _RUNNER FILE <<< "$SUITE"
emit_load "$FILE"
emit_eval "($_RUNNER)"
done
} > "$TMPFILE"
OUTPUT=$(timeout 180 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
# Final 9 outputs are the suite results. Parse each "{:passed N :failed N ..}".
TOTAL_PASS=0
TOTAL_FAIL=0
FAILED_SUITES=()
# Walk the output; for each suite, extract the {:passed ...} line.
# The dict format from sx_server is {:passed N :failed N :total N :fails (...)}.
LAST_DICT_LINES=$(echo "$OUTPUT" | grep -E '^\{:' || true)
I=0
while read -r LINE; do
[ -z "$LINE" ] && continue
P=$(echo "$LINE" | grep -oE ':passed [0-9]+' | awk '{print $2}')
F=$(echo "$LINE" | grep -oE ':failed [0-9]+' | awk '{print $2}')
[ -z "$P" ] && P=0
[ -z "$F" ] && F=0
SUITE_INFO="${SUITES[$I]}"
SUITE_NAME=$(echo "$SUITE_INFO" | awk '{print $1}')
TOTAL_PASS=$((TOTAL_PASS + P))
TOTAL_FAIL=$((TOTAL_FAIL + F))
if [ "$F" -gt 0 ]; then
FAILED_SUITES+=("$SUITE_NAME: $P/$((P+F))")
printf 'X %-12s %d/%d\n' "$SUITE_NAME" "$P" "$((P+F))"
elif [ "$VERBOSE" = "-v" ]; then
printf 'ok %-12s %d passed\n' "$SUITE_NAME" "$P"
fi
I=$((I+1))
done <<< "$LAST_DICT_LINES"
TOTAL=$((TOTAL_PASS + TOTAL_FAIL))
if [ $TOTAL_FAIL -eq 0 ]; then
echo "ok $TOTAL_PASS/$TOTAL scheme-on-sx tests passed (${#SUITES[@]} suites)"
else
echo "FAIL $TOTAL_PASS/$TOTAL passed, $TOTAL_FAIL failed:"
for S in "${FAILED_SUITES[@]}"; do echo " $S"; done
exit 1
fi

View File

@@ -1,168 +0,0 @@
;; lib/scheme/tests/control.sx — call/cc, dynamic-wind, exceptions.
(define scm-ctl-pass 0)
(define scm-ctl-fail 0)
(define scm-ctl-fails (list))
(define
scm-ctl-test
(fn
(name actual expected)
(if
(= actual expected)
(set! scm-ctl-pass (+ scm-ctl-pass 1))
(begin
(set! scm-ctl-fail (+ scm-ctl-fail 1))
(append! scm-ctl-fails {:name name :actual actual :expected expected})))))
(define
scm-ctl
(fn (src) (scheme-eval (scheme-parse src) (scheme-standard-env))))
(define
scm-ctl-all
(fn
(src)
(scheme-eval-program (scheme-parse-all src) (scheme-standard-env))))
;; ── call/cc — escape continuations ──────────────────────────────
;; Single-shot only: when k is invoked, control jumps out of the
;; surrounding call/cc and the result of the entire call/cc form is
;; whatever was passed to k.
(scm-ctl-test
"call/cc: no escape"
(scm-ctl "(call/cc (lambda (k) 42))")
42)
(scm-ctl-test
"call/cc: simple escape"
(scm-ctl "(call/cc (lambda (k) (+ 1 (k 42))))")
42)
(scm-ctl-test
"call/cc: escape past *"
(scm-ctl "(+ 10 (call/cc (lambda (k) (* 2 (k 5)))))")
15)
(scm-ctl-test
"call/cc: alias call-with-current-continuation"
(scm-ctl "(call-with-current-continuation (lambda (k) (k 99)))")
99)
(scm-ctl-test
"call/cc: doesn't escape if k unused"
(scm-ctl "(+ 1 (call/cc (lambda (k) (* 100 1))))")
101)
;; ── call/cc as early-exit for list search ───────────────────────
(scm-ctl-test
"call/cc: detect-via-escape"
(scm-ctl-all
"(define (detect pred xs)\n (call/cc\n (lambda (return)\n (for-each\n (lambda (x) (if (pred x) (return x) #f))\n xs)\n #f)))\n (detect (lambda (x) (> x 10)) '(1 5 7 12 20))")
12)
(scm-ctl-test
"call/cc: detect returns #f when no match"
(scm-ctl-all
"(define (detect pred xs)\n (call/cc\n (lambda (return)\n (for-each\n (lambda (x) (if (pred x) (return x) #f))\n xs)\n #f)))\n (detect (lambda (x) (> x 100)) '(1 5 7))")
false)
;; ── call/cc producing the captured k value ──────────────────────
(scm-ctl-test
"call/cc: k is a procedure"
(scm-ctl "(procedure? (call/cc (lambda (k) k)))")
true)
;; ── Exceptions: raise / guard / with-exception-handler / error ──
(scm-ctl-test "raise + guard caught"
(scm-ctl "(guard (e (else 'caught)) (raise 'boom))") "caught")
(scm-ctl-test "guard: number? matches"
(scm-ctl "(guard (e ((number? e) e) (else 'other)) (raise 42))") 42)
(scm-ctl-test "guard: number? mismatches → else"
(scm-ctl "(guard (e ((number? e) e) (else 'other)) (raise 'sym))")
"other")
(scm-ctl-test "guard: no error → body value"
(scm-ctl "(guard (e (else 'never)) 42)") 42)
(scm-ctl-test "guard: first matching clause wins"
(scm-ctl
"(guard (e ((number? e) 'num) ((symbol? e) 'sym) (else 'other)) (raise 'foo))")
"sym")
(scm-ctl-test "guard: re-raises when no clause matches"
(scm-ctl
"(guard (e (else 'outer)) (guard (e ((number? e) 'inner)) (raise 'not-a-number)))")
"outer")
(scm-ctl-test "guard: var bound in clause body"
(scm-ctl "(guard (e ((symbol? e) e)) (raise 'the-symbol))")
"the-symbol")
(scm-ctl-test "with-exception-handler: caught"
(scm-ctl
"(with-exception-handler (lambda (e) 'caught) (lambda () (raise 'oops)))")
"caught")
(scm-ctl-test "with-exception-handler: no raise"
(scm-ctl
"(with-exception-handler (lambda (e) 99) (lambda () 42))")
42)
(scm-ctl-test "with-exception-handler: handler sees the value"
(scm-ctl
"(with-exception-handler (lambda (e) (+ e 1)) (lambda () (raise 41)))")
42)
(scm-ctl-test "error: irritants accessible"
(scm-ctl
"(guard (e ((error-object? e) (error-object-irritants e))) (error \"msg\" 1 2 3))")
(list 1 2 3))
(scm-ctl-test "error: message accessible"
(scheme-string-value
(scm-ctl
"(guard (e ((error-object? e) (error-object-message e))) (error \"the-msg\"))"))
"the-msg")
;; ── dynamic-wind ────────────────────────────────────────────────
;; Basic version: runs before/thunk/after on success; before/after
;; on raise (with the raise still propagating after the after-thunk).
;; call/cc escape-out interaction is NOT yet tracked — deferred.
(scm-ctl-test "dynamic-wind: ordering on success"
(scm-ctl-all
"(define log '())
(define (note x) (set! log (cons x log)))
(dynamic-wind
(lambda () (note 'before))
(lambda () (note 'thunk) 42)
(lambda () (note 'after)))
(reverse log)")
(list "before" "thunk" "after"))
(scm-ctl-test "dynamic-wind: returns thunk value"
(scm-ctl
"(dynamic-wind (lambda () 'b) (lambda () 42) (lambda () 'a))") 42)
(scm-ctl-test "dynamic-wind: after runs on raise"
(scm-ctl-all
"(define log '())
(define (note x) (set! log (cons x log)))
(guard (e (else 'caught))
(dynamic-wind
(lambda () (note 'before))
(lambda () (raise 'boom))
(lambda () (note 'after))))
(reverse log)")
(list "before" "after"))
(scm-ctl-test "dynamic-wind: raise propagates after after-thunk"
(scm-ctl-all
"(guard (e (else e))
(dynamic-wind
(lambda () 'b)
(lambda () (raise 'the-raised))
(lambda () 'a)))")
"the-raised")
(scm-ctl-test "dynamic-wind: nested"
(scm-ctl-all
"(define log '())
(define (note x) (set! log (cons x log)))
(dynamic-wind
(lambda () (note 'outer-before))
(lambda ()
(dynamic-wind
(lambda () (note 'inner-before))
(lambda () (note 'inner-thunk))
(lambda () (note 'inner-after))))
(lambda () (note 'outer-after)))
(reverse log)")
(list "outer-before" "inner-before" "inner-thunk"
"inner-after" "outer-after"))
(define scm-ctl-tests-run! (fn () {:total (+ scm-ctl-pass scm-ctl-fail) :passed scm-ctl-pass :failed scm-ctl-fail :fails scm-ctl-fails}))

View File

@@ -1,162 +0,0 @@
;; lib/scheme/tests/eval.sx — exercises lib/scheme/eval.sx (Phase 2).
(define scm-eval-pass 0)
(define scm-eval-fail 0)
(define scm-eval-fails (list))
(define
scm-eval-test
(fn
(name actual expected)
(if
(= actual expected)
(set! scm-eval-pass (+ scm-eval-pass 1))
(begin
(set! scm-eval-fail (+ scm-eval-fail 1))
(append! scm-eval-fails {:name name :actual actual :expected expected})))))
(define scm-eval-src (fn (src env) (scheme-eval (scheme-parse src) env)))
;; A toy env with arithmetic + list primitives.
(define
scm-test-env
(fn
()
(let
((env (scheme-make-env)))
(scheme-env-bind!
env
"+"
(fn (args) (+ (first args) (nth args 1))))
(scheme-env-bind!
env
"-"
(fn (args) (- (first args) (nth args 1))))
(scheme-env-bind!
env
"*"
(fn (args) (* (first args) (nth args 1))))
(scheme-env-bind! env "list" (fn (args) args))
env)))
;; ── self-evaluating ──────────────────────────────────────────────
(scm-eval-test
"lit: integer"
(scm-eval-src "42" (scheme-make-env))
42)
(scm-eval-test "lit: float" (scm-eval-src "3.14" (scheme-make-env)) 3.14)
(scm-eval-test "lit: #t" (scm-eval-src "#t" (scheme-make-env)) true)
(scm-eval-test "lit: #f" (scm-eval-src "#f" (scheme-make-env)) false)
(scm-eval-test
"lit: empty list"
(scm-eval-src "()" (scheme-make-env))
(list))
(scm-eval-test
"lit: string"
(scheme-string? (scm-eval-src "\"hello\"" (scheme-make-env)))
true)
(scm-eval-test
"lit: char"
(scheme-char? (scm-eval-src "#\\a" (scheme-make-env)))
true)
(scm-eval-test
"lit: vector"
(scheme-vector? (scm-eval-src "#(1 2 3)" (scheme-make-env)))
true)
;; ── symbol lookup ────────────────────────────────────────────────
(scm-eval-test
"sym: bound"
(let
((env (scheme-make-env)))
(scheme-env-bind! env "x" 100)
(scm-eval-src "x" env))
100)
(scm-eval-test
"sym: parent chain"
(let
((p (scheme-make-env)))
(scheme-env-bind! p "outer" 1)
(let
((c (scheme-extend-env p)))
(scheme-env-bind! c "inner" 2)
(+ (scm-eval-src "outer" c) (scm-eval-src "inner" c))))
3)
(scm-eval-test
"sym: shadowing"
(let
((p (scheme-make-env)))
(scheme-env-bind! p "x" 1)
(let
((c (scheme-extend-env p)))
(scheme-env-bind! c "x" 2)
(scm-eval-src "x" c)))
2)
;; ── quote ────────────────────────────────────────────────────────
(scm-eval-test
"quote: symbol"
(scm-eval-src "(quote foo)" (scheme-make-env))
"foo")
(scm-eval-test
"quote: list"
(scm-eval-src "(quote (+ 1 2))" (scheme-make-env))
(list "+" 1 2))
(scm-eval-test "quote: sugar 'x" (scm-eval-src "'x" (scheme-make-env)) "x")
(scm-eval-test
"quote: sugar list"
(scm-eval-src "'(a b c)" (scheme-make-env))
(list "a" "b" "c"))
(scm-eval-test
"quote: nested"
(scm-eval-src "''x" (scheme-make-env))
(list "quote" "x"))
;; ── primitive application ────────────────────────────────────────
(scm-eval-test "prim: +" (scm-eval-src "(+ 2 3)" (scm-test-env)) 5)
(scm-eval-test
"prim: nested +"
(scm-eval-src "(+ (+ 1 2) (+ 3 4))" (scm-test-env))
10)
(scm-eval-test
"prim: mixed ops"
(scm-eval-src "(- (* 4 5) (+ 3 2))" (scm-test-env))
15)
(scm-eval-test
"prim: list builds SX list"
(scm-eval-src "(list 1 2 3)" (scm-test-env))
(list 1 2 3))
(scm-eval-test
"prim: args eval in order"
(let
((env (scm-test-env)))
(scheme-env-bind! env "a" 10)
(scheme-env-bind! env "b" 20)
(scm-eval-src "(+ a b)" env))
30)
;; ── env-as-value (the third-consumer demonstration) ─────────────
;; Scheme's env IS lib/guest/reflective/env.sx's canonical wire shape
;; with no adapter cfg. Verify the kit primitives work directly.
(scm-eval-test
"env: refl-env? on Scheme env"
(refl-env? (scheme-make-env))
true)
(scm-eval-test
"env: lookup via kit"
(let
((env (scheme-make-env)))
(refl-env-bind! env "name" "scheme")
(refl-env-lookup env "name"))
"scheme")
(scm-eval-test
"env: find-frame walks parent"
(let
((p (scheme-make-env)))
(refl-env-bind! p "root-binding" 99)
(let
((c (scheme-extend-env p)))
(= (refl-env-find-frame c "root-binding") p)))
true)
(define scm-eval-tests-run! (fn () {:total (+ scm-eval-pass scm-eval-fail) :passed scm-eval-pass :failed scm-eval-fail :fails scm-eval-fails}))

View File

@@ -1,155 +0,0 @@
;; lib/scheme/tests/macros.sx — define-syntax + syntax-rules.
(define scm-mac-pass 0)
(define scm-mac-fail 0)
(define scm-mac-fails (list))
(define
scm-mac-test
(fn
(name actual expected)
(if
(= actual expected)
(set! scm-mac-pass (+ scm-mac-pass 1))
(begin
(set! scm-mac-fail (+ scm-mac-fail 1))
(append! scm-mac-fails {:name name :actual actual :expected expected})))))
(define
scm-mac
(fn
(src)
(scheme-eval-program (scheme-parse-all src) (scheme-standard-env))))
;; ── Basic syntax-rules ──────────────────────────────────────────
(scm-mac-test
"my-if true"
(scm-mac
"(define-syntax my-if (syntax-rules () ((_ c t e) (cond (c t) (else e)))))\n (my-if #t 'yes 'no)")
"yes")
(scm-mac-test
"my-if false"
(scm-mac
"(define-syntax my-if (syntax-rules () ((_ c t e) (cond (c t) (else e)))))\n (my-if #f 'yes 'no)")
"no")
(scm-mac-test
"double"
(scm-mac
"(define-syntax double (syntax-rules () ((_ x) (+ x x))))\n (double 21)")
42)
(scm-mac-test
"nested macro use"
(scm-mac
"(define-syntax double (syntax-rules () ((_ x) (+ x x))))\n (double (double 5))")
20)
;; ── Macro with multiple rules ───────────────────────────────────
(scm-mac-test
"multi-rule: matches first"
(scm-mac
"(define-syntax twin (syntax-rules () ((_ a) a) ((_ a b) (+ a b))))\n (twin 7)")
7)
(scm-mac-test
"multi-rule: matches second"
(scm-mac
"(define-syntax twin (syntax-rules () ((_ a) a) ((_ a b) (+ a b))))\n (twin 3 4)")
7)
;; ── Macros wrapping control flow ────────────────────────────────
(scm-mac-test
"swap idiom"
(scm-mac
"(define-syntax swap! (syntax-rules () ((_ a b) (let ((tmp a)) (set! a b) (set! b tmp)))))\n (define x 1) (define y 2)\n (swap! x y)\n (list x y)")
(list 2 1))
;; ── Macros that expand to expressions, not values ──────────────
(scm-mac-test
"my-unless: true → empty"
(scm-mac
"(define-syntax my-unless (syntax-rules () ((_ c body) (if c 'skipped body))))\n (my-unless #t 99)")
"skipped")
(scm-mac-test
"my-unless: false → body"
(scm-mac
"(define-syntax my-unless (syntax-rules () ((_ c body) (if c 'skipped body))))\n (my-unless #f 99)")
99)
;; ── Macro with literal keyword ─────────────────────────────────
(scm-mac-test
"literal: => recognised"
(scm-mac
"(define-syntax tag-arrow (syntax-rules (=>) ((_ a => b) (list 'arrow a b))))\n (tag-arrow 1 => 2)")
(list "arrow" 1 2))
;; ── Macro keyword passed through unevaluated ────────────────────
(scm-mac-test
"list expansion preserves arg order"
(scm-mac
"(define-syntax tuple (syntax-rules () ((_ a b c) (list a b c))))\n (tuple 1 2 3)")
(list 1 2 3))
;; ── Macros + lambdas ────────────────────────────────────────────
(scm-mac-test
"macro inside lambda"
(scm-mac
"(define-syntax sq (syntax-rules () ((_ x) (* x x))))\n (define (f n) (+ (sq n) 1))\n (f 5)")
26)
;; ── Ellipsis patterns (Phase 6b — tail-rest single-variable) ────
(scm-mac-test "ellipsis: empty rest"
(scm-mac
"(define-syntax my-list (syntax-rules () ((_ xs ...) (list xs ...))))
(my-list)")
(list))
(scm-mac-test "ellipsis: list of values"
(scm-mac
"(define-syntax my-list (syntax-rules () ((_ xs ...) (list xs ...))))
(my-list 1 2 3 4)")
(list 1 2 3 4))
(scm-mac-test "ellipsis: my-when truthy"
(scm-mac
"(define-syntax my-when (syntax-rules () ((_ c body ...) (if c (begin body ...)))))
(my-when #t 1 2 3)")
3)
(scm-mac-test "ellipsis: my-when falsy returns nil"
(scm-mac
"(define-syntax my-when (syntax-rules () ((_ c body ...) (if c (begin body ...)))))
(my-when #f 1 2 3)")
nil)
(scm-mac-test "ellipsis: begin-rebuild"
(scm-mac
"(define-syntax my-begin (syntax-rules () ((_ body ...) (let () body ...))))
(my-begin (define x 5) (define y 10) (+ x y))")
15)
(scm-mac-test "ellipsis: variadic sum-em via fold"
(scm-mac
"(define-syntax sum-em (syntax-rules () ((_ xs ...) (fold-left + 0 (list xs ...)))))
(sum-em 1 2 3 4 5)")
15)
(scm-mac-test "ellipsis: recursive my-and"
(scm-mac
"(define-syntax my-and
(syntax-rules ()
((_) #t)
((_ x) x)
((_ x xs ...) (if x (my-and xs ...) #f))))
(my-and 1 2 3)")
3)
(scm-mac-test "ellipsis: my-and short-circuits"
(scm-mac
"(define-syntax my-and
(syntax-rules ()
((_) #t)
((_ x) x)
((_ x xs ...) (if x (my-and xs ...) #f))))
(my-and 1 #f 3)")
false)
(define scm-mac-tests-run! (fn () {:total (+ scm-mac-pass scm-mac-fail) :passed scm-mac-pass :failed scm-mac-fail :fails scm-mac-fails}))

View File

@@ -1,73 +0,0 @@
;; lib/scheme/tests/modules.sx — define-library + import.
(define scm-mod-pass 0)
(define scm-mod-fail 0)
(define scm-mod-fails (list))
(define
scm-mod-test
(fn
(name actual expected)
(if
(= actual expected)
(set! scm-mod-pass (+ scm-mod-pass 1))
(begin
(set! scm-mod-fail (+ scm-mod-fail 1))
(append! scm-mod-fails {:name name :actual actual :expected expected})))))
(define
scm-mod
(fn
(src)
(scheme-eval-program (scheme-parse-all src) (scheme-standard-env))))
;; ── Basic define-library + import ───────────────────────────────
(scm-mod-test
"simple lib: sq exported"
(scm-mod
"(define-library (my math)\n (export sq)\n (begin (define (sq x) (* x x))))\n (import (my math))\n (sq 5)")
25)
(scm-mod-test
"lib: multiple exports"
(scm-mod
"(define-library (my math)\n (export sq cube)\n (begin\n (define (sq x) (* x x))\n (define (cube x) (* x x x))))\n (import (my math))\n (list (sq 5) (cube 3))")
(list 25 27))
(scm-mod-test
"lib: single-symbol name"
(scm-mod
"(define-library (utils)\n (export greet)\n (begin (define (greet name) (string-append \"hi \" name))))\n (import (utils))\n (string=? (greet \"world\") \"hi world\")")
true)
;; ── Unexported names are not visible ───────────────────────────
(scm-mod-test
"lib: private name not exported"
(scm-mod
"(define-library (my math)\n (export sq)\n (begin\n (define (sq x) (* x x))\n (define (private-helper x) (+ x 1))))\n (import (my math))\n (guard (e (else 'unbound)) private-helper)")
"unbound")
;; ── Library calls its own internals ─────────────────────────────
(scm-mod-test
"lib: internal calls private fn"
(scm-mod
"(define-library (my math)\n (export public-add1)\n (begin\n (define (private-inc x) (+ x 1))\n (define (public-add1 x) (private-inc x))))\n (import (my math))\n (public-add1 41)")
42)
;; ── Two libs, both imported ────────────────────────────────────
(scm-mod-test
"two libs: both imported"
(scm-mod
"(define-library (a) (export af) (begin (define (af) 1)))\n (define-library (b) (export bf) (begin (define (bf) 2)))\n (import (a) (b))\n (+ (af) (bf))")
3)
;; ── Unknown library import errors ──────────────────────────────
(scm-mod-test
"import: unknown lib errors"
(scm-mod "(guard (e (else 'unknown-lib)) (import (no such lib)))")
"unknown-lib")
(define scm-mod-tests-run! (fn () {:total (+ scm-mod-pass scm-mod-fail) :passed scm-mod-pass :failed scm-mod-fail :fails scm-mod-fails}))

View File

@@ -1,177 +0,0 @@
;; lib/scheme/tests/parse.sx — exercises lib/scheme/parser.sx.
(define scm-test-pass 0)
(define scm-test-fail 0)
(define scm-test-fails (list))
(define
scm-test
(fn
(name actual expected)
(if
(= actual expected)
(set! scm-test-pass (+ scm-test-pass 1))
(begin
(set! scm-test-fail (+ scm-test-fail 1))
(append! scm-test-fails {:name name :actual actual :expected expected})))))
;; ── numbers ───────────────────────────────────────────────────────
(scm-test "num: integer" (scheme-parse "42") 42)
(scm-test "num: zero" (scheme-parse "0") 0)
(scm-test "num: negative" (scheme-parse "-17") -17)
(scm-test "num: float" (scheme-parse "3.14") 3.14)
(scm-test "num: exponent" (scheme-parse "1e3") 1000)
(scm-test "num: negative float" (scheme-parse "-2.5") -2.5)
;; ── booleans ──────────────────────────────────────────────────────
(scm-test "bool: #t" (scheme-parse "#t") true)
(scm-test "bool: #true" (scheme-parse "#true") true)
(scm-test "bool: #f" (scheme-parse "#f") false)
(scm-test "bool: #false" (scheme-parse "#false") false)
;; ── strings ───────────────────────────────────────────────────────
(scm-test "str: empty" (scheme-string-value (scheme-parse "\"\"")) "")
(scm-test
"str: hello"
(scheme-string-value (scheme-parse "\"hello\""))
"hello")
(scm-test "str: predicate" (scheme-string? (scheme-parse "\"x\"")) true)
(scm-test "str: not symbol" (scheme-string? (scheme-parse "x")) false)
(scm-test
"str: escape newline"
(scheme-string-value (scheme-parse "\"a\\nb\""))
"a\nb")
(scm-test
"str: escape tab"
(scheme-string-value (scheme-parse "\"a\\tb\""))
"a\tb")
(scm-test
"str: escape quote"
(scheme-string-value (scheme-parse "\"a\\\"b\""))
"a\"b")
;; ── symbols ───────────────────────────────────────────────────────
(scm-test "sym: word" (scheme-parse "foo") "foo")
(scm-test "sym: hyphenated" (scheme-parse "set-car!") "set-car!")
(scm-test "sym: question mark" (scheme-parse "null?") "null?")
(scm-test "sym: arrow" (scheme-parse "->") "->")
(scm-test "sym: lt-eq" (scheme-parse "<=") "<=")
(scm-test "sym: bare plus" (scheme-parse "+") "+")
(scm-test "sym: bare minus" (scheme-parse "-") "-")
(scm-test "sym: dot-prefixed" (scheme-parse ".foo") ".foo")
;; ── characters ────────────────────────────────────────────────────
(scm-test "char: single" (scheme-char-value (scheme-parse "#\\a")) "a")
(scm-test "char: space" (scheme-char-value (scheme-parse "#\\space")) " ")
(scm-test "char: newline" (scheme-char-value (scheme-parse "#\\newline")) "\n")
(scm-test "char: tab" (scheme-char-value (scheme-parse "#\\tab")) "\t")
(scm-test "char: predicate" (scheme-char? (scheme-parse "#\\x")) true)
(scm-test "char: digit" (scheme-char-value (scheme-parse "#\\5")) "5")
;; ── vectors ───────────────────────────────────────────────────────
(scm-test "vec: empty" (scheme-vector-elements (scheme-parse "#()")) (list))
(scm-test
"vec: numbers"
(scheme-vector-elements (scheme-parse "#(1 2 3)"))
(list 1 2 3))
(scm-test "vec: predicate" (scheme-vector? (scheme-parse "#(1)")) true)
(scm-test "vec: not list" (scheme-vector? (scheme-parse "(1)")) false)
;; Nested vector: SX `=` doesn't deep-compare dicts-with-list-values
;; reliably under this CEK path, so check structure piecewise.
(scm-test "vec: nested first"
(first (scheme-vector-elements (scheme-parse "#(a #(b c) d)"))) "a")
(scm-test "vec: nested second is vector"
(scheme-vector?
(nth (scheme-vector-elements (scheme-parse "#(a #(b c) d)")) 1))
true)
(scm-test "vec: nested second elements"
(scheme-vector-elements
(nth (scheme-vector-elements (scheme-parse "#(a #(b c) d)")) 1))
(list "b" "c"))
;; ── lists ─────────────────────────────────────────────────────────
(scm-test "list: empty" (scheme-parse "()") (list))
(scm-test "list: flat" (scheme-parse "(a b c)") (list "a" "b" "c"))
(scm-test
"list: nested"
(scheme-parse "(a (b c) d)")
(list "a" (list "b" "c") "d"))
(scm-test
"list: mixed atoms"
(scheme-parse "(1 #t foo)")
(list 1 true "foo"))
;; ── reader macros ─────────────────────────────────────────────────
(scm-test "quote: 'foo" (scheme-parse "'foo") (list "quote" "foo"))
(scm-test
"quote: '(a b c)"
(scheme-parse "'(a b c)")
(list "quote" (list "a" "b" "c")))
(scm-test "quasiquote: `x" (scheme-parse "`x") (list "quasiquote" "x"))
(scm-test "unquote: ,x" (scheme-parse ",x") (list "unquote" "x"))
(scm-test
"unquote-splicing: ,@x"
(scheme-parse ",@x")
(list "unquote-splicing" "x"))
(scm-test
"qq mix"
(scheme-parse "`(a ,b ,@c)")
(list
"quasiquote"
(list "a" (list "unquote" "b") (list "unquote-splicing" "c"))))
;; ── comments ──────────────────────────────────────────────────────
(scm-test "comment: line" (scheme-parse "; nope\n42") 42)
(scm-test "comment: trailing" (scheme-parse "42 ; tail") 42)
(scm-test
"comment: inside list"
(scheme-parse "(a ; mid\n b)")
(list "a" "b"))
(scm-test "comment: block simple" (scheme-parse "#| skip |# 42") 42)
(scm-test
"comment: block nested"
(scheme-parse "#| outer #| inner |# done |# 42")
42)
(scm-test "comment: datum #;" (scheme-parse "#;skipme 42") 42)
(scm-test
"comment: datum skips list"
(scheme-parse "#;(1 2 3) 42")
42)
;; ── parse-all ─────────────────────────────────────────────────────
(scm-test "all: empty" (scheme-parse-all "") (list))
(scm-test
"all: three forms"
(scheme-parse-all "1 2 3")
(list 1 2 3))
(scm-test
"all: mixed"
(scheme-parse-all "(if #t 1 2) foo")
(list (list "if" true 1 2) "foo"))
;; ── classic Scheme idioms ─────────────────────────────────────────
(scm-test
"classic: lambda"
(scheme-parse "(lambda (x) (+ x 1))")
(list "lambda" (list "x") (list "+" "x" 1)))
(scm-test
"classic: define"
(scheme-parse "(define (sq x) (* x x))")
(list "define" (list "sq" "x") (list "*" "x" "x")))
(scm-test
"classic: let"
(scheme-parse "(let ((x 1) (y 2)) (+ x y))")
(list
"let"
(list (list "x" 1) (list "y" 2))
(list "+" "x" "y")))
(scm-test
"classic: if"
(scheme-parse "(if (zero? n) 1 (* n (fact (- n 1))))")
(list
"if"
(list "zero?" "n")
1
(list "*" "n" (list "fact" (list "-" "n" 1)))))
(define scm-tests-run! (fn () {:total (+ scm-test-pass scm-test-fail) :passed scm-test-pass :failed scm-test-fail :fails scm-test-fails}))

View File

@@ -1,96 +0,0 @@
;; lib/scheme/tests/records.sx — define-record-type.
(define scm-rec-pass 0)
(define scm-rec-fail 0)
(define scm-rec-fails (list))
(define
scm-rec-test
(fn
(name actual expected)
(if
(= actual expected)
(set! scm-rec-pass (+ scm-rec-pass 1))
(begin
(set! scm-rec-fail (+ scm-rec-fail 1))
(append! scm-rec-fails {:name name :actual actual :expected expected})))))
(define
scm-rec
(fn (src) (scheme-eval (scheme-parse src) (scheme-standard-env))))
(define
scm-rec-all
(fn
(src)
(scheme-eval-program (scheme-parse-all src) (scheme-standard-env))))
;; ── Basic record: point ─────────────────────────────────────────
(scm-rec-test
"point: constructor + predicate"
(scm-rec-all
"(define-record-type point\n (make-point x y) point?\n (x point-x) (y point-y))\n (point? (make-point 3 4))")
true)
(scm-rec-test
"point: accessor x"
(scm-rec-all
"(define-record-type point\n (make-point x y) point?\n (x point-x) (y point-y))\n (point-x (make-point 3 4))")
3)
(scm-rec-test
"point: accessor y"
(scm-rec-all
"(define-record-type point\n (make-point x y) point?\n (x point-x) (y point-y))\n (point-y (make-point 3 4))")
4)
(scm-rec-test
"point: predicate false on number"
(scm-rec-all
"(define-record-type point\n (make-point x y) point?\n (x point-x) (y point-y))\n (point? 42)")
false)
;; ── Mutator ─────────────────────────────────────────────────────
(scm-rec-test
"point: mutator"
(scm-rec-all
"(define-record-type point\n (make-point x y) point?\n (x point-x) (y point-y set-point-y!))\n (define p (make-point 3 4))\n (set-point-y! p 99)\n (point-y p)")
99)
;; ── Multiple record types are distinct ──────────────────────────
(scm-rec-test
"distinct types: point? false on circle"
(scm-rec-all
"(define-record-type point\n (make-point x y) point? (x point-x) (y point-y))\n (define-record-type circle\n (make-circle r) circle? (r circle-r))\n (point? (make-circle 5))")
false)
(scm-rec-test
"distinct types: circle? true on circle"
(scm-rec-all
"(define-record-type point\n (make-point x y) point? (x point-x) (y point-y))\n (define-record-type circle\n (make-circle r) circle? (r circle-r))\n (circle? (make-circle 5))")
true)
;; ── Records as first-class values ───────────────────────────────
(scm-rec-test
"record in a list"
(scm-rec-all
"(define-record-type box\n (make-box v) box? (v box-v))\n (map box-v (list (make-box 1) (make-box 2) (make-box 3)))")
(list 1 2 3))
;; ── Records via map/filter ──────────────────────────────────────
(scm-rec-test
"filter records by predicate"
(scm-rec-all
"(define-record-type box\n (make-box v) box? (v box-v))\n (length\n (filter (lambda (b) (> (box-v b) 5))\n (list (make-box 1) (make-box 7) (make-box 3) (make-box 10)))))")
2)
;; ── Constructor arity errors ────────────────────────────────────
(scm-rec-test
"ctor: wrong arity errors"
(scm-rec-all
"(define-record-type point (make-point x y) point? (x point-x) (y point-y))\n (guard (e (else 'arity-err)) (make-point 1))")
"arity-err")
(define scm-rec-tests-run! (fn () {:total (+ scm-rec-pass scm-rec-fail) :passed scm-rec-pass :failed scm-rec-fail :fails scm-rec-fails}))

View File

@@ -1,130 +0,0 @@
;; lib/scheme/tests/reflection.sx — Phase 7 reflective primitives.
(define scm-ref-pass 0)
(define scm-ref-fail 0)
(define scm-ref-fails (list))
(define
scm-ref-test
(fn
(name actual expected)
(if
(= actual expected)
(set! scm-ref-pass (+ scm-ref-pass 1))
(begin
(set! scm-ref-fail (+ scm-ref-fail 1))
(append! scm-ref-fails {:name name :actual actual :expected expected})))))
(define
scm-ref
(fn (src) (scheme-eval (scheme-parse src) (scheme-standard-env))))
(define
scm-ref-all
(fn
(src)
(scheme-eval-program (scheme-parse-all src) (scheme-standard-env))))
;; ── eval ─────────────────────────────────────────────────────────
(scm-ref-test
"eval: arithmetic"
(scm-ref "(eval '(+ 1 2 3) (interaction-environment))")
6)
(scm-ref-test
"eval: nested"
(scm-ref "(eval '(* (+ 1 2) (- 5 1)) (interaction-environment))")
12)
(scm-ref-test
"eval: constructed form"
(scm-ref "(eval (list '+ 10 20) (interaction-environment))")
30)
(scm-ref-test
"eval: variable reference"
(scm-ref-all "(define x 42) (eval 'x (interaction-environment))")
42)
;; ── interaction-environment ─────────────────────────────────────
(scm-ref-test
"interaction-environment: is an env"
(scm-ref "(environment? (interaction-environment))")
true)
(scm-ref-test
"interaction-environment: define persists"
(scm-ref-all
"(define ie (interaction-environment))\n (eval '(define stashed 99) ie)\n (eval 'stashed ie)")
99)
(scm-ref-test
"interaction-environment: same env across calls"
(scm-ref-all
"(define a (interaction-environment))\n (define b (interaction-environment))\n (eqv? a b)")
true)
;; ── null-environment ────────────────────────────────────────────
(scm-ref-test
"null-environment: is an env"
(scm-ref "(environment? (null-environment 7))")
true)
(scm-ref-test
"null-environment: has no + binding"
(scm-ref-all
"(define ne (null-environment 7))\n (guard (e (else 'unbound)) (eval '+ ne))")
"unbound")
;; ── scheme-report-environment ───────────────────────────────────
(scm-ref-test
"scheme-report-environment: is an env"
(scm-ref "(environment? (scheme-report-environment 7))")
true)
(scm-ref-test
"scheme-report-environment: has +"
(scm-ref "(eval '(+ 1 2) (scheme-report-environment 7))")
3)
(scm-ref-test
"scheme-report-environment: distinct from interaction"
(scm-ref-all
"(define ie (interaction-environment))\n (define re (scheme-report-environment 7))\n (eval '(define only-in-ie 1) ie)\n (guard (e (else 'unbound)) (eval 'only-in-ie re))")
"unbound")
;; ── eval with explicit env for sandboxing ──────────────────────
(scm-ref-test
"eval: sandbox with null-environment"
(scm-ref-all
"(define sandbox (null-environment 7))\n (guard (e (else 'unbound))\n (eval '(+ 1 1) sandbox))")
"unbound")
;; ── quasiquote / unquote / unquote-splicing ─────────────────────
(scm-ref-test "qq: plain atom"
(scm-ref "`hello") "hello")
(scm-ref-test "qq: plain list"
(scm-ref "`(a b c)") (list "a" "b" "c"))
(scm-ref-test "qq: unquote substitutes value"
(scm-ref-all "(define x 42) `(a ,x b)")
(list "a" 42 "b"))
(scm-ref-test "qq: unquote-splicing splices list"
(scm-ref-all "(define xs '(1 2 3)) `(a ,@xs b)")
(list "a" 1 2 3 "b"))
(scm-ref-test "qq: splice at start"
(scm-ref-all "(define xs '(1 2)) `(,@xs c)")
(list 1 2 "c"))
(scm-ref-test "qq: splice at end"
(scm-ref-all "(define xs '(9 8)) `(a b ,@xs)")
(list "a" "b" 9 8))
(scm-ref-test "qq: nested list with unquote"
(scm-ref-all "(define x 5) `(a (b ,x) c)")
(list "a" (list "b" 5) "c"))
(scm-ref-test "qq: unquote evaluates expression"
(scm-ref "`(a ,(+ 1 2) b)")
(list "a" 3 "b"))
(scm-ref-test "qq: error on splicing non-list"
(scm-ref-all
"(define x 42) (guard (e (else 'raised)) `(a ,@x b))")
"raised")
(scm-ref-test "qq: bare unquote at top level errors"
(scm-ref "(guard (e (else 'raised)) (unquote 5))") "raised")
(define scm-ref-tests-run! (fn () {:total (+ scm-ref-pass scm-ref-fail) :passed scm-ref-pass :failed scm-ref-fail :fails scm-ref-fails}))

View File

@@ -1,213 +0,0 @@
;; lib/scheme/tests/runtime.sx — exercises the standard env.
(define scm-rt-pass 0)
(define scm-rt-fail 0)
(define scm-rt-fails (list))
(define
scm-rt-test
(fn
(name actual expected)
(if
(= actual expected)
(set! scm-rt-pass (+ scm-rt-pass 1))
(begin
(set! scm-rt-fail (+ scm-rt-fail 1))
(append! scm-rt-fails {:name name :actual actual :expected expected})))))
(define
scm-rt
(fn (src) (scheme-eval (scheme-parse src) (scheme-standard-env))))
(define
scm-rt-all
(fn
(src)
(scheme-eval-program (scheme-parse-all src) (scheme-standard-env))))
;; ── Variadic arithmetic ─────────────────────────────────────────
(scm-rt-test "+: zero" (scm-rt "(+)") 0)
(scm-rt-test "+: one" (scm-rt "(+ 7)") 7)
(scm-rt-test "+: many" (scm-rt "(+ 1 2 3 4 5)") 15)
(scm-rt-test "-: one" (scm-rt "(- 10)") -10)
(scm-rt-test "-: many" (scm-rt "(- 100 1 2 3)") 94)
(scm-rt-test "*: zero" (scm-rt "(*)") 1)
(scm-rt-test "*: many" (scm-rt "(* 1 2 3 4)") 24)
(scm-rt-test "/: two" (scm-rt "(/ 20 5)") 4)
;; ── Chained comparison ──────────────────────────────────────────
(scm-rt-test "<: chained" (scm-rt "(< 1 2 3 4 5)") true)
(scm-rt-test "<: not strict" (scm-rt "(< 1 2 2 3)") false)
(scm-rt-test ">: chained" (scm-rt "(> 5 4 3 2 1)") true)
(scm-rt-test "<=: with equality" (scm-rt "(<= 1 1 2 3 3)") true)
(scm-rt-test "=: chained" (scm-rt "(= 7 7 7)") true)
;; ── Numerical ───────────────────────────────────────────────────
(scm-rt-test "abs neg" (scm-rt "(abs -5)") 5)
(scm-rt-test "abs pos" (scm-rt "(abs 5)") 5)
(scm-rt-test "min" (scm-rt "(min 3 1 4 1 5)") 1)
(scm-rt-test "max" (scm-rt "(max 3 1 4 1 5)") 5)
(scm-rt-test "modulo" (scm-rt "(modulo 10 3)") 1)
(scm-rt-test "zero? 0" (scm-rt "(zero? 0)") true)
(scm-rt-test "zero? 1" (scm-rt "(zero? 1)") false)
(scm-rt-test "positive?" (scm-rt "(positive? 5)") true)
(scm-rt-test "negative?" (scm-rt "(negative? -5)") true)
;; ── Type predicates ─────────────────────────────────────────────
(scm-rt-test "number? int" (scm-rt "(number? 42)") true)
(scm-rt-test "number? str" (scm-rt "(number? \"hi\")") false)
(scm-rt-test "boolean? #t" (scm-rt "(boolean? #t)") true)
(scm-rt-test "boolean? 0" (scm-rt "(boolean? 0)") false)
(scm-rt-test "string? str" (scm-rt "(string? \"hi\")") true)
(scm-rt-test "string? sym" (scm-rt "(string? 'foo)") false)
(scm-rt-test "symbol? sym" (scm-rt "(symbol? 'foo)") true)
(scm-rt-test "null? ()" (scm-rt "(null? '())") true)
(scm-rt-test "null? (1)" (scm-rt "(null? '(1))") false)
(scm-rt-test "pair? (1)" (scm-rt "(pair? '(1))") true)
(scm-rt-test "pair? ()" (scm-rt "(pair? '())") false)
(scm-rt-test "procedure? lambda" (scm-rt "(procedure? (lambda (x) x))") true)
(scm-rt-test "procedure? +" (scm-rt "(procedure? +)") true)
(scm-rt-test "procedure? 42" (scm-rt "(procedure? 42)") false)
(scm-rt-test "not #t" (scm-rt "(not #t)") false)
(scm-rt-test "not #f" (scm-rt "(not #f)") true)
(scm-rt-test "not 0" (scm-rt "(not 0)") false)
;; ── List operations ─────────────────────────────────────────────
(scm-rt-test
"cons"
(scm-rt "(cons 1 '(2 3))")
(list 1 2 3))
(scm-rt-test "car" (scm-rt "(car '(1 2 3))") 1)
(scm-rt-test "cdr" (scm-rt "(cdr '(1 2 3))") (list 2 3))
(scm-rt-test
"list builds"
(scm-rt "(list 1 2 3)")
(list 1 2 3))
(scm-rt-test "list empty" (scm-rt "(list)") (list))
(scm-rt-test "length 3" (scm-rt "(length '(a b c))") 3)
(scm-rt-test "length 0" (scm-rt "(length '())") 0)
(scm-rt-test
"reverse"
(scm-rt "(reverse '(1 2 3))")
(list 3 2 1))
(scm-rt-test "reverse empty" (scm-rt "(reverse '())") (list))
(scm-rt-test
"append two"
(scm-rt "(append '(1 2) '(3 4))")
(list 1 2 3 4))
(scm-rt-test
"append three"
(scm-rt "(append '(1) '(2) '(3))")
(list 1 2 3))
(scm-rt-test "append empty" (scm-rt "(append)") (list))
;; ── Higher-order combinators ────────────────────────────────────
(scm-rt-test
"map square"
(scm-rt "(map (lambda (x) (* x x)) '(1 2 3 4))")
(list 1 4 9 16))
(scm-rt-test
"map with primitive"
(scm-rt-all "(define inc (lambda (x) (+ x 1))) (map inc '(10 20 30))")
(list 11 21 31))
(scm-rt-test
"filter positives"
(scm-rt "(filter positive? '(-2 -1 0 1 2))")
(list 1 2))
(scm-rt-test
"filter empty result"
(scm-rt "(filter (lambda (x) #f) '(1 2 3))")
(list))
(scm-rt-test
"fold-left sum"
(scm-rt "(fold-left + 0 '(1 2 3 4 5))")
15)
(scm-rt-test
"fold-left build list"
(scm-rt "(fold-left (lambda (acc x) (cons x acc)) '() '(1 2 3))")
(list 3 2 1))
(scm-rt-test
"fold-right preserves order"
(scm-rt "(fold-right cons '() '(1 2 3))")
(list 1 2 3))
(scm-rt-test
"for-each side effect"
(let
((env (scheme-standard-env)))
(scheme-eval-program
(scheme-parse-all
"(define sum 0) (for-each (lambda (n) (set! sum (+ sum n))) '(1 2 3 4 5)) sum")
env))
15)
;; ── apply ───────────────────────────────────────────────────────
(scm-rt-test "apply +" (scm-rt "(apply + '(1 2 3 4 5))") 15)
(scm-rt-test
"apply lambda"
(scm-rt "(apply (lambda (a b c) (+ a (* b c))) '(1 2 3))")
7)
(scm-rt-test
"apply via map"
(scm-rt "(apply + (map (lambda (x) (* x x)) '(1 2 3)))")
14)
;; ── String / char / vector ──────────────────────────────────────
(scm-rt-test "string-length" (scm-rt "(string-length \"hello\")") 5)
(scm-rt-test "string=? same" (scm-rt "(string=? \"abc\" \"abc\")") true)
(scm-rt-test "string=? diff" (scm-rt "(string=? \"abc\" \"abd\")") false)
(scm-rt-test
"string-append"
(scheme-string-value (scm-rt "(string-append \"hello\" \" \" \"world\")"))
"hello world")
(scm-rt-test "vector?" (scm-rt "(vector? #(1 2 3))") true)
(scm-rt-test "vector-length" (scm-rt "(vector-length #(1 2 3))") 3)
(scm-rt-test "vector-ref" (scm-rt "(vector-ref #(10 20 30) 1)") 20)
(scm-rt-test
"vector->list"
(scm-rt "(vector->list #(1 2 3))")
(list 1 2 3))
;; ── Classic Scheme programs ─────────────────────────────────────
(scm-rt-test
"factorial 5"
(scm-rt-all
"(define (fact n) (if (<= n 1) 1 (* n (fact (- n 1))))) (fact 5)")
120)
(scm-rt-test
"factorial 10"
(scm-rt-all
"(define (fact n) (if (<= n 1) 1 (* n (fact (- n 1))))) (fact 10)")
3628800)
(scm-rt-test
"fib 10"
(scm-rt-all
"(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 10)")
55)
(scm-rt-test
"sum via reduce"
(scm-rt "(fold-left + 0 (map (lambda (x) (* x x)) '(1 2 3 4 5)))")
55)
(scm-rt-test
"length via reduce"
(scm-rt-all
"(define (len xs) (fold-left (lambda (acc _) (+ acc 1)) 0 xs)) (len '(a b c d))")
4)
(scm-rt-test
"Y-ish reverse"
(scm-rt-all
"(define (rev xs) (if (null? xs) '() (append (rev (cdr xs)) (list (car xs))))) (rev '(1 2 3 4))")
(list 4 3 2 1))
;; ── env-as-value (kit consumer demo) ────────────────────────────
(scm-rt-test
"env: standard-env is refl-env"
(refl-env? (scheme-standard-env))
true)
(scm-rt-test
"env: kit lookup finds primitive"
(let
((env (scheme-standard-env)))
(callable? (refl-env-lookup env "+")))
true)
(define scm-rt-tests-run! (fn () {:total (+ scm-rt-pass scm-rt-fail) :passed scm-rt-pass :failed scm-rt-fail :fails scm-rt-fails}))

View File

@@ -1,288 +0,0 @@
;; lib/scheme/tests/syntax.sx — exercises Phase 3 syntactic operators.
(define scm-syn-pass 0)
(define scm-syn-fail 0)
(define scm-syn-fails (list))
(define
scm-syn-test
(fn
(name actual expected)
(if
(= actual expected)
(set! scm-syn-pass (+ scm-syn-pass 1))
(begin
(set! scm-syn-fail (+ scm-syn-fail 1))
(append! scm-syn-fails {:name name :actual actual :expected expected})))))
(define scm-syn-eval (fn (src env) (scheme-eval (scheme-parse src) env)))
(define
scm-syn-eval-all
(fn (src env) (scheme-eval-program (scheme-parse-all src) env)))
;; Test env with arithmetic primitives.
(define
scm-syn-env
(fn
()
(let
((env (scheme-make-env)))
(scheme-env-bind!
env
"+"
(fn (args) (+ (first args) (nth args 1))))
(scheme-env-bind!
env
"-"
(fn (args) (- (first args) (nth args 1))))
(scheme-env-bind!
env
"*"
(fn (args) (* (first args) (nth args 1))))
(scheme-env-bind!
env
"/"
(fn (args) (/ (first args) (nth args 1))))
(scheme-env-bind!
env
"<="
(fn (args) (<= (first args) (nth args 1))))
(scheme-env-bind!
env
"<"
(fn (args) (< (first args) (nth args 1))))
(scheme-env-bind!
env
"="
(fn (args) (= (first args) (nth args 1))))
(scheme-env-bind! env "list" (fn (args) args))
(scheme-env-bind!
env
"cons"
(fn (args) (cons (first args) (nth args 1))))
(scheme-env-bind! env "car" (fn (args) (first (first args))))
(scheme-env-bind! env "cdr" (fn (args) (rest (first args))))
env)))
;; ── if ───────────────────────────────────────────────────────────
(scm-syn-test
"if: true"
(scm-syn-eval "(if #t 1 2)" (scm-syn-env))
1)
(scm-syn-test
"if: false"
(scm-syn-eval "(if #f 1 2)" (scm-syn-env))
2)
(scm-syn-test
"if: predicate"
(scm-syn-eval "(if (<= 1 2) 99 nope)" (scm-syn-env))
99)
(scm-syn-test
"if: no else returns nil"
(scm-syn-eval "(if #f 99)" (scm-syn-env))
nil)
(scm-syn-test
"if: truthy non-#f"
(scm-syn-eval "(if 0 'yes 'no)" (scm-syn-env))
"yes")
;; ── define ───────────────────────────────────────────────────────
(scm-syn-test
"define: bind value"
(let
((env (scm-syn-env)))
(scm-syn-eval "(define x 42)" env)
(scm-syn-eval "x" env))
42)
(scm-syn-test
"define: function sugar"
(let
((env (scm-syn-env)))
(scm-syn-eval-all "(define (double n) (+ n n)) (double 21)" env))
42)
(scm-syn-test
"define: redefine"
(let
((env (scm-syn-env)))
(scm-syn-eval-all "(define x 1) (define x 2) x" env))
2)
;; ── set! ─────────────────────────────────────────────────────────
(scm-syn-test
"set!: mutate"
(let
((env (scm-syn-env)))
(scm-syn-eval-all "(define x 1) (set! x 99) x" env))
99)
(scm-syn-test
"set!: walks parent"
(let
((env (scm-syn-env)))
(scm-syn-eval-all "(define x 1) ((lambda () (set! x 100))) x" env))
100)
(scm-syn-test
"set!: errors on unbound"
(guard
(e (true :raised))
(scm-syn-eval-all "(set! never-defined 1)" (scm-syn-env)))
:raised)
;; ── begin ────────────────────────────────────────────────────────
(scm-syn-test
"begin: empty returns nil"
(scm-syn-eval "(begin)" (scm-syn-env))
nil)
(scm-syn-test
"begin: returns last"
(scm-syn-eval "(begin 1 2 3)" (scm-syn-env))
3)
(scm-syn-test
"begin: side effects in order"
(let
((env (scm-syn-env)))
(scm-syn-eval-all
"(define x 0) (begin (set! x 1) (set! x 2) (set! x 3)) x"
env))
3)
;; ── lambda ───────────────────────────────────────────────────────
(scm-syn-test
"lambda: identity"
(scm-syn-eval "((lambda (x) x) 42)" (scm-syn-env))
42)
(scm-syn-test
"lambda: arithmetic"
(scm-syn-eval "((lambda (x y) (+ x y)) 3 4)" (scm-syn-env))
7)
(scm-syn-test
"lambda: zero args"
(scm-syn-eval "((lambda () 99))" (scm-syn-env))
99)
(scm-syn-test
"lambda: multi-body"
(scm-syn-eval "((lambda (x) (define t (+ x 1)) (+ t t)) 5)" (scm-syn-env))
12)
(scm-syn-test
"lambda: rest-arg as bare symbol"
(scm-syn-eval "((lambda args args) 1 2 3)" (scm-syn-env))
(list 1 2 3))
;; ── closures ─────────────────────────────────────────────────────
(scm-syn-test
"closure: captures binding"
(let
((env (scm-syn-env)))
(scm-syn-eval-all
"(define (make-adder n) (lambda (x) (+ x n))) ((make-adder 10) 5)"
env))
15)
(scm-syn-test
"closure: counter via set!"
(let
((env (scm-syn-env)))
(scm-syn-eval-all
"(define (make-counter) (define n 0) (lambda () (set! n (+ n 1)) n)) (define c (make-counter)) (c) (c) (c)"
env))
3)
(scm-syn-test
"closure: curried"
(let
((env (scm-syn-env)))
(scm-syn-eval-all
"(define curry+ (lambda (a) (lambda (b) (lambda (c) (+ a (+ b c)))))) (((curry+ 1) 2) 3)"
env))
6)
;; ── recursion ────────────────────────────────────────────────────
(scm-syn-test
"recursive: factorial 5"
(let
((env (scm-syn-env)))
(scm-syn-eval-all
"(define (fact n) (if (<= n 1) 1 (* n (fact (- n 1))))) (fact 5)"
env))
120)
(scm-syn-test
"recursive: factorial 10"
(let
((env (scm-syn-env)))
(scm-syn-eval-all
"(define (fact n) (if (<= n 1) 1 (* n (fact (- n 1))))) (fact 10)"
env))
3628800)
(scm-syn-test
"recursive: list length"
(let
((env (scm-syn-env)))
(scm-syn-eval-all
"(define (len xs) (if (= 0 (- 0 0)) (if (= xs (quote ())) 0 (+ 1 (len (cdr xs)))) 0)) (len '(a b c d))"
env))
4)
;; ── quote vs eval distinction ────────────────────────────────────
(scm-syn-test
"quote: list literal"
(scm-syn-eval "'(1 2 3)" (scm-syn-env))
(list 1 2 3))
(scm-syn-test
"quote: nested"
(scm-syn-eval "'(a (b c) d)" (scm-syn-env))
(list "a" (list "b" "c") "d"))
(scm-syn-test
"quote: symbol vs evaluated"
(let ((env (scm-syn-env))) (scm-syn-eval-all "(define x 42) 'x" env))
"x")
;; ── let / let* ───────────────────────────────────────────────────
(scm-syn-test "let: returns body"
(scm-syn-eval "(let ((x 5)) (+ x 1))" (scm-syn-env)) 6)
(scm-syn-test "let: multiple bindings"
(scm-syn-eval "(let ((x 3) (y 4)) (+ x y))" (scm-syn-env)) 7)
(scm-syn-test "let: parallel (RHS sees outer)"
(let ((env (scm-syn-env)))
(scm-syn-eval-all "(define x 1) (let ((x 10) (y x)) y)" env)) 1)
(scm-syn-test "let: bindings don't leak"
(let ((env (scm-syn-env)))
(scm-syn-eval-all "(define x 1) (let ((x 99)) x) x" env)) 1)
(scm-syn-test "let*: sequential"
(scm-syn-eval "(let* ((x 1) (y (+ x 1)) (z (+ y 1))) z)"
(scm-syn-env)) 3)
(scm-syn-test "let*: shadow earlier"
(scm-syn-eval "(let* ((x 1) (x 2)) x)" (scm-syn-env)) 2)
;; ── cond / when / unless ─────────────────────────────────────────
(scm-syn-test "cond: first match"
(scm-syn-eval "(cond (#f 1) (#t 2) (#t 3))" (scm-syn-env)) 2)
(scm-syn-test "cond: else"
(scm-syn-eval "(cond (#f 1) (else 99))" (scm-syn-env)) 99)
(scm-syn-test "cond: untaken not evaluated"
(scm-syn-eval "(cond (#t 7) (nope ignored))" (scm-syn-env)) 7)
(scm-syn-test "cond: no match returns nil"
(scm-syn-eval "(cond (#f 1) (#f 2))" (scm-syn-env)) nil)
(scm-syn-test "cond: test-only clause"
(scm-syn-eval "(cond (42))" (scm-syn-env)) 42)
(scm-syn-test "when: true"
(scm-syn-eval "(when #t 1 2 3)" (scm-syn-env)) 3)
(scm-syn-test "when: false"
(scm-syn-eval "(when #f nope)" (scm-syn-env)) nil)
(scm-syn-test "unless: false"
(scm-syn-eval "(unless #f 42)" (scm-syn-env)) 42)
(scm-syn-test "unless: true"
(scm-syn-eval "(unless #t nope)" (scm-syn-env)) nil)
;; ── and / or ─────────────────────────────────────────────────────
(scm-syn-test "and: empty"
(scm-syn-eval "(and)" (scm-syn-env)) true)
(scm-syn-test "and: all truthy returns last"
(scm-syn-eval "(and 1 2 3)" (scm-syn-env)) 3)
(scm-syn-test "and: short-circuit on #f"
(scm-syn-eval "(and 1 #f nope)" (scm-syn-env)) false)
(scm-syn-test "or: empty"
(scm-syn-eval "(or)" (scm-syn-env)) false)
(scm-syn-test "or: first truthy"
(scm-syn-eval "(or #f 42 nope)" (scm-syn-env)) 42)
(scm-syn-test "or: all #f"
(scm-syn-eval "(or #f #f #f)" (scm-syn-env)) false)
(define scm-syn-tests-run! (fn () {:total (+ scm-syn-pass scm-syn-fail) :passed scm-syn-pass :failed scm-syn-fail :fails scm-syn-fails}))

View File

@@ -0,0 +1,83 @@
# lib/guest/test-runner.sx — extraction plan
## Status
- [x] **Phase 1 — Kit + Kernel.** `lib/guest/test-runner.sx` extracted (5 forms, ~50 LoC). Seven Kernel test files migrated (`parse.sx`, `eval.sx`, `vau.sx`, `standard.sx`, `encap.sx`, `hygiene.sx`, `metacircular.sx`). 322/322 tests unchanged. 84 LoC removed.
- [ ] **Phase 2 — Per-guest migrations.** 35 additional test files match the standard `(define X-test-pass 0)` pattern across 7 guests; each needs the test runner's `(load "lib/guest/test-runner.sx")` line and a per-file harness rewrite. Variant shapes (Tcl, Smalltalk, APL alternate) need *different* extraction targets.
## The kit
```lisp
(refl-make-test-suite) {:pass 0 :fail 0 :fails (list)}
(refl-test SUITE NAME ACT EXP) mutates suite (dict-set! + append!)
(refl-test-report SUITE) {:total :passed :failed :fails}
(refl-test-pass? SUITE) bool
(refl-test-suite? V) predicate
```
Each migrated test file collapses from a 14-line harness boilerplate to:
```lisp
(define X-suite (refl-make-test-suite))
(define X-test (fn (n a e) (refl-test X-suite n a e)))
;; ... tests ...
(define X-tests-run! (fn () (refl-test-report X-suite)))
```
## Per-guest migration status
| Guest | Std-pattern files | Variant? | Migration commit |
|--------------|------------------:|---------------------|------------------|
| kernel | 7 | - | landed (Phase 1) |
| prolog | 23 | - | pending |
| common-lisp | 4 | - | pending |
| erlang | 4 | sub-prefix per file | pending |
| apl | 1 | uses `set!` over `append`, args are `got expected` | needs variant adapter |
| forth | 1 | - | pending |
| minikanren | 1 | - | pending |
| ruby | 1 | - | pending |
| tcl | 0 (uses different shape — see below) | `tcl-X-pass/-failures`, append! a STRING | needs variant kit |
| smalltalk | 0 (uses SUnit) | own framework | not applicable |
| haskell, hyperscript, js, lua | 0 | no per-suite harness | not applicable |
## Variant shapes that need their own extractions
### Tcl-flavour (`lib/tcl/tests/*.sx`)
```lisp
(define tcl-X-pass 0)
(define tcl-X-fail 0)
(define tcl-X-failures (list)) ; not -fails
(define tcl-assert
(fn (label expected actual) ; arg order: label, expected, actual
(if (= expected actual)
(set! tcl-X-pass (+ tcl-X-pass 1))
(begin (set! tcl-X-fail (+ tcl-X-fail 1))
(append! tcl-X-failures
(str label ": expected=" (str expected) " got=" (str actual)))))))
```
Difference from canonical: failures hold formatted *strings*, not dicts. Could be unified by passing a formatter cfg, but the API divergence is real (Tcl's report just lists strings; the kit's `:fails` holds dicts). Either:
- Add `refl-make-string-formatting-test-suite` variant, or
- Migrate Tcl's reports to dict-of-name-expected-actual (preferred — converges the shape).
### APL-flavour
```lisp
(define apl-test
(fn (name got expected) ; arg order: name, got, expected
(if (= got expected) ...
(set! apl-test-fails (append apl-test-fails (list {:got got :expected expected :name name}))))))
```
Difference: uses functional `append`, not `append!`. Argument order: `got expected`, not `actual expected`. Minor; renaming `n a e` in the kit call site to `n got expected` is the only change.
## Migration playbook (for the loop that finishes Phase 2)
1. Pick a guest from the table.
2. Run `/tmp/migrate_harness.py lib/<guest>/tests/*.sx`. SKIP entries are variant-shaped; ignore them or hand-migrate.
3. Add `(load "lib/guest/test-runner.sx")` to that guest's `test.sh` and `conformance.sh` (before the first guest .sx load that uses the harness).
4. Run the guest's full test suite; counts should be unchanged.
5. Commit `test-runner: migrate <guest> — N files, NN LoC saved`.
Estimated effort: 12 hours per guest, dominated by verification time. Prolog (23 files) is the biggest single commit but the most mechanical.

View File

@@ -1,191 +0,0 @@
# Scheme-on-SX: the reflective-kit second-consumer port
The kernel-on-sx loop documented six reflective API candidates; two are now live (`env.sx`, `class-chain.sx`). Three more — `evaluator.sx`, `hygiene.sx`, `quoting.sx` — wait on a guest with operative-free lexical scope, hygienic syntax-transformer infrastructure, and quasiquote. **Scheme is exactly that guest.**
A correct R7RS-small implementation acts as second consumer for those three kits in one stroke. It also confirms a third independent consumer for `env.sx` (after Kernel + Tcl + Smalltalk), and a candidate fourth consumer for `class-chain.sx` (Scheme's record types have parent fields — though OO is non-core in Scheme so the fit is weaker).
## Strategic note on `combiner.sx`
Scheme has *no fexprs*. `combiner.sx`'s applicative/operative split is Kernel-specific machinery. **Scheme is not a second consumer for `combiner.sx`** — that file stays Kernel-only until a Maru, Klisp, or CL-fexpr port arrives. The current session's earlier claim that Scheme "unlocks four more reflective kits" was over-counted; the correct number is **three**.
## Scope decisions
- **Target dialect:** R7RS-small. Source-only — no images, no FFI, no C extensions, no JIT.
- **Numbers:** integers + floats. Rationals optional (defer to phase N+1). Complex out.
- **Tail-call optimisation:** required. Implemented via the existing SX CEK machinery — call recursion in the evaluator uses iterative `cek-call` rather than host recursion.
- **Continuations:** `call/cc` required for R7RS. Use SX's `call/cc` primitive directly.
- **Hygienic macros:** `syntax-rules` required. `syntax-case` deferred.
- **Char/string semantics:** Unicode codepoints; surface API matches R7RS section 6.
- **I/O:** minimal stub (`display`, `write`, `newline`, `read`) on SX's IO surface.
- **`define-library`:** required for module testing; implementation reuses SX's `define-library` if it's exposed, else hand-rolls a flat module registry.
## Architecture sketch
```
lib/scheme/parser.sx — reader: numbers, strings, symbols, booleans,
chars #\c, vectors #(...), dotted-pairs (a . b),
quasi-quote sugar, datum comments #;, block
comments #| ... |#
lib/scheme/eval.sx — eval-expr ENV: walks AST. Symbols → env-lookup.
Lists → look up head; if syntactic operator
(if/lambda/define/set!/quote/quasiquote/
let/let*/letrec/begin/cond/case/and/or/when/
unless/do), dispatch to native handler. Else
apply combiner (always applicative).
ENV is `lib/guest/reflective/env.sx` directly
— Scheme is the third consumer for env.sx with
NO adapter cfg (canonical wire shape).
lib/scheme/runtime.sx — Standard environment, primitives, R7RS base.
Variadic arithmetic, list ops, string ops,
char ops, vector ops, define-record-type,
syntax-rules, etc.
lib/scheme/tests/ — Standard pattern: parse, eval, lambda+closure,
macros (syntax-rules), call/cc, define-library,
classic programs (factorial, Y, tree-walking,
named let, do-loop), R7RS conformance subset.
```
## Roadmap
### Phase 1 — Parser
- [ ] Reader for R7RS lexical syntax: integers, floats, strings (with escapes), symbols (extended-identifier-character set), booleans `#t`/`#f`/`#true`/`#false`, characters `#\c` `#\space` `#\newline`, vectors `#(...)`, dotted pairs `(a . b)`, quote/quasiquote/unquote/unquote-splicing sugar (same reader macros as Kernel).
- [ ] Datum comments `#;<datum>` (skip one whole expression).
- [ ] Block comments `#| ... |#` (nestable).
- [ ] Tests in `lib/scheme/tests/parse.sx`.
### Phase 2 — Evaluator + env
- [ ] `scheme-eval EXPR ENV` — primary entry, uses `lib/guest/reflective/env.sx` directly as the canonical scope chain. **Third consumer for env.sx.**
- [ ] Self-evaluating: numbers, booleans, strings, chars, vectors.
- [ ] Symbol lookup → `refl-env-lookup-with`.
- [ ] List → look up head; syntactic operators dispatch natively; otherwise applicative call with evaluated args.
- [ ] Tests in `lib/scheme/tests/eval.sx`.
### Phase 3 — Syntactic operators
- [ ] `if`, `quote`, `set!`, `define` (top-level + internal).
- [ ] `lambda` — fixed-arity, rest-arg via dot, multi-body via implicit `begin`.
- [ ] `let`, `let*`, `letrec`, `letrec*` — including named-let.
- [ ] `begin` — implicit + explicit.
- [ ] `cond`, `case`, `when`, `unless`, `and`, `or`, `do`.
- [ ] Tests for each.
### Phase 4 — Standard environment
- [ ] Variadic `+ - * /` and chained comparison.
- [ ] Type predicates (R7RS `number?`, `pair?`, `null?`, `symbol?`, `string?`, `procedure?`, `vector?`, `char?`, `boolean?`).
- [ ] List ops: `cons car cdr caar cadr ... cddddr` (or just a subset), `list length reverse append map filter fold-left fold-right for-each`.
- [ ] String ops: `string-length string-ref substring string-append string=? string<? char->integer integer->char`.
- [ ] Char ops: `char->integer integer->char char-alphabetic? char-numeric?` etc.
- [ ] Vector ops: `vector make-vector vector-length vector-ref vector-set! vector->list list->vector`.
- [ ] I/O: `display write newline read`.
- [ ] Numerical: `abs floor ceiling round truncate min max modulo quotient remainder gcd lcm expt`.
- [ ] Classic programs: factorial, fib, list reversal, tree map.
### Phase 5 — call/cc + dynamic-wind
- [ ] `call-with-current-continuation` / `call/cc`.
- [ ] `dynamic-wind`.
- [ ] `with-exception-handler`, `raise`, `error`.
- [ ] Tests: escape continuations, multi-shot via call/cc (chosen via host SX `call/cc`).
### Phase 6 — `syntax-rules` + hygiene
- [ ] `define-syntax`, `let-syntax`, `letrec-syntax`.
- [ ] `syntax-rules` pattern matching, ellipsis, template instantiation.
- [ ] Hygiene: scope-set / lifted-symbol implementation. **Second consumer for `lib/guest/reflective/hygiene.sx` extraction once that kit's API surface stabilises.**
- [ ] Tests: hygienic identifier capture, ellipsis patterns, recursive macros.
### Phase 7 — Reflection: `eval`, `interaction-environment`, etc.
- [ ] `eval EXPR ENV` — applicative form of the evaluator. **Second consumer for `lib/guest/reflective/evaluator.sx` extraction.**
- [ ] `interaction-environment`, `null-environment`, `scheme-report-environment`.
- [ ] `environment?` predicate.
### Phase 8 — `define-library` + module hygiene
- [ ] `define-library`, `import`, `export`.
- [ ] `cond-expand` for feature-flag conditionals.
- [ ] Tests: cross-library imports, identifier renaming.
### Phase 9 — Records
- [ ] `define-record-type` with constructor/predicate/accessors/mutators.
- [ ] Tests: typical record idioms.
### Phase 10 — Quasiquote runtime
- [ ] Backquote walker with depth tracking. **Second consumer for `lib/guest/reflective/quoting.sx` extraction.**
- [ ] Tests including nested quasiquote.
### Phase 11 — Conformance + scoreboard
- [ ] Curated R7RS test slice (Chibi, Larceny, or hand-picked).
- [ ] `lib/scheme/conformance.sh` + scoreboard.
- [ ] Drive conformance toward 100% on chosen slice.
## Reflective kit consumption — explicit mapping
| Kit | When it lands | How Scheme uses it |
|-----|--------------|-------------------|
| `lib/guest/reflective/env.sx` | Phase 2 | Direct — canonical wire shape, no cfg needed. Third consumer. |
| `lib/guest/reflective/evaluator.sx` | Phase 7 (will trigger the extraction) | Scheme's `eval`/`interaction-environment`/`null-environment` mirror the proposed `refl-eval`/`refl-make-environment`/`refl-current-env` triple. Second consumer → extraction unblocked. |
| `lib/guest/reflective/hygiene.sx` | Phase 6 | Scheme's hygienic `syntax-rules` is the canonical implementation of scope sets / lifted symbols. Second consumer for the deferred Shutt-style hygiene work — Scheme's hygiene goes BEYOND Kernel's by-default-static-env-extension into proper scope-set lifting. Drives the deferred research-grade kit. |
| `lib/guest/reflective/quoting.sx` | Phase 10 | Scheme's backquote walker is structurally identical to Kernel's `knl-quasi-walk`, with depth tracking added. Second consumer → extraction unblocked. |
| `lib/guest/reflective/combiner.sx` | NEVER (no fexprs) | Not applicable. Stays Kernel-only until a fexpr-having consumer arrives. |
| `lib/guest/reflective/short-circuit.sx` | Possibly Phase 3 | Scheme's `and`/`or` are syntactic, not operative; could be second consumer but adapter would need to bridge "macro that short-circuits" vs "operative that short-circuits". Marginal. |
## Ground rules
- **Scope:** only `lib/scheme/**` and `plans/scheme-on-sx.md` and `lib/guest/reflective/**` (for extraction work). Don't edit `spec/`, `hosts/`, `shared/`, or other `lib/<lang>/` directories.
- **Consume:** `lib/guest/lex.sx` (character predicates), `lib/guest/reflective/env.sx` (scope chain), eventually `evaluator.sx`/`hygiene.sx`/`quoting.sx` once extracted with Scheme as second consumer.
- **Commits:** one feature per commit. Short factual messages.
- **Tests:** every phase ends with a test file. Conformance scoreboard at the end.
- **Branch:** `loops/scheme`. Worktree pattern (already set up at `/root/rose-ash-loops/scheme`).
- **Substrate gaps:** filed to `sx-improvements.md`, not fixed in this loop.
## References
- R7RS-small: https://small.r7rs.org/attachment/r7rs.pdf
- Chibi Scheme — a small, readable R7RS implementation.
- Dybvig, "Three Implementation Models for Scheme" — for the hygiene story.
- Existing kernel-on-sx code in `lib/kernel/` — much of the parser, evaluator structure, and env handling carries over near-verbatim because Kernel and Scheme share lexical scope.
## Progress log
- 2026-05-14 — **Phases 1, 2, 3, 3.5, 4, 5abc, 6ab, 7, 8, 9, 10, 11 landed in one loop session.** 296 Scheme tests across 9 suites; ~1830 LoC of substrate. Test runner + scoreboard at `lib/scheme/test.sh` and `lib/scheme/scoreboard.md`. Three reflective kits unlocked: `env.sx` extracted directly as third consumer, `evaluator.sx` and `quoting.sx` second-consumer-ready for the kit-extraction commits (kit code is documented in `plans/kernel-on-sx.md`; Scheme consumer code is in place).
### Phase-by-phase outcomes
- Phase 1 (Parser, 62 tests): R7RS lexical syntax with reader macros, three comment flavours (`;`, `#;`, `#| |#`).
- Phase 2 (Eval + env third-consumer, 23 tests): `scheme-make-env` etc. are thin aliases for `refl-env-*` from `lib/guest/reflective/env.sx`. No adapter cfg needed — Scheme uses the canonical wire shape directly.
- Phase 3 (if/define/set!/begin/lambda + closures, 24 tests): factorial 10 → 3628800, counter via closed-over `set!`, curried lambda.
- Phase 3.5 (let/let*/cond/when/unless/and/or, 21 tests).
- Phase 4 (standard env + set! bugfix, 82 tests): variadic arithmetic, type predicates, list/string/char/vector ops, higher-order combinators. **Found and fixed an SX cond multi-expression branch bug** affecting set!. Bugfix unblocked 4 silently-failing tests in Phase 3.
- Phase 5a (call/cc, 8 tests): single-shot escape continuations.
- Phase 5b (raise/guard/with-exception-handler/error, 12 tests): catch-once-then-rehandle-outside pattern avoids handler-self-raise loops.
- Phase 5c (dynamic-wind, 5 tests): basic before-thunk-after with raise propagation. call/cc-escape tracking deferred.
- Phase 6a (define-syntax + syntax-rules, 12 tests): pattern matching with literals + pattern variables + list structure; template substitution.
- Phase 6b (syntax-rules ellipsis, 8 tests): tail-rest single-variable form. `(my-and 1 2 3)` etc. work.
- Phase 7 (eval / interaction-environment, 13 tests): **second consumer for evaluator.sx**. `interaction-environment` closes over the env being built, so user-side defines via `(eval ... ie)` persist across calls.
- Phase 8 (define-library + import, 7 tests): minimal module system. Private definitions stay in library env; only exports are visible after import.
- Phase 9 (define-record-type, 9 tests): tagged-dict records with optional mutators.
- Phase 10 (quasiquote runtime, 10 tests): **second consumer for quoting.sx**. Identical algorithm to Kernel's `knl-quasi-walk` — universal across reflective Lisps.
- Phase 11 (test.sh + scoreboard): single-process aggregating runner, scoreboard markdown.
### Deferred phases
- **Phase 6c — full hygiene**. Dybvig-style scope-sets / lifted-symbol algorithm. Would be the second consumer for the deferred `lib/guest/reflective/hygiene.sx`. Current macros work for common patterns but don't prevent introduced-binding capture. Research-grade work; warrants its own loop iteration.
- **Nested quasiquote depth tracking**.
- **R7RS module rich features** (`cond-expand`, `include`, import sets like `only`/`except`/`prefix`/`rename`).
- **Dotted-pair `(a b . rest)` parser syntax** + lambda rest-args.
- **Full call/cc + dynamic-wind interaction**: dynamic-extent re-entry/re-exit tracking.
### Chisel ledger update
This Scheme port satisfies the two-consumer rule for **three** reflective kits documented in the kernel-on-sx loop:
| Kit | Status |
|-----|--------|
| `env.sx` | Extracted — Scheme is the third consumer (after Kernel + Tcl/Smalltalk), uses the canonical shape directly with no cfg |
| `evaluator.sx` | Second consumer ready — Scheme `eval`/`interaction-environment`/`null-environment`/`scheme-report-environment` mirror the proposed `refl-eval`/`refl-current-env`/`refl-make-environment` triple |
| `quoting.sx` | Second consumer ready — Scheme `scm-quasi-walk` is structurally identical to Kernel's `knl-quasi-walk`; the only difference is the unquote keyword names (cfg parameterisation) |
| `hygiene.sx` | Still awaiting (needs Phase 6c) |
| `combiner.sx` | N/A — Scheme has no fexprs |
| `short-circuit.sx` | N/A — Scheme `and`/`or` are syntactic, not operative |
The kit-extraction commits themselves are follow-on work; this Scheme port is the consumer-side foundation.