* interp/macros.lisp (COERCE-FAILURE-MSG): Remove.

	(check-subtype): Likewise.
	(check-union): Likewise.
	(MAKE-REASONABLE): Move to diagnostic.boot.  Rename.
	(assert): Move to sys-macros.lisp.
	* interp/g-opt.boot ($VMsideEffectFreeOperators): Include %retract
	and %pullback.
	(optRetract): Tidy.
	(optPullback): New.
	* interp/diagnostics.boot (makeReasonable): New.
	(moanRetract): Likewise.  Use it.
	* interp/buildom.boot (mkNewUnionFunList): Simplify.
	(mkUnionFunList): Likewise.

6 files changed, 66 insertions, 70 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index ddbc9312..b1f80cb7 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,21 @@
 2011-09-10  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
+	* interp/macros.lisp (COERCE-FAILURE-MSG): Remove.
+	(check-subtype): Likewise.
+	(check-union): Likewise.
+	(MAKE-REASONABLE): Move to diagnostic.boot.  Rename.
+	(assert): Move to sys-macros.lisp.
+	* interp/g-opt.boot ($VMsideEffectFreeOperators): Include %retract
+	and %pullback.
+	(optRetract): Tidy.
+	(optPullback): New.
+	* interp/diagnostics.boot (makeReasonable): New.
+	(moanRetract): Likewise.  Use it.
+	* interp/buildom.boot (mkNewUnionFunList): Simplify.
+	(mkUnionFunList): Likewise.
+
+2011-09-10  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
 	* interp/g-opt.boot (doInlineCall): New.
 	(optCall): Use it to implement inline functions.
 	($VMsideEffectFreeOperators): Include %apply and STRINGIMAGE.
diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot
index dd01f4a1..386e11d8 100644
--- a/src/interp/buildom.boot
+++ b/src/interp/buildom.boot
@@ -648,14 +648,7 @@ mkNewUnionFunList(name,form is ["Union",:listOfEntries],e) ==
 		   ["XLAM",["#1","#2"],['%ieq,['%head,"#1"],i]]]]
 		     for [.,tag,type] in listOfEntries for i in 0..])] where
 		       cdownFun() ==
-			gg:=gensym()
-			$InteractiveMode =>
-			  ["XLAM",["#1"],["PROG1",["%tail","#1"],
-			    ["check-union",['%ieq,['%head,"#1"],i],type,"#1"]]]
-			["XLAM",["#1"],
-                          ['%bind,[[gg,"#1"]],
-                            ["check-union",['%ieq,['%head,gg],i],type,gg],
-                              ["%tail",gg]]]
+                         ['XLAM,["#1","#2"],['%pullback,"#1",type,i]]
   [cList,e]
 
 mkEnumerationFunList(dc,["Enumeration",:SL],e) ==
@@ -673,10 +666,8 @@ mkEnumerationFunList(dc,["Enumeration",:SL],e) ==
 mkUnionFunList(op,form is ["Union",:listOfEntries],e) ==
   first listOfEntries is [":",.,.] => mkNewUnionFunList(op,form,e)
   nargs := #listOfEntries
-  --1. create representations of subtypes
-  predList:= mkPredList listOfEntries
-  g:=gensym()
-  --2. create coercions from subtypes to subUnion
+  -- create coercions from subtypes to subUnion
+  g := gensym()
   cList:=
    [["=",[$Boolean,g ,g],["ELT",op,$FirstParamSlot + nargs]],
      ["~=",[$Boolean,g,g],["ELT",op,0]],
@@ -687,29 +678,11 @@ mkUnionFunList(op,form is ["Union",:listOfEntries],e) ==
 	   ["coerce",[t,g],cdownFun],
 	   ["autoCoerce",[t,g],downFun], --this should be removed eventually
 	   ["case",[$Boolean,g,t],typeFun]]
-	     for p in predList for t in listOfEntries])] where
-		upFun() ==
-		  p is ['%ieq,['%head,x],n] =>
-                    ["XLAM",["#1"],["%pair",n,"#1"]]
-		  ["XLAM",["#1"],"#1"]
-		cdownFun() ==
-		  gg:=gensym()
-		  if p is ['%ieq,['%head,x],n] then
-		     ref:=["%tail",gg]
-		     q:= ['%ieq,['%head,gg],n]
-		  else
-		     ref:=gg
-		     q:= substitute(gg,"#1",p)
-		  ["XLAM",["#1"],
-                    ['%bind,[[gg,"#1"]],["check-union",q,t,gg],ref]]
-		downFun() ==
-		   p is ['%ieq,['%head,x],.] =>
-		     ["XLAM",["#1"],["%tail","#1"]]
-		   ["XLAM",["#1"],"#1"]
-		typeFun() ==
-		   p is ['%ieq,['%head,x],n] =>
-		     ["XLAM",["#1","#2"],['%ieq,['%head,x],n]]
-		   ["XLAM",["#1","#2"],p]
+	      for t in listOfEntries for n in 0..])] where
+		upFun() == ["XLAM",["#1"],["%pair",n,"#1"]]
+		cdownFun() == ['XLAM,["#1"],['%pullback,"#1",t,n]]
+		downFun() == ["XLAM",["#1"],["%tail","#1"]]
+		typeFun() == ["XLAM",["#1","#2"],['%ieq,['%head,"#1"],n]]
   cList:= substitute(dollarIfRepHack op,g,cList)
   [cList,e]
 
