* interp/compiler.boot (canReturn): Handle %when and %bind.

(compMatchAlternative): Generate %bind form. (compMatch): Likewise. (compReduce1): Rewrite. (getIdentity): Tidy. * interp/g-opt.boot (changeThrowToExit): HAndle %reduce. (varIsAssigned): %store is side-effectful. * interp/g-util.boot (expandReduce): New. Expand %reduce forms. * interp/i-map.boot (getUserIdentifiersIn): Handle %reduce. (findLocalVars1): Likewise. * interp/i-spec1.boot (checkForFreeVariables): Likewise.
author: dos-reis <gdr@axiomatics.org> 2010-06-09 16:00:43 +0000
committer: dos-reis <gdr@axiomatics.org> 2010-06-09 16:00:43 +0000
commit: 050ebc37a782f65ea7d305d32d79f1427057787f (patch)
tree: d2227523738cb9819c4f694089209d9eb65b39ec /src/interp
parent: 4e8ea57821d8deaccd9ffb47ff7a4a7f505880c5 (diff)
download: open-axiom-050ebc37a782f65ea7d305d32d79f1427057787f.tar.gz
7 files changed, 54 insertions, 46 deletions
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 6323bf51..7ac0ce3e 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -1229,7 +1229,7 @@ canReturn(expr,level,exitCount,ValueFlag) ==  --SPAD: exit and friends
           or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l]
         or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr]
     canReturn(data,level,exitCount,ValueFlag)
-  op = "COND" =>
+  op = "COND" or op = '%when =>
     level = exitCount =>
       or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr]
     or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v]
@@ -1241,7 +1241,7 @@ canReturn(expr,level,exitCount,ValueFlag) ==  --SPAD: exit and friends
       pp expr
     canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag)
       or canReturn(c,level,exitCount,ValueFlag)
-  op = "LET" or op = "LET*" =>
+  op in '(LET LET_* %bind) =>
     or/[canReturn(init,level,exitCount,false) for [.,init] in second expr]
        or canReturn(third expr,level,exitCount,ValueFlag)
   --now we have an ordinary form
@@ -2145,7 +2145,7 @@ compMatchAlternative(sn,sm,pat,stmt,m,e) ==
   body :=
     null inits => stmtT.expr
     atom sn => ["LET",inits,stmtT.expr]
