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

Add Scheme forms: named let, letrec, dynamic-wind, three-tier equality

Browse Source 
Spec (eval.sx, primitives.sx):
- Named let: (let loop ((i 0)) body) — self-recursive lambda with TCO
- letrec: mutually recursive local bindings with closure patching
- dynamic-wind: entry/exit guards with wind stack for future continuations
- eq?/eqv?/equal?: identity, atom-value, and deep structural equality

Implementation (evaluator.py, async_eval.py, primitives.py):
- Both sync and async evaluators implement all four forms
- 33 new tests covering all forms including TCO at 10k depth

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-06 01:11:31 +00:00
parent 9cde15c3ce
commit f34e55aa9b
7 changed files with 785 additions and 26 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
shared/sx/ref/bootstrap_js.py
View File

@@ -165,6 +165,12 @@ class JSEmitter:
"sf-and": "sfAnd",
"sf-or": "sfOr",
"sf-let": "sfLet",
"sf-named-let": "sfNamedLet",
"sf-letrec": "sfLetrec",
"sf-dynamic-wind": "sfDynamicWind",
"push-wind!": "pushWind",
"pop-wind!": "popWind",
"call-thunk": "callThunk",
"sf-lambda": "sfLambda",
"sf-define": "sfDefine",
"sf-defcomp": "sfDefcomp",

208
shared/sx/ref/eval.sx
View File

