* interp/g-util.boot (hasNoLeave?): Move from g-opt.boot.

	(mkLabelled): New.
	(mkBind): Likewise.
	* interp/g-opt.boot (groupVariableDefinitions): Use them.
	* algebra/aggcat.spad.pamphlet (ListAggregate) [merge!]: Declare
	local variables `r' and `s' before assigning to them.

4 files changed, 46 insertions, 23 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 05dbc0cb..6f3f808a 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,14 @@
 2011-12-02  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
+	* interp/g-util.boot (hasNoLeave?): Move from g-opt.boot.
+	(mkLabelled): New.
+	(mkBind): Likewise.
+	* interp/g-opt.boot (groupVariableDefinitions): Use them.
+	* algebra/aggcat.spad.pamphlet (ListAggregate) [merge!]: Declare
+	local variables `r' and `s' before assigning to them.
+
+2011-12-02  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
 	* interp/g-opt.boot (iteratorName): New.
 	(changeLoopVarDefsToStore): Likewise.
 	(changeVariableDefinitionToStore): Use it.  Tidy.
diff --git a/src/algebra/aggcat.spad.pamphlet b/src/algebra/aggcat.spad.pamphlet
index 3d0e1e14..ab9eb619 100644
--- a/src/algebra/aggcat.spad.pamphlet
+++ b/src/algebra/aggcat.spad.pamphlet
@@ -2353,6 +2353,8 @@ ListAggregate(S:Type): Category == Join(StreamAggregate S,
      empty? p => q
      empty? q => p
      eq?(p, q) => error "cannot merge a list into itself"
+     r: %
+     t: %
      if f(first p, first q)
        then (r := t := p; p := rest p)
        else (r := t := q; q := rest q)
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 64cde531..a53f6fb9 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -171,29 +171,23 @@ groupVariableDefinitions form ==
       second(clause) := groupVariableDefinitions second clause
     form
   form is ['%labelled,tag,expr] =>
-    expr := groupVariableDefinitions expr
-    expr is ['%bind,inits,expr'] and
-      (and/[hasNoLeave init for [.,init] in inits]) =>
-        ['%bind,inits,['%labelled,tag,expr']]
-    [form.op,tag,expr]
+    mkLabelled(tag,groupVariableDefinitions expr)
   form is ['%bind,inits,expr] =>
-    expr := groupVariableDefinitions expr
-    expr is ['%bind,inits',expr'] => ['%bind,[:inits,:inits'],expr']
-    [form.op,inits,expr]
+    mkBind(inits,groupVariableDefinitions expr)
   form is ['%lambda,:.] =>
     [form.absKind,form.absParms,groupVariableDefinitions form.absBody]
   form is ['%loop,:iters,body,val] =>
     [form.op,:iters,groupVariableDefinitions body,val]
   form isnt ['%seq,:stmts,['%exit,val]] => form
-  defs := nil
-  for x in stmts while nonExitingSingleAssignment? x  repeat
-    defs := [x.args,:defs]
-  defs = nil or jumpToToplevel? defs => form
+  form.args = nil => nil
+  form.args is [s] => groupVariableDefinitions s
+  defs := [s.args for s in stmts while nonExitingSingleAssignment? s]
+  defs = nil => form
   stmts := drop(#defs,stmts)
   expr :=
     stmts = nil => val
     ['%seq,:stmts,['%exit,val]]
-  ['%bind,reverse! defs,expr]
+  mkBind(defs,expr)
 
 optimizeFunctionDef(def) ==
   if $reportOptimization then
@@ -227,8 +221,8 @@ optimizeFunctionDef(def) ==
   [name,[slamOrLam,args,body']]
 
 resetTo(x,y) ==
-  y isnt [.,:.] => x := y
-  sameObject?(x,y) => x
+  y isnt [.,:.] => y
+  sameObject?(x,y) => y
   x.first := y.first
   x.rest := y.rest
   x
@@ -266,11 +260,6 @@ changeLeaveToExit(s,g) ==
   changeLeaveToExit(first s,g)
   changeLeaveToExit(rest s,g)
 
-hasNoLeave(a,g) ==
-  a is ['%leave, =g,:.] => false
-  a isnt [.,:.] => true
-  hasNoLeave(first a,g) and hasNoLeave(rest a,g)
-
 changeLeaveToGo(s,g) ==
   s isnt [.,:.] or s.op is 'QUOTE => nil
   s is ['%leave, =g,u] =>
@@ -303,9 +292,9 @@ optLabelled (x is ['%labelled,g,a]) ==
     changeLeaveToExit(s,g)
     a.rest := [:s,['%exit,u]]
     a := simplifyVMForm a
-  if hasNoLeave(a,g) then
-    resetTo(x,a)
-  else
+  a isnt [.,:.] => a
+  do
+    hasNoLeave?(a,g) => resetTo(x,a)
     changeLeaveToGo(a,g)
     x.first := '%seq
     x.rest := [['%exit,a],second g,['%exit,second g]]
diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot
index 18ada7f8..b9a6e99c 100644
--- a/src/interp/g-util.boot
+++ b/src/interp/g-util.boot
@@ -48,6 +48,29 @@ module g_-util where
 
 --%
 
+hasNoLeave?(expr,g) ==
+  expr is ['%leave, =g,:.] => false
+  expr isnt [.,:.] => true
+  hasNoLeave?(first expr,g) and hasNoLeave?(rest expr,g)
+
+mkLabelled(tag,expr) ==
+  expr is ['%leave,=tag,expr'] and hasNoLeave?(expr',tag) => expr'
+  expr is ['%bind,inits,expr'] and hasNoLeave?(inits,tag) =>
+    mkBind(inits,mkLabelled(tag,expr'))
+  hasNoLeave?(expr,tag) => expr
+  ['%labelled,tag,expr]
+
+mkBind(inits,expr) ==
+  expr is ['%leave,tag,expr'] =>
+    ['%leave,tag,mkBind(inits,expr')]
+  expr is ['%bind,inits',expr'] =>
+    mkBind([:inits,:inits'],expr')
+  ['%bind,inits,expr]
+
+
+
+--%
+
 ++ List of category constructors that do not have entries in the 
 ++ constructor database. So, they are mostly recognized by their names.
 $CategoryNames ==