diff --git a/lib/common-lisp/eval.sx b/lib/common-lisp/eval.sx index 1ff737f4..7ca9f8af 100644 --- a/lib/common-lisp/eval.sx +++ b/lib/common-lisp/eval.sx @@ -43,6 +43,18 @@ (define cl-go-tag? (fn (v) (and (dict? v) (= (get v "cl-type") "go-tag")))) +(define cl-mv? + (fn (v) (and (dict? v) (= (get v "cl-type") "mv")))) + +(define cl-mv-primary + (fn (v) + (if (cl-mv? v) + (if (> (len (get v "vals")) 0) (nth (get v "vals") 0) nil) + v))) + +(define cl-mv-vals + (fn (v) (if (cl-mv? v) (get v "vals") (list v)))) + (define cl-eval-body (fn (forms env) (cond @@ -252,7 +264,7 @@ (reduce (fn (acc x) (concat (list x) acc)) (list) (nth args 0))) "IDENTITY" (fn (args) (nth args 0)) - "VALUES" (fn (args) (if (> (len args) 0) (nth args 0) nil)) + "VALUES" (fn (args) (cond ((= (len args) 0) nil) ((= (len args) 1) (nth args 0)) (:else {:cl-type "mv" :vals args}))) "PRINT" (fn (args) (nth args 0)) "PRIN1" (fn (args) (nth args 0)) "PRINC" (fn (args) (nth args 0)) @@ -309,6 +321,39 @@ (:else (run (+ i 1)))))))))) (run 0)))) +;; ── MULTIPLE VALUES ────────────────────────────────────────────── + +(define cl-eval-multiple-value-bind + (fn (args env) + (let ((vars (nth args 0)) + (form (nth args 1)) + (body (rest (rest args)))) + (let ((vals (cl-mv-vals (cl-eval form env)))) + (define bind-vars + (fn (names i e) + (if (= (len names) 0) + e + (bind-vars (rest names) (+ i 1) + (cl-env-bind-var e (nth names 0) + (if (< i (len vals)) (nth vals i) nil)))))) + (cl-eval-body body (bind-vars vars 0 env)))))) + +(define cl-eval-multiple-value-call + (fn (args env) + (let ((fn-obj (cl-eval (nth args 0) env)) + (forms (rest args))) + (let ((all-vals (reduce + (fn (acc f) + (concat acc (cl-mv-vals (cl-eval f env)))) + (list) forms))) + (cl-apply fn-obj all-vals))))) + +(define cl-eval-multiple-value-prog1 + (fn (args env) + (let ((first-result (cl-eval (nth args 0) env))) + (for-each (fn (f) (cl-eval f env)) (rest args)) + first-result))) + ;; ── UNWIND-PROTECT ─────────────────────────────────────────────── (define cl-eval-unwind-protect @@ -341,7 +386,7 @@ (define cl-eval-if (fn (args env) - (let ((cond-val (cl-eval (nth args 0) env)) + (let ((cond-val (cl-mv-primary (cl-eval (nth args 0) env))) (then-form (nth args 1)) (else-form (if (> (len args) 2) (nth args 2) nil))) (if cond-val @@ -352,7 +397,7 @@ (fn (args env) (if (= (len args) 0) true - (let ((val (cl-eval (nth args 0) env))) + (let ((val (cl-mv-primary (cl-eval (nth args 0) env)))) (if (not val) nil (if (= (len args) 1) @@ -363,7 +408,7 @@ (fn (args env) (if (= (len args) 0) nil - (let ((val (cl-eval (nth args 0) env))) + (let ((val (cl-mv-primary (cl-eval (nth args 0) env)))) (if val val (cl-eval-or (rest args) env)))))) @@ -373,7 +418,7 @@ (if (= (len clauses) 0) nil (let ((clause (nth clauses 0))) - (let ((test-val (cl-eval (nth clause 0) env))) + (let ((test-val (cl-mv-primary (cl-eval (nth clause 0) env)))) (if test-val (if (= (len clause) 1) test-val @@ -523,7 +568,7 @@ ;; Function call: evaluate name → look up fns, builtins; evaluate args (define cl-call-fn (fn (name args env) - (let ((evaled (map (fn (a) (cl-eval a env)) args))) + (let ((evaled (map (fn (a) (cl-mv-primary (cl-eval a env))) args))) (cond ;; FUNCALL: (funcall fn arg...) ((= name "FUNCALL") @@ -615,6 +660,13 @@ ((= head "TAGBODY") (cl-eval-tagbody args env)) ((= head "GO") {:cl-type "go-tag" :tag (nth args 0)}) + ((= head "MULTIPLE-VALUE-BIND") (cl-eval-multiple-value-bind args env)) + ((= head "MULTIPLE-VALUE-CALL") (cl-eval-multiple-value-call args env)) + ((= head "MULTIPLE-VALUE-PROG1") (cl-eval-multiple-value-prog1 args env)) + ((= head "NTH-VALUE") + (let ((n (cl-mv-primary (cl-eval (nth args 0) env))) + (vals (cl-mv-vals (cl-eval (nth args 1) env)))) + (if (< n (len vals)) (nth vals n) nil))) ((= head "UNWIND-PROTECT") (cl-eval-unwind-protect args env)) ((= head "BLOCK") (cl-eval-block args env)) ((= head "RETURN-FROM") (cl-eval-return-from args env)) diff --git a/lib/common-lisp/tests/eval.sx b/lib/common-lisp/tests/eval.sx index 1b58f877..0b8e54d3 100644 --- a/lib/common-lisp/tests/eval.sx +++ b/lib/common-lisp/tests/eval.sx @@ -388,3 +388,51 @@ (cl-test "unwind-protect: nested, inner cleanup first" (ev "(let ((n 0)) (unwind-protect (unwind-protect 1 (setq n (+ n 10))) (setq n (+ n 1))) n)") 11) + +;; ── VALUES / MULTIPLE-VALUE-BIND / NTH-VALUE ──────────────────── + +(cl-test "values: single returns plain" + (ev "(values 42)") + 42) +(cl-test "values: zero returns nil" + (ev "(values)") + nil) +(cl-test "values: multi — primary via funcall" + (ev "(car (list (values 1 2)))") + 1) +(cl-test "multiple-value-bind: basic" + (ev "(multiple-value-bind (a b) (values 1 2) (+ a b))") + 3) +(cl-test "multiple-value-bind: extra vars get nil" + (ev "(multiple-value-bind (a b c) (values 10 20) (list a b c))") + (list 10 20 nil)) +(cl-test "multiple-value-bind: extra values ignored" + (ev "(multiple-value-bind (a) (values 1 2 3) a)") + 1) +(cl-test "multiple-value-bind: single value source" + (ev "(multiple-value-bind (a b) 42 (list a b))") + (list 42 nil)) +(cl-test "nth-value: 0" + (ev "(nth-value 0 (values 10 20 30))") + 10) +(cl-test "nth-value: 1" + (ev "(nth-value 1 (values 10 20 30))") + 20) +(cl-test "nth-value: out of range" + (ev "(nth-value 5 (values 10 20))") + nil) +(cl-test "multiple-value-call: basic" + (ev "(multiple-value-call #'+ (values 1 2) (values 3 4))") + 10) +(cl-test "multiple-value-prog1: returns first" + (ev "(multiple-value-prog1 1 2 3)") + 1) +(cl-test "multiple-value-prog1: side effects run" + (ev "(let ((x 0)) (multiple-value-prog1 99 (setq x 7)) x)") + 7) +(cl-test "values: nil primary in if" + (ev "(if (values nil t) 'yes 'no)") + "NO") +(cl-test "values: truthy primary in if" + (ev "(if (values 42 nil) 'yes 'no)") + "YES") diff --git a/plans/common-lisp-on-sx.md b/plans/common-lisp-on-sx.md index 63c0dd76..8bcbdf04 100644 --- a/plans/common-lisp-on-sx.md +++ b/plans/common-lisp-on-sx.md @@ -60,7 +60,7 @@ Core mapping: - [x] `block` + `return-from` via captured continuation - [x] `tagbody` + `go` via per-tag continuations - [x] `unwind-protect` cleanup frame -- [ ] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value` +- [x] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value` - [x] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op) - [ ] Dynamic variables — `defvar`/`defparameter` produce specials; `let` rebinds via parameterize-style scope - [x] 127 tests in `lib/common-lisp/tests/eval.sx` @@ -128,6 +128,7 @@ _Newest first._ - 2026-05-05: Phase 3 interactive-debugger.sx — cl-debugger-hook global, cl-invoke-debugger, cl-error-with-debugger, make-policy-debugger; 7 tests (143 total). Tests wired into test.sh program suite runner. Phase 3 condition core complete. - 2026-05-05: Phase 3 classic programs — `tests/programs/restart-demo.sx` (7 tests: safe-divide with use-zero + retry restarts) and `tests/programs/parse-recover.sx` (6 tests: token parser with skip-token + use-zero restarts, handler-case abort). Key gotcha: use `=` not `equal?` for list comparison in sx_server. - 2026-05-05: Phase 3 conditions + restarts — `cl-condition-classes` hierarchy (15 types), `cl-condition?`/`cl-condition-of-type?`, `cl-make-condition`, `cl-define-condition`, `cl-signal`/`cl-error`/`cl-warn`/`cl-cerror`, `cl-handler-bind` (non-unwinding), `cl-handler-case` (call/cc escape), `cl-restart-case`/`cl-with-simple-restart`, `cl-find-restart`/`cl-invoke-restart`/`cl-compute-restarts`, `cl-with-condition-restarts`; 55 new tests in `tests/conditions.sx` (123 total runtime tests). Key gotcha: `cl-condition-classes` must be captured at define-time via `let` in `cl-condition-of-type?` — free-variable lookup at call-time fails through env_merge parent chain. +- 2026-05-05: multiple values — VALUES returns {:cl-type "mv"} wrapper for 2+ values; cl-mv-primary/cl-mv-vals helpers; MULTIPLE-VALUE-BIND binds vars to value list; MULTIPLE-VALUE-CALL/PROG1/NTH-VALUE; cl-mv-primary applied in IF/AND/OR/COND/cl-call-fn for single-value contexts; 15 new tests (174 eval, 346 total green). - 2026-05-05: unwind-protect — cl-eval-unwind-protect: eval protected form, run cleanup with for-each (discards results, preserves original sentinel), return original result; 8 new tests (159 eval, 331 total green). - 2026-05-05: tagbody + go — cl-go-tag? sentinel; cl-eval-tagbody runs body with tag-index map (keys str-normalised for integer tags); go-tag propagation in cl-eval-body alongside block-return; 11 new tests (151 eval, 323 total green). - 2026-05-05: block + return-from — sentinel propagation in cl-eval-body; cl-eval-block catches matching sentinels; BLOCK/RETURN-FROM/RETURN dispatch in cl-eval-list; 13 new tests (140 eval, 312 total green). Parser: CL strings → {:cl-type "string"} dicts.