Merge pull request #33 from s-expressionists/all-special-operators

add catch & throw instructions

BIR-builder/builder.lisp

@@ -154,3 +154,5 @@
 
 (defmethod post ((inst bir:constant-bind))
   (setf (bir:dynamic-environment (first (bir:next inst))) inst))
+(defmethod post ((inst bir:unwind-protect))
+  (setf (bir:dynamic-environment (first (bir:next inst))) inst))

BIR/instructions.lisp

@@ -167,6 +167,18 @@ See VALUES-SAVE"))
 
 See UNWIND"))
 
+(defclass catchi (one-input no-output terminator dynamic-environment)
+  ()
+  (:documentation "Terminator and dynamic environment representing a dynamic exit point, i.e. CL:CATCH. The one input is the catch tag and there are no outputs. The first of the NEXT IBLOCKs is the normal child continuation, i.e. the body of the cl:catch, and the second IBLOCK is the end of the catch, i.e. the destination of any throws.
+
+See THROWI"))
+
+(defclass throwi (no-output terminator0)
+  ()
+  (:documentation "Terminator representing a dynamic exit i.e. CL:THROW. The first input is the catch tag, and the second input is the values thrown.
+
+See CATCHI"))
+
 (defclass leti (writevar)
   ()
   (:documentation "Instruction representing the initial binding of a variable.

BIR/packages.lisp

@@ -45,7 +45,7 @@
            #:eq-test #:typeq-test #:test-ctype
            #:ifi #:conditional-test
            #:case #:comparees
-           #:unwind-protect
+           #:unwind-protect #:catchi #:throwi
            #:come-from #:unwinds #:unwind #:destination
            #:values-save #:fixed-values-save #:nvalues
            #:values-restore #:values-collect

BIR/verify.lisp

@@ -396,6 +396,18 @@ If there are problems, a VERIFICATION-FAILED is signaled. If the verification pr
   ;; ensure inputs match destination
   (match-jump-types u (inputs u) (outputs u)))
 
+(defmethod verify progn ((c catchi))
+  (test (= (length (next c)) 2)
+        "has wrong number of successors" c)
+  (test (eq (dynamic-environment (first (next c))) c)
+        "has normal successor ~a with wrong dynamic environment ~a"
+        c (first (next c)) (dynamic-environment (first (next c)))))
+
+(defmethod verify progn ((th throwi))
+  (test (= (length (inputs th)) 2)
+        "has wrong number of inputs: ~s"
+        th (inputs th)))
+
 (defmethod verify progn ((j jump))
   (match-jump-types j (inputs j) (outputs j))
   ;; Check accuracy of unwindp (TODO: Check that the dynenv is a parent)