Compare commits
17 Commits
lib/guest/
...
loops/sche
| Author | SHA1 | Date | |
|---|---|---|---|
| 26112f1003 | |||
| 680cdf62aa | |||
| 7e795f95fc | |||
| f927fb6515 | |||
| e200935698 | |||
| 342e1a2ccf | |||
| 9a7ca54902 | |||
| eb14a7576b | |||
| a90f56e3f3 | |||
| 55c376f559 | |||
| e3e5d3e888 | |||
| cf933f0ece | |||
| 0fccd1b353 | |||
| 23a53a2ccb | |||
| e222e8b0aa | |||
| c919d9a0d7 | |||
| a75b4cbc57 |
1037
lib/scheme/eval.sx
Normal file
1037
lib/scheme/eval.sx
Normal file
File diff suppressed because it is too large
Load Diff
BIN
lib/scheme/parser.sx
Normal file
BIN
lib/scheme/parser.sx
Normal file
Binary file not shown.
649
lib/scheme/runtime.sx
Normal file
649
lib/scheme/runtime.sx
Normal file
@@ -0,0 +1,649 @@
|
||||
;; 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)))
|
||||
83
lib/scheme/scoreboard.md
Normal file
83
lib/scheme/scoreboard.md
Normal file
@@ -0,0 +1,83 @@
|
||||
# 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.
|
||||
92
lib/scheme/test.sh
Executable file
92
lib/scheme/test.sh
Executable file
@@ -0,0 +1,92 @@
|
||||
#!/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
|
||||
168
lib/scheme/tests/control.sx
Normal file
168
lib/scheme/tests/control.sx
Normal file
@@ -0,0 +1,168 @@
|
||||
;; 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}))
|
||||
162
lib/scheme/tests/eval.sx
Normal file
162
lib/scheme/tests/eval.sx
Normal file
@@ -0,0 +1,162 @@
|
||||
;; 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}))
|
||||
155
lib/scheme/tests/macros.sx
Normal file
155
lib/scheme/tests/macros.sx
Normal file
@@ -0,0 +1,155 @@
|
||||
;; 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}))
|
||||
73
lib/scheme/tests/modules.sx
Normal file
73
lib/scheme/tests/modules.sx
Normal file
@@ -0,0 +1,73 @@
|
||||
;; 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}))
|
||||
177
lib/scheme/tests/parse.sx
Normal file
177
lib/scheme/tests/parse.sx
Normal file
@@ -0,0 +1,177 @@
|
||||
;; 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}))
|
||||
96
lib/scheme/tests/records.sx
Normal file
96
lib/scheme/tests/records.sx
Normal file
@@ -0,0 +1,96 @@
|
||||
;; 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}))
|
||||
130
lib/scheme/tests/reflection.sx
Normal file
130
lib/scheme/tests/reflection.sx
Normal file
@@ -0,0 +1,130 @@
|
||||
;; 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}))
|
||||
213
lib/scheme/tests/runtime.sx
Normal file
213
lib/scheme/tests/runtime.sx
Normal file
@@ -0,0 +1,213 @@
|
||||
;; 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}))
|
||||
288
lib/scheme/tests/syntax.sx
Normal file
288
lib/scheme/tests/syntax.sx
Normal file
@@ -0,0 +1,288 @@
|
||||
;; 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}))
|
||||
191
plans/scheme-on-sx.md
Normal file
191
plans/scheme-on-sx.md
Normal file
@@ -0,0 +1,191 @@
|
||||
# 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.
|
||||
Reference in New Issue
Block a user