-    ["LET*",inits,stmtT.expr]
+    ["%bind",inits,stmtT.expr]
   [[guard,body],stmtT.mode,stmtT.env,eF]
 
 ++ Analyze and generate code for `is case'-pattern where the
@@ -2171,7 +2171,7 @@ compMatch(["%Match",subject,altBlock],m,env) ==
     stackAndThrow('"missing %b otherwise %d alternative in case pattern",nil)
   code := 
     atom sn => ["LET",[[sn,se]],["COND",:nreverse altsCode]]
-    ["LET*",[[n,e] for n in sn for e in rest se], 
+    ["%bind",[[n,e] for n in sn for e in rest se], 
        ["COND",:nreverse altsCode]]
   [code,m,savedEnv]
 
@@ -2205,46 +2205,48 @@ compReduce(form,m,e) ==
  compReduce1(form,m,e,$formalArgList)
 
 compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) ==
-  [collectOp,:itl,body]:= collectForm
-  if string? op then op:= INTERN op
+  [collectOp,:itl,body] := collectForm
+  if string? op then op := INTERN op
   collectOp ~= "COLLECT" => 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 := [([.,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
+  b := gensym()          -- holds value of the body
+  [bval,bmode,e] := comp(['%LET,b,body],$EmptyMode,e) or return nil
+  accu := gensym()       -- holds value of the accumulator
+  [move,.,e] := comp(['%LET,accu,b],$EmptyMode,e) or return nil
+  move.op := '%store     -- in reality, we are not defining a new variable
+  [update,mode,e] := comp(['%LET,accu,[op,accu,b]],m,e) or return nil
+  update.op := '%store   -- just update the accumulation variable.
+  nval :=
+    id := getIdentity(op,e) => u.expr where
+      u() == comp(id,mode,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]
+    [untilCode,.,e]:= comp($until,$Boolean,e) or return nil
+    itl := substitute(["UNTIL",untilCode],'$until,itl)
+  firstTime := gensym()
+  finalCode := ['%reduce,
+                 ['%init,accu,'%nil],['%init,firstTime,'%true],:itl,
+                   ['%when,[firstTime,nval],['%otherwise,accu]],
+                     ['%bind,[[b,third bval]],
+                       ['%when,[firstTime,move],['%otherwise,update]],
+                         ['%store,firstTime,'%false]]]
+  T := coerce([finalCode,mode,e],m) or return nil
+  [T.expr,T.mode,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")
+  GETL(x,"THETA") is [y] =>
+    y = 0 => $Zero
+    y = 1 => $One
+    -- The empty list should be indicated by name, not  by its
+    -- object representation.
+    y => y
+    "nil"
+  nil
  
 numberize x ==
   x=$Zero => 0
diff --git a/src/interp/define.boot b/src/interp/define.boot
index cc247270..d40033e0 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -501,7 +501,7 @@ compDefineCategory2(form,signature,specialCases,body,m,e,
         ['sublisV,['PAIR,['QUOTE,sargl],['LIST,:
           [['devaluate,u] for u in sargl]]],body]
     body:=
-      ["%Bind",[[g:= gensym(),body]],
+      ["%bind",[[g:= gensym(),body]],
          ["setShellEntry",g,0,mkConstructor $form],g]
     fun:= compile [op',["LAM",sargl,body]]
  
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 3557f554..dae16cde 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 %collect %repeat) => nil
+  atom s or first s in '(QUOTE SEQ REPEAT COLLECT %collect %repeat %reduce) => nil
   s is ["THROW", =g,:u] => (s.first := "EXIT"; s.rest := u)
   changeThrowToExit(first s,g)
   changeThrowToExit(rest s,g)
@@ -480,7 +480,7 @@ findVMFreeVars form ==
 ++ in `form'.
 varIsAssigned(var,form) ==
   isAtomicForm form => false
