cl: tagbody + go — 11 new tests (151 eval, 323 total green)

Sentinel-based tagbody: cl-build-tag-map indexes tags by str-normalised key
(handles integer tags); cl-eval-tagbody loops with go-jump restart;
go-tag propagates through cl-eval-body alongside block-return.
This commit is contained in:
2026-05-05 11:07:43 +00:00
parent ce7243a1fb
commit a12a6a11cb
3 changed files with 81 additions and 2 deletions

View File

@@ -40,6 +40,9 @@
(define cl-block-return?
(fn (v) (and (dict? v) (= (get v "cl-type") "block-return"))))
(define cl-go-tag?
(fn (v) (and (dict? v) (= (get v "cl-type") "go-tag"))))
(define cl-eval-body
(fn (forms env)
(cond
@@ -47,7 +50,7 @@
((= (len forms) 1) (cl-eval (nth forms 0) env))
(:else
(let ((result (cl-eval (nth forms 0) env)))
(if (cl-block-return? result)
(if (or (cl-block-return? result) (cl-go-tag? result))
result
(cl-eval-body (rest forms) env)))))))
@@ -270,6 +273,42 @@
{:cl-type "function" :builtin-fn (get cl-builtins name)}))
(keys cl-builtins))
;; ── TAGBODY / GO ─────────────────────────────────────────────────
(define cl-tagbody-tag?
(fn (form) (or (string? form) (number? form))))
(define cl-build-tag-map
(fn (forms i acc)
(if (>= i (len forms))
acc
(if (cl-tagbody-tag? (nth forms i))
(cl-build-tag-map forms (+ i 1)
(assoc acc (str (nth forms i)) i))
(cl-build-tag-map forms (+ i 1) acc)))))
(define cl-eval-tagbody
(fn (args env)
(let ((tag-map (cl-build-tag-map args 0 {})))
(define run
(fn (i)
(if (>= i (len args))
nil
(let ((form (nth args i)))
(if (cl-tagbody-tag? form)
(run (+ i 1))
(let ((result (cl-eval form env)))
(cond
((cl-go-tag? result)
(let ((target (get result "tag")))
(let ((tkey (str target)))
(if (has-key? tag-map tkey)
(run (get tag-map tkey))
{:cl-type "error" :message (str "No tag: " target)}))))
((cl-block-return? result) result)
(:else (run (+ i 1))))))))))
(run 0))))
;; ── BLOCK / RETURN-FROM ───────────────────────────────────────────
(define cl-eval-block
@@ -563,6 +602,9 @@
((= head "LOCALLY") (cl-eval-body args env))
((= head "EVAL-WHEN") (cl-eval-eval-when args env))
((= head "DEFUN") (cl-eval-defun args env))
((= head "TAGBODY") (cl-eval-tagbody args env))
((= head "GO")
{:cl-type "go-tag" :tag (nth args 0)})
((= head "BLOCK") (cl-eval-block args env))
((= head "RETURN-FROM") (cl-eval-return-from args env))
((= head "RETURN")

View File

@@ -325,3 +325,39 @@
(cl-test "block: return-from through function"
(ev "(block done (flet ((f () (return-from done 42))) (f)) nil)")
42)
;; ── TAGBODY / GO ─────────────────────────────────────────────────
(cl-test "tagbody: empty returns nil"
(ev "(tagbody)")
nil)
(cl-test "tagbody: forms only, returns nil"
(ev "(let ((x 0)) (tagbody (setq x 1) (setq x 2)) x)")
2)
(cl-test "tagbody: tag only, returns nil"
(ev "(tagbody done)")
nil)
(cl-test "tagbody: go skips forms"
(ev "(let ((x 0)) (tagbody (go done) (setq x 99) done) x)")
0)
(cl-test "tagbody: go to later tag"
(ev "(let ((x 0)) (tagbody start (setq x (+ x 1)) (go done) (setq x 99) done) x)")
1)
(cl-test "tagbody: loop with counter"
(ev "(let ((n 0)) (tagbody loop (when (>= n 3) (go done)) (setq n (+ n 1)) (go loop) done) n)")
3)
(cl-test "tagbody: go inside when"
(ev "(let ((x 0)) (tagbody (setq x 1) (when t (go done)) (setq x 99) done) x)")
1)
(cl-test "tagbody: go inside progn"
(ev "(let ((x 0)) (tagbody (progn (setq x 1) (go done)) (setq x 99) done) x)")
1)
(cl-test "tagbody: go inside let"
(ev "(let ((acc 0)) (tagbody (let ((y 5)) (when (> y 3) (go done))) (setq acc 99) done) acc)")
0)
(cl-test "tagbody: integer tags"
(ev "(let ((x 0)) (tagbody (go 2) 1 (setq x 1) (go 3) 2 (setq x 2) (go 3) 3) x)")
2)
(cl-test "tagbody: block-return propagates out"
(ev "(block done (tagbody (return-from done 42)) nil)")
42)