diff --git a/src/interp/diagnostics.boot b/src/interp/diagnostics.boot
index c5075839..ecaf9c7c 100644
--- a/src/interp/diagnostics.boot
+++ b/src/interp/diagnostics.boot
@@ -44,6 +44,21 @@ import vmlisp
 namespace BOOT
 
 
+++ Subroutine of moanRetract.
+makeReasonable s ==
+  # s > 30 =>
+    strconc('"expression beginning ",subString(s,0,20))
+  s
+
+++ This rountine is used by the runtime system to report failed
+++ attempt to coerce a value from one type to another.  Usually
+++ this involves Union branches or SubDomains or other forms
+++ of retraction.
+moanRetract(v,t) ==
+  error
+    strconc(makeReasonable STRINGIMAGE v,'" cannot be coerce to mode ",
+      outputDomainConstructor t)
+
 ++ This routine is used by the interperter to count syntax, or
 ++ precompilation, or semantics analysis errors.
 
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 27811638..e26c8089 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -448,7 +448,7 @@ $VMsideEffectFreeOperators ==
     %bitveccopy %bitvecconc %bitveclength %bitvecref %bitveceq %bitveclt
     %before? %equal %sptreq %ident? %property %tref
     %writeString %writeNewline %writeLine
-    %void)
+    %void %retract %pullback)
 
 ++ List of simple VM operators
 $simpleVMoperators == 
@@ -682,10 +682,23 @@ optRetract ["%retract",e,m,pred] ==
   e isnt [.,:.] =>
     cond := simplifyVMForm substitute(e,"#1",pred)
     cond is '%true => e
-    ["check-subtype",cond,MKQ m,e]
+    ['%when,[cond,e],['%otherwise,['moanRetract,e,MKQ m]]]
   g := gensym()
-  ['%bind,[[g,e]],["check-subtype",substitute(g,"#1",pred),MKQ m,g]]
-
+  ['%bind,[[g,e]],
+    ['%when,[substitute(g,"#1",pred),g],
+      ['%otherwise,['moanRetract,g,MKQ m]]]]
+
+++ We have an expression `x' of some Union type.  Expand an attempted
+++ pullback to the `n'th branch of type `t'.
+optPullback ['%pullback,x,t,n] ==
+  y :=
+    ident? x => x
+    gensym()
+  expr :=
+    ['%when,[['%ieq,['%head,y],n],['%tail,y]],
+      ['%otherwise,['moanRetract,y,MKQ t]]]
+  symbolEq?(x,y) => expr
+  ['%bind,[[y,x]],expr]
 
 --%  Boolean expression transformers
 
@@ -878,6 +891,7 @@ for x in '((%call         optCall) _
            (CATCH        optCatch)_
            (%when        optCond)_
            (%retract     optRetract)_
+           (%pullback    optPullback)_
            (%CollectV    optCollectVector)) _
    repeat property(first x,'OPTIMIZE) := second x
        --much quicker to call functions if they have an SBC
diff --git a/src/interp/macros.lisp b/src/interp/macros.lisp
index 3793de79..783de371 100644
--- a/src/interp/macros.lisp
+++ b/src/interp/macros.lisp
@@ -381,28 +381,6 @@ terminals and empty or at-end files.  In Common Lisp, we must assume record size
  
 ;; range tests and assertions
  
-(defmacro |assert| (x y) `(IF (NULL ,x) (|error| ,y)))
- 
-(defun coerce-failure-msg (val mode)
-   (STRCONC (MAKE-REASONABLE (STRINGIMAGE val))
-            " cannot be coerced to mode "
-            (STRINGIMAGE (|devaluate| mode))))
- 
-(defmacro |check-subtype| (pred submode val)
-  `(progn 
-     (|assert| ,pred (coerce-failure-msg ,val ,submode))
-     ,val))
-
-(defmacro |check-union| (pred branch val)
-  `(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))
- 
- 
 (defmacro |elapsedUserTime| () '(get-internal-run-time))
  
 #+IBCL
@@ -581,12 +559,3 @@ terminals and empty or at-end files.  In Common Lisp, we must assume record size
 
 
 (defvar HT nil)
-
-;; 
-;; -*- Record Structures -*-
-;; 
-
-(defmacro |:| (tag expr)
-  `(LIST '|:| ,(MKQ tag) ,expr))
-
-
diff --git a/src/interp/sys-macros.lisp b/src/interp/sys-macros.lisp
index 4b2d65d7..65777a4d 100644
--- a/src/interp/sys-macros.lisp
+++ b/src/interp/sys-macros.lisp
@@ -1135,3 +1135,12 @@
 
 (defmacro |shellEntry| (dollar n)
   `(svref ,dollar ,n))
+
+(defmacro |assert| (x y)
+  `(if (null ,x) (|error| ,y)))
+
+
+(defmacro |:| (tag expr)
+  `(list '|:| ,(mkq tag) ,expr))
+
+