* interp/compiler.boot (compSeq1): Generate %labelled forms.

	(coerceExit): Likewise.
	(compRepeatOrCollect): Likewise.
	(replaceExitEtc): Tidy.
	(canReturn): Likewise.
	(compIterate): Generate %lave form.
	(nullifyTargetingLeaves): Move out of massageLoop.
	(massageLoop): Adjust.
	* interp/define.boot (compDefineCapsuleFunction): Generate
	%labelled form for the body.
	* interp/g-opt.boot: Now handle %labelled and %leave forms.
	(optLabelled): Rename from optCatch.

4 files changed, 90 insertions, 69 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 914ca6ee..7316184e 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,20 @@
 2011-12-01  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
+	* interp/compiler.boot (compSeq1): Generate %labelled forms.
+	(coerceExit): Likewise.
+	(compRepeatOrCollect): Likewise.
+	(replaceExitEtc): Tidy.
+	(canReturn): Likewise.
+	(compIterate): Generate %lave form.
+	(nullifyTargetingLeaves): Move out of massageLoop.
+	(massageLoop): Adjust.
+	* interp/define.boot (compDefineCapsuleFunction): Generate
+	%labelled form for the body.
+	* interp/g-opt.boot: Now handle %labelled and %leave forms.
+	(optLabelled): Rename from optCatch.
+
+2011-12-01  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
 	* interp/buildom.boot (UnionEqual): Use %lambda, not %lam.
 	(coerceUn2E): Likewise.
 	* interp/compiler.boot (massageLoop): %leave now takes a label as
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index e99173ab..a4ee1cc7 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -1154,7 +1154,7 @@ compSeq1(l,$exitModeStack,e) ==
   if c is "failed" then return nil
   catchTag := MKQ gensym()
   form := ["SEQ",:replaceExitEtc(c,catchTag,"TAGGEDexit",first $exitModeStack)]
