From f0b6be21e20a76251afe2bc2ae92800fb267da0b Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Fri, 30 Apr 2010 14:53:30 +0000
Subject: 	* 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.

---
 src/interp/compiler.boot | 13 +------------
 src/interp/g-opt.boot    | 10 +++++++++-
 src/interp/macros.lisp   | 11 ++++++++---
 3 files changed, 18 insertions(+), 16 deletions(-)

(limited to 'src/interp')

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))
-- 
cgit v1.2.3