commit 81cb9889f950173d7045531c6b284a20a240105d
parent 83b6da62fabbdda3a189d49eba611679a4781546
Author: Ryan Sepassi <rsepassi@gmail.com>
Date: Mon, 27 Apr 2026 14:37:38 -0700
scheme1: multiple-values protocol
Adds R7RS values, call-with-values, let-values, let*-values,
define-values via a new HDR.MV heap object (count<<8 | HDR.MV header
plus inline slots). list_to_mv / mv_to_list bridge the protocol so
existing bind_params can drive all formals shapes uniformly. Single-arg
(values x) returns x unchanged; 0 or 2+ args materialize an MV-pack.
Internal define-values is rejected at eval_body alongside define.
Diffstat:
13 files changed, 488 insertions(+), 3 deletions(-)
diff --git a/scheme1/scheme1.P1pp b/scheme1/scheme1.P1pp
@@ -13,7 +13,7 @@
%enum TAG { FIXNUM PAIR SYM HEAP IMM }
%enum IMM { FALSE TRUE NIL UNSPEC UNBOUND EOF }
-%enum HDR { BV CLOSURE PRIM TD REC CASELAMBDA }
+%enum HDR { BV CLOSURE PRIM TD REC CASELAMBDA MV }
# imm_val(idx) -> integer-expression for the tagged immediate at IMM index
# `idx`. Used both at %li sites (loaded into a register) and at $() emission
@@ -1201,6 +1201,9 @@
%dispatch_form(&sym_letstar, &::do_letstar)
%dispatch_form(&sym_letrec, &::do_letrec)
%dispatch_form(&sym_letrecstar, &::do_letrec)
+ %dispatch_form(&sym_let_values, &::do_let_values)
+ %dispatch_form(&sym_letstar_values, &::do_letstar_values)
+ %dispatch_form(&sym_define_values, &::do_define_values)
%dispatch_form(&sym_and, &::do_and)
%dispatch_form(&sym_or, &::do_or)
%dispatch_form(&sym_when, &::do_when)
@@ -1256,6 +1259,12 @@
%tail_to_handler(&eval_letstar)
::do_letrec
%tail_to_handler(&eval_letrec)
+ ::do_let_values
+ %tail_to_handler(&eval_let_values)
+ ::do_letstar_values
+ %tail_to_handler(&eval_letstar_values)
+ ::do_define_values
+ %tail_to_handler(&eval_define_values)
::do_and
%tail_to_handler(&eval_and)
::do_or
@@ -1563,6 +1572,9 @@
%intern_form(&name_letstar, 4, &sym_letstar)
%intern_form(&name_letrec, 6, &sym_letrec)
%intern_form(&name_letrecstar, 7, &sym_letrecstar)
+ %intern_form(&name_let_values, 10, &sym_let_values)
+ %intern_form(&name_letstar_values, 11, &sym_letstar_values)
+ %intern_form(&name_define_values, 13, &sym_define_values)
%intern_form(&name_and, 3, &sym_and)
%intern_form(&name_or, 2, &sym_or)
%intern_form(&name_when, 4, &sym_when)
@@ -1709,6 +1721,70 @@
%li(a0, %imm_val(%IMM.UNSPEC))
})
+# eval_define_values(rest=a0, env=a1) -> UNSPEC (a0).
+# Top-level only. rest = (formals value-expr). Evaluates value-expr,
+# normalizes its result via mv_to_list, then walks formals and the value
+# list in lockstep, binding each name in the global symbol table. A SYM
+# tail (or bare-SYM formals) binds the remaining values list as one name.
+# Internal define-values is rejected by eval_body alongside `define`.
+#
+# Locals:
+# rest
+# env
+# vals (remaining values list; advances each iteration)
+# formals (remaining formals; advances each iteration)
+%fn2(eval_define_values, {rest env vals formals}, {
+ %stl(a0, rest)
+ %stl(a1, env)
+
+ # value = eval(cadr(rest), env)
+ %cdr(t0, a0)
+ %car(a0, t0)
+ %ldl(a1, env)
+ %call(&eval)
+
+ # vals = mv_to_list(value)
+ %call(&mv_to_list)
+ %stl(a0, vals)
+
+ %ldl(t0, rest)
+ %car(t0, t0) ; formals (initial)
+ %stl(t0, formals)
+
+ ::loop
+ %ldl(t0, formals)
+ %tagof(t1, t0)
+ %li(t2, %TAG.PAIR)
+ %beq(t1, t2, &::pair_form)
+ %li(t2, %TAG.SYM)
+ %beq(t1, t2, &::rest_bind)
+ %b(&::done)
+
+ ::pair_form
+ %ldl(t0, formals)
+ %car(t0, t0) ; name
+ %ldl(a0, vals)
+ %car(a0, a0) ; value
+ %bind_global_from_t0()
+
+ %ldl(t0, formals)
+ %cdr(t0, t0)
+ %stl(t0, formals)
+ %ldl(t0, vals)
+ %cdr(t0, t0)
+ %stl(t0, vals)
+ %b(&::loop)
+
+ ::rest_bind
+ # Bare-SYM (or dotted-tail) formal: bind remaining values list as one.
+ %ldl(t0, formals)
+ %ldl(a0, vals)
+ %bind_global_from_t0()
+
+ ::done
+ %li(a0, %imm_val(%IMM.UNSPEC))
+})
+
# eval_setbang(rest=a0, env=a1) -> UNSPEC (a0).
# rest = (sym value-expr). Evaluates value-expr in env, then walks the
# env alist looking for a binding cell whose car is the target sym;
@@ -2038,6 +2114,116 @@
%tail(&eval_body)
})
+# eval_let_values(rest=a0, env=a1) -> value (a0).
+# rest = (((formals init) ...) body...). Each init is evaluated in the
+# OUTER env; mv_to_list normalizes its result so bind_params can drive
+# both list-style and dotted/rest formals identically. Then bodies run
+# in the env extended by all clauses.
+#
+# Locals:
+# rest
+# env (original)
+# walk (clauses, advances)
+# new_env (built up)
+%fn2(eval_let_values, {rest env walk new_env}, {
+ %stl(a0, rest)
+ %stl(a1, env)
+
+ %ldl(t0, rest)
+ %car(t0, t0) ; clauses
+ %stl(t0, walk)
+ %ldl(t0, env)
+ %stl(t0, new_env) ; new_env = env
+
+ ::loop
+ %ldl(t0, walk)
+ %if_nil(t1, t0, &::done)
+
+ %car(t1, t0) ; clause = (formals init)
+ %cdr(t2, t1)
+ %car(t2, t2) ; init
+
+ # val = eval(init, env_orig)
+ %mov(a0, t2)
+ %ldl(a1, env)
+ %call(&eval)
+
+ # vals = mv_to_list(val)
+ %call(&mv_to_list)
+
+ # new_env = bind_params(formals, vals, new_env)
+ %ldl(t0, walk)
+ %car(t1, t0)
+ %car(t1, t1) ; formals
+ %mov(a1, a0)
+ %mov(a0, t1)
+ %ldl(a2, new_env)
+ %call(&bind_params)
+ %stl(a0, new_env)
+
+ %advance_walk(16)
+ %b(&::loop)
+
+ ::done
+ %ldl(a0, rest)
+ %cdr(a0, a0) ; body
+ %ldl(a1, new_env)
+ %tail(&eval_body)
+})
+
+# eval_letstar_values(rest=a0, env=a1) -> value (a0).
+# Like let-values but each init is evaluated in new_env (the env extended
+# by all prior clauses' bindings), giving sequential / shadowing semantics.
+#
+# Locals:
+# rest
+# env
+# walk
+# new_env
+%fn2(eval_letstar_values, {rest env walk new_env}, {
+ %stl(a0, rest)
+ %stl(a1, env)
+
+ %ldl(t0, rest)
+ %car(t0, t0)
+ %stl(t0, walk)
+ %ldl(t0, env)
+ %stl(t0, new_env)
+
+ ::loop
+ %ldl(t0, walk)
+ %if_nil(t1, t0, &::done)
+
+ %car(t1, t0)
+ %cdr(t2, t1)
+ %car(t2, t2) ; init
+
+ # val = eval(init, new_env)
+ %mov(a0, t2)
+ %ldl(a1, new_env)
+ %call(&eval)
+
+ %call(&mv_to_list)
+
+ %ldl(t0, walk)
+ %car(t1, t0)
+ %car(t1, t1) ; formals
+ %mov(a1, a0)
+ %mov(a0, t1)
+ %ldl(a2, new_env)
+ %call(&bind_params)
+ %stl(a0, new_env)
+
+ %advance_walk(16)
+ %b(&::loop)
+
+ ::done
+ %ldl(a0, rest)
+ %cdr(a0, a0)
+ %ldl(a1, new_env)
+ %tail(&eval_body)
+})
+
# eval_and(rest=a0, env=a1) -> value (a0).
# (and) is #t. Otherwise eval forms left-to-right, short-circuiting to #f
# the moment one yields #f. The last form is tail-evaluated so a tail call
@@ -3154,8 +3340,9 @@
%stl(a0, body)
%stl(a1, env)
- # Reject internal `define`. Detect (define ...) at the head of any
- # form before dispatching it to eval.
+ # Reject internal `define` / `define-values`. Detect (define ...) or
+ # (define-values ...) at the head of any form before dispatching to
+ # eval; both are top-level-only.
%car(t0, a0) ; form
%tagof(t1, t0)
%li(t2, %TAG.PAIR)
@@ -3163,6 +3350,8 @@
%car(t1, t0) ; head sym
%ld_global(t2, &sym_define)
%beq(t1, t2, &::internal_define)
+ %ld_global(t2, &sym_define_values)
+ %beq(t1, t2, &::internal_define)
::not_define
# If cdr(body) is NIL, body's car is the last form.
@@ -3289,6 +3478,115 @@
%endscope
# =========================================================================
+# Multiple-values protocol
+# =========================================================================
+#
+# An MV-pack is a HEAP-tagged object with header (count << 8) | HDR.MV
+# followed by `count` slot words (raw +8, +16, ...). The R7RS protocol
+# below treats single values and MV-packs uniformly: a 1-value yield is
+# returned as the bare value, while 0 or 2+ values are materialized as
+# an MV-pack. mv_to_list normalizes either form to a list so let-values /
+# call-with-values can reuse the existing destructuring machinery.
+
+# list_to_mv(list=a0) -> tagged MV-pack (a0).
+# Walks `list` to count it, allocates (count+1)*8 bytes with header
+# (count<<8)|HDR.MV, then copies elements into consecutive slots in
+# order. An empty list yields a 0-pack.
+#
+# Locals:
+# list (preserved across list_length + alloc_hdr)
+# count
+# mv (tagged MV-pack)
+%fn2(list_to_mv, {list count mv pad}, {
+ %stl(a0, list)
+ %call(&list_length) ; clobbers a0; returns count
+ %stl(a0, count)
+
+ # alloc_hdr((count+1)*8, (count<<8)|HDR.MV)
+ %addi(a0, a0, 1)
+ %shli(a0, a0, 3)
+ %ldl(t0, count)
+ %shli(t0, t0, 8)
+ %ori(a1, t0, %HDR.MV)
+ %call(&alloc_hdr)
+ %stl(a0, mv)
+
+ # Walk list, store at consecutive slots. The first slot's raw byte
+ # offset from a tagged HEAP pointer is +5 (= raw+8 - 3).
+ %ldl(t0, list)
+ %addi(t1, a0, 5)
+
+ ::loop
+ %if_nil(t2, t0, &::done)
+ %car(t2, t0)
+ %st(t2, t1, 0)
+ %addi(t1, t1, 8)
+ %cdr(t0, t0)
+ %b(&::loop)
+
+ ::done
+ %ldl(a0, mv)
+})
+
+# mv_to_list(val=a0) -> list (a0).
+# If val is HEAP-tagged with HDR.MV, build a fresh list of its slots in
+# order. Any other value is wrapped as a single-element list, so callers
+# can uniformly reuse list-shaped destructuring.
+#
+# Locals:
+# ptr (raw cursor into MV slots, walked backward)
+# count (remaining slot count)
+%fn2(mv_to_list, {ptr count}, {
+ %tagof(t0, a0)
+ %li(t1, %TAG.HEAP)
+ %bne(t0, t1, &::single)
+ %hdr_type(t0, a0)
+ %li(t1, %HDR.MV)
+ %bne(t0, t1, &::single)
+
+ # MV-pack: count = (hdr >> 8); header sits at raw+0 = tagged-3.
+ %ld(t0, a0, -3)
+ %shri(t0, t0, 8)
+ %stl(t0, count)
+
+ # Walk slots back-to-front so each cons prepends, yielding original
+ # left-to-right order. Cursor = (tagged+5) + (count-1)*8.
+ %addi(t1, a0, 5)
+ %shli(t2, t0, 3)
+ %add(t1, t1, t2)
+ %addi(t1, t1, -8)
+ %stl(t1, ptr)
+
+ %li(a0, %imm_val(%IMM.NIL))
+
+ ::loop
+ %ldl(t0, count)
+ %beqz(t0, &::done)
+
+ %ldl(t1, ptr)
+ %ld(t2, t1, 0)
+ %mov(a1, a0)
+ %mov(a0, t2)
+ %call(&cons)
+
+ %ldl(t1, ptr)
+ %addi(t1, t1, -8)
+ %stl(t1, ptr)
+ %ldl(t0, count)
+ %addi(t0, t0, -1)
+ %stl(t0, count)
+ %b(&::loop)
+
+ ::done
+ %eret
+
+ ::single
+ # Non-MV: return (val . NIL).
+ %li(a1, %imm_val(%IMM.NIL))
+ %tail(&cons)
+})
+
+# =========================================================================
# Symbol intern -- linear scan, append on miss
# =========================================================================
#
@@ -5923,6 +6221,42 @@
%li(a0, %imm_val(%IMM.UNSPEC))
%ret
+# (values . xs) -- multiple-values producer. Single-arg case returns the
+# arg unchanged so (values x) is interchangeable with x in any 1-value
+# context; 0 or 2+ args materialize an MV-pack.
+:prim_values_entry
+%scope prim_values
+ %if_nil(t0, a0, &::pack)
+ %cdr(t0, a0)
+ %if_nil(t1, t0, &::single)
+ ::pack
+ %b(&list_to_mv)
+ ::single
+ %car(a0, a0)
+ %ret
+%endscope
+
+# (call-with-values producer consumer) -- apply producer to no args, then
+# normalize its result (via mv_to_list) and tail-apply the consumer to the
+# resulting argument list.
+#
+# Locals:
+# consumer (saved across apply(producer) and mv_to_list)
+%fn2(prim_call_with_values_entry, {consumer pad}, {
+ %args2(t0, t1, a0) ; t0 = producer, t1 = consumer
+ %stl(t1, consumer)
+
+ %mov(a0, t0)
+ %li(a1, %imm_val(%IMM.NIL))
+ %call(&apply)
+
+ %call(&mv_to_list)
+
+ %mov(a1, a0)
+ %ldl(a0, consumer)
+ %tail(&apply)
+})
+
# Surface names. Length is hard-coded at the call site; no NUL needed
# because intern takes (ptr, len). Aligned padding via "\0" bytes is
# fine -- M0 emits ASCII verbatim.
@@ -5938,6 +6272,9 @@
:name_letstar "let*" 00 00 00
:name_letrec "letrec" 00
:name_letrecstar "letrec*"
+:name_let_values "let-values" 00 00 00 00 00
+:name_letstar_values "let*-values" 00 00 00 00
+:name_define_values "define-values" 00 00
:name_and "and" 00 00 00 00
:name_or "or" 00 00 00 00 00
:name_when "when" 00 00 00
@@ -6014,6 +6351,9 @@
:name_eof_object "eof-object" 00 00 00 00 00
:name_eof_objectq "eof-object?" 00 00 00 00
+:name_values "values" 00
+:name_call_with_values "call-with-values" 00 00 00 00 00 00 00
+
:name_display "display"
:name_write "write" 00 00
:name_error "error" 00 00
@@ -6112,6 +6452,8 @@
&name_heap_usage %(0) $(10) &prim_heap_usage_entry %(0)
&name_heap_mark %(0) $(9) &prim_heap_mark_entry %(0)
&name_heap_rewind_bang %(0) $(12) &prim_heap_rewind_bang_entry %(0)
+&name_values %(0) $(6) &prim_values_entry %(0)
+&name_call_with_values %(0) $(16) &prim_call_with_values_entry %(0)
:prim_table_end
:msg_usage "scheme1: usage: scheme1 SOURCE.scm" '0a' 00
@@ -6209,6 +6551,9 @@
:sym_letstar $(0)
:sym_letrec $(0)
:sym_letrecstar $(0)
+:sym_let_values $(0)
+:sym_letstar_values $(0)
+:sym_define_values $(0)
:sym_and $(0)
:sym_or $(0)
:sym_when $(0)
diff --git a/tests/scheme1/109-values-cwv.expected-exit b/tests/scheme1/109-values-cwv.expected-exit
@@ -0,0 +1 @@
+0
diff --git a/tests/scheme1/109-values-cwv.scm b/tests/scheme1/109-values-cwv.scm
@@ -0,0 +1,23 @@
+; values + call-with-values: producer yields 2+ values, consumer
+; receives them as positional args.
+
+(if (= 6 (call-with-values (lambda () (values 1 2 3)) +)) 0 (sys-exit 1))
+
+(if (= 5 (call-with-values
+ (lambda () (values 2 3))
+ (lambda (a b) (+ a b))))
+ 0 (sys-exit 2))
+
+; Producer yielding a single value via (values x): receiver gets x.
+(if (= 7 (call-with-values
+ (lambda () (values 7))
+ (lambda (x) x)))
+ 0 (sys-exit 3))
+
+; Producer returning a bare (non-values) value also flows as a single arg.
+(if (= 42 (call-with-values
+ (lambda () 42)
+ (lambda (x) x)))
+ 0 (sys-exit 4))
+
+(sys-exit 0)
diff --git a/tests/scheme1/110-cwv-zero.expected-exit b/tests/scheme1/110-cwv-zero.expected-exit
@@ -0,0 +1 @@
+0
diff --git a/tests/scheme1/110-cwv-zero.scm b/tests/scheme1/110-cwv-zero.scm
@@ -0,0 +1,8 @@
+; Zero-value yield: (values) returns a 0-pack; consumer must accept ().
+
+(if (= 99 (call-with-values
+ (lambda () (values))
+ (lambda () 99)))
+ 0 (sys-exit 1))
+
+(sys-exit 0)
diff --git a/tests/scheme1/111-cwv-rest.expected-exit b/tests/scheme1/111-cwv-rest.expected-exit
@@ -0,0 +1 @@
+0
diff --git a/tests/scheme1/111-cwv-rest.scm b/tests/scheme1/111-cwv-rest.scm
@@ -0,0 +1,16 @@
+; Variadic consumer: rest formals collect all yielded values into a list.
+
+(if (equal? (list 1 2 3)
+ (call-with-values
+ (lambda () (values 1 2 3))
+ (lambda args args)))
+ 0 (sys-exit 1))
+
+; Single-value yield arrives as a 1-list.
+(if (equal? (list 7)
+ (call-with-values
+ (lambda () 7)
+ (lambda args args)))
+ 0 (sys-exit 2))
+
+(sys-exit 0)
diff --git a/tests/scheme1/112-let-values.expected-exit b/tests/scheme1/112-let-values.expected-exit
@@ -0,0 +1 @@
+0
diff --git a/tests/scheme1/112-let-values.scm b/tests/scheme1/112-let-values.scm
@@ -0,0 +1,36 @@
+; let-values: bind formals from each clause's value-expr.
+
+; Single clause, exact arity.
+(if (= 3 (let-values (((a b) (values 1 2))) (+ a b))) 0 (sys-exit 1))
+
+; Multiple clauses, accumulated bindings.
+(if (= 36 (let-values (((a b c) (values 1 2 3))
+ ((x y) (values 10 20)))
+ (+ a b c x y)))
+ 0 (sys-exit 2))
+
+; Single-name formals with a non-values value-expr.
+(if (= 7 (let-values (((a) 7)) a)) 0 (sys-exit 3))
+
+; Single-name formals with a (values x) wrapper.
+(if (= 9 (let-values (((a) (values 9))) a)) 0 (sys-exit 4))
+
+; Inits are evaluated in the OUTER env, not in each other.
+; Outer a=100; (+ a 1) sees outer a, so b=101.
+(if (= 102
+ (let ((a 100))
+ (let-values (((a b) (values 1 (+ a 1))))
+ (+ a b))))
+ 0 (sys-exit 5))
+
+; Variadic formal collects all yielded values into a list.
+(if (equal? (list 1 2 3)
+ (let-values ((args (values 1 2 3))) args))
+ 0 (sys-exit 6))
+
+; Dotted formal: head + rest.
+(if (equal? (list 1 (list 2 3))
+ (let-values (((h . t) (values 1 2 3))) (list h t)))
+ 0 (sys-exit 7))
+
+(sys-exit 0)
diff --git a/tests/scheme1/113-letstar-values.expected-exit b/tests/scheme1/113-letstar-values.expected-exit
@@ -0,0 +1 @@
+0
diff --git a/tests/scheme1/113-letstar-values.scm b/tests/scheme1/113-letstar-values.scm
@@ -0,0 +1,28 @@
+; let*-values: each clause's init sees bindings from prior clauses.
+
+; Basic sequential: clause 2 references clause 1's bindings.
+(if (= 6 (let*-values (((a b) (values 1 2))
+ ((c) (+ a b)))
+ (+ c a b)))
+ 0 (sys-exit 1))
+
+; Outer shadowing: outer a is shadowed by clause 1, then clause 2 sees the
+; shadowed (clause-1) a, not the outer one. a=3, b=(+ 3 5)=8, body=3+8=11.
+(if (= 11
+ (let ((a 100))
+ (let*-values (((a) 3)
+ ((b) (+ a 5)))
+ (+ a b))))
+ 0 (sys-exit 2))
+
+; Single clause behaves like let-values.
+(if (= 3 (let*-values (((a b) (values 1 2))) (+ a b))) 0 (sys-exit 3))
+
+; Variadic formal in middle clause.
+(if (= 6
+ (let*-values ((xs (values 1 2))
+ ((sum) (+ (car xs) (car (cdr xs)) 3)))
+ sum))
+ 0 (sys-exit 4))
+
+(sys-exit 0)
diff --git a/tests/scheme1/114-define-values.expected-exit b/tests/scheme1/114-define-values.expected-exit
@@ -0,0 +1 @@
+0
diff --git a/tests/scheme1/114-define-values.scm b/tests/scheme1/114-define-values.scm
@@ -0,0 +1,23 @@
+; define-values: bind multiple top-level names from a values producer.
+
+(define-values (a b c) (values 1 2 3))
+(if (= 6 (+ a b c)) 0 (sys-exit 1))
+
+; Single-name formals work with non-values value-expr.
+(define-values (x) 42)
+(if (= 42 x) 0 (sys-exit 2))
+
+; Variadic formal collects all yielded values.
+(define-values rest (values 10 20 30))
+(if (equal? (list 10 20 30) rest) 0 (sys-exit 3))
+
+; Dotted formal: head + tail.
+(define-values (h . t) (values 1 2 3))
+(if (= 1 h) 0 (sys-exit 4))
+(if (equal? (list 2 3) t) 0 (sys-exit 5))
+
+; Subsequent define-values reassigns globally.
+(define-values (a b c) (values 100 200 300))
+(if (= 600 (+ a b c)) 0 (sys-exit 6))
+
+(sys-exit 0)