-  form is [op,=var,:.] and op in '(%LET LETT SETQ) => true
+  form is [op,=var,:.] and op in '(%LET LETT SETQ %store) => true
   or/[varIsAssigned(var,f) for f in form]
 
 ++ Subroutine of optLET.  Return true if the variable `var' locally
@@ -621,7 +621,7 @@ for x in '( (%Call         optCall) _
            (SEQ          optSEQ)_
            (LET          optLET)_
            (LET_*        optLET_*)_
-           (%Bind        optBind)_
+           (%bind        optBind)_
            (LIST         optLIST)_
            (MINUS        optMINUS)_
            (QSMINUS      optQSMINUS)_
diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot
index ac31d47e..e6926643 100644
--- a/src/interp/g-util.boot
+++ b/src/interp/g-util.boot
@@ -200,7 +200,7 @@ expandLoop(iters,body,ret) ==
   if bodyInits ~= nil then
     body := ["LET",bodyInits,body]
   exits := ["COND",
-             [mkpf(exits,"OR"),["RETURN",ret]],
+             [mkpf(exits,"OR"),["RETURN",expandToVMForm ret]],
                [true,body]]
   body := ["LOOP",exits,:cont]
   -- Finally, set up loop-wide initializations.
@@ -221,6 +221,9 @@ expandCollect ["%collect",:iters,body] ==
 expandRepeat ["%repeat",:iters,body] ==
   expandLoop(iters,body,["voidValue"])
 
+expandReduce ['%reduce,:iters,val,body] ==
+  expandLoop(iters,body,val)
+
 expandReturn(x is ['%return,.,y]) ==
   $FUNNAME = nil => systemErrorHere ['expandReturn,x]
   ['RETURN_-FROM,$FUNNAME,expandToVMForm y]
@@ -334,14 +337,17 @@ for x in [
     ['%string?, :'STRINGP],
 
     -- general utility
-    ['%hash,:'SXHASH],
-    ['%lam, :'LAMBDA]
+    ['%hash,     :'SXHASH],
+    ['%lam,      :'LAMBDA],
+    ['%otherwise,:'T],
+    ['%when,     :'COND]
   ] repeat property(first x,'%Rename) := rest x
 
 ++ Table of opcode-expander pairs.  
 for x in [
    ["%collect",:function expandCollect],
    ["%repeat",:function expandRepeat],
+   ['%reduce, :function expandReduce],
    ['%return,  :function expandReturn],
 
    ["%eq",:function expandEq],
diff --git a/src/interp/i-map.boot b/src/interp/i-map.boot
index 90db927f..a0ed9d15 100644
--- a/src/interp/i-map.boot
+++ b/src/interp/i-map.boot
@@ -226,7 +226,7 @@ getUserIdentifiersIn body ==
     body = $ClearBodyToken => nil
     [body]
   body is ["WRAPPED",:.] => nil
-  body is [op,:itl,body1] and op in '(COLLECT REPEAT %collect) =>
+  body is [op,:itl,body1] and op in '(COLLECT REPEAT %repeat %collect %reduce) =>
     userIds :=
       S_+(getUserIdentifiersInIterators itl,getUserIdentifiersIn body1)
     S_-(userIds,getIteratorIds itl)
@@ -1026,7 +1026,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 %collect %repeat) =>
+  form is [oper,:itrl,body] and oper in '(REPEAT COLLECT %collect %repeat %reduce) =>
     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 f6d51ed9..c297582e 100644
--- a/src/interp/i-spec1.boot
+++ b/src/interp/i-spec1.boot
@@ -815,7 +815,7 @@ checkForFreeVariables(v,locals) ==
     op in '(LAMBDA QUOTE getValueFromEnvironment) => v
     op = "LETT" => -- Expands to a SETQ.
       ["SETF",:[checkForFreeVariables(a,locals) for a in args]]
-    op in '(COLLECT REPEAT %collect %repeat) =>
+    op in '(COLLECT REPEAT %collect %repeat %reduce) =>
       first(args) is ["STEP",var,:.] =>
        $boundVariables := [var,:$boundVariables]
        r := [op,:[checkForFreeVariables(a,locals) for a in args]]
@@ -834,7 +834,7 @@ checkForFreeVariables(v,locals) ==
           ["getSimpleArrayEntry","envArg",positionInVec(0,#($freeVariables))]
         ["SETF",newvar,checkForFreeVariables(form,locals)]
       error "Non-simple variable bindings are not currently supported"
-    op in '(LET LET_* %Bind) =>
+    op in '(LET LET_* %bind) =>
       vars := [first init for init in first args]
       inits := [checkInit(init,locals) for init in first args] where
                   checkInit([var,init],locals) ==
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index 7d24c275..71cd6a21 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.boot
@@ -516,7 +516,7 @@ buildFunctor($definition is [name,:args],sig,code,$locals,$e) ==
       name='Integer => nil
       $ConstantAssignments
     epilogue:= $epilogue
-  ans := ["%Bind",bindings,
+  ans := ["%bind",bindings,
            :washFunctorBody optFunctorBody
               [:codePart1,:codePart2,:codePart3],"$"]
   $getDomainCode:= nil
author	dos-reis <gdr@axiomatics.org>	2010-06-09 16:00:43 +0000
committer	dos-reis <gdr@axiomatics.org>	2010-06-09 16:00:43 +0000
commit	050ebc37a782f65ea7d305d32d79f1427057787f (patch)
tree	d2227523738cb9819c4f694089209d9eb65b39ec /src/interp
parent	4e8ea57821d8deaccd9ffb47ff7a4a7f505880c5 (diff)
download	open-axiom-050ebc37a782f65ea7d305d32d79f1427057787f.tar.gz