aboutsummaryrefslogtreecommitdiff
path: root/src/interp/compiler.boot
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/compiler.boot')
-rw-r--r--src/interp/compiler.boot290
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.