* interp/g-util.boot: Implement expansion of %collect forms.

	* interp/c-util.boot (middleEndExpand): Tidy.
	* interp/g-opt.boot (changeThrowToExit): Don't look into %collect
	forms. 
	* interp/i-map.boot (getUserIdentifiersIn): Factorize.  Handle
	%collect forms same as COLLECT forms.
	(findLocalVars1): Likewise.
	* interp/i-spec1.boot (evalCOLLECT): Now generate %collect forms.
	(checkForFreeVariables): Factorize.  Handle %collect forms same as
	COLLECT forms.

6 files changed, 129 insertions, 18 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index ac68364e..d8ef7f6a 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,16 @@
+2010-05-25  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
+	* interp/g-util.boot: Implement expansion of %collect forms.
+	* interp/c-util.boot (middleEndExpand): Tidy.
+	* interp/g-opt.boot (changeThrowToExit): Don't look into %collect
+	forms. 
+	* interp/i-map.boot (getUserIdentifiersIn): Factorize.  Handle
+	%collect forms same as COLLECT forms.
+	(findLocalVars1): Likewise.
+	* interp/i-spec1.boot (evalCOLLECT): Now generate %collect forms.
+	(checkForFreeVariables): Factorize.  Handle %collect forms same as
+	COLLECT forms.
+
 2010-05-24  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
 	* interp/g-util.boot (expandToVMForm): New.  Export.
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index bf47eecb..b030f3b3 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -1073,9 +1073,9 @@ middleEndExpand: %Form -> %Form
 middleEndExpand x ==
   isAtomicForm x => x
   [op,:args] := x
+  IDENTP op and (fun := getOpcodeExpander op) => apply(fun,x,nil)
   op in $middleEndMacroList =>
     middleEndExpand MACROEXPAND_-1 x
-  IDENTP op and (fun := getOpcodeExpander op) => apply(fun,x,nil)
   a := middleEndExpand op
   b := middleEndExpand args
   EQ(a,op) and EQ(b,args) => x
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 0b5d7169..2717312a 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -124,7 +124,7 @@ subrname u ==
   nil
  
 changeThrowToExit(s,g) ==
-  atom s or first s in '(QUOTE SEQ REPEAT COLLECT) => nil
+  atom s or first s in '(QUOTE SEQ REPEAT COLLECT %collect) => nil
   s is ["THROW", =g,:u] => (s.first := "EXIT"; s.rest := u)
   changeThrowToExit(first s,g)
   changeThrowToExit(rest s,g)
diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot
index 3181c0c8..72c05126 100644
--- a/src/interp/g-util.boot
+++ b/src/interp/g-util.boot
@@ -50,12 +50,117 @@ module g_-util where
 --% Opcode expansion to VM codes.
 --%
 
