diff --git a/lib/common-lisp/eval.sx b/lib/common-lisp/eval.sx index 3259b483..1ff737f4 100644 --- a/lib/common-lisp/eval.sx +++ b/lib/common-lisp/eval.sx @@ -309,6 +309,16 @@ (:else (run (+ i 1)))))))))) (run 0)))) +;; ── UNWIND-PROTECT ─────────────────────────────────────────────── + +(define cl-eval-unwind-protect + (fn (args env) + (let ((protected (nth args 0)) + (cleanup (rest args))) + (let ((result (cl-eval protected env))) + (for-each (fn (f) (cl-eval f env)) cleanup) + result)))) + ;; ── BLOCK / RETURN-FROM ─────────────────────────────────────────── (define cl-eval-block @@ -605,6 +615,7 @@ ((= head "TAGBODY") (cl-eval-tagbody args env)) ((= head "GO") {:cl-type "go-tag" :tag (nth args 0)}) + ((= 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)) ((= head "RETURN") diff --git a/lib/common-lisp/tests/eval.sx b/lib/common-lisp/tests/eval.sx index 5ad33170..cfcbda60 100644 --- a/lib/common-lisp/tests/eval.sx +++ b/lib/common-lisp/tests/eval.sx @@ -361,3 +361,30 @@ (cl-test "tagbody: block-return propagates out" (ev "(block done (tagbody (return-from done 42)) nil)") 42) + +;; ── UNWIND-PROTECT ─────────────────────────────────────────────── + +(cl-test "unwind-protect: normal returns protected" + (ev "(unwind-protect 42 nil)") + 42) +(cl-test "unwind-protect: cleanup runs" + (ev "(let ((x 0)) (unwind-protect 1 (setq x 99)) x)") + 99) +(cl-test "unwind-protect: cleanup result ignored" + (ev "(unwind-protect 42 777)") + 42) +(cl-test "unwind-protect: multiple cleanup forms" + (ev "(let ((x 0)) (unwind-protect 1 (setq x (+ x 1)) (setq x (+ x 1))) x)") + 2) +(cl-test "unwind-protect: cleanup on return-from" + (ev "(let ((x 0)) (block done (unwind-protect (return-from done 7) (setq x 99))) x)") + 99) +(cl-test "unwind-protect: return-from still propagates" + (ev "(block done (unwind-protect (return-from done 42) nil))") + 42) +(cl-test "unwind-protect: cleanup on go" + (ev "(let ((x 0)) (tagbody (unwind-protect (go done) (setq x 1)) done) x)") + 1) +(cl-test "unwind-protect: nested, inner cleanup first" + (ev "(let ((log (list))) (unwind-protect (unwind-protect 1 (append! log 2)) (append! log 3)) log)") + (list 2 3))