cl: multiple values — 15 new tests (174 eval, 346 total green)

VALUES wraps 2+ values in {:cl-type "mv"}; cl-mv-primary strips to primary in IF/AND/OR/COND/cl-call-fn single-value contexts; cl-mv-vals expands for MULTIPLE-VALUE-BIND, MULTIPLE-VALUE-CALL, NTH-VALUE.
2026-05-05 11:23:12 +00:00
parent 733b1ebefa
commit 4cd8773766
3 changed files with 108 additions and 7 deletions
--- 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))
--- 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")