From 187be74554e7fee84848dc66fa489e3cdde63fa5 Mon Sep 17 00:00:00 2001
From: Bike <aeshtaer@gmail.com>
Date: Sun, 1 Oct 2023 09:43:17 -0400
Subject: [PATCH 1/4] Get catch compilation/instruction working

karlosz put it in early on but it had never been much tested, as
Clasp does not use it yet.
---
 Cross/vm.lisp          |  85 ++++++++++++++++++++-----------
 compile.lisp           |  24 ++++-----
 cvm.asd                |   1 +
 machine.lisp           |   4 +-
 test/ansi/catch.lisp   | 113 +++++++++++++++++++++++++++++++++++++++++
 test/ansi/tagbody.lisp |   1 -
 vm.lisp                |  18 ++++---
 7 files changed, 194 insertions(+), 52 deletions(-)
 create mode 100644 test/ansi/catch.lisp

diff --git a/Cross/vm.lisp b/Cross/vm.lisp
index 47a2643..af01723 100644
--- a/Cross/vm.lisp
+++ b/Cross/vm.lisp
@@ -35,6 +35,16 @@
 (defstruct (sbind-dynenv (:include dynenv)
                          (:constructor %make-sbind-dynenv (symbol cell)))
   symbol cell)
+(defstruct (catch-dynenv (:include dynenv)
+                         (:constructor make-catch-dynenv
+                             (tag dest-tag dest)))
+  ;; the actual catch tag
+  (tag (error "missing arg"))
+  ;; the catch tag established by bytecode-vm, representing the
+  ;; frame to return to
+  (dest-tag (error "missing arg"))
+  ;; the new IP to jump to
+  (dest (error "missing arg")))
 
 ;;; For uniformity, we put a Clostrum-style cell into these structs.
 (defun make-sbind-dynenv (symbol value)
@@ -109,6 +119,15 @@
   (let ((cell (symbol-cell symbol global-cell)))
     (setf (car cell) new)))
 
+;;; Unwind to the VM frame represented by rtag at ip new-ip,
+;;; set the de stack to the given de stack, and execute cleanups
+;;; along the way.
+;;; ...except we use deep binding and don't implement UNWIND-PROTECT,
+;;; so there's nothing to clean up right now.
+(defun unwind-to (vm rtag new-ip new-de-stack)
+  (setf (vm-dynenv-stack vm) new-de-stack)
+  (throw rtag new-ip))
+
 (define-condition out-of-extent-unwind (control-error)
   ())
 
@@ -117,10 +136,26 @@
   ;; If it is, reset the DE stack, and throw.
   ;; Otherwise complain.
   (let ((old-de-stack (member entry-dynenv (vm-dynenv-stack vm))))
-    (when (null old-de-stack)
-      (error 'out-of-extent-unwind))
-    (setf (vm-dynenv-stack vm) old-de-stack)
-    (throw (entry-dynenv-tag entry-dynenv) new-ip)))
+    (if (null old-de-stack)
+        (error 'out-of-extent-unwind)
+        (unwind-to vm (entry-dynenv-tag entry-dynenv) new-ip
+                   old-de-stack))))
+
+(define-condition no-catch-tag (control-error)
+  ((%tag :initarg :tag :reader tag)))
+
+(defun throw-to (vm tag)
+  (let ((catch-de-stack
+          (member-if (lambda (de)
+                       (and (catch-dynenv-p de)
+                            (eq (catch-dynenv-tag de) tag)))
+                     (vm-dynenv-stack vm))))
+    (if (null catch-de-stack)
+        (error 'no-catch-tag :tag tag)
+        (let* ((de (first catch-de-stack))
+               (rtag (catch-dynenv-dest-tag de))
+               (dest (catch-dynenv-dest de)))
+          (unwind-to vm rtag dest (rest catch-de-stack))))))
 
 (defun instruction-trace (bytecode stack ip bp sp frame-size)
   (fresh-line *trace-output*)
@@ -407,36 +442,24 @@
                       (push de (vm-dynenv-stack vm))
                       (setf (stack (+ bp (next-code))) de)
                       (incf ip)))
