r12459@gauss: gdr | 2008-12-12 18:18:31 -0600

 	Tidy compApplyModemap.
 r12460@gauss:  gdr | 2008-12-13 09:24:50 -0600
 	Tidy compMapCond.
 r12461@gauss:  gdr | 2008-12-13 10:24:14 -0600
 	Activate compViableModemap.
 r12462@gauss:  gdr | 2008-12-13 11:18:17 -0600
 	Remove pmatch and pmatchWithSl out of main compiler.
 r12463@gauss:  gdr | 2008-12-13 12:26:44 -0600
 	Tidy compApplyModemap.
 r12464@gauss:  gdr | 2008-12-13 16:39:28 -0600
 	Add compExclusiveOr.
 r12465@gauss:  gdr | 2008-12-13 16:54:58 -0600
 	.
 r12466@gauss:  gdr | 2008-12-14 15:01:33 -0600
 	Tidy compLogicalNot.

1 files changed, 73 insertions, 58 deletions

diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 7c5a764d..f59babe7 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -610,17 +610,15 @@ compFormWithModemap(form,m,e,modemap) ==
       if ss in sv then
         [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap)
         -- SAY ["new map is",map]
-  not (target':= coerceable(target,m,e)) => nil
-  map:= [target',:rest map]
-  [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil
+  not coerceable(target,m,e) => nil
+  [f,Tl]:= compApplyModemap(form,modemap,e) or return nil
 
   --generate code; return
   T:=
-    [x',m',e'] where
-      m':= SUBLIS(sl,map.(1))
+    [x',target,e'] where
       x':=
         form':= [f,:[t.expr for t in Tl]]
-        m'=$Category or isCategoryForm(m',e) => form'
+        target=$Category or isCategoryForm(target,e) => form'
         -- try to deal with new-style Unions where we know the conditions
         op = "elt" and f is ['XLAM,:.] and IDENTP(z := first argl) and
           (c:=get(z,'condition,e)) and
@@ -1282,16 +1280,33 @@ compImport(["import",:doms],m,e) ==
 --% meaning, or may need special handling because or short-circuiting
 --% etc.
 
-++ compile a logical negation form `(not ...)'.
-compNot: (%Form,%Mode,%Env) -> %Maybe %Triple
-compNot(x,m,e) ==
+++ Compile a logical negation form `(not ...)'.
+compLogicalNot: (%Form,%Mode,%Env) -> %Maybe %Triple
+compLogicalNot(x,m,e) ==
   x isnt ["not", y] => nil
   -- ??? For the time being compiler values cannot handle operations
   -- ??? selected through general modemaps, and their semantics
   -- ??? are quite hardwired with their syntax.
   -- ??? Eventually, we should not need to do this.
   $normalizeTree => compIf(["IF",y,"false","true"],m,e)
-  compForm(x,m,e)
+  yT := comp(y,$EmptyMode,e) or return nil
+  yT.mode = $Boolean =>
+    e := getInverseEnvironment(y,yT.env)
+    convert([["NOT",yT.expr],$Boolean,e],m)
+  compResolveCall("not",[yT],m,yT.env)
+
+
+++ Compile an exclusive `xor' expression.
+compExclusiveOr: (%Form,%Mode,%Env) -> %Maybe %Triple
+compExclusiveOr(x,m,e) ==
+  x isnt ["xor",a,b] => nil
+  aT := comp(a,$EmptyMode,e) or return nil
+  e := 
+    aT.mode = $Boolean => getSuccessEnvironment(a,aT.env)
+    aT.env
+  bT := comp(b,$EmptyMode,e) or return nil
+  compResolveCall("xor",[aT,bT],m,bT.env)
+
 
 --% Case
 compCase: (%Form,%Mode,%Env) -> %Maybe %Triple
@@ -1430,9 +1445,7 @@ tryCourtesyCoercion(T,m) ==
 
 coerce(T,m) ==
   T' := tryCourtesyCoercion(T,m) => T'
-  -- if from from coerceable, this coerce was just a trial coercion
-  -- from compFormWithModemap to filter through the modemaps
-  T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil
+  isSomeDomainVariable m => nil
   stackMessage('"Cannot coerce %1b of mode %2pb to mode %3pb",
     [T.expr,T.mode,m])
 
@@ -1509,9 +1522,7 @@ belongsTo?(m,cat,e) ==
 
 coerceable(m,m',e) ==
   m=m' => m
-  -- must find any free parameters in m
-  sl:= pmatch(m',m) => SUBLIS(sl,m')
-  coerce(["$fromCoerceable$",m,e],m') => m'
+  tryCourtesyCoercion(["$fromCoerceable$",m,e],m') => m'
   nil
 
 coerceExit: (%Triple,%Mode) -> %Maybe %Triple
@@ -1660,61 +1671,55 @@ compCat(form is [functorName,:argl],m,e) ==
  
 --% APPLY MODEMAPS
 
-compApplyModemap(form,modemap,$e,sl) ==
+++ `op' has been selected as a viable candidate exported operation, 
+++ for argument triple list `argTl', modemap `mm'.
+++ Return the most refined implementation that makes the call successful.
+compViableModemap(op,argTl,mm) ==
+  [[dc,.,:margl],fnsel] := mm
+  -- 1. Give up if the call is hopeless.
+  argTl := [coerce(x,m) or return "failed" for x in argTl for m in margl]
+  argTl = "failed" => nil
+
+  -- 2.  obtain domain-specific function, if possible
+  f := compMapCond(dc,fnsel) or return nil
+
+  -- 3. Mark `f' as used.
+  -- We can no longer trust what the modemap says for a reference into
+  -- an exterior domain (it is calculating the displacement based on view
+  -- information which is no longer valid; thus ignore this index and
+  -- store the signature instead.
+  f is [op1,.,.] and MEMQ(op1,'(ELT CONST Subsumed)) =>
+    [genDeltaEntry [op,:mm],argTl]
+  [f,argTl]
+
+compApplyModemap(form,modemap,$e) ==
   [op,:argl] := form                   --form to be compiled
-  [[mc,mr,:margl],:fnsel] := modemap   --modemap we are testing
+  [[mc,mr,:margl],fnsel] := modemap    --modemap we are testing
 
   -- $e     is the current environment
-  -- sl     substitution list, nil means bottom-up, otherwise top-down
 
   -- 0.  fail immediately if #argl=#margl
-
   if #argl^=#margl then return nil
 
   -- 1.  use modemap to evaluate arguments, returning failed if
   --     not possible
-
   lt:=
-    [[.,m',$e]:=
-      comp(y,g,$e) or return "failed" where
-        g:= SUBLIS(sl,m) where
-            sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl]
+    [[.,.,$e]:= comp(y,m,$e) or return "failed"
+            for y in argl for m in margl]
   lt="failed" => return nil
 
-  -- 2.  coerce each argument to final domain, returning failed
-  --     if not possible
-
-  lt':= [coerce(y,d) or return "failed"
-         for y in lt for d in SUBLIS(sl,margl)]
-  lt'="failed" => return nil
+  -- 2. Select viable modemap implementation.
+  compViableModemap(op,lt,modemap)
 
-  -- 3.  obtain domain-specific function, if possible, and return
-
-  --$bindings is bound by compMapCond
-  [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil
-
---+ can no longer trust what the modemap says for a reference into
---+ an exterior domain (it is calculating the displacement based on view
---+ information which is no longer valid; thus ignore this index and
---+ store the signature instead.
-
-  f is [op1,d,.] and MEMQ(op1,'(ELT CONST Subsumed)) =>
-    [genDeltaEntry [op,:modemap],lt',$bindings]
-  [f,lt',$bindings]
-
-compMapCond(op,mc,$bindings,fnsel) ==
-  or/[compMapCond'(u,op,mc,$bindings) for u in fnsel]
-
-compMapCond'([cexpr,fnexpr],op,dc,bindings) ==
-  compMapCond''(cexpr,dc) => compMapCondFun(fnexpr,op,dc,bindings)
+compMapCond(dc,[cexpr,fnexpr]) ==
+  compMapCond'(cexpr,dc) => fnexpr
   stackMessage('"not known that %1pb has %2pb",[dc,cexpr])
 
-compMapCond''(cexpr,dc) ==
+compMapCond'(cexpr,dc) ==
   cexpr=true => true
-  --cexpr = "true" => true
-  cexpr is ["AND",:l] => and/[compMapCond''(u,dc) for u in l]
-  cexpr is ["OR",:l] => or/[compMapCond''(u,dc) for u in l]
-  cexpr is ["not",u] => not compMapCond''(u,dc)
+  cexpr is ["AND",:l] => and/[compMapCond'(u,dc) for u in l]
+  cexpr is ["OR",:l] => or/[compMapCond'(u,dc) for u in l]
+  cexpr is ["not",u] => not compMapCond'(u,dc)
   cexpr is ["has",name,cat] => (knownInfo cexpr => true; false)
         --for the time being we'll stop here - shouldn't happen so far
         --$disregardConditionIfTrue => true
@@ -1726,9 +1731,18 @@ compMapCond''(cexpr,dc) ==
   stackMessage('"not known that %1pb has %2pb",[dc,cexpr])
   false
 
-compMapCondFun(fnexpr,op,dc,bindings) == 
-  [fnexpr,bindings]
 
+--%
+
+compResolveCall(op,argTs,m,$e) ==
+  outcomes := 
+    [t for mm in getModemapList(op,#argTs,$e) | t := tryMM] where
+       tryMM() ==
+         not coerceable(mm.mmTarget,m,$e) =>nil
+         compViableModemap(op,argTs,mm) isnt [f,Ts] => nil
+         coerce([["call",f,:[T.expr for T in Ts]],mm.mmTarget,$e],m)
+  #outcomes ^= 1 => nil
+  first outcomes
 
 --% %Match
 
@@ -1927,13 +1941,14 @@ for x in [["|", :"compSuchthat"],_
 	  ["exit", :"compExit"],_
 	  ["has", :"compHas"],_
 	  ["IF", : "compIf"],_
+          ["xor",: "compExclusiveOr"],_
 	  ["import", :"compImport"],_
 	  ["is", :"compIs"],_
 	  ["Join", :"compJoin"],_
 	  ["leave", :"compLeave"],_
 	  ["%LET", :"compSetq"],_
 	  ["MDEF", :"compMacro"],_
-          ["not", :"compNot"],_
+          ["not", :"compLogicalNot"],_
 	  ["pretend", :"compPretend"],_
 	  ["Record", :"compCat"],_
 	  ["RecordCategory", :"compConstructorCategory"],_