-  [["CATCH",catchTag,form],first $exitModeStack,$finalEnv]
+  [['%labelled,catchTag,form],first $exitModeStack,$finalEnv]
 
 compSeqItem(x,m,e) ==
   $insideExpressionIfTrue := false
@@ -1170,10 +1170,10 @@ replaceExitEtc(x,tag,opFlag,opMode) ==
           $finalEnv :=
             $finalEnv ~= nil => intersectionEnvironment($finalEnv,t.env)
             t.env
-          first(x) :=
+          x.op :=
             opFlag is 'TAGGEDreturn => '%return
             second(x) := tag
-            "THROW"
+            '%leave
           third(x) := convertOrCroak(t,opMode).expr
         second(x) := n-1
       x is [key,n,t] and key in '(TAGGEDreturn TAGGEDexit) =>
@@ -1242,7 +1242,7 @@ compIterate(x,m,e) ==
   modifyModeStack(u.mode,index)
   if $loopBodyTag = nil then       -- bound in compRepeatOrCollect
     $loopBodyTag := MKQ gensym()
-  [['THROW,$loopBodyTag,u.expr],u.mode,e]
+  [['%leave,$loopBodyTag,u.expr],u.mode,e]
 
 --% return
 
@@ -1385,12 +1385,12 @@ canReturn(expr,level,exitCount,ValueFlag) ==  --SPAD: exit and friends
   level=exitCount and not ValueFlag => nil
   op is "SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr]
   op is "TAGGEDreturn" => nil
-  op is "CATCH" =>
+  op is '%labelled =>
     [.,gs,data]:= expr
     (findThrow(gs,data,level,exitCount,ValueFlag) => true) where
       findThrow(gs,expr,level,exitCount,ValueFlag) ==
         expr isnt [.,:.] => nil
-        expr is ["THROW", =gs,data] => true
+        expr is ['%leave, =gs,data] => true
             --this is pessimistic, but I know of no more accurate idea
         expr is ["SEQ",:l] =>
           or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l]
@@ -1865,7 +1865,7 @@ coerceExit: (%Triple,%Mode) -> %Maybe %Triple
 coerceExit([x,m,e],m') ==
   m' := resolve(m,m')
   x' := replaceExitEtc(x,catchTag := MKQ gensym(),"TAGGEDexit",$exitMode)
-  coerce([["CATCH",catchTag,x'],m,e],m')
+  coerce([['%labelled,catchTag,x'],m,e],m')
 
 compAtSign: (%Form,%Mode,%Env) -> %Maybe %Triple
 compAtSign(["@",x,m'],m,e) ==
@@ -2413,29 +2413,36 @@ localReferenceIfThere(m,e) ==
   idx := assocIndex(constructorDB currentConstructor e,m) => ['%tref,'$,idx]
   quote m
 
+++ We are processing a loop with entrypoint labelled `tag'.
+++ Attempt to nullify targets of all enclosed %leave forms
+++ that designate `tag'.
+++ NOTES: A %leave form with null target exits the innermost
+++        enclosing labelled expression.
+nullifyTargetingLeaves(x,tag) ==
+  atomic? x => nil
+  x is ['%leave,=tag,expr] =>
+    nullifyTargetingLeaves(expr,tag)
+    -- Avoid redundant %leave for return-expressions.
+    expr is ['TAGGEDreturn,:.] =>
+      x.op := expr.op
+      x.args := expr.args
+    second(x) := nil
+  for x' in x repeat
+    nullifyTargetingLeaves(x',tag)
+
+
 massageLoop x == main x where
   main x ==
-    x isnt ['CATCH,tag,['REPEAT,:iters,body]] => x
-    replaceThrowWithLeave(body,tag)
+    x isnt ['%labelled,tag,['REPEAT,:iters,body]] => x
+    nullifyTargetingLeaves(body,tag)
     containsNonLocalControl?(body,nil) => systemErrorHere ['massageLoop,x]
-    ['CATCH,tag,['%loop,:iters,body,'%nil]]
-  replaceThrowWithLeave(x,tag) ==
-    atomic? x => nil
-    x is ['THROW,=tag,expr] =>
-      replaceThrowWithLeave(expr,tag)
-      -- Avoid redudant THROW for return-expressions.
-      if expr is ['TAGGEDreturn,:.] then
-        x.op := expr.op
-        x.args := expr.args
-      else
-        x.op := '%leave
-        x.args := [nil,:rest x.args]
-    for x' in x repeat replaceThrowWithLeave(x',tag)
+    ['%labelled,tag,['%loop,:iters,body,'%nil]]
   containsNonLocalControl?(x,tags) ==
     atomic? x => false
-    x is ['THROW,tag,x'] =>
+    x is ['%leave,tag,x'] =>
+      tag = nil => false  -- see NOTES in nullifyTargetingLeaves.
       not symbolMember?(tag,tags) or containsNonLocalControl?(x',tags)
-    x is ['CATCH,tag,x'] =>
+    x is ['%labelled,tag,x'] =>
       containsNonLocalControl?(x',[tag,:tags])
     or/[containsNonLocalControl?(x',tags) for x' in x]
 
@@ -2474,7 +2481,7 @@ compRepeatOrCollect(form,m,e) ==
         [body',m',e'] := compOrCroak(body,bodyMode,e) or return nil
         -- Massage the loop body if we have a structured jump.
         if $iterateCount > 0 then
-           body' := ["CATCH",$loopBodyTag,body']
+           body' := ['%labelled,$loopBodyTag,body']
         if $until then
           [untilCode,.,e']:= comp($until,$Boolean,e')
           itl':= substitute(["UNTIL",untilCode],'$until,itl')
diff --git a/src/interp/define.boot b/src/interp/define.boot
index f9a6e6e0..1102f795 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -1910,7 +1910,7 @@ compDefineCapsuleFunction(db,df is ['DEF,form,signature,body],
       catchTag := MKQ gensym()
       body' := replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode)
       body' := addArgumentConditions(body',$op)
-      finalBody := ["CATCH",catchTag,body']
+      finalBody := ['%labelled,catchTag,body']
       compile(db,[op',["LAM",[:argl,'_$],finalBody]],signature)
     $functorStats:= addStats($functorStats,$functionStats)
  
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index c92e326e..5cdf2d66 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -105,8 +105,8 @@ changeVariableDefinitionToStore(form,vars) ==
 jumpToToplevel? x ==
   atomic? x => false
   op := x.op
-  op is 'SEQ => CONTAINED('THROW,x.args) -- FIXME: what about GO?
-  op in '(EXIT THROW %leave) => true
+  op is 'SEQ => CONTAINED('%leave,x.args) -- FIXME: what about GO?
+  op in '(EXIT %leave) => true
   or/[jumpToToplevel? x' for x' in x]
 
 ++ Return true if `form' is just one assignment expression.
@@ -148,21 +148,21 @@ optimizeFunctionDef(def) ==
   [name,[slamOrLam,args,body]] := def'
  
   body':=
-    removeTopLevelCatch body where
-      removeTopLevelCatch body ==
-        body is ["CATCH",g,u] =>
-          removeTopLevelCatch replaceThrowByReturn(u,g)
+    removeTopLevelLabel body where
+      removeTopLevelLabel body ==
+        body is ['%labelled,g,u] =>
+          removeTopLevelLabel replaceLeaveByReturn(u,g)
         body
-      replaceThrowByReturn(x,g) ==
+      replaceLeaveByReturn(x,g) ==
         fn(x,g)
         x
       fn(x,g) ==
-        x is ["THROW", =g,:u] =>
+        x is ['%leave,=g,:u] =>
           x.first := "RETURN"
-          x.rest := replaceThrowByReturn(u,g)
+          x.rest := replaceLeaveByReturn(u,g)
         x isnt [.,:.] => nil
-        replaceThrowByReturn(first x,g)
-        replaceThrowByReturn(rest x,g)
+        replaceLeaveByReturn(first x,g)
+        replaceLeaveByReturn(rest x,g)
   changeVariableDefinitionToStore(body',args)
   [name,[slamOrLam,args,groupVariableDefinitions body']]
 
@@ -198,54 +198,53 @@ subrname u ==
   COMPILED_-FUNCTION_-P u or MBPIP u => BPINAME u
   nil
  
-changeThrowToExit(s,g) ==
+changeLeaveToExit(s,g) ==
   s isnt [.,:.] or s.op in '(QUOTE SEQ REPEAT COLLECT %collect %loop) => nil
-  s is ["THROW", =g,:u] => (s.first := "EXIT"; s.rest := u)
-  changeThrowToExit(first s,g)
-  changeThrowToExit(rest s,g)
+  s is ['%leave, =g,:u] => (s.first := "EXIT"; s.rest := u)
+  changeLeaveToExit(first s,g)
+  changeLeaveToExit(rest s,g)
 
-hasNoThrows(a,g) ==
-  a is ["THROW", =g,:.] => false
+hasNoLeave(a,g) ==
+  a is ['%leave, =g,:.] => false
   a isnt [.,:.] => true
-  hasNoThrows(first a,g) and hasNoThrows(rest a,g)
+  hasNoLeave(first a,g) and hasNoLeave(rest a,g)
 
-changeThrowToGo(s,g) ==
+changeLeaveToGo(s,g) ==
   s isnt [.,:.] or s.op is 'QUOTE => nil
-  s is ["THROW", =g,u] =>
-    changeThrowToGo(u,g)
+  s is ['%leave, =g,u] =>
+    changeLeaveToGo(u,g)
     s.first := "PROGN"
     s.rest := [["%LET",second g,u],["GO",second g]]
-  changeThrowToGo(first s,g)
-  changeThrowToGo(rest s,g)
+  changeLeaveToGo(first s,g)
+  changeLeaveToGo(rest s,g)
 
-++ Change any `(THROW tag (%return expr))' in x to just
+++ Change any `(%leave tag (%return expr))' in x to just
 ++ `(%return expr) since a %return-expression transfers control
 ++ out of the function body anyway.  Similarly, transform
-++ reudant `(THROW tag (THROW tag expr))' to `(THROW tag expr)'.
-removeNeedlessThrow x ==
+++ reudant `('%leave tag (%leave tag expr))' to `(%leave tag expr)'.
+removeNeedlessLeave x ==
   atomic? x => x
-  x is ['THROW,.,y] and y is ['%return,:.] =>
-    removeNeedlessThrow third y
+  x is ['%leave,.,y] and y is ['%return,:.] =>
+    removeNeedlessLeave third y
     x.op := y.op
     x.args := y.args
-  x is ['THROW,g,y] and y is ['THROW,=g,z] =>
-    removeNeedlessThrow z
+  x is ['%leave,g,y] and y is ['%leave,=g,z] =>
+    removeNeedlessLeave z
     second(x.args) := z
   for x' in x repeat
-    removeNeedlessThrow x'
+    removeNeedlessLeave x'
 
-optCatch (x is ["CATCH",g,a]) ==
-  $InteractiveMode => x
+optLabelled (x is ['%labelled,g,a]) ==
   a isnt [.,:.] => a
-  removeNeedlessThrow a
-  if a is ["SEQ",:s,["THROW", =g,u]] then
-    changeThrowToExit(s,g)
+  removeNeedlessLeave a
+  if a is ["SEQ",:s,['%leave,=g,u]] then
+    changeLeaveToExit(s,g)
     a.rest := [:s,["EXIT",u]]
     a := simplifyVMForm a
-  if hasNoThrows(a,g) then
+  if hasNoLeave(a,g) then
     resetTo(x,a)
   else
-    changeThrowToGo(a,g)
+    changeLeaveToGo(a,g)
     x.first := "SEQ"
     x.rest := [["EXIT",a],second g,["EXIT",second g]]
   x
@@ -389,10 +388,10 @@ optIF2COND ["IF",a,b,c] ==
 
 ++ Determine whether the symbol `g' is the name of a temporary that
 ++ can be replaced in the form `x', if it is of linear usage and not
-++ the name of a program point.  The latter occurs when THROW forms
-++ are changed to %LET form followed by a GO form -- see optCatch.
+++ the name of a program point.  The latter occurs when %leave forms
+++ are changed to %LET form followed by a GO form -- see optLabelled.
 replaceableTemporary?(g,x) ==
-  GENSYMP g and numOfOccurencesOf(g,x) < 2 and not jumpTarget?(g,x) where
+  gensym? g and numOfOccurencesOf(g,x) < 2 and not jumpTarget?(g,x) where
     jumpTarget?(g,x) ==
       atomic? x => false
       x is ['GO,=g] => true
@@ -419,7 +418,7 @@ optSEQ ["SEQ",:l] ==
       null aft => ['%when,:transform,'(%otherwise (conderr))]
       optCond ['%when,:transform,['%otherwise,optSEQ ["SEQ",:aft]]]
     tryToRemoveSEQ l ==
-      l is ["SEQ",[op,a]] and op in '(EXIT RETURN THROW) => a
+      l is ["SEQ",[op,a]] and op in '(EXIT RETURN %leave %return) => a
       l
  
 optSuchthat [.,:u] == ["SUCHTHAT",:u]
@@ -841,7 +840,7 @@ for x in '((%call         optCall) _
            (%list        optList)_
            (SPADCALL     optSPADCALL)_
            (_|           optSuchthat)_
-           (CATCH        optCatch)_
+           (%labelled    optLabelled)_
            (%when        optCond)_
            (%retract     optRetract)_
            (%pullback    optPullback)_