Add support for exception handling.

	* interp/parsing.lisp (TEST-LEXING): Remove.
	(RTRACE): Likewise.
	(RUNTRACE): Likewise.
	(MATCH-ADVANCE-KEYWORD): New.
	(MATCH-ADVANCE-GLYPH): Likewise.
	(MATCH-ADVANCE-SPECIAL): Likewise.
	(MATCH-SPECIAL): Likewise.
	(MATCH-KEYWORD-NEXT): Likewise.
	* interp/newaux.lisp: Make try and throw prefix operators.
	* interp/metalex.lisp (KEYWORDS): Include finally, catch and throw.
	* interp/fnewmeta.lisp (PARSE-Throw): New. Parse throw-expressions.
	(PARSE-Catch): New.  Parse catch-expressions.
	(PARSE-Finally): New. Parse finally-expressions.
	(PARSE-Try): New. Parse try-expressions.
	* interp/compiler.boot (compThrow): New. Register to compile
	throw-expressions. 
	(compTry): New. Register to compiler try-expressions.
	(compCatch): New. Compile catch-handler expression.
	* interp/g-opt.boot (optTry): New.  Simplify simple expressions in
	the try operand.
	* interp/g-util.boot (expandThrow): New.  Expand %throw forms.
	(domainMatchCode): New.
	(expandTry): New. Expand %try forms.
	* doc/msgs/s2-us.msgs: Add new message with key S2GE0020.
	* interp/g-error.boot (systemErrorHandler): Handle possible
	uncaucght expression condition.

1 files changed, 36 insertions, 1 deletions

diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot
index e8fe239c..2462e843 100644
--- a/src/interp/g-util.boot
+++ b/src/interp/g-util.boot
@@ -371,6 +371,39 @@ expandStore ["%store",place,value] ==
   cons? place => ["SETF",place,value]
   ["SETQ",place,value]
 
+-- non-local control transfer
+
+$OpenAxiomCatchTag == KEYWORD::OpenAxiomCatchPoint
+
+expandThrow ['%throw,m,x] ==
+  ['THROW,$OpenAxiomCatchTag,
+    ['CONS,$OpenAxiomCatchTag,
+      ['CONS,expandToVMForm m,expandToVMForm x]]]
+
+++ Subroutine of expandTry.  Generate code for domain matching
+++ of object `obj' with domain `dom'.
+domainMatchCode(dom,obj) ==
+  -- FIXME: Instead of domain equality, we should also consider
+  -- FIXME: cases of sub-domains, or domain schemes with constraints.
+  ['domainEqual,dom,['%head,obj]]
+
+expandTry ['%try,expr,handlers,cleanup] ==
+  g := gensym()              -- hold the exception object
+  ys := [[domainMatchCode(mode,['%tail,g]),
+          ['%bind,[[var,['%tail,['%tail,g]]]],stmt]]
+            for [.,var,mode,stmt] in handlers]
+  handlerBody :=
+    ys = nil => g
+    ys := [:ys,['%true,['THROW,$OpenAxiomCatchTag,g]]]
+    ['%when,
+      [['%and,['%pair?,g],
+        ['%peq,['%head,g],$OpenAxiomCatchTag]], ['%when,:ys]],
+          ['%true,g]]
+  tryBlock := expandBind
+    ['%bind,[[g,['CATCH,$OpenAxiomCatchTag,expr]]],handlerBody]
+  cleanup = nil => tryBlock
+  ['UNWIND_-PROTECT,tryBlock,:expandToVMForm rest cleanup]
+  
 ++ Opcodes with direct mapping to target operations.
 for x in [
     -- Boolean constants
@@ -523,7 +556,9 @@ for x in [
 
    ['%bind,   :function expandBind],
    ['%store,  :function expandStore],
-   ['%dynval, :function expandDynval]
+   ['%dynval, :function expandDynval],
+   ['%throw,  :function expandThrow],
+   ['%try,    :function expandTry]
  ] repeat property(first x,'%Expander) := rest x
 
 ++ Return the expander of a middle-end opcode, or nil if there is none.