-                   #+(or)
                    ((#.m:catch-8)
-                    (let ((target (+ ip (next-code-signed) 1))
-                          (tag (spop))
-                          (old-sp sp)
-                          (old-bp bp))
-                      (incf ip)
-                      (catch tag
-                        (vm bytecode closure constants frame-size))
-                      (setf ip target)
-                      (setf sp old-sp)
-                      (setf bp old-bp)))
-                   #+(or)
+                    (let* ((target (+ ip (next-code-signed)))
+                           (dest-tag tag)
+                           (tag (spop))
+                           (de (make-catch-dynenv tag dest-tag target)))
+                      (push de (vm-dynenv-stack vm))
+                      (incf ip 2)))
                    ((#.m:catch-16)
-                    (let ((target (+ ip (next-code-signed-16) 1))
-                          (tag (spop))
-                          (old-sp sp)
-                          (old-bp bp))
-                      (incf ip)
-                      (catch tag
-                        (vm bytecode closure constants frame-size))
-                      (setf ip target)
-                      (setf sp old-sp)
-                      (setf bp old-bp)))
-                   #+(or)
-                   ((#.m:throw) (throw (spop) (values)))
-                   #+(or)
+                    (let* ((target (+ ip (next-code-signed-16)))
+                           (dest-tag tag)
+                           (tag (spop))
+                           (de (make-catch-dynenv tag dest-tag target)))
+                      (push de (vm-dynenv-stack vm))
+                      (incf ip 3)))
+                   ((#.m:throw) (throw-to vm (spop)))
                    ((#.m:catch-close)
-                    (incf ip)
-                    (return))
+                    (pop (vm-dynenv-stack vm))
+                    (incf ip))
                    ((#.m:exit-8)
                     (incf ip (next-code-signed))
                     (exit-to vm (spop) ip))
diff --git a/compile.lisp b/compile.lisp
index 026f74c..359b637 100644
--- a/compile.lisp
+++ b/compile.lisp
@@ -92,9 +92,9 @@
 (defstruct context
   ;; either an integer, meaning that many values, or T, meaning all
   receiving
-  ;; A list of lexical variable infos and symbols. A symbol means a special
+  ;; A list of lexical variable infos and symbols. :special means a special
   ;; variable binding is in place, while a lexical variable info is the variable
-  ;; for a tagbody or block dynenv.
+  ;; for a tagbody or block dynenv. :catch means a catch.
   ;; Note that the symbol may not be the special variable in question, since
   ;; we don't really need that information.
   ;; Since this is only used for exits, it may not include specials bound by
@@ -986,13 +986,12 @@
   ;; If we need to return the new value, dup on the stack.
   ;; We can't just read from the special, since some other thread may
   ;; alter it.
-  (let ((index (context-frame-end context)))
-    (unless (eql (context-receiving context) 0)
-      (assemble context m:dup))
-    (assemble-maybe-long context m:symbol-value-set
-                         (value-cell-index var context))
-    (when (eql (context-receiving context) t)
-      (assemble context m:pop))))
+  (unless (eql (context-receiving context) 0)
+    (assemble context m:dup))
+  (assemble-maybe-long context m:symbol-value-set
+                       (value-cell-index var context))
+  (when (eql (context-receiving context) t)
+    (assemble context m:pop)))
 
 (defmethod compile-setq-1 ((info trucler:special-variable-description)
                            var valf env context)
@@ -1004,8 +1003,7 @@
 
 (defmethod compile-setq-1 ((info trucler:lexical-variable-description)
                            var valf env context)
-  (let ((localp (eq (lvar-cfunction info) (context-function context)))
-        (index (context-frame-end context)))
+  (let ((localp (eq (lvar-cfunction info) (context-function context))))
     (unless localp
       (setf (closed-over-p info) t))
     (setf (setp info) t)
@@ -1117,6 +1115,8 @@
                 ;; TODO: Doesn't matter now, but if we had an unbind-n
                 ;; instruction we could leverage that here.
                 (emit-unbind context 1))
+               ((eql :catch)
+                (assemble context m:catch-close))
                (trucler:lexical-variable-description
                 (maybe-emit-entry-close context entry))))
            ;; Exit.
@@ -1176,7 +1176,7 @@
         (target (make-label)))
     (compile-form tag env (new-context context :receiving 1))
     (emit-catch context target)
-    (compile-progn body env context)
+    (compile-progn body env (new-context context :dynenv '(:catch)))
     (assemble context m:catch-close)
     (emit-label context target)))
 
diff --git a/cvm.asd b/cvm.asd
index 437a140..e58dbd8 100644
--- a/cvm.asd
+++ b/cvm.asd
@@ -48,6 +48,7 @@
                                (:file "type")
                                ;; data-and-control-flow
                                (:file "block")
+                               (:file "catch")
                                (:file "flet")
                                (:file "if")
                                (:file "labels")
diff --git a/machine.lisp b/machine.lisp
index d2fc52b..f9af374 100644
--- a/machine.lisp
+++ b/machine.lisp
@@ -113,8 +113,8 @@
     (exit-16 41 ((label-arg 2)))
     (exit-24 42 ((label-arg 3)))
     (entry-close 43)
-    (catch-8 44)
-    (catch-16 45)
+    (catch-8 44 ((label-arg 1)))
+    (catch-16 45 ((label-arg 2)))
     (throw 46)
     (catch-close 47)
     (special-bind 48 ((constant-arg 1)) ((constant-arg 2)))
diff --git a/test/ansi/catch.lisp b/test/ansi/catch.lisp
new file mode 100644
index 0000000..d2776af
--- /dev/null
+++ b/test/ansi/catch.lisp
@@ -0,0 +1,113 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Oct 12 13:04:02 2002
+;;;; Contains: Tests of CATCH and THROW
+
+(in-package #:cvm.test)
+
+(5am:def-suite catch :in data-and-control-flow)
+(5am:in-suite catch)
+
+(deftest catch.1
+  (catch 'foo)
+  nil)
+
+(deftest catch.2
+  (catch 'foo 'a)
+  a)
+
+(deftest catch.3
+  (catch 'foo (values)))
+
+(deftest catch.4
+  (catch 'foo (values 1 2 3))
+  1 2 3)
+
+(deftest catch.5
+  (catch 'foo 'a (throw 'foo 'b) 'c)
+  b)
+
+;;
+;; The test below is wrong:
+;;   Numbers can't be assumed to be EQ at
+;;   any time by conforming programs.
+;;
+;; (deftest catch.6
+;;   (let ((tag1 (1+ most-positive-fixnum))
+;;      (tag2 (1+ most-positive-fixnum)))
+;;     (if (eqt tag1 tag2)
+;;      'good
+;;       (catch tag1
+;;      (catch tag2 (throw tag1 'good))
+;;      'bad)))
+;;   good)
+
+(deftest catch.7
+  (catch 'foo 'a (throw 'foo (values)) 'c))
+
+(deftest catch.8
+  (catch 'foo 'a (throw 'foo (values 1 2 3)) 'c)
+  1 2 3)
+
+#+(or) ; assert is weird/not defined in cross
+(deftest catch.9
+  (let ((i 0))
+    (catch (progn (incf i) 'foo)
+      (assert (eql i 1))
+      (throw (progn (incf i 2) 'foo) i)))
+  3)
+
+(deftest catch.10
+  (flet ((%f (x) (throw 'foo x)))
+    (catch 'foo
+      (%f 'good)
+      'bad))
+  good)
+
+#+(or) ; defun
+(defun catch.11-fn (x) (throw 'foo x))
+#+(or)
+(deftest catch.11
+  (catch 'foo
+    (catch.11-fn 'good)
+    'bad)
+  good)
+
+(deftest catch.12
+  (labels ((%f (x) (throw 'foo x)))
+    (catch 'foo
+      (%f 'good)
+      'bad))
+  good)
+
+;;; No implicit tagbody
+(deftest catch.13
+  (block done
+    (tagbody
+     (catch 'foo
+       (go 10)
+       10
+       (return-from done 'bad))
+     10
+     (return-from done 'good)))
+  good)
+
+;;; Macros are expanded in the appropriate environment
+
+(deftest catch.14
+  (macrolet ((%m (z) z))
+    (catch 'foo (s:expand-in-current-env (%m :good))))
+  :good)
+
+(deftest catch.15
+  (macrolet ((%m (z) z))
+    (catch 'foo (throw (s:expand-in-current-env (%m 'foo)) :good) :bad))
+  :good)
+
+(deftest catch.16
+  (macrolet ((%m (z) z))
+    (catch 'foo (throw 'foo (s:expand-in-current-env (%m :good))) :bad))
+  :good)
+
+(5am:test throw-error
+  (signals-eval control-error (throw (list nil) nil)))
diff --git a/test/ansi/tagbody.lisp b/test/ansi/tagbody.lisp
index 07d8e9a..30db45d 100644
--- a/test/ansi/tagbody.lisp
+++ b/test/ansi/tagbody.lisp
@@ -95,7 +95,6 @@
     result)
   10)
 
-#+(or) ; catch not working yet
 (deftest tagbody.11
   (let (result)
     (tagbody
diff --git a/vm.lisp b/vm.lisp
index f3400fa..ec76c28 100644
--- a/vm.lisp
+++ b/vm.lisp
@@ -354,24 +354,30 @@
                        loop
                          (vm bytecode closure constants frame-size)))
                    ((#.m:catch-8)
-                    (let ((target (+ ip (next-code-signed) 1))
+                    (let ((target (+ ip (next-code-signed)))
                           (tag (spop))
                           (old-sp sp)
                           (old-bp bp))
-                      (incf ip)
+                      (incf ip 2)
                       (catch tag
-                        (vm bytecode closure constants frame-size))
+                        (vm bytecode closure constants frame-size)
+                        ;; since catch-close is used for local unwinds
+                        ;; as well as normal exit of the catch block,
+                        ;; don't jump to the end of the catch
+                        ;; unless something actually threw.
+                        (setf target ip))
                       (setf ip target)
                       (setf sp old-sp)
                       (setf bp old-bp)))
                    ((#.m:catch-16)
-                    (let ((target (+ ip (next-code-signed-16) 1))
+                    (let ((target (+ ip (next-code-signed-16)))
                           (tag (spop))
                           (old-sp sp)
                           (old-bp bp))
-                      (incf ip)
+                      (incf ip 3)
                       (catch tag
-                        (vm bytecode closure constants frame-size))
+                        (vm bytecode closure constants frame-size)
+                        (setf target ip))
                       (setf ip target)
                       (setf sp old-sp)
                       (setf bp old-bp)))

From f6a7d1e3c28c42e6f6f7c3eccee5c0d1dc244748 Mon Sep 17 00:00:00 2001
From: Bike <aeshtaer@gmail.com>
Date: Sun, 1 Oct 2023 12:34:39 -0400
Subject: [PATCH 2/4] Implement PROGV

Like CATCH, the instruction has been there, but was not used.

Having UNBIND work on both PROGV and SPECIAL-BIND environments
might be mildly annoying for a shallow binding implementation
that might have to distinguish between two kinds of dynenvs.
But at least it should be implementable.
---
 Cross/vm.lisp        | 101 +++++++++++++++++++++++--------
 compile.lisp         |   2 +-
 cvm.asd              |   1 +
 machine.lisp         |   2 +-
 test/ansi/progv.lisp | 138 +++++++++++++++++++++++++++++++++++++++++++
 test/cross/sham.lisp |  14 ++++-
 vm.lisp              |   2 +
 7 files changed, 233 insertions(+), 27 deletions(-)
 create mode 100644 test/ansi/progv.lisp

diff --git a/Cross/vm.lisp b/Cross/vm.lisp
index af01723..d80284c 100644
--- a/Cross/vm.lisp
+++ b/Cross/vm.lisp
@@ -4,7 +4,7 @@
                     (#:arg #:cvm.argparse))
   (:export #:initialize-vm)
   (:export #:*trace*)
-  (:export #:symbol-cell))
+  (:export #:make-variable-access-closures))
 
 (in-package #:cvm.cross.vm)
 
@@ -33,8 +33,18 @@
                          (:constructor make-entry-dynenv (tag)))
   (tag (error "missing arg")))
 (defstruct (sbind-dynenv (:include dynenv)
-                         (:constructor %make-sbind-dynenv (symbol cell)))
-  symbol cell)
+                         (:constructor %make-sbind-dynenv
+                             (global-cell cell)))
+  ;; global-cell is the symbol's global Clostrum value cell,
+  ;; whereas cell is local a local binding cell.
+  ;; We bind etc. using global cells as keys, rather than symbol
+  ;; names, so that the same symbol can have distinct local bindings
+  ;; in distinct global environments.
+  global-cell cell)
+(defstruct (progv-dynenv (:include dynenv)
+                         (:constructor %make-progv-dynenv (mapping)))
+  ;; Alist from global cells to local cells.
+  mapping)
 (defstruct (catch-dynenv (:include dynenv)
                          (:constructor make-catch-dynenv
                              (tag dest-tag dest)))
@@ -47,8 +57,17 @@
   (dest (error "missing arg")))
 
 ;;; For uniformity, we put a Clostrum-style cell into these structs.
-(defun make-sbind-dynenv (symbol value)
-  (%make-sbind-dynenv symbol (cons value *unbound*)))
+(defun make-sbind-dynenv (global-cell value)
+  (%make-sbind-dynenv global-cell (cons value *unbound*)))
+(defun make-progv-dynenv (global-cells values)
+  ;; Per CLHS:
+  ;; If we have too few values, the remaining symbols are unbound.
+  ;; If we have too many, the excess are ignored.
+  (loop for global-cell in global-cells
+        for value = (if (null values) *unbound* (pop values))
+        for cell = (cons value *unbound*)
+        collect (cons global-cell cell) into mapping
+        finally (return (%make-progv-dynenv mapping))))
 
 (defun bytecode-call (template closure-env args)
   (declare (optimize speed)
@@ -97,28 +116,41 @@
 (defun signed (x size)
   (logior x (- (mask-field (byte 1 (1- size)) x))))
 
-(defun %find-sbind-dynenv (symbol stack)
-  (dolist (de stack)
-    (when (eq symbol (sbind-dynenv-symbol de))
-      (return de))))
-
-(defun symbol-cell (symbol global-cell)
-  (let* ((de (%find-sbind-dynenv symbol (vm-dynenv-stack *vm*))))
-    (if de
-        (sbind-dynenv-cell de)
-        global-cell)))
+(defun symbol-cell (global-cell)
+  (loop for de in (vm-dynenv-stack *vm*)
+        do (typecase de
+             (sbind-dynenv
+              (when (eq global-cell (sbind-dynenv-global-cell de))
+                (return (sbind-dynenv-cell de))))
+             (progv-dynenv
+              (let ((pair (assoc global-cell
+                                 (progv-dynenv-mapping de))))
+                (when pair
+                  (return (cdr pair))))))
+        finally (return global-cell)))
 
 (defun %symbol-value (symbol global-cell)
-  (let* ((cell (symbol-cell symbol global-cell))
+  (let* ((cell (symbol-cell global-cell))
          (value (car cell)))
     (if (eq value (cdr cell))
         (error 'unbound-variable :name symbol)
         value)))
 
 (defun (setf %symbol-value) (new symbol global-cell)
-  (let ((cell (symbol-cell symbol global-cell)))
+  (declare (ignore symbol))
+  (let ((cell (symbol-cell global-cell)))
     (setf (car cell) new)))
 
+(defun %boundp (symbol global-cell)
+  (declare (ignore symbol))
+  (let ((cell (symbol-cell global-cell)))
+    (not (eq (car cell) (cdr cell)))))
+
+(defun %makunbound (symbol global-cell)
+  (let ((cell (symbol-cell global-cell)))
+    (setf (car cell) (cdr cell)))
+  symbol)
+
 ;;; Unwind to the VM frame represented by rtag at ip new-ip,
 ;;; set the de stack to the given de stack, and execute cleanups
 ;;; along the way.
@@ -474,7 +506,7 @@
                     (incf ip))
                    ((#.m:special-bind)
                     (let ((de (make-sbind-dynenv
-                               (car (constant (next-code))) (spop))))
+                               (cdr (constant (next-code))) (spop))))
                       (push de (vm-dynenv-stack vm)))
                     (incf ip))
                    ((#.m:symbol-value)
@@ -486,13 +518,20 @@
                       (setf (%symbol-value (car vcell) (cdr vcell))
                             (spop)))
                     (incf ip))
-                   #+(or)
                    ((#.m:progv)
-                    (let ((values (spop)))
-                      (progv (spop) values
-                        (incf ip)
-                        (vm bytecode closure constants frame-size))))
+                    (let* ((env (constant (next-code)))
+                           (values (spop)) (varnames (spop))
+                           (global-cells
+                             (loop with client = (vm-client vm)
+                                   for symbol in varnames
+                                   collect (clostrum-sys:variable-cell
+                                            client env symbol)))
+                           (de
+                             (make-progv-dynenv global-cells values)))
+                      (push de (vm-dynenv-stack vm)))
+                    (incf ip))
                    ((#.m:unbind)
+                    ;; NOTE: used for both special-bind and progv
                     (pop (vm-dynenv-stack vm))
                     (incf ip))
                    ((#.m:push-values)
@@ -565,3 +604,19 @@
                                         (fun m:bytecode-function))
   (lambda (&rest args)
     (bytecode-call fun #() args)))
+
+;;; Given a client and environment, return closures that implement,
+;;; respectively, CL:SYMBOL-VALUE, (SETF CL:SYMBOL-VALUE),
+;;; CL:BOUNDP, and CL:MAKUNBOUND.
+(defun make-variable-access-closures (client environment)
+  (labels ((cell (symbol)
+             (clostrum-sys:variable-cell client environment symbol))
+           (#1=#:symbol-value (symbol)
+             (%symbol-value symbol (cell symbol)))
+           ((setf #1#) (value symbol)
+             (setf (%symbol-value symbol (cell symbol)) value))
+           (#2=#:boundp (symbol)
+             (%boundp symbol (cell symbol)))
+           (#3=#:makunbound (symbol)
+             (%makunbound symbol (cell symbol))))
+    (values #'#1# #'(setf #1#) #'#2# #'#3#)))
diff --git a/compile.lisp b/compile.lisp
index 359b637..584f405 100644
--- a/compile.lisp
+++ b/compile.lisp
@@ -1190,7 +1190,7 @@
   (destructuring-bind (symbols values . body) (rest form)
     (compile-form symbols env (new-context context :receiving 1))
     (compile-form values env (new-context context :receiving 1))
-    (assemble context m:progv)
+    (assemble-maybe-long context m:progv (env-index context))
     (compile-progn body env context)
     (emit-unbind context 1)))
 
diff --git a/cvm.asd b/cvm.asd
index e58dbd8..ba08a1e 100644
--- a/cvm.asd
+++ b/cvm.asd
@@ -58,6 +58,7 @@
                                (:file "multiple-value-call")
                                (:file "multiple-value-prog1")
                                (:file "progn")
+                               (:file "progv")
                                (:file "return-from")
                                (:file "tagbody")))))))
 
diff --git a/machine.lisp b/machine.lisp
index f9af374..c458867 100644
--- a/machine.lisp
+++ b/machine.lisp
@@ -121,7 +121,7 @@
     (symbol-value 49 ((constant-arg 1)) ((constant-arg 2)))
     (symbol-value-set 50 ((constant-arg 1)) ((constant-arg 2)))
     (unbind 51)
-    (progv 52)
+    (progv 52 ((constant-arg 1)) ((constant-arg 2)))
     (fdefinition 53 ((constant-arg 1)) ((constant-arg 2)))
     (nil 54)
     (eq 55)
diff --git a/test/ansi/progv.lisp b/test/ansi/progv.lisp
new file mode 100644
index 0000000..96d7e78
--- /dev/null
+++ b/test/ansi/progv.lisp
@@ -0,0 +1,138 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Oct 12 10:00:50 2002
+;;;; Contains: Tests for PROGV
+
+(in-package #:cvm.test)
+
+(5am:def-suite progv :in data-and-control-flow)
+(5am:in-suite progv)
+
+(deftest progv.1
+  (progv () () t)
+  t)
+
+(deftest progv.2
+  (progv '(x) '(1) (not (not (boundp 'x))))
+  t)
+
+(deftest progv.3
+  (progv '(x) '(1) (symbol-value 'x))
+  1)
+
+(deftest progv.4
+  (progv '(x) '(1)
+    (locally (declare (special x))
+             x))
+  1)
+
+(deftest progv.5
+  (let ((x 0))
+    (progv '(x) '(1) x))
+  0)
+
+(deftest progv.6
+  (let ((x 0))
+    (declare (special x))
+    (progv '(x) ()
+      (boundp 'x)))
+  nil)
+
+(deftest progv.6a
+  (let ((x 0))
+    (declare (special x))
+    (progv '(x) () (setq x 1))
+    x)
+  0)
+
+(deftest progv.7
+  (progv '(x y z) '(1 2 3)
+    (locally (declare (special x y z))
+             (values x y z)))
+  1 2 3)
+
+(deftest progv.8
+  (progv '(x y z) '(1 2 3 4 5 6 7 8)
+    (locally (declare (special x y z))
+             (values x y z)))
+  1 2 3)
+
+(deftest progv.9
+  (let ((x 0))
+    (declare (special x))
+    (progv '(x y z w) '(1)
+      (values (not (not (boundp 'x)))
+              (boundp 'y)
+              (boundp 'z)
+              (boundp 'w))))
+  t nil nil nil)
+
+;; forms are evaluated in order
+
+(deftest progv.10
+  (let ((x 0) (y 0) (c 0))
+    (progv
+        (progn (s:setf x (s:incf c)) nil)
+        (progn (s:setf y (s:incf c)) nil)
+      (values x y c)))
+  1 2 2)
+
+;;; No tagbody
+
+(deftest progv.11
+  (block nil
+    (tagbody
+     (progv nil nil (go 10) 10 (return 'bad))
+     10
+     (return 'good)))
+  good)
+
+;;; Variables that are not bound don't have any type constraints
+
+(deftest progv.12
+  (progv '(x y) '(1)
+    (locally (declare  (special x y) (type nil y))
+             (values
+              x
+              (boundp 'y))))
+  1 nil)
+
+;;; Macros are expanded in the appropriate environment
+
+(deftest progv.13
+  (macrolet
+   ((%m (z) z))
+   (progv (s:expand-in-current-env (%m '(x)))
+          '(:good)
+          (locally (declare (special x)) x)))
+  :good)
+
+(deftest progv.14
+  (macrolet
+   ((%m (z) z))
+   (progv (list (s:expand-in-current-env (%m 'x)))
+          '(:good)
+          (locally (declare (special x)) x)))
+  :good)
+
+(deftest progv.15
+  (macrolet
+   ((%m (z) z))
+   (progv '(x)
+          (s:expand-in-current-env (%m '(:good)))
+          (locally (declare (special x)) x)))
+  :good)
+
+(deftest progv.16
+  (macrolet
+   ((%m (z) z))
+   (progv '(x)
+          (list (s:expand-in-current-env (%m :good)))
+          (locally (declare (special x)) x)))
+  :good)
+
+(deftest progv.17
+  (macrolet
+   ((%m (z) z))
+   (progv nil nil (s:expand-in-current-env (%m :good))))
+  :good)
diff --git a/test/cross/sham.lisp b/test/cross/sham.lisp
index cf694e8..23df85e 100644
--- a/test/cross/sham.lisp
+++ b/test/cross/sham.lisp
@@ -69,7 +69,6 @@ tagbody: ()
                  (clostrum:fdefinition client environment cl) f)))
 
 (defun define-env-access (client environment)
-  ;; fdefinition is used implicitly by multiple-value-call.
   (flet ((%fdefinition (name)
            (clostrum:fdefinition client environment name))
          (%symbol-function (name)
@@ -78,7 +77,18 @@ tagbody: ()
     (setf (clostrum:fdefinition client environment 'fdefinition)
           #'%fdefinition
           (clostrum:fdefinition client environment 'symbol-function)
-          #'%symbol-function)))
+          #'%symbol-function))
+  (multiple-value-bind (symbol-value setf-symbol-value
+                        boundp makunbound)
+      (cvm.cross.vm:make-variable-access-closures client environment)
+    (setf (clostrum:fdefinition client environment 'symbol-value)
+          symbol-value
+          (clostrum:fdefinition client environment '(setf symbol-value))
+          setf-symbol-value
+          (clostrum:fdefinition client environment 'boundp)
+          boundp
+          (clostrum:fdefinition client environment 'makunbound)
+          makunbound)))
 
 ;;; functions that can be copied except we ban the env-specific parts
 (defun define-stricter-aliases (client environment)
diff --git a/vm.lisp b/vm.lisp
index ec76c28..a70057f 100644
--- a/vm.lisp
+++ b/vm.lisp
@@ -408,11 +408,13 @@
                     (setf (symbol-value (constant (next-code))) (spop))
                     (incf ip))
                    ((#.m:progv)
+                    (incf ip) ; ignore environment
                     (let ((values (spop)))
                       (progv (spop) values
                         (incf ip)
                         (vm bytecode closure constants frame-size))))
                    ((#.m:unbind)
+                    ;; NOTE: used for both progv and special-bind
                     (incf ip)
                     (return))
                    ((#.m:push-values)

From caf9ef3a4ebdaab64db3451c79f32b8b4172d57b Mon Sep 17 00:00:00 2001
From: Bike <aeshtaer@gmail.com>
Date: Sun, 1 Oct 2023 13:50:14 -0400
Subject: [PATCH 3/4] Implement UNWIND-PROTECT

That's all the standard special operators.

An alternative design would be to inline the cleanup, and have the
PROTECT instruction refer to a label. The cleanup would then end
with a special resume instruction, that would either continue
unwinding, or jump back to whatever local exit caused the cleanup.
But that would be really complicated.

Originally I was going to call the cleanup instruction "deprotect"
as a chemistry joke, but I figure deprotect sounds like it's
merely removing protection, rather than actually doing things.
---
 Cross/vm.lisp                 |  46 +++++++++++-
 compile.lisp                  |  16 ++++
 cvm.asd                       |   3 +-
 machine.lisp                  |   2 +
 test/ansi/unwind-protect.lisp | 136 ++++++++++++++++++++++++++++++++++
 test/cross/sham.lisp          |   4 +-
 test/native-sham.lisp         |  10 +++
 test/packages.lisp            |   2 +-
 vm.lisp                       |  12 +++
 9 files changed, 224 insertions(+), 7 deletions(-)
 create mode 100644 test/ansi/unwind-protect.lisp

diff --git a/Cross/vm.lisp b/Cross/vm.lisp
index d80284c..db51e35 100644
--- a/Cross/vm.lisp
+++ b/Cross/vm.lisp
@@ -55,6 +55,11 @@
   (dest-tag (error "missing arg"))
   ;; the new IP to jump to
   (dest (error "missing arg")))
+;;; unwind-protect
+(defstruct (protection-dynenv (:include dynenv)
+                              (:constructor make-protection-dynenv
+                                  (cleanup)))
+  (cleanup (error "missing arg") :type function))
 
 ;;; For uniformity, we put a Clostrum-style cell into these structs.
 (defun make-sbind-dynenv (global-cell value)
@@ -154,10 +159,31 @@
 ;;; Unwind to the VM frame represented by rtag at ip new-ip,
 ;;; set the de stack to the given de stack, and execute cleanups
 ;;; along the way.
-;;; ...except we use deep binding and don't implement UNWIND-PROTECT,
-;;; so there's nothing to clean up right now.
 (defun unwind-to (vm rtag new-ip new-de-stack)
-  (setf (vm-dynenv-stack vm) new-de-stack)
+  ;; Pop off dynenvs until we reach the destination.
+  ;; Note that we have to actually pop the de-stack rather than
+  ;; use a local variable or whatever, so that any cleanup thunks
+  ;; are executed in the correct dynamic environment.
+  ;; Also note that per CLHS 5.2 point 1, it is illegal for a cleanup
+  ;; to escape to a point between it and the ultimate destination -
+  ;; here, that would be some entry or catch between the de-stack and
+  ;; the new-de-stack. But we don't have to go through the extra
+  ;; effort of enforcing this by signaling an error, so we don't.
+  ;; This is like the failed X3J13 EXIT-EXTENT:MEDIUM.
+  ;; If we did want to signal an error, the obvious procedure would
+  ;; be to go through and mark any intervening exits invalid by
+  ;; setting some slot in them, and then checking that slot when
+  ;; initiating a nonlocal exit.
+  ;; (Simply changing the de-stack to new-de-stack would not work
+  ;;  because then e.g. all special bindings would be undone.)
+  (loop until (eq (vm-dynenv-stack vm) new-de-stack)
+        do (let ((de (pop (vm-dynenv-stack vm))))
+             (typecase de
+               (protection-dynenv
+                ;; Preserve values
+                (let ((values (vm-values vm)))
+                  (funcall (protection-dynenv-cleanup de))
+                  (setf (vm-values vm) values))))))
   (throw rtag new-ip))
 
 (define-condition out-of-extent-unwind (control-error)
@@ -583,6 +609,20 @@
                            (vm-client vm) (constant (next-code))
                            desig)))))
                     (incf ip))
+                   ((#.m:protect)
+                    (let* ((cleanup-thunk (spop))
+                           (de (make-protection-dynenv cleanup-thunk)))
+                      (push de (vm-dynenv-stack vm)))
+                    (incf ip))
+                   ((#.m:cleanup)
+                    (let ((de (pop (vm-dynenv-stack vm)))
+                          ;; Preserve values,
+                          ;; in case the thunk messes with them.
+                          (values (vm-values vm)))
+                      (setf (vm-stack-top vm) sp)
+                      (funcall (protection-dynenv-cleanup de))
+                      (setf (vm-values vm) values))
+                    (incf ip))
                    ((#.m:long)
                     (ecase (next-code)
                       (#.m:const
diff --git a/compile.lisp b/compile.lisp
index 584f405..a322ad4 100644
--- a/compile.lisp
+++ b/compile.lisp
@@ -1117,6 +1117,8 @@
                 (emit-unbind context 1))
                ((eql :catch)
                 (assemble context m:catch-close))
+               ((eql :protect) ; unwind protect
+                (assemble context m:cleanup))
                (trucler:lexical-variable-description
                 (maybe-emit-entry-close context entry))))
            ;; Exit.
@@ -1194,6 +1196,20 @@
     (compile-progn body env context)
     (emit-unbind context 1)))
 
+(defmethod compile-special ((op (eql 'unwind-protect))
+                            form env context)
+  (destructuring-bind (protected . cleanup) (rest form)
+    ;; Build a cleanup thunk.
+    ;; This will often/usually be a closure, which is why we
+    ;; can't just give M:PROTECT a constant argument.
+    ;; PROGN is to signal proper errors with DECLARE.
+    (compile-lambda-expression `(lambda () (progn ,@cleanup))
+                               env context)
+    (assemble context m:protect)
+    (compile-form protected env
+                  (new-context context :dynenv '(:protect)))
+    (assemble context m:cleanup)))
+
 (defmethod compile-special ((op (eql 'quote)) form env context)
   (compile-literal (second form) env context))
 
diff --git a/cvm.asd b/cvm.asd
index ba08a1e..2f0b8bc 100644
--- a/cvm.asd
+++ b/cvm.asd
@@ -60,7 +60,8 @@
                                (:file "progn")
                                (:file "progv")
                                (:file "return-from")
-                               (:file "tagbody")))))))
+                               (:file "tagbody")
+                               (:file "unwind-protect")))))))
 
 (asdf:defsystem #:cvm/test/cross
   :author ("Bike <aeshtaer@gmail.com>")
diff --git a/machine.lisp b/machine.lisp
index c458867..e7ab604 100644
--- a/machine.lisp
+++ b/machine.lisp
@@ -130,4 +130,6 @@
     (dup 58)
     (fdesignator 59)
     (called-fdefinition 60)
+    (protect 61)
+    (cleanup 62)
     (long 255)))
diff --git a/test/ansi/unwind-protect.lisp b/test/ansi/unwind-protect.lisp
new file mode 100644
index 0000000..fec0b89
--- /dev/null
+++ b/test/ansi/unwind-protect.lisp
@@ -0,0 +1,136 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Oct 12 14:41:16 2002
+;;;; Contains: Tests of UNWIND-PROTECT
+
+(in-package #:cvm.test)
+
+(5am:def-suite unwind-protect :in data-and-control-flow)
+(5am:in-suite unwind-protect)
+
+(deftest unwind-protect.1
+  (let ((x nil))
+    (unwind-protect
+        (s:push 1 x)
+      (s:incf (car x))))
+  (2))
+
+(deftest unwind-protect.2
+  (let ((x nil))
+    (block foo
+      (unwind-protect
+          (progn (s:push 1 x) (return-from foo x))
+        (s:incf (car x)))))
+  (2))
+
+(deftest unwind-protect.3
+  (let ((x nil))
+    (tagbody
+      (unwind-protect
+          (progn (s:push 1 x) (go done))
+        (s:incf (car x)))
+      done)
+    x)
+  (2))
+
+(deftest unwind-protect.4
+  (let ((x nil))
+    (catch 'done
+      (unwind-protect
+          (progn (s:push 1 x) (throw 'done x))
+        (s:incf (car x)))))
+  (2))
+
+#+(or) ; error, ignore-errors
+(deftest unwind-protect.5
+  (let ((x nil))
+    (ignore-errors
+      (unwind-protect
+          (progn (push 1 x) (error "Boo!"))
+        (s:incf (car x))))
+    x)
+  (2))
+
+(deftest unwind-protect.6
+  (let ((x nil))
+    (block done
+      (flet ((%f () (return-from done nil)))
+        (unwind-protect (%f)
+          (s:push 'a x))))
+    x)
+  (a))
+
+(deftest unwind-protect.7
+  (let ((x nil))
+    (block done
+      (flet ((%f () (return-from done nil)))
+        (unwind-protect
+            (unwind-protect (%f)
+              (s:push 'b x))
+          (s:push 'a x))))
+    x)
+  (a b))
+
+(deftest unwind-protect.8
+  (let ((x nil))
+    (block done
+      (unwind-protect
+          (flet ((%f () (return-from done nil)))
+            (unwind-protect
+                (unwind-protect (%f)
+                  (s:push 'b x))
+              (s:push 'a x)))
+        (s:push 'c x)))
+    x)
+  (c a b))
+
+#+(or) ; handler-case
+(deftest unwind-protect.9
+  (let ((x nil))
+    (handler-case
+      (flet ((%f () (error 'type-error :datum 'foo :expected-type nil)))
+        (unwind-protect (handler-case (%f))
+          (push 'a x)))
+      (type-error () x)))
+  (a))
+
+;;; No implicit tagbody
+(deftest unwind-protect.10
+  (block done
+    (tagbody
+     (unwind-protect
+         'foo
+       (go 10)
+       10
+       (return-from done 'bad))
+     10
+     (return-from done 'good)))
+  good)
+
+;;; Executes all forms of the implicit progn
+(deftest unwind-protect.11
+  (let ((x nil) (y nil))
+    (values
+     (block nil
+       (unwind-protect (return 'a)
+         (s:setf y 'c)
+         (s:setf x 'b)))
+     x y))
+  a b c)
+
+;;; Test that explicit calls to macroexpand in subforms
+;;; are done in the correct environment
+
+(deftest unwind-protect.12
+  (macrolet
+   ((%m (z) z))
+   (unwind-protect (s:expand-in-current-env (%m :good)) :bad))
+  :good)
+
+(deftest unwind-protect.13
+  (macrolet
+   ((%m (z) z))
+   (unwind-protect :good (s:expand-in-current-env (%m :bad))))
+  :good)
+
+
diff --git a/test/cross/sham.lisp b/test/cross/sham.lisp
index 23df85e..2ca9e1d 100644
--- a/test/cross/sham.lisp
+++ b/test/cross/sham.lisp
@@ -112,10 +112,10 @@ tagbody: ()
         for f = (macro-function mac)
         do (setf (clostrum:macro-function client environment mac) f))
   (loop for mac in '(s:multiple-value-bind
-                     s:setf s:incf s:decf
+                     s:setf s:incf s:decf s:push
                      s:when s:unless s:prog1 s:prog s:return)
         for cl in    '(multiple-value-bind
-                       setf   incf   decf
+                       setf   incf   decf   push
                        when   unless   prog1   prog   return)
         for f = (macro-function mac)
         do (setf (clostrum:macro-function client environment mac) f
diff --git a/test/native-sham.lisp b/test/native-sham.lisp
index da1065b..56864e6 100644
--- a/test/native-sham.lisp
+++ b/test/native-sham.lisp
@@ -147,3 +147,13 @@
     `(let* (,@(mapcar #'list temps forms))
        (multiple-value-bind (,@news) (- ,read ,delta)
          ,write))))
+
+;;; Used in UNWIND-PROTECT tests as a side effect.
+(defmacro s:push (object place &environment env)
+  (multiple-value-bind (temps forms news write read)
+      (%get-setf-expansion place env)
+    (let ((osym (gensym "OBJECT")))
+      `(let* ((,osym ,object)
+              ,@(mapcar #'list temps forms)
+              (,(first news) (cons ,osym ,read)))
+         ,write))))
diff --git a/test/packages.lisp b/test/packages.lisp
index 71d97e4..80bd40c 100644
--- a/test/packages.lisp
+++ b/test/packages.lisp
@@ -2,7 +2,7 @@
   (:use)
   (:export #:expand-in-current-env #:notnot)
   (:export #:macroexpand-1 #:macroexpand #:eval)
-  (:export #:multiple-value-bind #:setf #:incf #:decf
+  (:export #:multiple-value-bind #:setf #:incf #:decf #:push
            #:prog1 #:when #:unless #:return #:prog))
 
 (defpackage #:cvm.test
diff --git a/vm.lisp b/vm.lisp
index a70057f..3305f16 100644
--- a/vm.lisp
+++ b/vm.lisp
@@ -464,6 +464,18 @@
                          (function fdesig)
                          (symbol (fdefinition fdesig)))))
                     (incf ip))
+                   ((#.m:protect)
+                    (let ((cleanup-thunk (spop)))
+                      (declare (type function cleanup-thunk))
+                      (incf ip)
+                      (unwind-protect
+                           (vm bytecode closure constants frame-size)
+                        (let ((values (vm-values vm)))
+                          (funcall cleanup-thunk)
+                          (setf (vm-values vm) values)))))
+                   ((#.m:cleanup)
+                    (incf ip)
+                    (return))
                    ((#.m:long)
                     (ecase (next-code)
                       (#.m:const

From 3526871fb6338c6ff0a05bfb84c25779eb3ca3c9 Mon Sep 17 00:00:00 2001
From: Bike <aeshtaer@gmail.com>
Date: Sun, 1 Oct 2023 13:55:04 -0400
Subject: [PATCH 4/4] Mention changes to machine definition

---
 FASL.md | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/FASL.md b/FASL.md
index aeba626..51de661 100644
--- a/FASL.md
+++ b/FASL.md
@@ -22,8 +22,9 @@ After the last instruction is executed, the FASL has been fully loaded. Any rema
 
 ## 0.13 (pending)
 
-* `fdesignator` changed to have an environment parameter for first-class environment purposes.
+* `fdesignator` and `progv` changed to have an environment parameter for first-class environment purposes.
 * `environment` fasl op to get the loader environment for `fdesignator`.
+* New instructions `protect` and `cleanup` for implementing `cl:unwind-protect`.
 
 ## 0.12