r12415@gauss: gdr | 2008-12-06 11:42:45 -0600

 Implement basic support for pattern matching.
 r12416@gauss:  gdr | 2008-12-06 18:09:19 -0600
 	Parse case pattern match.
 r12417@gauss:  gdr | 2008-12-06 21:28:30 -0600
 	Implement basic case pattern matching for retractable domain.
 r12418@gauss:  gdr | 2008-12-07 00:58:58 -0600
 	Refine retractability implementation.
 r12419@gauss:  gdr | 2008-12-07 01:39:32 -0600
 Update cached Lisp translation
 r12420@gauss:  gdr | 2008-12-07 03:52:09 -0600
 
 r12421@gauss:  gdr | 2008-12-07 10:30:44 -0600
 	Implement type recovery too.
 r12422@gauss:  gdr | 2008-12-07 19:18:09 -0600
 	Simplify LET-forms and COND-forms.
 r12423@gauss:  gdr | 2008-12-07 21:21:12 -0600
 Fix typos
 r12424@gauss:  gdr | 2008-12-08 01:14:54 -0600
 	Parse case-pattern in the interpreter.
 r12427@gauss:  gdr | 2008-12-08 20:32:29 -0600
 	Handle RetractableTo T.

2 files changed, 32 insertions, 16 deletions

diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index a297b448..5aa9e6cb 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -1757,25 +1757,40 @@ compRetractAlternative(x,t,stmt,m,s,T) ==
   -- convertible to t (using only courtesy coerciions) or that
   -- `y' is retractable to t.
   --
-  -- 1.  Evaluate the retract condition.
+  -- 1.  Evaluate the retract condition, and retract.
   y := T.expr            -- guaranteed to be a name.
   e := T.env
-  [caseCode,caseMode,e,envFalse] := 
-    compBoolean(["case",y,t],$Boolean,e) or return 
-       stackAndThrow('"%1 is not retractable to %2",[s,t])
-  -- 2.  Evaluate the actual retraction to `t'.
-  --     We try courtesy coercions first, then `retract'.  That way
-  --     we can use optimized versions where available.  That also
-  --     makes the scheme works for untagged unions.
-  [restrictCode,.,e] := tryCourtesyCoercion([y,T.mode,e],t) or
-                          comp(["retract",y],t,e) or return nil
-  -- 3.  Now declare `x'.
+  caseCode := nil
+  restrictCode := nil
+  envFalse := e
+  -- 1.1. Try courtesy coercions first.  That way we can use 
+  --      optimized versions where available.  That also
+  --      makes the scheme work for untagged unions.
+  if testT := compBoolean(["case",y,t],$Boolean,e) then
+    [caseCode,.,e,envFalse] := testT
+    [restrictCode,.,e] := 
+      tryCourtesyCoercion([y,T.mode,e],t) or
+        comp(["retract",y],t,e) or return 
+          stackAndThrow('"Could not retract %1 to type %2bp",[s,t])
+  -- 1.2. Otherwise try retractIfCan, for those `% has RetractableTo t'.
+  else if retractT := comp(["retractIfCan",y],["Union",t,'"failed"],e) then
+    [retractCode,.,e] := retractT
+    -- Assign this value to a temporary.  From the backend point of
+    -- view, that temporary needs to have a lifetime that covers both
+    -- the condition and the body of the alternative, so just use 
+    -- assignment here and let the rest of the compiler deal with it.
+    z := GENSYM()
+    caseCode := ["PROGN",["%LET",z,retractCode],["QEQCAR",z,0]]
+    restrictCode := ["QCDR",z]
+  -- 1.3. Everything else failed; nice try.
+  else return stackAndThrow('"%1 is not retractable to %2bp",[s,t])
+  -- 2.  Now declare `x'.
   [.,.,e] := compMakeDeclaration([":",x,t],$EmptyMode,e) or return nil
   e := put(x,"value",[genSomeVariable(),t,e],e)
-  -- 4.  Compile body of the retract pattern.
+  -- 3.  Compile body of the retract pattern.
   stmtT := comp(stmt,m,e) or return 
     stackAndThrow('"could not compile %1b under mode %2pb",[stmt,m])
-  -- 5.  Generate code for the whole pattern.
+  -- 4.  Generate code for the whole pattern.
   code := [caseCode, ["LET",[[x,restrictCode]],stmtT.expr]]
   [code,stmtT.mode,stmtT.env,envFalse]
 
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 2b194c76..30e253f2 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -380,8 +380,8 @@ optEQ u ==
   u
 
 $simpleVMoperators == 
-  '(CONS CAR CDR LENGTH SIZE EQUAL EQL EQ
-    INTEGERP FLOATP STRINGP IDENTP SYMBOLP)
+  '(CONS CAR CDR LENGTH SIZE EQUAL EQL EQ NOT NULL OR AND
+    QEQCAR QCDR QCAR INTEGERP FLOATP STRINGP IDENTP SYMBOLP)
 
 isSimpleVMForm form ==
   isAtomicForm form => true
@@ -423,13 +423,14 @@ optLET u ==
     substPairs := [[var,:init] for [var,init] in inits]
     for clauses in tails args while continue repeat
       clause := first clauses
-      -- we do not attempt more complicate clauses yet.
+      -- we do not attempt more complicated clauses yet.
       clause isnt [test,stmt] => continue := false
       -- Stop inlining at least one test is not simple
       not isSimpleVMForm test => continue := false
       rplac(first clause,SUBLIS(substPairs,test))
       isSimpleVMForm stmt =>
         rplac(second clause,SUBLIS(substPairs,stmt))
+      continue := false
     continue => body
     u
   not MEMQ(op,$simpleVMoperators) => u