diff options
Diffstat (limited to 'src/interp/compiler.boot')
| -rw-r--r-- | src/interp/compiler.boot | 290 |
1 files changed, 280 insertions, 10 deletions
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index f59babe7..49d99f9a 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -36,7 +36,6 @@ import msgdb import pathname import modemap import define -import iterator namespace BOOT module compiler where @@ -83,7 +82,6 @@ reshapeArgumentList: (%Form,%Signature) -> %Form applyMapping: (%Form,%Mode,%Env,%List) -> %Maybe %Triple compMapCond: (%Symbol,%Mode,%Env,%List) -> %Code compMapCond': (%List,%Symbol,%Mode,%Env) -> %Code -compMapCond'': (%Thing,%Mode) -> %Boolean compMapCondFun: (%Thing,%Symbol,%Mode,%Env) -> %Code @@ -102,7 +100,6 @@ compTopLevel(x,m,e) == $NRTderivedTargetIfTrue: local := false $killOptimizeIfTrue: local:= false $forceAdd: local:= false - $packagesUsed: local := [] x is ["DEF",:.] or x is ["where",["DEF",:.],:.] => ([val,mode,.]:= compOrCroak(x,m,e); [val,mode,e]) --keep old environment after top level function defs @@ -170,9 +167,6 @@ compNoStacking1(x,m,e,$compStack) == comp2(x,m,e) == [y,m',e]:= comp3(x,m,e) or return nil - if $LISPLIB and isDomainForm(x,e) then - if isFunctor x then - $packagesUsed:= insert([opOf x],$packagesUsed) --if null atom y and isDomainForm(y,e) then e := addDomain(x,e) --line commented out to prevent adding derived domain forms m^=m' and ($bootStrapMode or isDomainForm(m',e))=>[y,m',addDomain(m',e)] @@ -1207,7 +1201,7 @@ canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] op is ["XLAM",args,bods] => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] - systemErrorHere '"canReturn" --for the time being + systemErrorHere ['"canReturn",expr] --for the time being compBoolean(p,m,E) == [p',m,E]:= comp(p,m,E) or return nil @@ -1367,14 +1361,14 @@ compColon([":",f,t],m,e) == f is ["LISTOF",:l] => (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T) e:= - f is [op,:argl] and not (t is ["Mapping",:.]) => + f is [op,:argl] => --for MPOLY--replace parameters by formal arguments: RDJ 3/83 newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList), [(x is [":",a,m] => a; x) for x in argl],t) signature:= ["Mapping",newTarget,: [(x is [":",a,m] => m; - getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]] + getmode(x,e) or systemErrorHere ['"compColon",x]) for x in argl]] put(op,"mode",signature,e) put(f,"mode",t,e) if not $bootStrapMode and $insideFunctorIfTrue and @@ -1600,7 +1594,7 @@ autoCoerceByModemap([x,source,e],target) == ++ vararg operations. compComma: (%Form,%Mode,%Env) -> %Maybe %Triple compComma(form,m,e) == - form isnt ["%Comma",:argl] => systemErrorHere "compComma" + form isnt ["%Comma",:argl] => systemErrorHere ["compComma",form] Tl := [comp(a,$EmptyMode,e) or return "failed" for a in argl] Tl = "failed" => nil -- ??? Ideally, we would like to compile to a Cross type, then @@ -1885,7 +1879,282 @@ compMatch(["%Match",subject,altBlock],m,e) == [code,m,savedEnv] +--% +--% ITERATORS +--% + +compReduce(form,m,e) == + compReduce1(form,m,e,$formalArgList) + +compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == + [collectOp,:itl,body]:= collectForm + if STRINGP op then op:= INTERN op + ^MEMQ(collectOp,'(COLLECT COLLECTV COLLECTVEC)) => + 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="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 + ["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] + +++ 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") + +numberize x == + x=$Zero => 0 + x=$One => 1 + atom x => x + [numberize first x,:numberize rest x] + +compRepeatOrCollect(form,m,e) == + fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList + ,e) where + fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == + $until: local := nil + oldEnv := e + [repeatOrCollect,:itl,body]:= form + itl':= + [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] + itl'="failed" => nil + targetMode:= first $exitModeStack + bodyMode:= + repeatOrCollect="COLLECT" => + targetMode = '$EmptyMode => '$EmptyMode + (u:=modeIsAggregateOf('List,targetMode,e)) => + CADR u + (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => + repeatOrCollect:='COLLECTV + CADR u + (u:=modeIsAggregateOf('Vector,targetMode,e)) => + repeatOrCollect:='COLLECTVEC + CADR u + stackMessage('"Invalid collect bodytype") + return nil + -- If we're doing a collect, and the type isn't conformable + -- then we've boobed. JHD 26.July.1990 + $NoValueMode + [body',m',e']:= + compOrCroak(body,bodyMode,e) or return nil + if $until then + [untilCode,.,e']:= comp($until,$Boolean,e') + itl':= substitute(["UNTIL",untilCode],'$until,itl') + form':= [repeatOrCollect,:itl',body'] + m'':= + repeatOrCollect="COLLECT" => + (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u + ["List",m'] + repeatOrCollect="COLLECTV" => + (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => CAR u + ["PrimitiveArray",m'] + repeatOrCollect="COLLECTVEC" => + (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u + ["Vector",m'] + m' + T := coerceExit([form',m'',e'],targetMode) or return nil + -- iterator variables and other variables declared in + -- in a loop are local to the loop. + [T.expr,T.mode,oldEnv] + +--constructByModemap([x,source,e],target) == +-- u:= +-- [cexpr +-- for (modemap:= [map,cexpr]) in getModemapList("construct",1,e) | map is [ +-- .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil +-- fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil +-- [["call",fn,x],target,e] + +listOrVectorElementMode x == + x is [a,b,:.] and member(a,'(PrimitiveArray Vector List)) => b + +compIterator(it,e) == + it is ["IN",x,y] => + --these two lines must be in this order, to get "for f in list f" + --to give an error message if f is undefined + [y',m,e]:= comp(y,$EmptyMode,e) or return nil + $formalArgList:= [x,:$formalArgList] + [mOver,mUnder]:= + modeIsAggregateOf("List",m,e) or return + stackMessage('"mode: %1pb must be a list of some mode",[m]) + if null get(x,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil + e:= put(x,"value",[genSomeVariable(),mUnder,e],e) + [y'',m'',e] := coerce([y',m,e], mOver) or return nil + [["IN",x,y''],e] + it is ["ON",x,y] => + $formalArgList:= [x,:$formalArgList] + [y',m,e]:= comp(y,$EmptyMode,e) or return nil + [mOver,mUnder]:= + modeIsAggregateOf("List",m,e) or return + stackMessage('"mode: %1pb must be a list of other modes",[m]) + if null get(x,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil + e:= put(x,"value",[genSomeVariable(),m,e],e) + [y'',m'',e] := coerce([y',m,e], mOver) or return nil + [["ON",x,y''],e] + it is ["STEP",index,start,inc,:optFinal] => + $formalArgList:= [index,:$formalArgList] + --if all start/inc/end compile as small integers, then loop + --is compiled as a small integer loop + final':= nil + (start':= comp(start,$SmallInteger,e)) and + (inc':= comp(inc,$NonNegativeInteger,start'.env)) and + (not (optFinal is [final]) or + (final':= comp(final,$SmallInteger,inc'.env))) => + indexmode:= + comp(start,$NonNegativeInteger,e) => + $NonNegativeInteger + $SmallInteger + if null get(index,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",index,indexmode],$EmptyMode, + (final' => final'.env; inc'.env)) or return nil + e:= put(index,"value",[genSomeVariable(),indexmode,e],e) + if final' then optFinal:= [final'.expr] + [["ISTEP",index,start'.expr,inc'.expr,:optFinal],e] + [start,.,e]:= + comp(start,$Integer,e) or return + stackMessage('"start value of index: %1b must be an integer",[start]) + [inc,.,e]:= + comp(inc,$Integer,e) or return + stackMessage('"index increment: %1b must be an integer",[inc]) + if optFinal is [final] then + [final,.,e]:= + comp(final,$Integer,e) or return + stackMessage('"final value of index: %1b must be an integer",[final]) + optFinal:= [final] + indexmode:= + comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger + $Integer + if null get(index,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil + e:= put(index,"value",[genSomeVariable(),indexmode,e],e) + [["STEP",index,start,inc,:optFinal],e] + it is ["WHILE",p] => + [p',m,e]:= + comp(p,$Boolean,e) or return + stackMessage('"WHILE operand: %1b is not Boolean valued",[p]) + [["WHILE",p'],e] + it is ["UNTIL",p] => ($until:= p; ['$until,e]) + it is ["|",x] => + u:= + comp(x,$Boolean,e) or return + stackMessage('"SUCHTHAT operand: %1b is not Boolean value",[x]) + [["|",u.expr],u.env] + nil + +--isAggregateMode(m,e) == +-- m is [c,R] and MEMQ(c,'(Vector List)) => R +-- name:= +-- m is [fn,:.] => fn +-- m="$" => "Rep" +-- m +-- get(name,"value",e) is [c,R] and MEMQ(c,'(Vector List)) => R + +modeIsAggregateOf(ListOrVector,m,e) == + m is [ =ListOrVector,R] => [m,R] +--m = '$EmptyMode => [m,m] I don't think this is correct, breaks POLY + + m is ["Union",:l] => + mList:= [pair for m' in l | (pair:= modeIsAggregateOf(ListOrVector,m',e))] + 1=#mList => first mList + name:= + m is [fn,:.] => fn + m="$" => "Rep" + m + get(name,"value",e) is [[ =ListOrVector,R],:.] => [m,R] + +--% VECTOR ITERATORS + +--the following 4 functions are not currently used + +compCollectV(form,m,e) == + fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],e) where + fn(form,$exitModeStack,$leaveLevelStack,e) == + [repeatOrCollect,it,body]:= form + [it',e]:= compIteratorV(it,e) or return nil + m:= first $exitModeStack + [mOver,mUnder]:= modeIsAggregateOf("Vector",m,e) or $EmptyMode + [body',m',e']:= compOrCroak(body,mUnder,e) or return nil + form':= ["COLLECTV",it',body'] + n:= + it' is ["STEP",.,s,i,f] or it' is ["ISTEP",.,s,i,f] => + computeMaxIndex(s,f,i); + return nil + coerce([form',mOver,e'],m) + +compIteratorV(it,e) == + it is ["STEP",index,start,inc,final] => + (start':= comp(start,$Integer,e)) and + (inc':= comp(inc,$NonNegativeInteger,start'.env)) and + (final':= comp(final,$Integer,inc'.env)) => + indexmode:= + comp(start,$NonNegativeInteger,e) => $NonNegativeInteger + $Integer + if null get(index,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",index,indexmode],$EmptyMode,final'.env) or + return nil + e:= put(index,"value",[genSomeVariable(),indexmode,e],e) + [["ISTEP",index,start'.expr,inc'.expr,final'.expr],e] + [start,.,e]:= + comp(start,$Integer,e) or return + stackMessage('"start value of index: %1b is not an integer",[start]) + [inc,.,e]:= + comp(inc,$NonNegativeInteger,e) or return + stackMessage('"index increment: %1b must be a non-negative integer", + [inc]) + [final,.,e]:= + comp(final,$Integer,e) or return + stackMessage('"final value of index: %1b is not an integer",[final]) + indexmode:= + comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger + $Integer + if null get(index,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil + e:= put(index,"value",[genSomeVariable(),indexmode,e],e) + [["STEP",index,start,inc,final],e] + nil + +computeMaxIndex(s,f,i) == + i^=1 => cannotDo() + s=1 => f + exprDifference(f,exprDifference(s,1)) + +exprDifference(x,y) == + y=0 => x + FIXP x and FIXP y => DIFFERENCE(x,y) + ["DIFFERENCE",x,y] + + +--% --% Entry point to the compiler +--% preprocessParseTree pt == $postStack := [] @@ -1919,6 +2188,7 @@ compileParseTree pt == TERPRI() +--% --% Register compilers for special forms. -- Those compilers are on the `SPECIAL' property of the corresponding -- special form operator symbol. |