r12470@gauss: gdr | 2008-12-14 17:43:50 -0600

 	Forgot to commit ChangeLog.
 r12471@gauss:  gdr | 2008-12-14 19:11:21 -0600
 	Fix typo in PrimitiveRatRicDE.
 r12472@gauss:  gdr | 2008-12-15 01:40:45 -0600
 	Reformat preparse.lisp.
 r12473@gauss:  gdr | 2008-12-15 03:25:17 -0600
 	Tidy.
 r12474@gauss:  gdr | 2008-12-15 21:33:54 -0600
 	Remove unused codes.
 r12475@gauss:  gdr | 2008-12-15 21:57:22 -0600
 	.
 r12476@gauss:  gdr | 2008-12-15 23:07:49 -0600
 	Tidy fatal diagnostics.
 r12477@gauss:  gdr | 2008-12-15 23:50:02 -0600
 	Fold iterator.boot into compiler.boot.

1 files changed, 280 insertions, 10 deletions

diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index f59babe7..49d99f9a 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -36,7 +36,6 @@ import msgdb
 import pathname
 import modemap
 import define
-import iterator
 namespace BOOT
 
 module compiler where
@@ -83,7 +82,6 @@ reshapeArgumentList: (%Form,%Signature) -> %Form
 applyMapping: (%Form,%Mode,%Env,%List) -> %Maybe %Triple
 compMapCond: (%Symbol,%Mode,%Env,%List) -> %Code
 compMapCond': (%List,%Symbol,%Mode,%Env) -> %Code
-compMapCond'': (%Thing,%Mode) -> %Boolean
 compMapCondFun: (%Thing,%Symbol,%Mode,%Env) -> %Code
 
 
@@ -102,7 +100,6 @@ compTopLevel(x,m,e) ==
   $NRTderivedTargetIfTrue: local := false
   $killOptimizeIfTrue: local:= false
   $forceAdd: local:= false
-  $packagesUsed: local := []
   x is ["DEF",:.] or x is ["where",["DEF",:.],:.] =>
     ([val,mode,.]:= compOrCroak(x,m,e); [val,mode,e])
         --keep old environment after top level function defs
@@ -170,9 +167,6 @@ compNoStacking1(x,m,e,$compStack) ==
 
 comp2(x,m,e) ==
   [y,m',e]:= comp3(x,m,e) or return nil
-  if $LISPLIB and isDomainForm(x,e) then
-      if isFunctor x then
-         $packagesUsed:= insert([opOf x],$packagesUsed)
   --if null atom y and isDomainForm(y,e) then e := addDomain(x,e)
         --line commented out to prevent adding derived domain forms
   m^=m' and ($bootStrapMode or isDomainForm(m',e))=>[y,m',addDomain(m',e)]
@@ -1207,7 +1201,7 @@ canReturn(expr,level,exitCount,ValueFlag) ==  --SPAD: exit and friends
   atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
   op is ["XLAM",args,bods] =>
     and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
