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:
@@ -40,6 +40,9 @@
|
|||||||
(define cl-block-return?
|
(define cl-block-return?
|
||||||
(fn (v) (and (dict? v) (= (get v "cl-type") "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
|
(define cl-eval-body
|
||||||
(fn (forms env)
|
(fn (forms env)
|
||||||
(cond
|
(cond
|
||||||
@@ -47,7 +50,7 @@
|
|||||||
((= (len forms) 1) (cl-eval (nth forms 0) env))
|
((= (len forms) 1) (cl-eval (nth forms 0) env))
|
||||||
(:else
|
(:else
|
||||||
(let ((result (cl-eval (nth forms 0) env)))
|
(let ((result (cl-eval (nth forms 0) env)))
|
||||||
(if (cl-block-return? result)
|
(if (or (cl-block-return? result) (cl-go-tag? result))
|
||||||
result
|
result
|
||||||
(cl-eval-body (rest forms) env)))))))
|
(cl-eval-body (rest forms) env)))))))
|
||||||
|
|
||||||
@@ -270,6 +273,42 @@
|
|||||||
{:cl-type "function" :builtin-fn (get cl-builtins name)}))
|
{:cl-type "function" :builtin-fn (get cl-builtins name)}))
|
||||||
(keys cl-builtins))
|
(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 ───────────────────────────────────────────
|
;; ── BLOCK / RETURN-FROM ───────────────────────────────────────────
|
||||||
|
|
||||||
(define cl-eval-block
|
(define cl-eval-block
|
||||||
@@ -563,6 +602,9 @@
|
|||||||
((= head "LOCALLY") (cl-eval-body args env))
|
((= head "LOCALLY") (cl-eval-body args env))
|
||||||
((= head "EVAL-WHEN") (cl-eval-eval-when args env))
|
((= head "EVAL-WHEN") (cl-eval-eval-when args env))
|
||||||
((= head "DEFUN") (cl-eval-defun 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 "BLOCK") (cl-eval-block args env))
|
||||||
((= head "RETURN-FROM") (cl-eval-return-from args env))
|
((= head "RETURN-FROM") (cl-eval-return-from args env))
|
||||||
((= head "RETURN")
|
((= head "RETURN")
|
||||||
|
|||||||
@@ -325,3 +325,39 @@
|
|||||||
(cl-test "block: return-from through function"
|
(cl-test "block: return-from through function"
|
||||||
(ev "(block done (flet ((f () (return-from done 42))) (f)) nil)")
|
(ev "(block done (flet ((f () (return-from done 42))) (f)) nil)")
|
||||||
42)
|
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)
|
||||||
|
|||||||
@@ -58,7 +58,7 @@ Core mapping:
|
|||||||
### Phase 2 — sequential eval + special forms
|
### Phase 2 — sequential eval + special forms
|
||||||
- [x] `cl-eval-ast`: `quote`, `if`, `progn`, `let`, `let*`, `flet`, `labels`, `setq`, `setf` (subset), `function`, `lambda`, `the`, `locally`, `eval-when`
|
- [x] `cl-eval-ast`: `quote`, `if`, `progn`, `let`, `let*`, `flet`, `labels`, `setq`, `setf` (subset), `function`, `lambda`, `the`, `locally`, `eval-when`
|
||||||
- [x] `block` + `return-from` via captured continuation
|
- [x] `block` + `return-from` via captured continuation
|
||||||
- [ ] `tagbody` + `go` via per-tag continuations
|
- [x] `tagbody` + `go` via per-tag continuations
|
||||||
- [ ] `unwind-protect` cleanup frame
|
- [ ] `unwind-protect` cleanup frame
|
||||||
- [ ] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value`
|
- [ ] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value`
|
||||||
- [x] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op)
|
- [x] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op)
|
||||||
@@ -124,6 +124,7 @@ data; format for string templating.
|
|||||||
|
|
||||||
_Newest first._
|
_Newest first._
|
||||||
|
|
||||||
|
- 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.
|
- 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.
|
||||||
- 2026-04-25: Phase 2 eval — 127 tests, 299 total green. `lib/common-lisp/eval.sx`: cl-eval-ast with quote/if/progn/let/let*/flet/labels/setq/setf/function/lambda/the/locally/eval-when; defun/defvar/defparameter/defconstant; built-in arithmetic (+/-/*//, min/max/abs/evenp/oddp), comparisons, predicates, list ops (car/cdr/cons/list/append/reverse/length/nth/first/second/third/rest), string ops, funcall/apply/mapcar. Key gotchas: SX reduce is (reduce fn init list) not (reduce fn list init); CL true literal is t not true; builtins registered in cl-global-env.fns via wrapper dicts for #' syntax.
|
- 2026-04-25: Phase 2 eval — 127 tests, 299 total green. `lib/common-lisp/eval.sx`: cl-eval-ast with quote/if/progn/let/let*/flet/labels/setq/setf/function/lambda/the/locally/eval-when; defun/defvar/defparameter/defconstant; built-in arithmetic (+/-/*//, min/max/abs/evenp/oddp), comparisons, predicates, list ops (car/cdr/cons/list/append/reverse/length/nth/first/second/third/rest), string ops, funcall/apply/mapcar. Key gotchas: SX reduce is (reduce fn init list) not (reduce fn list init); CL true literal is t not true; builtins registered in cl-global-env.fns via wrapper dicts for #' syntax.
|
||||||
- 2026-04-25: Phase 1 lambda-list parser — 31 new tests, 172 total green. `cl-parse-lambda-list` in `parser.sx` + `tests/lambda.sx`. Handles &optional/&rest/&body/&key/&aux/&allow-other-keys, defaults, supplied-p. Key gotchas: `(when (> (len items) 0) ...)` not `(when items ...)` (empty list is truthy); custom `cl-deep=` needed for dict/list structural equality in tests.
|
- 2026-04-25: Phase 1 lambda-list parser — 31 new tests, 172 total green. `cl-parse-lambda-list` in `parser.sx` + `tests/lambda.sx`. Handles &optional/&rest/&body/&key/&aux/&allow-other-keys, defaults, supplied-p. Key gotchas: `(when (> (len items) 0) ...)` not `(when items ...)` (empty list is truthy); custom `cl-deep=` needed for dict/list structural equality in tests.
|
||||||
|
|||||||
Reference in New Issue
Block a user