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

spec: multiple values — values/call-with-values/let-values/define-values

Browse Source 
25 tests pass on both JS and OCaml hosts. Uses dict marker
{:_values true :_list [...]} for 0/2+ values; 1 value passes
through directly. step-sf-define extended to desugar shorthand
(define (name params) body) forms on both hosts.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-01 08:03:17 +00:00
parent 8328e96ff6
commit 43cc1d9003
5 changed files with 498 additions and 88 deletions
Download Patch File Download Diff File Expand all files Collapse all files

248
spec/evaluator.sx
View File

@@ -1384,6 +1384,79 @@
;; Creates a Macro with rules/literals stored in closure env.
;; Body is a marker symbol; expand-macro detects it and calls
;; the pattern matcher directly.
(define
call-with-values
(fn
(producer consumer)
(let
((result (apply producer (list))))
(if
(and (dict? result) (get result :_values false))
(apply consumer (get result :_list))
(apply consumer (list result))))))
(define
sf-let-values
(fn
(args env)
(let
((clauses (first args))
(body (rest args))
(local (env-extend env)))
(for-each
(fn
(clause)
(let
((names (first clause)) (val-expr (nth clause 1)))
(let
((result (trampoline (eval-expr val-expr local))))
(let
((vs (if (and (dict? result) (get result :_values false)) (get result :_list) (list result))))
(for-each-indexed
(fn
(idx name)
(env-bind! local (symbol-name name) (nth vs idx)))
names)))))
clauses)
(let
((last-val nil))
(for-each
(fn (e) (set! last-val (trampoline (eval-expr e local))))
body)
last-val))))
;; R7RS records (SRFI-9)
;;
;; (define-record-type <point>
;; (make-point x y)
;; point?
;; (x point-x)
;; (y point-y set-point-y!))
;;
;; Creates: constructor, predicate, accessors, optional mutators.
;; Opaque — only accessible through generated functions.
;; Generative — each call creates a unique type.
(define
sf-define-values
(fn
(args env)
(let
((names (first args)) (val-expr (nth args 1)))
(let
((result (trampoline (eval-expr val-expr env))))
(let
((vs (if (and (dict? result) (get result :_values false)) (get result :_list) (list result))))
(for-each-indexed
(fn (idx name) (env-bind! env (symbol-name name) (nth vs idx)))
names)
nil)))))
;; Delimited continuations
(register-special-form! "define-values" sf-define-values)
(register-special-form! "let-values" sf-let-values)
;; Signal dereferencing with reactive dependency tracking
(define
step-sf-letrec
(fn
@@ -1392,6 +1465,13 @@
((thk (sf-letrec args env)))
(make-cek-state (thunk-expr thk) (thunk-env thk) kont))))
;; ═══════════════════════════════════════════════════════════════
;; Part 8: Call Dispatch
;;
;; cek-call: invoke a function from native code (runs a nested
;; trampoline). step-eval-call: CEK-native call dispatch for
;; lambda, component, native fn, and continuations.
;; ═══════════════════════════════════════════════════════════════
(define
step-sf-dynamic-wind
(fn
@@ -1412,17 +1492,7 @@
(list)
(kont-push (make-wind-after-frame after winders-len env) kont)))))))
;; R7RS records (SRFI-9)
;;
;; (define-record-type <point>
;; (make-point x y)
;; point?
;; (x point-x)
;; (y point-y set-point-y!))
;;
;; Creates: constructor, predicate, accessors, optional mutators.
;; Opaque — only accessible through generated functions.
;; Generative — each call creates a unique type.
;; Reactive signal tracking — captures dependency continuation for re-render
(define
sf-scope
(fn
@@ -1450,7 +1520,6 @@
(scope-pop! name)
result))))
;; Delimited continuations
(define
sf-provide
(fn
@@ -1467,6 +1536,13 @@
(scope-pop! name)
result)))
;; ═══════════════════════════════════════════════════════════════
;; Part 9: Higher-Order Form Machinery
;;
;; Data-first HO forms: (map coll fn) and (map fn coll) both work.
;; ho-swap-args auto-detects argument order. HoSetupFrame stages
;; argument evaluation, then dispatches to the appropriate step-ho-*.
;; ═══════════════════════════════════════════════════════════════
(define
expand-macro
(fn
@@ -1502,7 +1578,6 @@
(slice raw-args (len (macro-params mac)))))
(trampoline (eval-expr (macro-body mac) local)))))))
;; Signal dereferencing with reactive dependency tracking
(define
cek-step-loop
(fn
@@ -1512,13 +1587,6 @@
state
(cek-step-loop (cek-step state)))))
;; ═══════════════════════════════════════════════════════════════
;; Part 8: Call Dispatch
;;
;; cek-call: invoke a function from native code (runs a nested
;; trampoline). step-eval-call: CEK-native call dispatch for
;; lambda, component, native fn, and continuations.
;; ═══════════════════════════════════════════════════════════════
(define
cek-run
(fn
@@ -1530,7 +1598,6 @@
(error "IO suspension in non-IO context")
(cek-value final)))))
;; Reactive signal tracking — captures dependency continuation for re-render
(define
cek-resume
(fn
@@ -1550,13 +1617,6 @@
(step-eval state)
(step-continue state))))
;; ═══════════════════════════════════════════════════════════════
;; Part 9: Higher-Order Form Machinery
;;
;; Data-first HO forms: (map coll fn) and (map fn coll) both work.
;; ho-swap-args auto-detects argument order. HoSetupFrame stages
;; argument evaluation, then dispatches to the appropriate step-ho-*.
;; ═══════════════════════════════════════════════════════════════
(define
step-eval
(fn
@@ -1683,7 +1743,10 @@
(list
(quote and)
(list (quote list?) (quote __guard-result))
(list (quote =) (list (quote len) (quote __guard-result)) 2)
(list
(quote =)
(list (quote len) (quote __guard-result))
2)
(list
(quote =)
(list (quote first) (quote __guard-result))
@@ -1726,6 +1789,14 @@
env
kont))))
;; ═══════════════════════════════════════════════════════════════
;; Part 10: Continue Phase — Frame Dispatch
;;
;; When phase="continue", pop the top frame and process the value.
;; Each frame type has its own handling: if frames check truthiness,
;; let frames bind the value, arg frames accumulate it, etc.
;; continue-with-call handles the final function/component dispatch.
;; ═══════════════════════════════════════════════════════════════
(define
step-eval-list
(fn
@@ -1784,7 +1855,12 @@
(inits (map (fn (b) (nth b 1)) bindings))
(steps
(map
(fn (b) (if (> (len b) 2) (nth b 2) (first b)))
(fn
(b)
(if
(> (len b) 2)
(nth b 2)
(first b)))
bindings))
(test (first test-clause))
(result (rest test-clause)))
@@ -1898,6 +1974,9 @@
:else (step-eval-call head args env kont)))))
(step-eval-call head args env kont))))))
;; Final call dispatch from arg frame — all args evaluated, invoke function.
;; Handles: lambda (bind params + TCO), component (keyword args + TCO),
;; native fn (direct call), continuation (resume), callcc continuation (escape).
(define
sf-define-type
(fn
@@ -1957,6 +2036,17 @@
ctor-specs)
nil))))
(define
values
(fn (&rest vs) (if (= (len vs) 1) (first vs) {:_values true :_list vs})))
;; ═══════════════════════════════════════════════════════════════
;; Part 11: Entry Points
;;
;; eval-expr-cek / trampoline-cek: CEK evaluation entry points.
;; eval-expr / trampoline: top-level bindings that override the
;; forward declarations from Part 5.
;; ═══════════════════════════════════════════════════════════════
(register-special-form! "define-type" sf-define-type)
(define
@@ -1993,14 +2083,6 @@
subs)
(for-each (fn (sub) (cek-call sub (list kont))) subs))))))
;; ═══════════════════════════════════════════════════════════════
;; Part 10: Continue Phase — Frame Dispatch
;;
;; When phase="continue", pop the top frame and process the value.
;; Each frame type has its own handling: if frames check truthiness,
;; let frames bind the value, arg frames accumulate it, etc.
;; continue-with-call handles the final function/component dispatch.
;; ═══════════════════════════════════════════════════════════════
(define
fire-provide-subscribers
(fn
@@ -2020,9 +2102,6 @@
subs)
(for-each (fn (sub) (cek-call sub (list nil))) subs))))))
;; Final call dispatch from arg frame — all args evaluated, invoke function.
;; Handles: lambda (bind params + TCO), component (keyword args + TCO),
;; native fn (direct call), continuation (resume), callcc continuation (escape).
(define
batch-begin!
(fn () (set! *provide-batch-depth* (+ *provide-batch-depth* 1))))
@@ -2039,13 +2118,6 @@
(set! *provide-batch-queue* (list))
(for-each (fn (sub) (cek-call sub (list nil))) queue)))))
;; ═══════════════════════════════════════════════════════════════
;; Part 11: Entry Points
;;
;; eval-expr-cek / trampoline-cek: CEK evaluation entry points.
;; eval-expr / trampoline: top-level bindings that override the
;; forward declarations from Part 5.
;; ═══════════════════════════════════════════════════════════════
(define
step-sf-bind
(fn
@@ -2736,7 +2808,12 @@
(= value (nth pattern 1))
(symbol? pattern)
(do (env-bind! env (symbol-name pattern) value) true)
(and (list? pattern) (not (empty? pattern)) (symbol? (first pattern)) (dict? value) (get value :_adt))
(and
(list? pattern)
(not (empty? pattern))
(symbol? (first pattern))
(dict? value)
(get value :_adt))
(let
((ctor-name (symbol-name (first pattern)))
(field-patterns (rest pattern))
@@ -2745,7 +2822,9 @@
(= (get value :_ctor) ctor-name)
(= (len field-patterns) (len fields))
(every?
(fn (pair) (match-pattern (first pair) (nth pair 1) env))
(fn
(pair)
(match-pattern (first pair) (nth pair 1) env))
(zip field-patterns fields))))
(and (dict? pattern) (dict? value))
(every?
@@ -2791,7 +2870,10 @@
((result (match-find-clause val clauses env)))
(if
(nil? result)
(make-cek-value (str "match: no clause matched " (inspect val)) env (kont-push (make-raise-eval-frame env false) kont))
(make-cek-value
(str "match: no clause matched " (inspect val))
env
(kont-push (make-raise-eval-frame env false) kont))
(make-cek-state (nth result 1) (first result) kont))))))
(define
@@ -2973,38 +3055,40 @@
(fn
(args env kont)
(let
((name-sym (first args))
(has-effects
(and
(>= (len args) 4)
(= (type-of (nth args 1)) "keyword")
(= (keyword-name (nth args 1)) "effects")))
(val-idx
(if
((resolved-args (if (= (type-of (first args)) "list") (let ((fn-name (first (first args))) (params (rest (first args))) (body-parts (rest args))) (list fn-name (concat (list (make-symbol "fn")) (list params) body-parts))) args)))
(let
((name-sym (first resolved-args))
(has-effects
(and
(>= (len args) 4)
(= (type-of (nth args 1)) "keyword")
(= (keyword-name (nth args 1)) "effects"))
3
1))
(effect-list
(if
(and
(>= (len args) 4)
(= (type-of (nth args 1)) "keyword")
(= (keyword-name (nth args 1)) "effects"))
(nth args 2)
nil)))
(make-cek-state
(nth args val-idx)
env
(kont-push
(make-define-frame
(symbol-name name-sym)
env
has-effects
effect-list)
kont)))))
(>= (len resolved-args) 4)
(= (type-of (nth resolved-args 1)) "keyword")
(= (keyword-name (nth resolved-args 1)) "effects")))
(val-idx
(if
(and
(>= (len resolved-args) 4)
(= (type-of (nth resolved-args 1)) "keyword")
(= (keyword-name (nth resolved-args 1)) "effects"))
3
1))
(effect-list
(if
(and
(>= (len resolved-args) 4)
(= (type-of (nth resolved-args 1)) "keyword")
(= (keyword-name (nth resolved-args 1)) "effects"))
(nth resolved-args 2)
nil)))
(make-cek-state
(nth resolved-args val-idx)
env
(kont-push
(make-define-frame
(symbol-name name-sym)
env
has-effects
effect-list)
kont))))))
(define
step-sf-set!