-  systemErrorHere '"canReturn" --for the time being
+  systemErrorHere ['"canReturn",expr] --for the time being
 
 compBoolean(p,m,E) ==
   [p',m,E]:= comp(p,m,E) or return nil
@@ -1367,14 +1361,14 @@ compColon([":",f,t],m,e) ==
   f is ["LISTOF",:l] =>
     (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T)
   e:=
-    f is [op,:argl] and not (t is ["Mapping",:.]) =>
+    f is [op,:argl] =>
       --for MPOLY--replace parameters by formal arguments: RDJ 3/83
       newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList),
         [(x is [":",a,m] => a; x) for x in argl],t)
       signature:=
         ["Mapping",newTarget,:
           [(x is [":",a,m] => m;
-              getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]]
+              getmode(x,e) or systemErrorHere ['"compColon",x]) for x in argl]]
       put(op,"mode",signature,e)
     put(f,"mode",t,e)
   if not $bootStrapMode and $insideFunctorIfTrue and
@@ -1600,7 +1594,7 @@ autoCoerceByModemap([x,source,e],target) ==
 ++ vararg operations.
 compComma: (%Form,%Mode,%Env) -> %Maybe %Triple
 compComma(form,m,e) ==
-  form isnt ["%Comma",:argl] => systemErrorHere "compComma"
+  form isnt ["%Comma",:argl] => systemErrorHere ["compComma",form]
   Tl := [comp(a,$EmptyMode,e) or return "failed" for a in argl]
   Tl = "failed" => nil
   -- ??? Ideally, we would like to compile to a Cross type, then
@@ -1885,7 +1879,282 @@ compMatch(["%Match",subject,altBlock],m,e) ==
   [code,m,savedEnv]
 
 
+--%
+--% ITERATORS
+--%
+ 
+compReduce(form,m,e) ==
+ compReduce1(form,m,e,$formalArgList)
+
+compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) ==
+  [collectOp,:itl,body]:= collectForm
+  if STRINGP op then op:= INTERN op
+  ^MEMQ(collectOp,'(COLLECT COLLECTV COLLECTVEC)) =>
+        systemError ["illegal reduction form:",form]
+  $sideEffectsList: local := nil
+  $until: local := nil
+  $initList: local := nil
+  $endTestList: local := nil
+  oldEnv := e
+  $e:= e
+  itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl]
+  itl="failed" => return nil
+  e:= $e
+  acc:= GENSYM()
+  afterFirst:= GENSYM()
+  bodyVal:= GENSYM()
+  [part1,m,e]:= comp(["%LET",bodyVal,body],m,e) or return nil
+  [part2,.,e]:= comp(["%LET",acc,bodyVal],m,e) or return nil
+  [part3,.,e]:= comp(["%LET",acc,parseTran [op,acc,bodyVal]],m,e) or return nil
+  identityCode:=
+    id:= getIdentity(op,e) => u.expr where u() == comp(id,m,e) or return nil
+    ["IdentityError",MKQ op]
+  finalCode:=
+    ["PROGN",
+      ["%LET",afterFirst,nil],
+       ["REPEAT",:itl,
+        ["PROGN",part1,
+          ["IF", afterFirst,part3,
+                   ["PROGN",part2,["%LET",afterFirst,MKQ true]]]]],
+                    ["IF",afterFirst,acc,identityCode]]
+  if $until then
+    [untilCode,.,e]:= comp($until,$Boolean,e)
+    finalCode:= substitute(["UNTIL",untilCode],'$until,finalCode)
+  [finalCode,m,oldEnv]
+
+++ returns the identity element of the `reduction' operation `x'
+++ over a list -- a monoid homomorphism.   
+getIdentity(x,e) ==
+  -- The empty list should be indicated by name, not  by its
+  -- object representation.
+  GETL(x,"THETA") is [y] => (y => y; "nil")
+ 
+numberize x ==
+  x=$Zero => 0
+  x=$One => 1
+  atom x => x
+  [numberize first x,:numberize rest x]
+ 
+compRepeatOrCollect(form,m,e) ==
+  fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList
+    ,e) where
+      fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) ==
+        $until: local := nil
+        oldEnv := e
+        [repeatOrCollect,:itl,body]:= form
+        itl':=
+          [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl]
+        itl'="failed" => nil
+        targetMode:= first $exitModeStack
+        bodyMode:=
+          repeatOrCollect="COLLECT" =>
+            targetMode = '$EmptyMode => '$EmptyMode
+            (u:=modeIsAggregateOf('List,targetMode,e)) =>
+              CADR u
+            (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) =>
+              repeatOrCollect:='COLLECTV
+              CADR u
+            (u:=modeIsAggregateOf('Vector,targetMode,e)) =>
+              repeatOrCollect:='COLLECTVEC
+              CADR u
+            stackMessage('"Invalid collect bodytype")
+            return nil
+            -- If we're doing a collect, and the type isn't conformable
+            -- then we've boobed. JHD 26.July.1990
+          $NoValueMode
+        [body',m',e']:=
+            compOrCroak(body,bodyMode,e) or return nil
+        if $until then
+          [untilCode,.,e']:= comp($until,$Boolean,e')
+          itl':= substitute(["UNTIL",untilCode],'$until,itl')
+        form':= [repeatOrCollect,:itl',body']
+        m'':=
+          repeatOrCollect="COLLECT" =>
+            (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u
+            ["List",m']
+          repeatOrCollect="COLLECTV" =>
+            (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => CAR u
+            ["PrimitiveArray",m']
+          repeatOrCollect="COLLECTVEC" =>
+            (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u
+            ["Vector",m']
+          m'
+        T := coerceExit([form',m'',e'],targetMode) or return nil
+        -- iterator variables and other variables declared in
+        -- in a loop are local to the loop.
+        [T.expr,T.mode,oldEnv]
+ 
+--constructByModemap([x,source,e],target) ==
+--  u:=
+--    [cexpr
+--      for (modemap:= [map,cexpr]) in getModemapList("construct",1,e) | map is [
+--        .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil
+--  fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil
+--  [["call",fn,x],target,e]
+ 
+listOrVectorElementMode x ==
+  x is [a,b,:.] and member(a,'(PrimitiveArray Vector List)) => b
+ 
+compIterator(it,e) ==
+  it is ["IN",x,y] =>
+    --these two lines must be in this order, to get "for f in list f"
+    --to give  an error message if f is undefined
+    [y',m,e]:= comp(y,$EmptyMode,e) or return nil
+    $formalArgList:= [x,:$formalArgList]
+    [mOver,mUnder]:=
+      modeIsAggregateOf("List",m,e) or return
+         stackMessage('"mode: %1pb must be a list of some mode",[m])
+    if null get(x,"mode",e) then [.,.,e]:=
+      compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil
+    e:= put(x,"value",[genSomeVariable(),mUnder,e],e)
+    [y'',m'',e] := coerce([y',m,e], mOver) or return nil
+    [["IN",x,y''],e]
+  it is ["ON",x,y] =>
+    $formalArgList:= [x,:$formalArgList]
+    [y',m,e]:= comp(y,$EmptyMode,e) or return nil
+    [mOver,mUnder]:=
+      modeIsAggregateOf("List",m,e) or return
+        stackMessage('"mode: %1pb must be a list of other modes",[m])
+    if null get(x,"mode",e) then [.,.,e]:=
+      compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil
+    e:= put(x,"value",[genSomeVariable(),m,e],e)
+    [y'',m'',e] := coerce([y',m,e], mOver) or return nil
+    [["ON",x,y''],e]
+  it is ["STEP",index,start,inc,:optFinal] =>
+    $formalArgList:= [index,:$formalArgList]
+    --if all start/inc/end compile as small integers, then loop
+    --is compiled as a small integer loop
+    final':= nil
+    (start':= comp(start,$SmallInteger,e)) and
+      (inc':= comp(inc,$NonNegativeInteger,start'.env)) and
+        (not (optFinal is [final]) or
+          (final':= comp(final,$SmallInteger,inc'.env))) =>
+            indexmode:=
+              comp(start,$NonNegativeInteger,e) =>
+                      $NonNegativeInteger
+              $SmallInteger
+            if null get(index,"mode",e) then [.,.,e]:=
+              compMakeDeclaration([":",index,indexmode],$EmptyMode,
+                (final' => final'.env; inc'.env)) or return nil
+            e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
+            if final' then optFinal:= [final'.expr]
+            [["ISTEP",index,start'.expr,inc'.expr,:optFinal],e]
+    [start,.,e]:=
+      comp(start,$Integer,e) or return
+        stackMessage('"start value of index: %1b must be an integer",[start])
+    [inc,.,e]:=
+      comp(inc,$Integer,e) or return
+        stackMessage('"index increment: %1b must be an integer",[inc])
+    if optFinal is [final] then
+      [final,.,e]:=
+        comp(final,$Integer,e) or return
+          stackMessage('"final value of index: %1b must be an integer",[final])
+      optFinal:= [final]
+    indexmode:=
+      comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger
+      $Integer
+    if null get(index,"mode",e) then [.,.,e]:=
+      compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil
+    e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
+    [["STEP",index,start,inc,:optFinal],e]
+  it is ["WHILE",p] =>
+    [p',m,e]:=
+      comp(p,$Boolean,e) or return
+        stackMessage('"WHILE operand: %1b is not Boolean valued",[p])
+    [["WHILE",p'],e]
+  it is ["UNTIL",p] => ($until:= p; ['$until,e])
+  it is ["|",x] =>
+    u:=
+      comp(x,$Boolean,e) or return
+        stackMessage('"SUCHTHAT operand: %1b is not Boolean value",[x])
+    [["|",u.expr],u.env]
+  nil
+ 
+--isAggregateMode(m,e) ==
+--  m is [c,R] and MEMQ(c,'(Vector List)) => R
+--  name:=
+--    m is [fn,:.] => fn
+--    m="$" => "Rep"
+--    m
+--  get(name,"value",e) is [c,R] and MEMQ(c,'(Vector List)) => R
+ 
+modeIsAggregateOf(ListOrVector,m,e) ==
+  m is [ =ListOrVector,R] => [m,R]
+--m = '$EmptyMode => [m,m] I don't think this is correct, breaks POLY +
+  m is ["Union",:l] =>
+    mList:= [pair for m' in l | (pair:= modeIsAggregateOf(ListOrVector,m',e))]
+    1=#mList => first mList
+  name:=
+    m is [fn,:.] => fn
+    m="$" => "Rep"
+    m
+  get(name,"value",e) is [[ =ListOrVector,R],:.] => [m,R]
+ 
+--% VECTOR ITERATORS
+ 
+--the following 4 functions are not currently used
+ 
+compCollectV(form,m,e) ==
+  fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],e) where
+    fn(form,$exitModeStack,$leaveLevelStack,e) ==
+      [repeatOrCollect,it,body]:= form
+      [it',e]:= compIteratorV(it,e) or return nil
+      m:= first $exitModeStack
+      [mOver,mUnder]:= modeIsAggregateOf("Vector",m,e) or $EmptyMode
+      [body',m',e']:= compOrCroak(body,mUnder,e) or return nil
+      form':= ["COLLECTV",it',body']
+      n:=
+	it' is ["STEP",.,s,i,f] or it' is ["ISTEP",.,s,i,f] =>
+	      computeMaxIndex(s,f,i);
+	return nil
+      coerce([form',mOver,e'],m)
+
+compIteratorV(it,e) ==
+  it is ["STEP",index,start,inc,final] =>
+    (start':= comp(start,$Integer,e)) and
+      (inc':= comp(inc,$NonNegativeInteger,start'.env)) and
+       (final':= comp(final,$Integer,inc'.env)) =>
+	indexmode:=
+	  comp(start,$NonNegativeInteger,e) => $NonNegativeInteger
+	  $Integer
+	if null get(index,"mode",e) then [.,.,e]:=
+	  compMakeDeclaration([":",index,indexmode],$EmptyMode,final'.env) or
+	    return nil
+	e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
+	[["ISTEP",index,start'.expr,inc'.expr,final'.expr],e]
+    [start,.,e]:=
+      comp(start,$Integer,e) or return
+	stackMessage('"start value of index: %1b is not an integer",[start])
+    [inc,.,e]:=
+      comp(inc,$NonNegativeInteger,e) or return
+	stackMessage('"index increment: %1b must be a non-negative integer",
+          [inc])
+    [final,.,e]:=
+      comp(final,$Integer,e) or return
+	stackMessage('"final value of index: %1b is not an integer",[final])
+    indexmode:=
+      comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger
+      $Integer
+    if null get(index,"mode",e) then [.,.,e]:=
+      compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil
+    e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
+    [["STEP",index,start,inc,final],e]
+  nil
+
+computeMaxIndex(s,f,i) ==
+  i^=1 => cannotDo()
+  s=1 => f
+  exprDifference(f,exprDifference(s,1))
+
+exprDifference(x,y) ==
+  y=0 => x
+  FIXP x and FIXP y => DIFFERENCE(x,y)
+  ["DIFFERENCE",x,y]
+ 
+
+--%
 --% Entry point to the compiler
+--%
 
 preprocessParseTree pt ==
   $postStack := []
@@ -1919,6 +2188,7 @@ compileParseTree pt ==
   TERPRI()
 
 
+--%
 --% Register compilers for special forms.
 -- Those compilers are on the `SPECIAL' property of the corresponding
 -- special form operator symbol.