* interp/compiler.boot (getUnionMode): Remove.

	(isUnionMode): Move to c-util.boot.
	(coerceExtraHard): Rework.
	(belongsTo?): Remove.
	* interp/c-util.boot (isUnionMode): Moved from compiler.boot.
	(unionLike?): New.
	(unionProperty): Likewise.
	(getInverseEnvironment): Use unionProperty instead of getUnionMode.

4 files changed, 51 insertions, 30 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index daa58a45..e5045df1 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,14 @@
+2011-02-14  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
+	* interp/compiler.boot (getUnionMode): Remove.
+	(isUnionMode): Move to c-util.boot.
+	(coerceExtraHard): Rework.
+	(belongsTo?): Remove.
+	* interp/c-util.boot (isUnionMode): Moved from compiler.boot.
+	(unionLike?): New.
+	(unionProperty): Likewise.
+	(getInverseEnvironment): Use unionProperty instead of getUnionMode.
+
 2011-02-13  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
 	* interp/c-util.boot (getSuccessEnvironment): Follow through
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 05915075..5820b091 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -441,13 +441,39 @@ getSuccessEnvironment(a,e) ==
   symbol? a and (T := get(a,"value",e)) => getSuccessEnvironment(T.expr,e)
   e
 
+isUnionMode(m,e) ==
+  m is ["Union",:.] => m
+  v := get(RepIfRepHack m,"value",e) =>
+    (v.expr is ["Union",:.] => v.expr; nil)
+  nil
+
+++ Return the UnionCategory of `m' in the environment `e', if known.
+unionLike?(m,e) ==
+  isUnionMode(m,e) is ['Union,:branches] => ['UnionCategory,:branches]
+  -- Take a cheap approximation at domains with Union-like flavour.
+  T := compForMode(m,$EmptyMode,e) or return nil
+  T.expr is ['Union,:branches] => ['UnionCategory,:T.expr.args]
+  T.mode is ['UnionCategory,:.] => T.mode
+  T.mode is ['UnionType] => ['UnionCategory]
+  T.mode isnt ['Join,:cats,['CATEGORY,.,:sigs]] => nil
+  member(['UnionType],cats) =>
+    ['UnionCategory,
+      :[b for ['SIGNATURE,"case",[=$Boolean,'$,["[||]",b]]] in sigs]]
+  nil
+
+++ If `x' designates a store with multiple views, e.g. Union, return
+++ the collection of those modes.
+unionProperty(x,e) ==
+  atom x => unionLike?(getmode(x,e),e)
+  nil
+
 getInverseEnvironment(a,e) ==
   a is ["case",x,m] and (x := lhsOfAssignment x) and IDENTP x =>
     --the next two lines are necessary to get 3-branched Unions to work
     -- old-style unions, that is
     (get(x,"condition",e) is [["OR",:oldpred]]) and member(a,oldpred) =>
       put(x,"condition",[MKPF(delete(a,oldpred),"OR")],e)
-    getUnionMode(x,e) is ["Union",:l] =>
+    unionProperty(x,e) is ['UnionCategory,:l] =>
       l':= delete(m,l)
       for u in l' repeat
 	 if u is ['_:,=m,:.] then l':= delete(u,l')
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 940c296d..73f7410d 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -1300,19 +1300,6 @@ compPredicate(p,E) ==
   [p',m,E] := comp(p,$Boolean,E) or return nil
   [p',m,getSuccessEnvironment(p,E),getInverseEnvironment(p,E)]
 
-getUnionMode(x,e) ==
-  m:=
-    atom x => getmode(x,e)
-    return nil
-  isUnionMode(m,e)
-
-isUnionMode(m,e) ==
-  m is ["Union",:.] => m
-  (m':= getmode(m,e)) is ["Mapping",["UnionCategory",:.]] => second m'
-  v:= get(RepIfRepHack m,"value",e) =>
-    (v.expr is ["Union",:.] => v.expr; nil)
-  nil
-
 compFromIf(a,m,E) ==
   a="%noBranch" => ["%noBranch",m,E]
   comp(a,m,E)
@@ -1710,14 +1697,20 @@ coerceHard(T,m) ==
 
 coerceExtraHard: (%Triple,%Mode) -> %Maybe %Triple
 coerceExtraHard(T is [x,m',e],m) ==
-  T':= autoCoerceByModemap(T,m) => T'
-  (t:= hasType(x,e)) and isUnionMode(m',e) is ["Union",:l] and 
-    member(t,l) and (T':= autoCoerceByModemap(T,t)) and
-      (T'':= coerce(T',m)) => T''
+  -- Allow implicit injection into Union, if that is
+  -- clear from the context
+  isUnionMode(m,e) is ['Union,:l] and member(m',l) =>
+    autoCoerceByModemap(T,m)
+  -- For values from domains satisfying Union-like properties, apply
+  -- implicit retraction if clear from context.
+  (t := hasType(x,e)) and unionLike?(m',e) is ['UnionCategory,:l]
+     and member(t,l) => coerce(autoCoerceByModemap(T,t),m)
+  -- Give it one last chance.
+  -- FIXME: really, we shouldn't.  Codes relying on this are
+  -- FIXME: inherently difficult to comprehend and likely broken.
+  T' := autoCoerceByModemap(T,m) => T'
   m' is ['Record,:.] and m = $Expression =>
       [['coerceRe2E,x,['ELT,COPY m',0]],m,e]
-  hasUniqueCaseView(x,m,e) and belongsTo?(m',["UnionType"],e) =>
-    autoCoerceByModemap(T,m)
   -- Domain instantiations are first class objects
   m = $Domain =>
     m' = $Category => nil
@@ -1725,15 +1718,6 @@ coerceExtraHard(T is [x,m',e],m) ==
     nil
   nil
 
-++ returns true if mode `m' is known to belong to category `cat' in
-++ the environment `e'.  This function is different from its cousines
-++ `ofCategory', or `has'.  The latter perform runtime checks.  Here,
-++ we are interested in a static approximation.  So, use with care.
-belongsTo?(m,cat,e) ==
-  c := get(m,"mode",e)
-  c isnt ["Join",:cats] => nil
-  member(cat,cats)
-
 coerceable(m,m',e) ==
   m=m' => m
   tryCourtesyCoercion(["$fromCoerceable$",m,e],m') => m'
diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot
index 508213c5..943515eb 100644
--- a/src/interp/wi1.boot
+++ b/src/interp/wi1.boot
@@ -882,7 +882,7 @@ coerceHard(T,m) ==
 
 coerceExtraHard(T is [x,m',e],m) ==
   T':= autoCoerceByModemap(T,m) => T'
-  isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and
+  unionLike?(m',e) is ['UnionCategory,:l] and (t:= hasType(x,e)) and
     member(t,l) and (T':= autoCoerceByModemap(T,t)) and
       (T'':= coerce(T',m)) => T''
   m' is ['Record,:.] and m = $Expression =>