diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/compiler.boot | 70 | ||||
| -rw-r--r-- | src/interp/define.boot | 2 | ||||
| -rw-r--r-- | src/interp/g-opt.boot | 6 | ||||
| -rw-r--r-- | src/interp/g-util.boot | 12 | ||||
| -rw-r--r-- | src/interp/i-map.boot | 4 | ||||
| -rw-r--r-- | src/interp/i-spec1.boot | 4 | ||||
| -rw-r--r-- | src/interp/nruncomp.boot | 2 |
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 |