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.

11 files changed, 98 insertions, 91 deletions

diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 1c7dec58..c7274eb8 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -684,16 +684,6 @@ printSignature(before,op,[target,:argSigList]) ==
   printAny target
   TERPRI()
  
-pmatch(s,p) == pmatchWithSl(s,p,"ok")
- 
-pmatchWithSl(s,p,al) ==
-  s=$EmptyMode => nil
-  s=p => al
-  v:= assoc(p,al) => s=rest v or al
-  MEMQ(p,$PatternVariableList) => [[p,:s],:al]
-  null atom p and null atom s and (al':= pmatchWithSl(first s,first p,al)) and
-    pmatchWithSl(rest s,rest p,al')
- 
 elapsedTime() ==
   currentTime:= TEMPUS_-FUGIT()
   elapsedSeconds:= (currentTime-$previousTime)*QUOTIENT(1.0,$timerTicksPerSecond)
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"],_
diff --git a/src/interp/functor.boot b/src/interp/functor.boot
index e31d5399..595d5a6e 100644
--- a/src/interp/functor.boot
+++ b/src/interp/functor.boot
@@ -565,10 +565,10 @@ DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes) ==
       j:=j-1
       j > i+2 =>
         for k in i..j repeat copyvec.k:=delete([name,:count+k-i],copyvec.k)
-        code:=[['REPLACE, name, instantiatedBase,
-                 INTERN('"START1",'"KEYWORD"), count,
-                  INTERN('"START2",'"KEYWORD"), i,
-                   INTERN('"END2",'"KEYWORD"), j+1],:code]
+        code:=[["REPLACE", name, instantiatedBase,
+                 KEYWORD::START1, count,
+                  KEYWORD::START2, i,
+                   KEYWORD::END2, j+1],:code]
     copyvec.i =>
       v:=["getShellEntry",instantiatedBase,i]
       for u in copyvec.i repeat
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 30e253f2..5b07aad2 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -176,6 +176,7 @@ optCallSpecially(q,x,n,R) ==
     nil
  
 optCallEval u ==
+  u is ["Boolean"] => Boolean()
   u is ["List",:.] => List Integer()
   u is ["Vector",:.] => Vector Integer()
   u is ["PrimitiveArray",:.] => PrimitiveArray Integer()
diff --git a/src/interp/macros.lisp b/src/interp/macros.lisp
index edb0b652..809c5c1e 100644
--- a/src/interp/macros.lisp
+++ b/src/interp/macros.lisp
@@ -184,9 +184,6 @@
  
 (defmacro TL (&rest L) `(tail . ,L))
  
- 
-(defmacro SPADCONST (&rest L) (cons 'qrefelt L))
- 
 (DEFUN LASTELEM (X) (car (last X)))
  
 (defun LISTOFATOMS (X)
diff --git a/src/interp/modemap.boot b/src/interp/modemap.boot
index fce0fb46..d836c3ed 100644
--- a/src/interp/modemap.boot
+++ b/src/interp/modemap.boot
@@ -80,7 +80,7 @@ domainMember(dom,domList) == or/[modeEqual(dom,d) for d in domList]
  
 getModemap(x is [op,:.],e) ==
   for modemap in get(op,'modemap,e) repeat
-    if u:= compApplyModemap(x,modemap,e,nil) then return
+    if u:= compApplyModemap(x,modemap,e) then return
       ([.,.,sl]:= u; SUBLIS(sl,modemap))
  
 getUniqueSignature(form,e) ==
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index a5f356f0..dcb5ecbe 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.boot
@@ -775,11 +775,6 @@ NRTputInHead bod ==
   bod is ["QUOTE",:.] => bod
   bod is ["CLOSEDFN",:.] => bod
   bod is ["SPADCONST",dom,ind] =>
-    RPLACA(bod,$elt)
-    dom = '_$ => nil
-    k:= NRTassocIndex dom =>
-      RPLACA(LASTNODE bod,[$elt,'_$,k])
-      bod
     keyedSystemError("S2GE0016",['"NRTputInHead",
        '"unexpected SPADCONST form"])
   NRTputInHead first bod
diff --git a/src/interp/parse.boot b/src/interp/parse.boot
index 2e5febe1..3dacec05 100644
--- a/src/interp/parse.boot
+++ b/src/interp/parse.boot
@@ -285,12 +285,6 @@ parseOr t ==
     parseIf ["IF",y,parseOr ["or",:rest u],"true"]
   parseIf ["IF",x,"true",parseOr ["or",:rest u]]
  
-parseExclusiveOr: %ParseForm -> %Form
-parseExclusiveOr t == 
-  t isnt ["xor",a,b] => systemErrorHere "parseExclusiveOr"
-  parseIf ["IF",a,parseIf ["IF",b,:'(false true)],b]
- 
-
 parseExit: %ParseForm -> %Form
 parseExit t ==
   t isnt ["exit",a,:b] => systemErrorHere "parseExit"
@@ -504,6 +498,5 @@ for x in [["<=", :"parseLessEqual"],_
 	  ["SEGMENT", :"parseSegment"],_
 	  ["SEQ", :"parseSeq"],_
 	  ["VCONS", :"parseVCONS"],_
-	  ["where", :"parseWhere"],_
-          ["xor", :"parseExclusiveOr"]] repeat
+	  ["where", :"parseWhere"]] repeat
   MAKEPROP(first x, "parseTran", rest x)
diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot
index f4468e15..74d7f3bf 100644
--- a/src/interp/sys-constants.boot
+++ b/src/interp/sys-constants.boot
@@ -304,6 +304,10 @@ $BasicPredicates ==
 ++ FIXME: Check that the names on this list are not renamed.
 $SideEffectFreeFunctionList ==
   '(_null    _
+    _not     _
+    _and     _
+    _or      _
+    _xor     _
     _case    _
     Zero     _
     One      _
diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot
index f149f1b2..201a8a71 100644
--- a/src/interp/wi1.boot
+++ b/src/interp/wi1.boot
@@ -83,6 +83,17 @@ addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) ==
                  --Previous line should save some space
   [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist]
 
+
+pmatch(s,p) == pmatchWithSl(s,p,"ok")
+
+pmatchWithSl(s,p,al) ==
+  s=$EmptyMode => nil
+  s=p => al
+  v:= assoc(p,al) => s=rest v or al
+  MEMQ(p,$PatternVariableList) => [[p,:s],:al]
+  null atom p and null atom s and (al':= pmatchWithSl(first s,first p,al)) and
+    pmatchWithSl(rest s,rest p,al')
+
 --======================================================================
 --                    From define.boot
 --======================================================================
diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot
index 85969666..46075fdb 100644
--- a/src/interp/wi2.boot
+++ b/src/interp/wi2.boot
@@ -542,7 +542,7 @@ compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) ==
   not (target':= coerceable(target,m,e)) => nil
   markMap := map
   map:= [target',:rest map]
-  [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil
+  [f,Tl,sl]:= compApplyModemap(form,modemap,e) or return nil
  
   --generate code; return
   T:=
@@ -605,7 +605,8 @@ compElt(origForm,m,E) ==
   compForm(origForm,m,E)
  
 pause op == op
-compApplyModemap(form,modemap,$e,sl) ==
+compApplyModemap(form,modemap,$e) ==
+  sl := nil
   [op,:argl] := form                   --form to be compiled
   [[mc,mr,:margl],:fnsel] := modemap   --modemap we are testing