spec: multiple values — values/call-with-values/let-values/define-values
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:
@@ -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!
|
||||
|
||||
172
spec/tests/test-values.sx
Normal file
172
spec/tests/test-values.sx
Normal file
@@ -0,0 +1,172 @@
|
||||
(defsuite
|
||||
"multiple-values"
|
||||
(deftest
|
||||
"values single returns value directly"
|
||||
(do
|
||||
(assert= 42 (values 42))
|
||||
(assert= "hi" (values "hi"))
|
||||
(assert= nil (values nil))))
|
||||
(deftest
|
||||
"values multiple returns marker dict"
|
||||
(do
|
||||
(let
|
||||
((v (values 1 2 3)))
|
||||
(assert (dict? v))
|
||||
(assert= true (get v :_values false))
|
||||
(assert-equal (list 1 2 3) (get v :_list)))))
|
||||
(deftest
|
||||
"call-with-values basic two values"
|
||||
(do
|
||||
(assert=
|
||||
3
|
||||
(call-with-values
|
||||
(fn () (values 1 2))
|
||||
(fn (a b) (+ a b))))))
|
||||
(deftest
|
||||
"call-with-values three values"
|
||||
(do
|
||||
(assert=
|
||||
6
|
||||
(call-with-values
|
||||
(fn () (values 1 2 3))
|
||||
(fn (a b c) (+ a b c))))))
|
||||
(deftest
|
||||
"call-with-values single value passthrough"
|
||||
(do
|
||||
(assert= 10 (call-with-values (fn () 10) (fn (x) x)))))
|
||||
(deftest
|
||||
"call-with-values passes non-values result as single arg"
|
||||
(do (assert= "hello" (call-with-values (fn () "hello") (fn (x) x)))))
|
||||
(deftest
|
||||
"call-with-values with string concat"
|
||||
(do
|
||||
(assert=
|
||||
"ab"
|
||||
(call-with-values (fn () (values "a" "b")) (fn (a b) (str a b))))))
|
||||
(deftest
|
||||
"let-values basic two bindings"
|
||||
(do
|
||||
(let-values
|
||||
(((a b) (values 10 20)))
|
||||
(assert= 10 a)
|
||||
(assert= 20 b))))
|
||||
(deftest
|
||||
"let-values computes with bindings"
|
||||
(do
|
||||
(let-values
|
||||
(((x y) (values 3 4)))
|
||||
(assert= 7 (+ x y)))))
|
||||
(deftest
|
||||
"let-values three values"
|
||||
(do
|
||||
(let-values
|
||||
(((a b c) (values 1 2 3)))
|
||||
(assert= 6 (+ a b c)))))
|
||||
(deftest
|
||||
"let-values single value binding"
|
||||
(do (let-values (((x) (values 42))) (assert= 42 x))))
|
||||
(deftest
|
||||
"let-values multiple binding clauses"
|
||||
(do
|
||||
(let-values
|
||||
(((a b) (values 1 2))
|
||||
((c d) (values 3 4)))
|
||||
(assert= 10 (+ a b c d)))))
|
||||
(deftest
|
||||
"let-values body is multiple expressions"
|
||||
(do
|
||||
(let-values
|
||||
(((a b) (values 5 6)))
|
||||
(define sum (+ a b))
|
||||
(assert= 11 sum))))
|
||||
(deftest
|
||||
"let-values with no bindings evals body"
|
||||
(do (let-values () (assert= 99 99))))
|
||||
(deftest
|
||||
"define-values binds multiple names"
|
||||
(do
|
||||
(define-values (x y) (values 7 8))
|
||||
(assert= 7 x)
|
||||
(assert= 8 y)))
|
||||
(deftest
|
||||
"define-values three names"
|
||||
(do
|
||||
(define-values (a b c) (values 10 20 30))
|
||||
(assert= 10 a)
|
||||
(assert= 20 b)
|
||||
(assert= 30 c)))
|
||||
(deftest
|
||||
"define-values single name"
|
||||
(do (define-values (n) (values 42)) (assert= 42 n)))
|
||||
(deftest
|
||||
"define-values used in computation"
|
||||
(do
|
||||
(define-values (w h) (values 6 7))
|
||||
(assert= 42 (* w h))))
|
||||
(deftest
|
||||
"values in let binding"
|
||||
(do
|
||||
(let
|
||||
((v (values 100 200)))
|
||||
(assert= true (get v :_values false))
|
||||
(assert= 100 (first (get v :_list))))))
|
||||
(deftest
|
||||
"call-with-values with swap"
|
||||
(do
|
||||
(define (swap a b) (values b a))
|
||||
(assert=
|
||||
5
|
||||
(call-with-values
|
||||
(fn () (swap 3 5))
|
||||
(fn (first-val second-val) first-val)))))
|
||||
(deftest
|
||||
"let-values from function returning values"
|
||||
(do
|
||||
(define (min-max a b) (values (min a b) (max a b)))
|
||||
(let-values
|
||||
(((lo hi) (min-max 7 3)))
|
||||
(assert= 3 lo)
|
||||
(assert= 7 hi))))
|
||||
(deftest
|
||||
"nested let-values"
|
||||
(do
|
||||
(let-values
|
||||
(((a b) (values 1 2)))
|
||||
(let-values
|
||||
(((c d) (values 3 4)))
|
||||
(assert= 10 (+ a b c d))))))
|
||||
(deftest
|
||||
"call-with-values chained"
|
||||
(do
|
||||
(define
|
||||
result
|
||||
(call-with-values
|
||||
(fn
|
||||
()
|
||||
(call-with-values
|
||||
(fn () (values 4 6))
|
||||
(fn (a b) (* a b))))
|
||||
(fn (x) x)))
|
||||
(assert= 24 result)))
|
||||
(deftest
|
||||
"values zero args produces dict"
|
||||
(do
|
||||
(let
|
||||
((v (values)))
|
||||
(assert (dict? v))
|
||||
(assert (get v :_values false))
|
||||
(assert-equal (list) (get v :_list)))))
|
||||
(deftest
|
||||
"let-values strings"
|
||||
(do
|
||||
(let-values
|
||||
(((first-name last-name) (values "Alice" "Smith")))
|
||||
(assert= "Alice Smith" (str first-name " " last-name)))))
|
||||
(deftest
|
||||
"define-values with list values"
|
||||
(do
|
||||
(define-values
|
||||
(head tail)
|
||||
(values 1 (list 2 3 4)))
|
||||
(assert= 1 head)
|
||||
(assert-equal (list 2 3 4) tail))))
|
||||
Reference in New Issue
Block a user