@@ -136,6 +136,7 @@
(= name "or") (sf-or args env)
(= name "let") (sf-let args env)
(= name "let*") (sf-let args env)
(= name "letrec") (sf-letrec args env)
(= name "lambda") (sf-lambda args env)
(= name "fn") (sf-lambda args env)
(= name "define") (sf-define args env)
@@ -150,6 +151,7 @@
(= name "quasiquote") (sf-quasiquote args env)
(= name "->") (sf-thread-first args env)
(= name "set!") (sf-set! args env)
(= name "dynamic-wind") (sf-dynamic-wind args env)
;; Higher-order forms
(= name "map") (ho-map args env)
@@ -381,36 +383,83 @@
(define sf-let
(fn (args env)
(let ((bindings (first args))
(body (rest args))
(local (env-extend env)))
;; Parse bindings — support both ((name val) ...) and (name val name val ...)
;; Detect named let: (let name ((x 0) ...) body)
;; If first arg is a symbol, delegate to sf-named-let.
(if (= (type-of (first args)) "symbol")
(sf-named-let args env)
(let ((bindings (first args))
(body (rest args))
(local (env-extend env)))
;; Parse bindings — support both ((name val) ...) and (name val name val ...)
(if (and (= (type-of (first bindings)) "list")
(= (len (first bindings)) 2))
;; Scheme-style
(for-each
(fn (binding)
(let ((vname (if (= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(first binding))))
(env-set! local vname (trampoline (eval-expr (nth binding 1) local)))))
bindings)
;; Clojure-style
(let ((i 0))
(reduce
(fn (acc pair-idx)
(let ((vname (if (= (type-of (nth bindings (* pair-idx 2))) "symbol")
(symbol-name (nth bindings (* pair-idx 2)))
(nth bindings (* pair-idx 2))))
(val-expr (nth bindings (inc (* pair-idx 2)))))
(env-set! local vname (trampoline (eval-expr val-expr local)))))
nil
(range 0 (/ (len bindings) 2)))))
;; Evaluate body — last expression in tail position
(for-each
(fn (e) (trampoline (eval-expr e local)))
(slice body 0 (dec (len body))))
(make-thunk (last body) local)))))
;; Named let: (let name ((x 0) (y 1)) body...)
;; Desugars to a self-recursive lambda called with initial values.
;; The loop name is bound in the body so recursive calls produce TCO thunks.
(define sf-named-let
(fn (args env)
(let ((loop-name (symbol-name (first args)))
(bindings (nth args 1))
(body (slice args 2))
(params (list))
(inits (list)))
;; Extract param names and init expressions
(if (and (= (type-of (first bindings)) "list")
(= (len (first bindings)) 2))
;; Scheme-style
;; Scheme-style: ((x 0) (y 1))
(for-each
(fn (binding)
(let ((vname (if (= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(first binding))))
(env-set! local vname (trampoline (eval-expr (nth binding 1) local)))))
(append! params (if (= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(first binding)))
(append! inits (nth binding 1)))
bindings)
;; Clojure-style
(let ((i 0))
(reduce
(fn (acc pair-idx)
(let ((vname (if (= (type-of (nth bindings (* pair-idx 2))) "symbol")
(symbol-name (nth bindings (* pair-idx 2)))
(nth bindings (* pair-idx 2))))
(val-expr (nth bindings (inc (* pair-idx 2)))))
(env-set! local vname (trampoline (eval-expr val-expr local)))))
nil
(range 0 (/ (len bindings) 2)))))
;; Evaluate body — last expression in tail position
(for-each
(fn (e) (trampoline (eval-expr e local)))
(slice body 0 (dec (len body))))
(make-thunk (last body) local))))
;; Clojure-style: (x 0 y 1)
(reduce
(fn (acc pair-idx)
(do
(append! params (if (= (type-of (nth bindings (* pair-idx 2))) "symbol")
(symbol-name (nth bindings (* pair-idx 2)))
(nth bindings (* pair-idx 2))))
(append! inits (nth bindings (inc (* pair-idx 2))))))
nil
(range 0 (/ (len bindings) 2))))
;; Build loop body (wrap in begin if multiple exprs)
(let ((loop-body (if (= (len body) 1) (first body)
(cons (make-symbol "begin") body)))
(loop-fn (make-lambda params loop-body env)))
;; Self-reference: loop can call itself by name
(set-lambda-name! loop-fn loop-name)
(env-set! (lambda-closure loop-fn) loop-name loop-fn)
;; Evaluate initial values in enclosing env, then call
(let ((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits)))
(call-lambda loop-fn init-vals env))))))
(define sf-lambda
@@ -602,6 +651,109 @@
value)))
;; --------------------------------------------------------------------------
;; 6c. letrec — mutually recursive local bindings
;; --------------------------------------------------------------------------
;;
;; (letrec ((even? (fn (n) (if (= n 0) true (odd? (- n 1)))))
;; (odd? (fn (n) (if (= n 0) false (even? (- n 1))))))
;; (even? 10))
;;
;; All bindings are first set to nil in the local env, then all values
;; are evaluated (so they can see each other's names), then lambda
;; closures are patched to include the final bindings.
;; --------------------------------------------------------------------------
(define sf-letrec
(fn (args env)
(let ((bindings (first args))
(body (rest args))
(local (env-extend env))
(names (list))
(val-exprs (list)))
;; First pass: bind all names to nil
(if (and (= (type-of (first bindings)) "list")
(= (len (first bindings)) 2))
;; Scheme-style
(for-each
(fn (binding)
(let ((vname (if (= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(first binding))))
(append! names vname)
(append! val-exprs (nth binding 1))
(env-set! local vname nil)))
bindings)
;; Clojure-style
(reduce
(fn (acc pair-idx)
(let ((vname (if (= (type-of (nth bindings (* pair-idx 2))) "symbol")
(symbol-name (nth bindings (* pair-idx 2)))
(nth bindings (* pair-idx 2))))
(val-expr (nth bindings (inc (* pair-idx 2)))))
(append! names vname)
(append! val-exprs val-expr)
(env-set! local vname nil)))
nil
(range 0 (/ (len bindings) 2))))
;; Second pass: evaluate values (they can see each other's names)
(let ((values (map (fn (e) (trampoline (eval-expr e local))) val-exprs)))
;; Bind final values
(for-each
(fn (pair) (env-set! local (first pair) (nth pair 1)))
(zip names values))
;; Patch lambda closures so they see the final bindings
(for-each
(fn (val)
(when (lambda? val)
(for-each
(fn (n) (env-set! (lambda-closure val) n (env-get local n)))
names)))
values))
;; Evaluate body
(for-each
(fn (e) (trampoline (eval-expr e local)))
(slice body 0 (dec (len body))))
(make-thunk (last body) local))))
;; --------------------------------------------------------------------------
;; 6d. dynamic-wind — entry/exit guards
;; --------------------------------------------------------------------------
;;
;; (dynamic-wind before-thunk body-thunk after-thunk)
;;
;; All three are zero-argument functions (thunks):
;; 1. Call before-thunk
;; 2. Call body-thunk, capture result
;; 3. Call after-thunk (always, even on error)
;; 4. Return body result
;;
;; The wind stack is maintained so that when continuations jump across
;; dynamic-wind boundaries, the correct before/after thunks fire.
;; Without active continuations, this is equivalent to try/finally.
;;
;; Platform requirements:
;; (push-wind! before after) — push wind record onto stack
;; (pop-wind!) — pop wind record from stack
;; (call-thunk f env) — call a zero-arg function
;; --------------------------------------------------------------------------
(define sf-dynamic-wind
(fn (args env)
(let ((before (trampoline (eval-expr (first args) env)))
(body (trampoline (eval-expr (nth args 1) env)))
(after (trampoline (eval-expr (nth args 2) env))))
;; Call entry thunk
(call-thunk before env)
;; Push wind record, run body, pop, call exit
(push-wind! before after)
(let ((result (call-thunk body env)))
(pop-wind!)
(call-thunk after env)
result))))
;; --------------------------------------------------------------------------
;; 6b. Macro expansion
;; --------------------------------------------------------------------------
@@ -765,6 +917,12 @@
;; (apply f args) → call f with args list
;; (zip lists...) → list of tuples
;;
;;
;; CSSX (style system):
;; (build-keyframes name steps env) → StyleValue (platform builds @keyframes)
;;
;; Dynamic wind (for dynamic-wind):
;; (push-wind! before after) → void (push wind record onto stack)
;; (pop-wind!) → void (pop wind record from stack)
;; (call-thunk f env) → value (call a zero-arg function)
;; --------------------------------------------------------------------------

23
shared/sx/ref/primitives.sx
View File

@@ -121,7 +121,7 @@
(define-primitive "="
:params (a b)
:returns "boolean"
:doc "Equality (value equality, not identity).")
:doc "Deep structural equality. Alias for equal?.")
(define-primitive "!="
:params (a b)
@@ -129,6 +129,27 @@
:doc "Inequality."
:body (not (= a b)))
(define-primitive "eq?"
:params (a b)
:returns "boolean"
:doc "Identity equality. True only if a and b are the exact same object.
For immutable atoms (numbers, strings, booleans, nil) this may or
may not match — use eqv? for reliable atom comparison.")
(define-primitive "eqv?"
:params (a b)
:returns "boolean"
:doc "Equivalent value for atoms, identity for compound objects.
Returns true for identical objects (eq?), and also for numbers,
strings, booleans, and nil with the same value. For lists, dicts,
lambdas, and components, only true if same identity.")
(define-primitive "equal?"
:params (a b)
:returns "boolean"
:doc "Deep structural equality. Recursively compares lists and dicts.
Same semantics as = but explicit Scheme name.")
(define-primitive "<"
:params (a b)
:returns "boolean"