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

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