-++ List of opcode-expander pairs.  
-$middleEndOpcodes == nil
+
+--%
+--% Iteration control structures
+--%
+--% Code generation for an iterator produces a sequence of 
+--% length 5, whose components have the following meanings:
+--%  0. list of loop-wide variables and their initializers
+--%  1. list of body-wide variables and their initializers
+--%  2. update code for next iteration
+--%  3. predicate guarding loop body execution
+--%  4. loop termination predicate
+
+++ Generate code that sequentially visits each component of a list.
+expandIN(x,l) ==
+  g := gensym()           -- rest of the list yet to be visited
+  [[[g,middleEndExpand l]],
+    [[x,["CAR",g]]],[["SETQ",g,["CDR",g]]],
+      nil,[["ATOM",g]]]
+
+expandON(x,l) ==
+  [[[x,middleEndExpand l]],nil,[["SETQ",x,["CDR",x]]],nil,[["ATOM",x]]]
+  
+++ Generate code that traverses an interval with lower bound 'lo',
+++ arithmetic progression `step, and possible upper bound `final'.
+expandSTEP(id,lo,step,final)==
+  lo := middleEndExpand lo
+  step := middleEndExpand step
+  final := middleEndExpand final
+  loopvar := [[id,lo]]
+  inc :=
+    isAtomicForm step => step
+    g1 := gensym()
+    loopvar := [:loopvar,[g1,step]]
+    g1
+  final :=
+    atom final => final
+    final is [hi] and isAtomicForm hi => hi
+    g2 := gensym()
+    loopvar := [:loopvar,[g2,:final]]
+    g2
+  ex :=
+     final = nil => nil
+     integer? inc =>
+       pred :=
+	 MINUSP inc => "<"
+	 ">"
+       [[pred,id,final]]
+     [['COND,[['MINUSP,inc],
+	   ["<",id,final]],['T,[">",id,final]]]]
+  suc := [["SETQ",id,["+",id,inc]]]
+  [loopvar,nil,suc,nil,ex]
+
+++ Generate code for iterators that filter out execution state
+++ not satisfying predicate `p'.
+expandSUCHTHAT p == 
+  [nil,nil,nil,[middleEndExpand p],nil]
+
+++ Generate code for iterators that stop loop iteration when the
+++ state fails predicate `p'.
+expandWHILE p == 
+  [nil,nil,nil,nil,[["NOT",middleEndExpand p]]]
+
+expandUNTIL p ==
+  g := gensym()
+  [[[g,false]],nil,[["SETQ",g,middleEndExpand p]],nil,[g]]
+
+expandIterators iters ==
+  [toLisp it or leave "failed" for it in iters] where
+     toLisp it ==
+       it is ["STEP",var,lo,inc,:hi] => expandSTEP(var,lo,inc,hi)
+       it is ["IN",var,seq] => expandIN(var,seq)
+       it is ["ON",var,seq] => expandON(var,seq)
+       it is ["WHILE",pred] => expandWHILE pred
+       it is [op,pred] and op in '(SUCHTHAT _|) => expandSUCHTHAT pred
+       it is ["UNTIL",pred] => expandUNTIL pred
+       nil
+
+++ Generate code for list comprehension.
+expandCollect ["%collect",:iters,body] ==
+  itersCode := expandIterators iters
+  itersCode = "failed" => systemErrorHere ["expandCollect",iters]
+  val := gensym()    -- result of the list comprehension
+  itersCode := "coagulate"/itersCode
+    where
+      coagulate(it1,it2) == [append(it1.k,it2.k) for k in 0..4]
+  [loopInits,bodyInits,cont,filters,exits,value] := itersCode
+  -- Transform the body to build the list as we go.
+  body := ["SETQ",val,["CONS",middleEndExpand body,val]]
+  -- Guard th execution of the body by the filters.
+  if filters ~= nil then
+    body := mkpf([:filters,body],"AND")
+  -- If there is any body-wide initialization, now is the time.
+  if bodyInits ~= nil then
+    body := ["LET",bodyInits,body]
+  if value ~= nil then
+    value := first value
+  exits := ["COND",
+             [mkpf(exits,"OR"),["RETURN",["NREVERSE",val]]],
+               [true,body]]
+  body := ["LOOP",exits,:cont]
+  -- Finally, set up loop-wide initializations.
+  ["LET",[:loopInits,[val,nil]],body]
+
+++ Table of opcode-expander pairs.  
+$OpcodeExpanders == [
+   ["%collect",:"expandCollect"]
+ ]
 
 ++ Return the expander of a middle-end opcode, or nil if there is none.
 getOpcodeExpander op ==
-  x := ASSOC(op,$middleEndOpcodes) => rest x
+  x := ASSOC(op,$OpcodeExpanders) => rest x
   nil
 
 ++ Expand all opcodes contained in the form `x' into a form
diff --git a/src/interp/i-map.boot b/src/interp/i-map.boot
index 331c54fa..9bb6bf4e 100644
--- a/src/interp/i-map.boot
+++ b/src/interp/i-map.boot
@@ -230,7 +230,7 @@ getUserIdentifiersIn body ==
     body="" => nil
     [body]
   body is ["WRAPPED",:.] => nil
-  (body is ["COLLECT",:itl,body1]) or (body is ['REPEAT,:itl,body1]) =>
+  body is [op,:itl,body1] and op in '(COLLECT REPEAT %collect) =>
     userIds :=
       S_+(getUserIdentifiersInIterators itl,getUserIdentifiersIn body1)
     S_-(userIds,getIteratorIds itl)
@@ -1031,7 +1031,7 @@ findLocalVars1(op,form) ==
   form is ['is,l,pattern] =>
     findLocalVars1(op,l)
     for var in listOfVariables rest pattern repeat mkLocalVar(op,var)
-  form is [oper,:itrl,body] and oper in '(REPEAT COLLECT) =>
+  form is [oper,:itrl,body] and oper in '(REPEAT COLLECT %collect) =>
     findLocalsInLoop(op,itrl,body)
   form is [y,:argl] =>
     y is "Record" or (y is "Union" and argl is [[":",.,.],:.]) => 
diff --git a/src/interp/i-spec1.boot b/src/interp/i-spec1.boot
index cf2c649d..769af133 100644
--- a/src/interp/i-spec1.boot
+++ b/src/interp/i-spec1.boot
@@ -544,7 +544,7 @@ evalCOLLECT(op,[:itrl,body],m) ==
   iters := [evalLoopIter itr for itr in itrl]
   bod := getArgValue(body,computedMode body)
   if bod isnt ['SPADCALL,:.] then bod := ['unwrap,bod]
-  code := timedOptimization asTupleNewCode0(second m, ['COLLECT,:iters,bod])
+  code := timedOptimization asTupleNewCode0(second m, ["%collect",:iters,bod])
   putValue(op,object(code,m))
 
 falseFun(x) == nil
@@ -817,20 +817,13 @@ checkForFreeVariables(v,locals) ==
     op in '(LAMBDA QUOTE getValueFromEnvironment) => v
     op = "LETT" => -- Expands to a SETQ.
       ["SETF",:[checkForFreeVariables(a,locals) for a in args]]
-    op = "COLLECT" => -- Introduces a new bound variable?
+    op in '(COLLECT REPEAT %collect) => -- Introduces a new bound variable?
       first(args) is ["STEP",var,:.] =>
        $boundVariables := [var,:$boundVariables]
-       r := ["COLLECT",:[checkForFreeVariables(a,locals) for a in args]]
+       r := [op,:[checkForFreeVariables(a,locals) for a in args]]
        $boundVariables := delete(var,$boundVariables)
        r
-      ["COLLECT",:[checkForFreeVariables(a,locals) for a in args]]
-    op = "REPEAT" => -- Introduces a new bound variable?
-      first(args) is ["STEP",var,:.] =>
-       $boundVariables := [var,:$boundVariables]
-       r := ["REPEAT",:[checkForFreeVariables(a,locals) for a in args]]
-       $boundVariables := delete(var,$boundVariables)
-       r
-      ["REPEAT",:[checkForFreeVariables(a,locals) for a in args]]
+      [op,:[checkForFreeVariables(a,locals) for a in args]]
     op = "%LET" =>
       args is [var,form,name] =>
         -- This is some bizarre %LET, not what one would expect in Common Lisp!