* interp/macros.lisp (|check-subtype|): Return coerced value if can.

	(|check-union|): Likewise.
	* interp/compiler.boot (coerceSuperset): Tidy.  Generate %Retract
	instruction. 
	* interp/g-opt.boot (optRetract): New. 

3 files changed, 18 insertions, 16 deletions

diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index a8f63b8a..74847aaa 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -1762,18 +1762,7 @@ coerceSuperset(T,sub) ==
     rplac(second T',"$")
     T'
   pred := isSubset(sub,T.mode,T.env) =>
-    -- Don't bother introducing a temporary if we have an
-    -- atomic expression.
-    simple? := atom T.expr and not MEMQ(T.expr,$functorLocalParameters)
-    g := 
-      simple? => T.expr
-      GENSYM()
-    result := 
-      simple? => g
-      ["%LET",g,T.expr]
-    pred := substitute(g,"#1",pred)
-    code := ["PROG1",result, ["check-subtype",pred,MKQ sub,g]]
-    [code,sub,T.env]
+    [["%Retract",T.expr,sub,pred],sub,T.env]
   nil
 
 compCoerce1(x,m',e) ==
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 38613f11..31420217 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -571,7 +571,14 @@ optCollectVector form ==
   ["LET",[[vec,["makeSimpleArray",["getVMType",eltType],vecSize]]],
     ["REPEAT",:iters,["setSimpleArrayEntry",vec,index,body]], 
       vec]
- 
+
+++ Translate retraction of a value denoted by `e' to sub-domain `m'
+++ defined by predicate `pred',
+optRetract ["%Retract",e,m,pred] ==
+  atom e => ["check-subtype",substitute(e,"#1",pred),MKQ m,e]
+  g := GENSYM()
+  ["LET",[[g,e]],["check-subtype",substitute(g,"#1",pred),MKQ m,g]]
+
 lispize x == first optimize [x]
  
 --% optimizer hash table
@@ -588,6 +595,7 @@ for x in '( (call         optCall) _
            (_|           optSuchthat)_
            (CATCH        optCatch)_
            (COND         optCond)_
+           (%Retract     optRetract)_
            (%CollectV    optCollectVector)_
            (mkRecord     optMkRecord)_
            (RECORDELT    optRECORDELT)_
diff --git a/src/interp/macros.lisp b/src/interp/macros.lisp
index 8c73a892..217cf844 100644
--- a/src/interp/macros.lisp
+++ b/src/interp/macros.lisp
@@ -509,10 +509,15 @@ terminals and empty or at-end files.  In Common Lisp, we must assume record size
             (STRINGIMAGE (|devaluate| mode))))
  
 (defmacro |check-subtype| (pred submode val)
-   `(|assert| ,pred (coerce-failure-msg ,val ,submode)))
- 
+  `(progn 
+     (|assert| ,pred (coerce-failure-msg ,val ,submode))
+     ,val))
+
 (defmacro |check-union| (pred branch val)
-   `(|assert| ,pred (coerce-failure-msg ,val ,branch )))
+  `(progn
+     (|assert| ,pred (coerce-failure-msg ,val ,branch))
+     ,val))
+  
  
 (defun MAKE-REASONABLE (Z)
    (if (> (length Z) 30) (CONCAT "expression beginning " (subseq Z 0 20)) Z))