diff options
| -rw-r--r-- | src/ChangeLog | 6 | ||||
| -rw-r--r-- | src/boot/ast.boot | 324 | ||||
| -rw-r--r-- | src/boot/parser.boot | 75 | ||||
| -rw-r--r-- | src/boot/strap/ast.clisp | 353 | ||||
| -rw-r--r-- | src/boot/strap/parser.clisp | 130 | ||||
| -rw-r--r-- | src/boot/strap/translator.clisp | 18 | ||||
| -rw-r--r-- | src/boot/translator.boot | 13 |
7 files changed, 496 insertions, 423 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 14d64d63..bc364249 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,9 @@ +2012-05-31 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * boot/ast.boot: Add a %LoadUnit parameter to most functions. + Adjust callers. + * boot/translator.boot: Tidy. + 2012-05-30 Gabriel Dos Reis <gdr@cs.tamu.edu> * boot/parser.boot: Replace references to $ttok. diff --git a/src/boot/ast.boot b/src/boot/ast.boot index 8cee6417..fcb7ffff 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -114,6 +114,26 @@ structure %Ast == %Where(%Ast,%Sequence) -- e where f x == y %Structure(%Ast,%Sequence) -- structure Foo == ... +--% +--% Data type for translation units data +--% +structure %LoadUnit == + Record(fdefs: %List %Thing, sigs: %List %Thing, + xports: %List %Identifier, csts: %List %Binding, varno: %Short) with + functionDefinitions == (.fdefs) -- functions defined in this TU + globalSignatures == (.sigs) -- signatures proclaimed by this TU + exportedNames == (.xports) -- names exported by this TU + constantBindings == (.csts) -- constants defined in this TU + currentGensymNumber == (.varno) -- current gensym sequence number + +makeLoadUnit() == + mk%LoadUnit(nil,nil,nil,nil,0) + +pushFunctionDefinition(tu,def) == + functionDefinitions(tu) := [def,:functionDefinitions tu] + +--% + -- TRUE if we are currently building the syntax tree for an 'is' -- expression. $inDefIS := false @@ -128,10 +148,10 @@ bfSpecificErrorHere msg == --% -bfGenSymbol: () -> %Symbol -bfGenSymbol()== - $GenVarCounter := $GenVarCounter+1 - makeSymbol strconc('"bfVar#",toString $GenVarCounter) +bfGenSymbol: %LoadUnit -> %Symbol +bfGenSymbol tu == + currentGensymNumber(tu) := currentGensymNumber tu + 1 + makeSymbol strconc('"bfVar#",toString currentGensymNumber tu) bfLetVar: () -> %Symbol bfLetVar() == @@ -256,41 +276,41 @@ bfMakeCons l == a ['CONS,first l,bfMakeCons rest l] -bfFor(lhs,u,step) == - u is ["tails",:.] => bfForTree('ON, lhs, second u) - u is ["SEGMENT",:.] => bfSTEP(lhs,second u,step,third u) - u is ['entries,:.] => bfIterateTable(lhs,second u) - bfForTree('IN,lhs,u) +bfFor(tu,lhs,u,step) == + u is ["tails",:.] => bfForTree(tu,'ON,lhs,second u) + u is ["SEGMENT",:.] => bfSTEP(tu,lhs,second u,step,third u) + u is ['entries,:.] => bfIterateTable(tu,lhs,second u) + bfForTree(tu,'IN,lhs,u) -bfForTree(OP,lhs,whole)== +bfForTree(tu,OP,lhs,whole)== whole := bfTupleP whole => bfMakeCons rest whole whole - lhs isnt [.,:.] => bfINON [OP,lhs,whole] + lhs isnt [.,:.] => bfINON(tu,[OP,lhs,whole]) lhs := bfTupleP lhs => second lhs lhs lhs is ["L%T",:.] => G := second lhs - [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,third lhs)] - G := bfGenSymbol() - [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,lhs)] + [:bfINON(tu,[OP,G,whole]),:bfSuchthat(tu,bfIS(tu,G,third lhs))] + G := bfGenSymbol tu + [:bfINON(tu,[OP,G,whole]),:bfSuchthat(tu,bfIS(tu,G,lhs))] -bfSTEP(id,fst,step,lst)== +bfSTEP(tu,id,fst,step,lst)== if id is "DOT" then - id := bfGenSymbol() + id := bfGenSymbol tu initvar := [id] initval := [fst] inc := step isnt [.,:.] => step - g1 := bfGenSymbol() + g1 := bfGenSymbol tu initvar := [g1,:initvar] initval := [step,:initval] g1 final := lst isnt [.,:.] => lst - g2 := bfGenSymbol() + g2 := bfGenSymbol tu initvar := [g2,:initvar] initval := [lst,:initval] g2 @@ -307,16 +327,16 @@ bfSTEP(id,fst,step,lst)== [[initvar,initval,suc,[],ex,[]]] ++ Build a hashtable-iterator form. -bfIterateTable(e,t) == +bfIterateTable(tu,e,t) == ['%tbliter,e,t,gensym()] -bfINON x== +bfINON(tu,x) == [op,id,whole] := x - op is "ON" => bfON(id,whole) - bfIN(id,whole) + op is "ON" => bfON(tu,id,whole) + bfIN(tu,id,whole) -bfIN(x,E)== - g := bfGenSymbol() +bfIN(tu,x,E)== + g := bfGenSymbol tu vars := [g] inits := [E] exitCond := ['NOT,['CONSP,g]] @@ -326,9 +346,9 @@ bfIN(x,E)== exitCond := ['OR,exitCond,['PROGN,['SETQ,x,['CAR,g]] ,'NIL]] [[vars,inits,[['SETQ,g,['CDR, g]]],[],[exitCond],[]]] -bfON(x,E)== +bfON(tu,x,E)== if x is "DOT" then - x := bfGenSymbol() + x := bfGenSymbol tu -- allow a list variable to iterate over its own tails. var := init := nil if not symbol? E or not symbolEq?(x,E) then @@ -336,15 +356,15 @@ bfON(x,E)== init := [E] [[var,init,[['SETQ,x,['CDR, x]]],[],[['NOT,['CONSP,x]]],[]]] -bfSuchthat p == +bfSuchthat(tu,p) == [[[],[],[],[p],[],[]]] -bfWhile p == +bfWhile(tu,p) == [[[],[],[],[],[bfNOT p],[]]] -bfUntil p== - g:=bfGenSymbol() - [[[g],[nil],[['SETQ,g,p]],[],[g],[]]] +bfUntil(tu,p) == + g := bfGenSymbol tu + [[[g],[nil],[['SETQ,g,p]],[],[g],[]]] bfIterators x == ["ITERATORS",:x] @@ -352,13 +372,13 @@ bfIterators x == bfCross x == ["CROSS",:x] -bfLp(iters,body)== - iters is ["ITERATORS",:.] => bfLp1(rest iters,body) - bfLpCross(rest iters,body) +bfLp(tu,iters,body)== + iters is ["ITERATORS",:.] => bfLp1(tu,rest iters,body) + bfLpCross(tu,rest iters,body) -bfLpCross(iters,body)== - rest iters = nil => bfLp(first iters,body) - bfLp(first iters,bfLpCross(rest iters,body)) +bfLpCross(tu,iters,body)== + rest iters = nil => bfLp(tu,first iters,body) + bfLp(tu,first iters,bfLpCross(tu,rest iters,body)) bfSep(iters)== iters = nil => [[],[],[],[],[],[]] @@ -366,41 +386,41 @@ bfSep(iters)== r := bfSep rest iters [[:i,:j] for i in f for j in r] -bfReduce(op,y)== +bfReduce(tu,op,y)== a := op is ['QUOTE,:.] => second op op op := bfReName a init := a has SHOETHETA or op has SHOETHETA - g := bfGenSymbol() - g1 := bfGenSymbol() + g := bfGenSymbol tu + g1 := bfGenSymbol tu body := ['SETQ,g,[op,g,g1]] init = nil => - g2 := bfGenSymbol() + g2 := bfGenSymbol tu init := ['CAR,g2] ny := ['CDR,g2] - it := ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,ny)]] - bfMKPROGN [['L%T,g2,y],bfLp(it,body)] + it := ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(tu,g1,ny)]] + bfMKPROGN [['L%T,g2,y],bfLp(tu,it,body)] init := first init - it := ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,y)]] - bfLp(it,body) + it := ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(tu,g1,y)]] + bfLp(tu,it,body) -bfReduceCollect(op,y)== +bfReduceCollect(tu,op,y)== y is ["COLLECT",:.] => body := second y itl := third y a := op is ['QUOTE,:.] => second op op - a is "append!" => bfDoCollect(body,itl,'lastNode,'skipNil) - a is "append" => bfDoCollect(['copyList,body],itl,'lastNode,'skipNil) + a is "append!" => bfDoCollect(tu,body,itl,'lastNode,'skipNil) + a is "append" => bfDoCollect(tu,['copyList,body],itl,'lastNode,'skipNil) op := bfReName a init := a has SHOETHETA or op has SHOETHETA - bfOpReduce(op,init,body,itl) + bfOpReduce(tu,op,init,body,itl) seq := y = nil => bfTuple nil second y - bfReduce(op,bfTupleConstruct seq) + bfReduce(tu,op,bfTupleConstruct seq) -- delayed collect @@ -410,14 +430,14 @@ bfDCollect(y,itl) == bfDTuple x == ["DTUPLE",x] -bfCollect(y,itl) == +bfCollect(tu,y,itl) == y is ["COLON",a] => a is ['CONS,:.] or a is ['LIST,:.] => - bfDoCollect(a,itl,'lastNode,'skipNil) - bfDoCollect(['copyList,a],itl,'lastNode,'skipNil) + bfDoCollect(tu,a,itl,'lastNode,'skipNil) + bfDoCollect(tu,['copyList,a],itl,'lastNode,'skipNil) y is ["TUPLE",:.] => - bfDoCollect(bfConstruct y,itl,'lastNode,'skipNil) - bfDoCollect(['CONS,y,'NIL],itl,'CDR,nil) + bfDoCollect(tu,bfConstruct y,itl,'lastNode,'skipNil) + bfDoCollect(tu,['CONS,y,'NIL],itl,'CDR,nil) bfMakeCollectInsn(expr,prev,head,adv) == firstTime := bfMKPROGN @@ -425,17 +445,17 @@ bfMakeCollectInsn(expr,prev,head,adv) == otherTime := bfMKPROGN [['RPLACD,prev,expr],['SETQ,prev,[adv,prev]]] bfIf(['NULL,head],firstTime,otherTime) -bfDoCollect(expr,itl,adv,k) == - head := bfGenSymbol() -- pointer to the result - prev := bfGenSymbol() -- pointer to the previous cell +bfDoCollect(tu,expr,itl,adv,k) == + head := bfGenSymbol tu -- pointer to the result + prev := bfGenSymbol tu -- pointer to the previous cell body := k is 'skipNil => - x := bfGenSymbol() + x := bfGenSymbol tu ['LET,[[x,expr]], bfIf(['NULL,x],'NIL,bfMakeCollectInsn(x,prev,head,adv))] bfMakeCollectInsn(expr,prev,head,adv) extrait := [[[head,prev],['NIL,'NIL],nil,nil,nil,[head]]] - bfLp2(extrait,itl,body) + bfLp2(tu,extrait,itl,body) ++ Given the list of loop iterators, return 2-list where the first ++ component is the list of all non-table iterators and the second @@ -448,7 +468,7 @@ separateIterators iters == x := [iter,:x] [reverse! x,reverse! y] -bfTableIteratorBindingForm(keyval,end?,succ) == +bfTableIteratorBindingForm(tu,keyval,end?,succ) == -- FIXME: most of the repetitions below could be avoided -- FIXME: with better bfIS1 implementation. keyval is ['CONS,key,val] => @@ -458,21 +478,21 @@ bfTableIteratorBindingForm(keyval,end?,succ) == ['MULTIPLE_-VALUE_-BIND,[end?,key,val],[succ]] ident? key => v := gensym() - ['MULTIPLE_-VALUE_-BIND,[end?,key,v],[succ],bfLET(val,v)] + ['MULTIPLE_-VALUE_-BIND,[end?,key,v],[succ],bfLET(tu,val,v)] k := gensym() ident? val => - ['MULTIPLE_-VALUE_-BIND,[end?,k,val],[succ],bfLET(key,k)] + ['MULTIPLE_-VALUE_-BIND,[end?,k,val],[succ],bfLET(tu,key,k)] v := gensym() - ['MULTIPLE_-VALUE_-BIND,[end?,k,v],[succ],bfLET(key,k),bfLET(val,v)] + ['MULTIPLE_-VALUE_-BIND,[end?,k,v],[succ],bfLET(tu,key,k),bfLET(tu,val,v)] k := gensym() v := gensym() - ['MULTIPLE_-VALUE_-BIND,[end?,k,v],[succ],bfLET(keyval,['CONS,k,v])] + ['MULTIPLE_-VALUE_-BIND,[end?,k,v],[succ],bfLET(tu,keyval,['CONS,k,v])] ++ Expand the list of table iterators into a tuple form with ++ (a) list of table iteration initialization ++ (b) for each iteration, local bindings of key value ++ (c) a list of exit conditions -bfExpandTableIters iters == +bfExpandTableIters(tu,iters) == inits := nil localBindings := nil exits := nil @@ -480,13 +500,13 @@ bfExpandTableIters iters == inits := [[g,t],:inits] x := gensym() -- exit guard exits := [['NOT,x],:exits] - localBindings := [bfTableIteratorBindingForm(e,x,g),:localBindings] + localBindings := [bfTableIteratorBindingForm(tu,e,x,g),:localBindings] [inits,localBindings,exits] -- NOTE: things are returned in reverse order. -bfLp1(iters,body)== +bfLp1(tu,iters,body)== [iters,tbls] := separateIterators iters [vars,inits,sucs,filters,exits,value] := bfSep bfAppend iters - [tblInits,tblLocs,tblExits] := bfExpandTableIters tbls + [tblInits,tblLocs,tblExits] := bfExpandTableIters(tu,tbls) nbody := filters = nil => body bfAND [:filters,body] @@ -505,30 +525,30 @@ bfLp1(iters,body)== loop := ['WITH_-HASH_-TABLE_-ITERATOR,x,loop] loop -bfLp2(extrait,itl,body)== - itl is ["ITERATORS",:.] => bfLp1([extrait,:rest itl],body) +bfLp2(tu,extrait,itl,body)== + itl is ["ITERATORS",:.] => bfLp1(tu,[extrait,:rest itl],body) iters := rest itl - bfLpCross([["ITERATORS",extrait,:CDAR iters],:rest iters],body) + bfLpCross(tu,[["ITERATORS",extrait,:CDAR iters],:rest iters],body) -bfOpReduce(op,init,y,itl)== - g := bfGenSymbol() +bfOpReduce(tu,op,init,y,itl)== + g := bfGenSymbol tu body:= op is "AND" => bfMKPROGN [["SETQ",g,y], ['COND, [['NOT,g],['RETURN,'NIL]]]] op is "OR" => bfMKPROGN [["SETQ",g,y], ['COND, [g,['RETURN,g]]]] ['SETQ,g,[op,g,y]] init = nil => - g1 := bfGenSymbol() + g1 := bfGenSymbol tu init := ['CAR,g1] y := ['CDR,g1] -- ??? bogus self-assignment/initialization extrait := [[[g],[init],[],[],[],[g]]] - bfMKPROGN [['L%T,g1,y],bfLp2(extrait,itl,body)] + bfMKPROGN [['L%T,g1,y],bfLp2(tu,extrait,itl,body)] init := first init extrait := [[[g],[init],[],[],[],[g]]] - bfLp2(extrait,itl,body) + bfLp2(tu,extrait,itl,body) -bfLoop1 body == - bfLp (bfIterators nil,body) +bfLoop1(tu,body) == + bfLp(tu,bfIterators nil,body) bfSegment1(lo) == ["SEGMENT",lo,nil] @@ -536,11 +556,11 @@ bfSegment1(lo) == bfSegment2(lo,hi) == ["SEGMENT",lo,hi] -bfForInBy(variable,collection,step)== - bfFor(variable,collection,step) +bfForInBy(tu,variable,collection,step)== + bfFor(tu,variable,collection,step) -bfForin(lhs,U)== - bfFor(lhs,U,1) +bfForin(tu,lhs,U)== + bfFor(tu,lhs,U,1) bfLocal(a,b)== b is "local" => compFluid a @@ -604,25 +624,25 @@ defSheepAndGoatsList(x)== bfLetForm(lhs,rhs) == ['L%T,lhs,rhs] -bfLET1(lhs,rhs) == +bfLET1(tu,lhs,rhs) == symbol? lhs => bfLetForm(lhs,rhs) lhs is ['%Dynamic,.] => bfLetForm(lhs,rhs) symbol? rhs and not bfCONTAINED(rhs,lhs) => - rhs1 := bfLET2(lhs,rhs) + rhs1 := bfLET2(tu,lhs,rhs) rhs1 is ["L%T",:.] => bfMKPROGN [rhs1,rhs] rhs1 is ["PROGN",:.] => [:rhs1,:[rhs]] if symbol? first rhs1 then rhs1 := [rhs1,:nil] bfMKPROGN [:rhs1,rhs] rhs is ["L%T",:.] and symbol?(name := second rhs) => -- handle things like [a] := x := foo - l1 := bfLET1(name,third rhs) - l2 := bfLET1(lhs,name) + l1 := bfLET1(tu,name,third rhs) + l2 := bfLET1(tu,lhs,name) l2 is ["PROGN",:.] => bfMKPROGN [l1,:rest l2] if symbol? first l2 then l2 := [l2,:nil] bfMKPROGN [l1,:l2,name] g := bfLetVar() rhs1 := ['L%T,g,rhs] - let1 := bfLET1(lhs,g) + let1 := bfLET1(tu,lhs,g) let1 is ["PROGN",:.] => bfMKPROGN [rhs1,:rest let1] if symbol? first let1 then let1 := [let1,:nil] bfMKPROGN [rhs1,:let1,g] @@ -632,26 +652,26 @@ bfCONTAINED(x,y)== y isnt [.,:.] => false bfCONTAINED(x,first y) or bfCONTAINED(x,rest y) -bfLET2(lhs,rhs) == +bfLET2(tu,lhs,rhs) == lhs = nil => nil symbol? lhs => bfLetForm(lhs,rhs) lhs is ['%Dynamic,.] => bfLetForm(lhs,rhs) lhs is ['L%T,a,b] => - a := bfLET2(a,rhs) - (b := bfLET2(b,rhs)) = nil => a + a := bfLET2(tu,a,rhs) + (b := bfLET2(tu,b,rhs)) = nil => a b isnt [.,:.] => [a,b] cons? first b => [a,:b] [a,b] lhs is ['CONS,var1,var2] => var1 is "DOT" or var1 is ['QUOTE,:.] => - bfLET2(var2,addCARorCDR('CDR,rhs)) - l1 := bfLET2(var1,addCARorCDR('CAR,rhs)) + bfLET2(tu,var2,addCARorCDR('CDR,rhs)) + l1 := bfLET2(tu,var1,addCARorCDR('CAR,rhs)) var2 = nil or var2 is "DOT" =>l1 if cons? l1 and first l1 isnt [.,:.] then l1 := [l1,:nil] symbol? var2 => [:l1,bfLetForm(var2,addCARorCDR('CDR,rhs))] - l2 := bfLET2(var2,addCARorCDR('CDR,rhs)) + l2 := bfLET2(tu,var2,addCARorCDR('CDR,rhs)) if cons? l2 and first l2 isnt [.,:.] then l2 := [l2,:nil] [:l1,:l2] @@ -659,7 +679,7 @@ bfLET2(lhs,rhs) == patrev := bfISReverse(var2,var1) rev := ['reverse,rhs] g := bfLetVar() - l2 := bfLET2(patrev,g) + l2 := bfLET2(tu,patrev,g) if cons? l2 and first l2 isnt [.,:.] then l2 := [l2,:nil] var1 is "DOT" => [['L%T,g,rev],:l2] @@ -676,14 +696,14 @@ bfLET2(lhs,rhs) == -- and generate appropriate codes. -- -- gdr/2007-04-02. isPred := - $inDefIS => bfIS1(rhs,lhs) - bfIS(rhs,lhs) + $inDefIS => bfIS1(tu,rhs,lhs) + bfIS(tu,rhs,lhs) ['COND,[isPred,rhs]] -bfLET(lhs,rhs) == +bfLET(tu,lhs,rhs) == $letGenVarCounter : local := 0 - bfLET1(lhs,rhs) + bfLET1(tu,lhs,rhs) addCARorCDR(acc,expr) == expr isnt [.,:.] => [acc,expr] @@ -708,15 +728,15 @@ bfPosn(x,l,n) == --% IS -bfISApplication(op,left,right)== - op is "IS" => bfIS(left,right) - op is "ISNT" => bfNOT bfIS(left,right) +bfISApplication(tu,op,left,right)== + op is "IS" => bfIS(tu,left,right) + op is "ISNT" => bfNOT bfIS(tu,left,right) [op ,left,right] -bfIS(left,right)== +bfIS(tu,left,right)== $isGenVarCounter: local := 0 $inDefIS: local :=true - bfIS1(left,right) + bfIS1(tu,left,right) bfISReverse(x,a) == x is ['CONS,:.] => @@ -726,7 +746,7 @@ bfISReverse(x,a) == y bfSpecificErrorHere '"Error in bfISReverse" -bfIS1(lhs,rhs) == +bfIS1(tu,lhs,rhs) == rhs = nil => ['NULL,lhs] rhs = true => ['EQ,lhs,rhs] bfString? rhs => bfAND [['STRINGP,lhs],["STRING=",lhs,rhs]] @@ -739,24 +759,24 @@ bfIS1(lhs,rhs) == ["EQUAL",lhs,rhs] rhs.op is 'L%T => [.,c,d] := rhs - l := bfLET(c,lhs) - bfAND [bfIS1(lhs,d),bfMKPROGN [l,'T]] + l := bfLET(tu,c,lhs) + bfAND [bfIS1(tu,lhs,d),bfMKPROGN [l,'T]] rhs is ["EQUAL",a] => bfQ(lhs,a) rhs is ['CONS,a,b] and a is "DOT" and b is "DOT" => ['CONSP,lhs] cons? lhs => g := bfIsVar() - bfMKPROGN [['L%T,g,lhs],bfIS1(g,rhs)] + bfMKPROGN [['L%T,g,lhs],bfIS1(tu,g,rhs)] rhs.op is 'CONS => [.,a,b] := rhs a is "DOT" => b = nil => bfAND [['CONSP,lhs],['NULL,['CDR,lhs]]] b is "DOT" => ['CONSP,lhs] - bfAND [['CONSP,lhs],bfIS1(['CDR,lhs],b)] + bfAND [['CONSP,lhs],bfIS1(tu,['CDR,lhs],b)] b = nil => - bfAND [['CONSP,lhs],['NULL,['CDR,lhs]],bfIS1(['CAR,lhs],a)] - b is "DOT" => bfAND [['CONSP,lhs],bfIS1(['CAR,lhs],a)] - a1 := bfIS1(['CAR,lhs],a) - b1 := bfIS1(['CDR,lhs],b) + bfAND [['CONSP,lhs],['NULL,['CDR,lhs]],bfIS1(tu,['CAR,lhs],a)] + b is "DOT" => bfAND [['CONSP,lhs],bfIS1(tu,['CAR,lhs],a)] + a1 := bfIS1(tu,['CAR,lhs],a) + b1 := bfIS1(tu,['CDR,lhs],b) a1 is ['PROGN,c,'T] and b1 is ['PROGN,:cls] => bfAND [['CONSP,lhs],bfMKPROGN [c,:cls]] bfAND [['CONSP,lhs],a1,b1] @@ -765,7 +785,7 @@ bfIS1(lhs,rhs) == patrev := bfISReverse(b,a) g := bfIsVar() rev := bfAND [['CONSP,lhs],['PROGN,['L%T,g,['reverse,lhs]],'T]] - l2 := bfIS1(g,patrev) + l2 := bfIS1(tu,g,patrev) if cons? l2 and first l2 isnt [.,:.] then l2 := [l2,:nil] a is "DOT" => bfAND [rev,:l2] @@ -913,44 +933,44 @@ bfLambda(vars,body) == [vars] ["LAMBDA",vars,body] -bfMDef (op,args,body) == +bfMDef(tu,op,args,body) == argl := bfTupleP args => rest args [args] lamex := ["MLAMBDA",argl,backquote(body,argl)] def := [op,lamex] - [shoeComp def,:[:shoeComps bfDef1 d for d in $wheredefs]] + [shoeComp def,:[:shoeComps bfDef1(tu,d) for d in $wheredefs]] -bfGargl argl== +bfGargl(tu,argl) == argl = nil => [[],[],[],[]] - [a,b,c,d] := bfGargl rest argl + [a,b,c,d] := bfGargl(tu,rest argl) first argl is "&REST" => [[first argl,:b],b,c, [["CONS",quote "LIST",first d],:rest d]] - f := bfGenSymbol() + f := bfGenSymbol tu [[f,:a],[f,:b],[first argl,:c],[f,:d]] -bfDef1 [op,args,body] == +bfDef1(tu,[op,args,body]) == argl := bfTupleP args => rest args [args] - [quotes,control,arglp,body] := bfInsertLet (argl,body) - quotes => shoeLAM(op,arglp,control,body) + [quotes,control,arglp,body] := bfInsertLet(tu,argl,body) + quotes => shoeLAM(tu,op,arglp,control,body) [[op,["LAMBDA",arglp,body]]] -shoeLAM (op,args,control,body)== - margs :=bfGenSymbol() +shoeLAM(tu,op,args,control,body) == + margs := bfGenSymbol tu innerfunc:= makeSymbol strconc(symbolName op,'",LAM") [[innerfunc,["LAMBDA",args,body]], [op,["MLAMBDA",["&REST",margs],["CONS", quote innerfunc, ["WRAP",margs,quote control]]]]] -bfDef(op,args,body) == +bfDef(tu,op,args,body) == $bfClamming => - [.,op1,arg1,:body1] := shoeComp first bfDef1 [op,args,body] - bfCompHash(op1,arg1,body1) + [.,op1,arg1,:body1] := shoeComp first bfDef1(tu,[op,args,body]) + bfCompHash(tu,op1,arg1,body1) bfTuple - [:shoeComps bfDef1 d for d in [[op,args,body],:$wheredefs]] + [:shoeComps bfDef1(tu,d) for d in [[op,args,body],:$wheredefs]] shoeComps x== [shoeComp def for def in x] @@ -975,24 +995,24 @@ bfParameterList(p1,p2) == p2 is ["&OPTIONAL",:.] => [p1,first p2,:rest p2] [p1,:p2] -bfInsertLet(x,body)== +bfInsertLet(tu,x,body)== x = nil => [false,nil,x,body] x is ["&REST",a] => a is ['QUOTE,b] => [true,'QUOTE,["&REST",b],body] [false,nil,x,body] - [b,norq,name1,body1] := bfInsertLet1 (first x,body) - [b1,norq1,name2,body2] := bfInsertLet (rest x,body1) + [b,norq,name1,body1] := bfInsertLet1(tu,first x,body) + [b1,norq1,name2,body2] := bfInsertLet(tu,rest x,body1) [b or b1,[norq,:norq1],bfParameterList(name1,name2),body2] -bfInsertLet1(y,body)== - y is ["L%T",l,r] => [false,nil,l,bfMKPROGN [bfLET(r,l),body]] +bfInsertLet1(tu,y,body)== + y is ["L%T",l,r] => [false,nil,l,bfMKPROGN [bfLET(tu,r,l),body]] symbol? y => [false,nil,y,body] y is ["BVQUOTE",b] => [true,'QUOTE,b,body] - g:=bfGenSymbol() + g := bfGenSymbol tu y isnt [.,:.] => [false,nil,g,body] case y of %DefaultValue(p,v) => [false,nil,["&OPTIONAL",[p,v]],body] - otherwise => [false,nil,g,bfMKPROGN [bfLET(compFluidize y,g),body]] + otherwise => [false,nil,g,bfMKPROGN [bfLET(tu,compFluidize y,g),body]] shoeCompTran x== [lamtype,args,:body] := x @@ -1135,10 +1155,10 @@ groupFluidVars(inits,vars,stmts) == ["LET",inits,["DECLARE",["SPECIAL",:vars]],bfMKPROGN stmts] ["LET*",inits,["DECLARE",["SPECIAL",:vars]],bfMKPROGN stmts] -bfTagged(a,b)== +bfTagged(tu,a,b)== $op = nil => %Signature(a,b) -- surely a toplevel decl symbol? a => - b is "local" => bfLET(compFluid a,nil) + b is "local" => bfLET(tu,compFluid a,nil) $typings := [["TYPE",b,a],:$typings] a ["THE",b,a] @@ -1146,10 +1166,10 @@ bfTagged(a,b)== bfRestrict(x,t) == ["THE",t,x] -bfAssign(l,r)== +bfAssign(tu,l,r)== bfTupleP l => bfSetelt(second l,CDDR l ,r) l is ["%Place",:l'] => ["SETF",l',r] - bfLET(l,r) + bfLET(tu,l,r) bfSetelt(e,l,r)== rest l = nil => defSETELT(e,first l,r) @@ -1245,20 +1265,20 @@ bfWhere (context,expr)== -- exp = nil => nil -- [exp,:shoeReadLispString(s,ind)] -bfCompHash(op,argl,body) == +bfCompHash(tu,op,argl,body) == auxfn:= makeSymbol strconc(symbolName op,'";") computeFunction:= ["DEFUN",auxfn,argl,:body] - bfTuple [computeFunction,:bfMain(auxfn,op)] + bfTuple [computeFunction,:bfMain(tu,auxfn,op)] shoeCompileTimeEvaluation x == ["EVAL-WHEN", [KEYWORD::COMPILE_-TOPLEVEL], x] -bfMain(auxfn,op)== - g1 := bfGenSymbol() +bfMain(tu,auxfn,op)== + g1 := bfGenSymbol tu arg :=["&REST",g1] computeValue := ['APPLY,["FUNCTION",auxfn],g1] cacheName := makeSymbol strconc(symbolName op,'";AL") - g2:= bfGenSymbol() + g2:= bfGenSymbol tu getCode := ['GETHASH,g1,cacheName] secondPredPair := [['SETQ,g2,getCode],g2] putCode := ['SETF ,getCode,computeValue] @@ -1292,24 +1312,24 @@ bfNameArgs (x,y)== [y] [x,:y] -bfCreateDef: %Thing -> %Form -bfCreateDef x== +bfCreateDef: (%LoadUnit,%Thing) -> %Form +bfCreateDef(tu,x) == x is [f] => ["DEFCONSTANT",f,["LIST",quote f]] - a := [bfGenSymbol() for i in rest x] + a := [bfGenSymbol tu for i in rest x] ["DEFUN",first x,a,["CONS",quote first x,["LIST",:a]]] bfCaseItem: (%Thing,%Thing) -> %Form bfCaseItem(x,y) == [x,y] -bfCase: (%Thing,%Thing) -> %Form -bfCase(x,y)== +bfCase: (%LoadUnit,%Thing,%Thing) -> %Form +bfCase(tu,x,y)== -- Introduce a temporary to hold the value of the scrutinee. -- To minimize the number of GENSYMS and assignments, we want -- to do this only when the scrutinee is not reduced yet. g := x isnt [.,:.] => x - bfGenSymbol() + bfGenSymbol tu body := ["CASE",["CAR", g], :bfCaseItems(g,y)] sameObject?(g,x) => body ["LET",[[g,x]],body] @@ -1338,7 +1358,7 @@ bfDs n == bfEnum(t,csts) == ['DEFTYPE,t,nil,backquote(['MEMBER,:csts],nil)] -bfRecordDef(s,fields,accessors) == +bfRecordDef(tu,s,fields,accessors) == parms := [x for f in fields | f is ['%Signature,x,.]] fun := makeSymbol strconc('"mk",symbolName s) ctor := makeSymbol strconc('"MAKE-",symbolName s) @@ -1351,7 +1371,7 @@ bfRecordDef(s,fields,accessors) == ["DEFMACRO",fun,parms,["LIST",quote ctor,:args]] accDefs := accessors = nil => nil - x := bfGenSymbol() + x := bfGenSymbol tu [["DEFMACRO",acc,[x], ["LIST",quote makeSymbol strconc(symbolName s,'"-",symbolName f),x]] for ['%AccessorDef,acc,f] in accessors] diff --git a/src/boot/parser.boot b/src/boot/parser.boot index e67705bd..f1c8c8c2 100644 --- a/src/boot/parser.boot +++ b/src/boot/parser.boot @@ -51,15 +51,16 @@ module parser structure %ParserState == Record(toks: %List %Tokens, trees: %List %Ast, pren: %Short, scp: %Short, - cur: %Token) with + cur: %Token,tu: %LoadUnit) with parserTokens == (.toks) -- remaining token sequence parserTrees == (.trees) -- list of successful parse trees parserNesting == (.pren) -- parenthesis nesting level parserScope == (.scp) -- scope nesting level parserCurrentToken == (.cur) -- current token + parserLoadUnit == (.tu) -- current translation unit makeParserState toks == - mk%ParserState(toks,nil,0,0,nil) + mk%ParserState(toks,nil,0,0,nil,makeLoadUnit()) ++ Access the value of the current token macro parserTokenValue ps == @@ -73,20 +74,8 @@ macro parserTokenClass ps == macro parserTokenPosition ps == tokenPosition parserCurrentToken ps ---% ---% Translator global state ---% -structure %Translator == - Record(ipath: %String, fdefs: %List %Thing, sigs: %List %Thing, - xports: %List %Identifier, csts: %List %Binding) with - inputFilePath == (.ifile) -- path to the input file - functionDefinitions == (.fdefs) -- functions defined in this TU - globalSignatures == (.sigs) -- signatures proclaimed by this TU - exportedNames == (.xports) -- names exported by this TU - constantBindings == (.csts) -- constants defined in this TU - -makeTranslator ip == - mk%Translator(ip,nil,nil,nil,nil) +macro parserGensymSequenceNumber ps == + currentGensymNumber parserLoadUnit ps --% @@ -266,7 +255,7 @@ bpAnyNo(ps,s) == -- AndOr(k,p,f)= k p bpAndOr(ps,keyword,p,f)== bpEqKey(ps,keyword) and bpRequire(ps,p) - and bpPush(ps,FUNCALL(f, bpPop1 ps)) + and bpPush(ps,FUNCALL(f,parserLoadUnit ps,bpPop1 ps)) bpConditional(ps,f) == bpEqKey(ps,"IF") and bpRequire(ps,function bpWhere) and (bpEqKey(ps,"BACKSET") or true) => @@ -704,7 +693,7 @@ bpTyped ps == bpApplication ps and bpEqKey(ps,"COLON") => bpRequire(ps,function bpTyping) and - bpPush(ps,bfTagged(bpPop2 ps,bpPop1 ps)) + bpPush(ps,bfTagged(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) bpEqKey(ps,"AT") => bpRequire(ps,function bpTyping) and bpPush(ps,bfRestrict(bpPop2 ps, bpPop1 ps)) @@ -758,9 +747,9 @@ bpReduce ps == bpReduceOperator ps and bpEqKey(ps,"SLASH") => bpEqPeek(ps,"OBRACK") => bpRequire(ps,function bpDConstruct) and - bpPush(ps,bfReduceCollect(bpPop2 ps,bpPop1 ps)) + bpPush(ps,bfReduceCollect(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) bpRequire(ps,function bpApplication) and - bpPush(ps,bfReduce(bpPop2 ps,bpPop1 ps)) + bpPush(ps,bfReduce(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) bpRestore(ps,a) false @@ -781,7 +770,7 @@ bpArith ps == bpIs ps == bpArith ps and bpInfKey(ps,'(IS ISNT)) and bpRequire(ps,function bpPattern) => - bpPush(ps,bfISApplication(bpPop2 ps,bpPop2 ps,bpPop1 ps)) + bpPush(ps,bfISApplication(parserLoadUnit ps,bpPop2 ps,bpPop2 ps,bpPop1 ps)) bpEqKey(ps,"HAS") and bpRequire(ps,function bpApplication) => bpPush(ps,bfHas(bpPop2 ps, bpPop1 ps)) true @@ -896,10 +885,9 @@ bpLoop ps == bpIterators ps and (bpCompMissing(ps,"REPEAT") and bpRequire(ps,function bpWhere) and - bpPush(ps,bfLp(bpPop2 ps,bpPop1 ps))) - or - bpEqKey(ps,"REPEAT") and bpRequire(ps,function bpLogical) and - bpPush(ps,bfLoop1 bpPop1 ps) + bpPush(ps,bfLp(parserLoadUnit ps,bpPop2 ps,bpPop1 ps))) + or bpEqKey(ps,"REPEAT") and bpRequire(ps,function bpLogical) and + bpPush(ps,bfLoop1(parserLoadUnit ps,bpPop1 ps)) bpSuchThat ps == bpAndOr(ps,"BAR",function bpWhere,function bfSuchthat) @@ -917,8 +905,8 @@ bpForIn ps == bpEqKey(ps,"FOR") and bpRequire(ps,function bpFormal) and (bpCompMissing(ps,"IN")) and (bpRequire(ps,function bpSeg) and (bpEqKey(ps,"BY") and bpRequire(ps,function bpArith) and - bpPush(ps,bfForInBy(bpPop3 ps,bpPop2 ps,bpPop1 ps))) or - bpPush(ps,bfForin(bpPop2 ps,bpPop1 ps))) + bpPush(ps,bfForInBy(parserLoadUnit ps,bpPop3 ps,bpPop2 ps,bpPop1 ps))) or + bpPush(ps,bfForin(parserLoadUnit ps,bpPop2 ps,bpPop1 ps))) bpSeg ps == bpArith ps and @@ -960,7 +948,7 @@ bpAssignment ps == bpAssignVariable ps and bpEqKey(ps,"BEC") and bpRequire(ps,function bpAssign) and - bpPush(ps,bfAssign(bpPop2 ps,bpPop1 ps)) + bpPush(ps,bfAssign(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) ++ Parse a lambda expression ++ Lambda ::= Variable +-> Assign @@ -1095,8 +1083,8 @@ bpConstruct ps == bpConstruction ps== bpComma ps and (bpIteratorTail ps and - bpPush(ps,bfCollect(bpPop2 ps,bpPop1 ps)) or - bpPush(ps,bfTupleConstruct bpPop1 ps)) + bpPush(ps,bfCollect(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) + or bpPush(ps,bfTupleConstruct bpPop1 ps)) bpDConstruct ps == bpBracket(ps,function bpDConstruction) @@ -1120,12 +1108,12 @@ bpEqual ps == bpTrap ps) and bpPush(ps,bfEqual bpPop1 ps) bpRegularPatternItem ps == - bpEqual ps or - bpConstTok ps or bpDot ps or + bpEqual ps + or bpConstTok ps or bpDot ps or bpName ps and - ((bpEqKey(ps,"BEC") and bpRequire(ps,function bpPattern) - and bpPush(ps,bfAssign(bpPop2 ps,bpPop1 ps))) or true) - or bpBracketConstruct(ps,function bpPatternL) + ((bpEqKey(ps,"BEC") and bpRequire(ps,function bpPattern) + and bpPush(ps,bfAssign(parserLoadUnit ps,bpPop2 ps,bpPop1 ps))) or true) + or bpBracketConstruct(ps,function bpPatternL) bpRegularPatternItemL ps == bpRegularPatternItem ps and bpPush(ps,[bpPop1 ps]) @@ -1166,11 +1154,11 @@ bpPatternTail ps == ++ a default value. bpRegularBVItemTail ps == bpEqKey(ps,"COLON") and bpRequire(ps,function bpApplication) and - bpPush(ps,bfTagged(bpPop2 ps, bpPop1 ps)) + bpPush(ps,bfTagged(parserLoadUnit ps,bpPop2 ps, bpPop1 ps)) or bpEqKey(ps,"BEC") and bpRequire(ps,function bpPattern) and - bpPush(ps,bfAssign(bpPop2 ps,bpPop1 ps)) + bpPush(ps,bfAssign(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) or bpEqKey(ps,"IS") and bpRequire(ps,function bpPattern) and - bpPush(ps,bfAssign(bpPop2 ps,bpPop1 ps)) + bpPush(ps,bfAssign(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) or bpEqKey(ps,"DEF") and bpRequire(ps,function bpApplication) and bpPush(ps,%DefaultValue(bpPop2 ps, bpPop1 ps)) @@ -1309,7 +1297,7 @@ bpCase ps == bpPiledCaseItems ps == bpPileBracketed(ps,function bpCaseItemList) and - bpPush(ps,bfCase(bpPop2 ps,bpPop1 ps)) + bpPush(ps,bfCase(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) bpCaseItemList ps == bpListAndRecover(ps,function bpCaseItem) @@ -1330,17 +1318,20 @@ bpCaseItem ps == ++ Main entry point into the parser module. bpOutItem ps == $op: local := nil - $GenVarCounter: local := 0 - try bpRequire(ps,function bpComma) + varno := parserGensymSequenceNumber ps + try + parserGensymSequenceNumber(ps) := 0 + bpRequire(ps,function bpComma) catch(e: BootSpecificError) => bpSpecificErrorHere(ps,e) bpTrap ps + finally parserGensymSequenceNumber(ps) := varno b := bpPop1 ps t := b is ["+LINE",:.] => [ b ] b is ["L%T",l,r] and symbol? l => $InteractiveMode => [["SETQ",l,r]] [["DEFPARAMETER",l,r]] - translateToplevel(b,false) + translateToplevel(ps,b,false) bpPush(ps,t) diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index f00bb570..b8ae1806 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -144,6 +144,32 @@ (DEFUN |%Structure| #1=(|bfVar#95| |bfVar#96|) (CONS '|%Structure| (LIST . #1#))) +(DEFSTRUCT (|%LoadUnit| (:COPIER |copy%LoadUnit|)) + |fdefs| + |sigs| + |xports| + |csts| + |varno|) + +(DEFMACRO |mk%LoadUnit| (|fdefs| |sigs| |xports| |csts| |varno|) + (LIST '|MAKE-%LoadUnit| :|fdefs| |fdefs| :|sigs| |sigs| :|xports| |xports| + :|csts| |csts| :|varno| |varno|)) + +(DEFMACRO |functionDefinitions| (|bfVar#1|) (LIST '|%LoadUnit-fdefs| |bfVar#1|)) + +(DEFMACRO |globalSignatures| (|bfVar#1|) (LIST '|%LoadUnit-sigs| |bfVar#1|)) + +(DEFMACRO |exportedNames| (|bfVar#1|) (LIST '|%LoadUnit-xports| |bfVar#1|)) + +(DEFMACRO |constantBindings| (|bfVar#1|) (LIST '|%LoadUnit-csts| |bfVar#1|)) + +(DEFMACRO |currentGensymNumber| (|bfVar#1|) (LIST '|%LoadUnit-varno| |bfVar#1|)) + +(DEFUN |makeLoadUnit| () (|mk%LoadUnit| NIL NIL NIL NIL 0)) + +(DEFUN |pushFunctionDefinition| (|tu| |def|) + (SETF (|functionDefinitions| |tu|) (CONS |def| (|functionDefinitions| |tu|)))) + (DEFPARAMETER |$inDefIS| NIL) (DEFUN |quote| (|x|) (LIST 'QUOTE |x|)) @@ -152,13 +178,12 @@ (THROW :OPEN-AXIOM-CATCH-POINT (CONS :OPEN-AXIOM-CATCH-POINT (CONS '(|BootSpecificError|) |msg|)))) -(DECLAIM (FTYPE (FUNCTION NIL |%Symbol|) |bfGenSymbol|)) +(DECLAIM (FTYPE (FUNCTION (|%LoadUnit|) |%Symbol|) |bfGenSymbol|)) -(DEFUN |bfGenSymbol| () - (DECLARE (SPECIAL |$GenVarCounter|)) +(DEFUN |bfGenSymbol| (|tu|) (PROGN - (SETQ |$GenVarCounter| (+ |$GenVarCounter| 1)) - (INTERN (CONCAT "bfVar#" (WRITE-TO-STRING |$GenVarCounter|))))) + (SETF (|currentGensymNumber| |tu|) (+ (|currentGensymNumber| |tu|) 1)) + (INTERN (CONCAT "bfVar#" (WRITE-TO-STRING (|currentGensymNumber| |tu|)))))) (DECLAIM (FTYPE (FUNCTION NIL |%Symbol|) |bfLetVar|)) @@ -315,46 +340,46 @@ (COND (|l1| (LIST '|append| |a| (|bfMakeCons| |l1|))) (T |a|))) (T (LIST 'CONS (CAR |l|) (|bfMakeCons| (CDR |l|))))))) -(DEFUN |bfFor| (|lhs| |u| |step|) +(DEFUN |bfFor| (|tu| |lhs| |u| |step|) (COND ((AND (CONSP |u|) (EQ (CAR |u|) '|tails|)) - (|bfForTree| 'ON |lhs| (CADR |u|))) + (|bfForTree| |tu| 'ON |lhs| (CADR |u|))) ((AND (CONSP |u|) (EQ (CAR |u|) 'SEGMENT)) - (|bfSTEP| |lhs| (CADR |u|) |step| (CADDR |u|))) + (|bfSTEP| |tu| |lhs| (CADR |u|) |step| (CADDR |u|))) ((AND (CONSP |u|) (EQ (CAR |u|) '|entries|)) - (|bfIterateTable| |lhs| (CADR |u|))) - (T (|bfForTree| 'IN |lhs| |u|)))) + (|bfIterateTable| |tu| |lhs| (CADR |u|))) + (T (|bfForTree| |tu| 'IN |lhs| |u|)))) -(DEFUN |bfForTree| (OP |lhs| |whole|) +(DEFUN |bfForTree| (|tu| OP |lhs| |whole|) (LET* (G) (PROGN (SETQ |whole| (COND ((|bfTupleP| |whole|) (|bfMakeCons| (CDR |whole|))) (T |whole|))) - (COND ((NOT (CONSP |lhs|)) (|bfINON| (LIST OP |lhs| |whole|))) + (COND ((NOT (CONSP |lhs|)) (|bfINON| |tu| (LIST OP |lhs| |whole|))) (T (SETQ |lhs| (COND ((|bfTupleP| |lhs|) (CADR |lhs|)) (T |lhs|))) (COND ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'L%T)) (SETQ G (CADR |lhs|)) - (|append| (|bfINON| (LIST OP G |whole|)) - (|bfSuchthat| (|bfIS| G (CADDR |lhs|))))) - (T (SETQ G (|bfGenSymbol|)) - (|append| (|bfINON| (LIST OP G |whole|)) - (|bfSuchthat| (|bfIS| G |lhs|)))))))))) + (|append| (|bfINON| |tu| (LIST OP G |whole|)) + (|bfSuchthat| |tu| (|bfIS| |tu| G (CADDR |lhs|))))) + (T (SETQ G (|bfGenSymbol| |tu|)) + (|append| (|bfINON| |tu| (LIST OP G |whole|)) + (|bfSuchthat| |tu| (|bfIS| |tu| G |lhs|)))))))))) -(DEFUN |bfSTEP| (|id| |fst| |step| |lst|) +(DEFUN |bfSTEP| (|tu| |id| |fst| |step| |lst|) (LET* (|suc| |ex| |pred| |final| |g2| |inc| |g1| |initval| |initvar|) (PROGN - (COND ((EQ |id| 'DOT) (SETQ |id| (|bfGenSymbol|)))) + (COND ((EQ |id| 'DOT) (SETQ |id| (|bfGenSymbol| |tu|)))) (SETQ |initvar| (LIST |id|)) (SETQ |initval| (LIST |fst|)) (SETQ |inc| (COND ((NOT (CONSP |step|)) |step|) - (T (SETQ |g1| (|bfGenSymbol|)) + (T (SETQ |g1| (|bfGenSymbol| |tu|)) (SETQ |initvar| (CONS |g1| |initvar|)) (SETQ |initval| (CONS |step| |initval|)) |g1|))) (SETQ |final| (COND ((NOT (CONSP |lst|)) |lst|) - (T (SETQ |g2| (|bfGenSymbol|)) + (T (SETQ |g2| (|bfGenSymbol| |tu|)) (SETQ |initvar| (CONS |g2| |initvar|)) (SETQ |initval| (CONS |lst| |initval|)) |g2|))) (SETQ |ex| @@ -370,20 +395,21 @@ (SETQ |suc| (LIST (LIST 'SETQ |id| (LIST '+ |id| |inc|)))) (LIST (LIST |initvar| |initval| |suc| NIL |ex| NIL))))) -(DEFUN |bfIterateTable| (|e| |t|) (LIST '|%tbliter| |e| |t| (GENSYM))) +(DEFUN |bfIterateTable| (|tu| |e| |t|) (LIST '|%tbliter| |e| |t| (GENSYM))) -(DEFUN |bfINON| (|x|) +(DEFUN |bfINON| (|tu| |x|) (LET* (|whole| |id| |op|) (PROGN (SETQ |op| (CAR |x|)) (SETQ |id| (CADR . #1=(|x|))) (SETQ |whole| (CADDR . #1#)) - (COND ((EQ |op| 'ON) (|bfON| |id| |whole|)) (T (|bfIN| |id| |whole|)))))) + (COND ((EQ |op| 'ON) (|bfON| |tu| |id| |whole|)) + (T (|bfIN| |tu| |id| |whole|)))))) -(DEFUN |bfIN| (|x| E) +(DEFUN |bfIN| (|tu| |x| E) (LET* (|exitCond| |inits| |vars| |g|) (PROGN - (SETQ |g| (|bfGenSymbol|)) + (SETQ |g| (|bfGenSymbol| |tu|)) (SETQ |vars| (LIST |g|)) (SETQ |inits| (LIST E)) (SETQ |exitCond| (LIST 'NOT (LIST 'CONSP |g|))) @@ -397,10 +423,10 @@ (LIST |vars| |inits| (LIST (LIST 'SETQ |g| (LIST 'CDR |g|))) NIL (LIST |exitCond|) NIL))))) -(DEFUN |bfON| (|x| E) +(DEFUN |bfON| (|tu| |x| E) (LET* (|var| |init|) (PROGN - (COND ((EQ |x| 'DOT) (SETQ |x| (|bfGenSymbol|)))) + (COND ((EQ |x| 'DOT) (SETQ |x| (|bfGenSymbol| |tu|)))) (SETQ |var| (SETQ |init| NIL)) (COND ((OR (NOT (SYMBOLP E)) (NOT (EQ |x| E))) (SETQ |var| (LIST |x|)) @@ -409,14 +435,15 @@ (LIST |var| |init| (LIST (LIST 'SETQ |x| (LIST 'CDR |x|))) NIL (LIST (LIST 'NOT (LIST 'CONSP |x|))) NIL))))) -(DEFUN |bfSuchthat| (|p|) (LIST (LIST NIL NIL NIL (LIST |p|) NIL NIL))) +(DEFUN |bfSuchthat| (|tu| |p|) (LIST (LIST NIL NIL NIL (LIST |p|) NIL NIL))) -(DEFUN |bfWhile| (|p|) (LIST (LIST NIL NIL NIL NIL (LIST (|bfNOT| |p|)) NIL))) +(DEFUN |bfWhile| (|tu| |p|) + (LIST (LIST NIL NIL NIL NIL (LIST (|bfNOT| |p|)) NIL))) -(DEFUN |bfUntil| (|p|) +(DEFUN |bfUntil| (|tu| |p|) (LET* (|g|) (PROGN - (SETQ |g| (|bfGenSymbol|)) + (SETQ |g| (|bfGenSymbol| |tu|)) (LIST (LIST (LIST |g|) (LIST NIL) (LIST (LIST 'SETQ |g| |p|)) NIL (LIST |g|) NIL))))) @@ -425,15 +452,16 @@ (DEFUN |bfCross| (|x|) (CONS 'CROSS |x|)) -(DEFUN |bfLp| (|iters| |body|) +(DEFUN |bfLp| (|tu| |iters| |body|) (COND ((AND (CONSP |iters|) (EQ (CAR |iters|) 'ITERATORS)) - (|bfLp1| (CDR |iters|) |body|)) - (T (|bfLpCross| (CDR |iters|) |body|)))) + (|bfLp1| |tu| (CDR |iters|) |body|)) + (T (|bfLpCross| |tu| (CDR |iters|) |body|)))) -(DEFUN |bfLpCross| (|iters| |body|) - (COND ((NULL (CDR |iters|)) (|bfLp| (CAR |iters|) |body|)) - (T (|bfLp| (CAR |iters|) (|bfLpCross| (CDR |iters|) |body|))))) +(DEFUN |bfLpCross| (|tu| |iters| |body|) + (COND ((NULL (CDR |iters|)) (|bfLp| |tu| (CAR |iters|) |body|)) + (T + (|bfLp| |tu| (CAR |iters|) (|bfLpCross| |tu| (CDR |iters|) |body|))))) (DEFUN |bfSep| (|iters|) (LET* (|r| |f|) @@ -459,7 +487,7 @@ (SETQ |bfVar#1| (CDR |bfVar#1|)) (SETQ |bfVar#2| (CDR |bfVar#2|)))))))) -(DEFUN |bfReduce| (|op| |y|) +(DEFUN |bfReduce| (|tu| |op| |y|) (LET* (|it| |ny| |g2| |body| |g1| |g| |init| |a|) (PROGN (SETQ |a| @@ -467,29 +495,29 @@ (T |op|))) (SETQ |op| (|bfReName| |a|)) (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA))) - (SETQ |g| (|bfGenSymbol|)) - (SETQ |g1| (|bfGenSymbol|)) + (SETQ |g| (|bfGenSymbol| |tu|)) + (SETQ |g1| (|bfGenSymbol| |tu|)) (SETQ |body| (LIST 'SETQ |g| (LIST |op| |g| |g1|))) (COND - ((NULL |init|) (SETQ |g2| (|bfGenSymbol|)) (SETQ |init| (LIST 'CAR |g2|)) - (SETQ |ny| (LIST 'CDR |g2|)) + ((NULL |init|) (SETQ |g2| (|bfGenSymbol| |tu|)) + (SETQ |init| (LIST 'CAR |g2|)) (SETQ |ny| (LIST 'CDR |g2|)) (SETQ |it| (CONS 'ITERATORS (LIST (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|))) - (|bfIN| |g1| |ny|)))) - (|bfMKPROGN| (LIST (LIST 'L%T |g2| |y|) (|bfLp| |it| |body|)))) + (|bfIN| |tu| |g1| |ny|)))) + (|bfMKPROGN| (LIST (LIST 'L%T |g2| |y|) (|bfLp| |tu| |it| |body|)))) (T (SETQ |init| (CAR |init|)) (SETQ |it| (CONS 'ITERATORS (LIST (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|))) - (|bfIN| |g1| |y|)))) - (|bfLp| |it| |body|)))))) + (|bfIN| |tu| |g1| |y|)))) + (|bfLp| |tu| |it| |body|)))))) -(DEFUN |bfReduceCollect| (|op| |y|) +(DEFUN |bfReduceCollect| (|tu| |op| |y|) (LET* (|seq| |init| |a| |itl| |body|) (COND ((AND (CONSP |y|) (EQ (CAR |y|) 'COLLECT)) (SETQ |body| (CADR |y|)) @@ -499,20 +527,21 @@ (T |op|))) (COND ((EQ |a| '|append!|) - (|bfDoCollect| |body| |itl| '|lastNode| '|skipNil|)) + (|bfDoCollect| |tu| |body| |itl| '|lastNode| '|skipNil|)) ((EQ |a| '|append|) - (|bfDoCollect| (LIST '|copyList| |body|) |itl| '|lastNode| '|skipNil|)) + (|bfDoCollect| |tu| (LIST '|copyList| |body|) |itl| '|lastNode| + '|skipNil|)) (T (SETQ |op| (|bfReName| |a|)) (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA))) - (|bfOpReduce| |op| |init| |body| |itl|)))) + (|bfOpReduce| |tu| |op| |init| |body| |itl|)))) (T (SETQ |seq| (COND ((NULL |y|) (|bfTuple| NIL)) (T (CADR |y|)))) - (|bfReduce| |op| (|bfTupleConstruct| |seq|)))))) + (|bfReduce| |tu| |op| (|bfTupleConstruct| |seq|)))))) (DEFUN |bfDCollect| (|y| |itl|) (LIST 'COLLECT |y| |itl|)) (DEFUN |bfDTuple| (|x|) (LIST 'DTUPLE |x|)) -(DEFUN |bfCollect| (|y| |itl|) +(DEFUN |bfCollect| (|tu| |y| |itl|) (LET* (|a| |ISTMP#1|) (COND ((AND (CONSP |y|) (EQ (CAR |y|) 'COLON) @@ -523,12 +552,13 @@ (COND ((OR (AND (CONSP |a|) (EQ (CAR |a|) 'CONS)) (AND (CONSP |a|) (EQ (CAR |a|) 'LIST))) - (|bfDoCollect| |a| |itl| '|lastNode| '|skipNil|)) + (|bfDoCollect| |tu| |a| |itl| '|lastNode| '|skipNil|)) (T - (|bfDoCollect| (LIST '|copyList| |a|) |itl| '|lastNode| '|skipNil|)))) + (|bfDoCollect| |tu| (LIST '|copyList| |a|) |itl| '|lastNode| + '|skipNil|)))) ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) - (|bfDoCollect| (|bfConstruct| |y|) |itl| '|lastNode| '|skipNil|)) - (T (|bfDoCollect| (LIST 'CONS |y| 'NIL) |itl| 'CDR NIL))))) + (|bfDoCollect| |tu| (|bfConstruct| |y|) |itl| '|lastNode| '|skipNil|)) + (T (|bfDoCollect| |tu| (LIST 'CONS |y| 'NIL) |itl| 'CDR NIL))))) (DEFUN |bfMakeCollectInsn| (|expr| |prev| |head| |adv|) (LET* (|otherTime| |firstTime|) @@ -545,14 +575,14 @@ (LIST 'SETQ |prev| (LIST |adv| |prev|))))) (|bfIf| (LIST 'NULL |head|) |firstTime| |otherTime|)))) -(DEFUN |bfDoCollect| (|expr| |itl| |adv| |k|) +(DEFUN |bfDoCollect| (|tu| |expr| |itl| |adv| |k|) (LET* (|extrait| |body| |x| |prev| |head|) (PROGN - (SETQ |head| (|bfGenSymbol|)) - (SETQ |prev| (|bfGenSymbol|)) + (SETQ |head| (|bfGenSymbol| |tu|)) + (SETQ |prev| (|bfGenSymbol| |tu|)) (SETQ |body| (COND - ((EQ |k| '|skipNil|) (SETQ |x| (|bfGenSymbol|)) + ((EQ |k| '|skipNil|) (SETQ |x| (|bfGenSymbol| |tu|)) (LIST 'LET (LIST (LIST |x| |expr|)) (|bfIf| (LIST 'NULL |x|) 'NIL (|bfMakeCollectInsn| |x| |prev| |head| |adv|)))) @@ -561,7 +591,7 @@ (LIST (LIST (LIST |head| |prev|) (LIST 'NIL 'NIL) NIL NIL NIL (LIST |head|)))) - (|bfLp2| |extrait| |itl| |body|)))) + (|bfLp2| |tu| |extrait| |itl| |body|)))) (DEFUN |separateIterators| (|iters|) (LET* (|y| |x|) @@ -580,7 +610,7 @@ (SETQ |bfVar#1| (CDR |bfVar#1|)))) (LIST (|reverse!| |x|) (|reverse!| |y|))))) -(DEFUN |bfTableIteratorBindingForm| (|keyval| |end?| |succ|) +(DEFUN |bfTableIteratorBindingForm| (|tu| |keyval| |end?| |succ|) (LET* (|k| |v| |val| |ISTMP#2| |key| |ISTMP#1|) (COND ((AND (CONSP |keyval|) (EQ (CAR |keyval|) 'CONS) @@ -599,20 +629,20 @@ (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |key| |val|) (LIST |succ|))) ((|ident?| |key|) (SETQ |v| (GENSYM)) (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |key| |v|) (LIST |succ|) - (|bfLET| |val| |v|))) + (|bfLET| |tu| |val| |v|))) (T (SETQ |k| (GENSYM)) (COND ((|ident?| |val|) (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |val|) (LIST |succ|) - (|bfLET| |key| |k|))) + (|bfLET| |tu| |key| |k|))) (T (SETQ |v| (GENSYM)) (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |v|) (LIST |succ|) - (|bfLET| |key| |k|) (|bfLET| |val| |v|))))))) + (|bfLET| |tu| |key| |k|) (|bfLET| |tu| |val| |v|))))))) (T (SETQ |k| (GENSYM)) (SETQ |v| (GENSYM)) (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |v|) (LIST |succ|) - (|bfLET| |keyval| (LIST 'CONS |k| |v|))))))) + (|bfLET| |tu| |keyval| (LIST 'CONS |k| |v|))))))) -(DEFUN |bfExpandTableIters| (|iters|) +(DEFUN |bfExpandTableIters| (|tu| |iters|) (LET* (|x| |g| |ISTMP#2| |t| |ISTMP#1| |e| |exits| |localBindings| |inits|) (PROGN (SETQ |inits| NIL) @@ -640,12 +670,12 @@ (SETQ |x| (GENSYM)) (SETQ |exits| (CONS (LIST 'NOT |x|) |exits|)) (SETQ |localBindings| - (CONS (|bfTableIteratorBindingForm| |e| |x| |g|) + (CONS (|bfTableIteratorBindingForm| |tu| |e| |x| |g|) |localBindings|)))))) (SETQ |bfVar#2| (CDR |bfVar#2|)))) (LIST |inits| |localBindings| |exits|)))) -(DEFUN |bfLp1| (|iters| |body|) +(DEFUN |bfLp1| (|tu| |iters| |body|) (LET* (|loop| |nbody| |tblExits| @@ -670,7 +700,7 @@ (SETQ |filters| (CADDDR . #1#)) (SETQ |exits| (CAR #2=(CDDDDR . #1#))) (SETQ |value| (CADR #2#)) - (SETQ |LETTMP#1| (|bfExpandTableIters| |tbls|)) + (SETQ |LETTMP#1| (|bfExpandTableIters| |tu| |tbls|)) (SETQ |tblInits| (CAR |LETTMP#1|)) (SETQ |tblLocs| (CADR . #3=(|LETTMP#1|))) (SETQ |tblExits| (CADDR . #3#)) @@ -726,20 +756,21 @@ (SETQ |bfVar#6| (CDR |bfVar#6|)))) |loop|))) -(DEFUN |bfLp2| (|extrait| |itl| |body|) +(DEFUN |bfLp2| (|tu| |extrait| |itl| |body|) (LET* (|iters|) (COND ((AND (CONSP |itl|) (EQ (CAR |itl|) 'ITERATORS)) - (|bfLp1| (CONS |extrait| (CDR |itl|)) |body|)) + (|bfLp1| |tu| (CONS |extrait| (CDR |itl|)) |body|)) (T (SETQ |iters| (CDR |itl|)) - (|bfLpCross| - (CONS (CONS 'ITERATORS (CONS |extrait| (CDAR |iters|))) (CDR |iters|)) - |body|))))) + (|bfLpCross| |tu| + (CONS (CONS 'ITERATORS (CONS |extrait| (CDAR |iters|))) + (CDR |iters|)) + |body|))))) -(DEFUN |bfOpReduce| (|op| |init| |y| |itl|) +(DEFUN |bfOpReduce| (|tu| |op| |init| |y| |itl|) (LET* (|extrait| |g1| |body| |g|) (PROGN - (SETQ |g| (|bfGenSymbol|)) + (SETQ |g| (|bfGenSymbol| |tu|)) (SETQ |body| (COND ((EQ |op| 'AND) @@ -753,27 +784,27 @@ (LIST 'COND (LIST |g| (LIST 'RETURN |g|)))))) (T (LIST 'SETQ |g| (LIST |op| |g| |y|))))) (COND - ((NULL |init|) (SETQ |g1| (|bfGenSymbol|)) (SETQ |init| (LIST 'CAR |g1|)) - (SETQ |y| (LIST 'CDR |g1|)) + ((NULL |init|) (SETQ |g1| (|bfGenSymbol| |tu|)) + (SETQ |init| (LIST 'CAR |g1|)) (SETQ |y| (LIST 'CDR |g1|)) (SETQ |extrait| (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|)))) (|bfMKPROGN| - (LIST (LIST 'L%T |g1| |y|) (|bfLp2| |extrait| |itl| |body|)))) + (LIST (LIST 'L%T |g1| |y|) (|bfLp2| |tu| |extrait| |itl| |body|)))) (T (SETQ |init| (CAR |init|)) (SETQ |extrait| (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|)))) - (|bfLp2| |extrait| |itl| |body|)))))) + (|bfLp2| |tu| |extrait| |itl| |body|)))))) -(DEFUN |bfLoop1| (|body|) (|bfLp| (|bfIterators| NIL) |body|)) +(DEFUN |bfLoop1| (|tu| |body|) (|bfLp| |tu| (|bfIterators| NIL) |body|)) (DEFUN |bfSegment1| (|lo|) (LIST 'SEGMENT |lo| NIL)) (DEFUN |bfSegment2| (|lo| |hi|) (LIST 'SEGMENT |lo| |hi|)) -(DEFUN |bfForInBy| (|variable| |collection| |step|) - (|bfFor| |variable| |collection| |step|)) +(DEFUN |bfForInBy| (|tu| |variable| |collection| |step|) + (|bfFor| |tu| |variable| |collection| |step|)) -(DEFUN |bfForin| (|lhs| U) (|bfFor| |lhs| U 1)) +(DEFUN |bfForin| (|tu| |lhs| U) (|bfFor| |tu| |lhs| U 1)) (DEFUN |bfLocal| (|a| |b|) (COND ((EQ |b| '|local|) (|compFluid| |a|)) (T |a|))) @@ -839,7 +870,7 @@ (DEFUN |bfLetForm| (|lhs| |rhs|) (LIST 'L%T |lhs| |rhs|)) -(DEFUN |bfLET1| (|lhs| |rhs|) +(DEFUN |bfLET1| (|tu| |lhs| |rhs|) (LET* (|let1| |g| |l2| |l1| |name| |rhs1| |ISTMP#1|) (COND ((SYMBOLP |lhs|) (|bfLetForm| |lhs| |rhs|)) ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Dynamic|) @@ -848,7 +879,7 @@ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))) (|bfLetForm| |lhs| |rhs|)) ((AND (SYMBOLP |rhs|) (NOT (|bfCONTAINED| |rhs| |lhs|))) - (SETQ |rhs1| (|bfLET2| |lhs| |rhs|)) + (SETQ |rhs1| (|bfLET2| |tu| |lhs| |rhs|)) (COND ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'L%T)) (|bfMKPROGN| (LIST |rhs1| |rhs|))) @@ -858,15 +889,15 @@ (|bfMKPROGN| (|append| |rhs1| (CONS |rhs| NIL)))))) ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'L%T) (SYMBOLP (SETQ |name| (CADR |rhs|)))) - (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|))) - (SETQ |l2| (|bfLET1| |lhs| |name|)) + (SETQ |l1| (|bfLET1| |tu| |name| (CADDR |rhs|))) + (SETQ |l2| (|bfLET1| |tu| |lhs| |name|)) (COND ((AND (CONSP |l2|) (EQ (CAR |l2|) 'PROGN)) (|bfMKPROGN| (CONS |l1| (CDR |l2|)))) (T (COND ((SYMBOLP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL)))) (|bfMKPROGN| (CONS |l1| (|append| |l2| (CONS |name| NIL))))))) (T (SETQ |g| (|bfLetVar|)) (SETQ |rhs1| (LIST 'L%T |g| |rhs|)) - (SETQ |let1| (|bfLET1| |lhs| |g|)) + (SETQ |let1| (|bfLET1| |tu| |lhs| |g|)) (COND ((AND (CONSP |let1|) (EQ (CAR |let1|) 'PROGN)) (|bfMKPROGN| (CONS |rhs1| (CDR |let1|)))) @@ -877,7 +908,7 @@ (COND ((EQ |x| |y|) T) ((NOT (CONSP |y|)) NIL) (T (OR (|bfCONTAINED| |x| (CAR |y|)) (|bfCONTAINED| |x| (CDR |y|)))))) -(DEFUN |bfLET2| (|lhs| |rhs|) +(DEFUN |bfLET2| (|tu| |lhs| |rhs|) (LET* (|isPred| |val1| |ISTMP#3| @@ -908,8 +939,8 @@ (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) (PROGN (SETQ |b| (CAR |ISTMP#2|)) T)))))) - (SETQ |a| (|bfLET2| |a| |rhs|)) - (COND ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|) + (SETQ |a| (|bfLET2| |tu| |a| |rhs|)) + (COND ((NULL (SETQ |b| (|bfLET2| |tu| |b| |rhs|))) |a|) ((NOT (CONSP |b|)) (LIST |a| |b|)) ((CONSP (CAR |b|)) (CONS |a| |b|)) (T (LIST |a| |b|)))) ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'CONS) @@ -924,8 +955,8 @@ (COND ((OR (EQ |var1| 'DOT) (AND (CONSP |var1|) (EQ (CAR |var1|) 'QUOTE))) - (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) - (T (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|))) + (|bfLET2| |tu| |var2| (|addCARorCDR| 'CDR |rhs|))) + (T (SETQ |l1| (|bfLET2| |tu| |var1| (|addCARorCDR| 'CAR |rhs|))) (COND ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|) (T (COND @@ -939,7 +970,9 @@ (|addCARorCDR| 'CDR |rhs|)) NIL))) (T - (SETQ |l2| (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) + (SETQ |l2| + (|bfLET2| |tu| |var2| + (|addCARorCDR| 'CDR |rhs|))) (COND ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|)))) (SETQ |l2| (CONS |l2| NIL)))) @@ -955,7 +988,7 @@ (PROGN (SETQ |var2| (CAR |ISTMP#2|)) T)))))) (SETQ |patrev| (|bfISReverse| |var2| |var1|)) (SETQ |rev| (LIST '|reverse| |rhs|)) (SETQ |g| (|bfLetVar|)) - (SETQ |l2| (|bfLET2| |patrev| |g|)) + (SETQ |l2| (|bfLET2| |tu| |patrev| |g|)) (COND ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|)))) (SETQ |l2| (CONS |l2| NIL)))) @@ -993,14 +1026,14 @@ (LIST 'COND (LIST (|bfQ| |var1| |rhs|) |var1|))) (T (SETQ |isPred| - (COND (|$inDefIS| (|bfIS1| |rhs| |lhs|)) - (T (|bfIS| |rhs| |lhs|)))) + (COND (|$inDefIS| (|bfIS1| |tu| |rhs| |lhs|)) + (T (|bfIS| |tu| |rhs| |lhs|)))) (LIST 'COND (LIST |isPred| |rhs|)))))) -(DEFUN |bfLET| (|lhs| |rhs|) +(DEFUN |bfLET| (|tu| |lhs| |rhs|) (LET ((|$letGenVarCounter| 0)) (DECLARE (SPECIAL |$letGenVarCounter|)) - (|bfLET1| |lhs| |rhs|))) + (|bfLET1| |tu| |lhs| |rhs|))) (DEFUN |addCARorCDR| (|acc| |expr|) (LET* (|funsR| |funsA| |p| |funs|) @@ -1029,15 +1062,15 @@ (COND ((NULL |l|) (- 1)) ((EQUAL |x| (CAR |l|)) |n|) (T (|bfPosn| |x| (CDR |l|) (+ |n| 1))))) -(DEFUN |bfISApplication| (|op| |left| |right|) - (COND ((EQ |op| 'IS) (|bfIS| |left| |right|)) - ((EQ |op| 'ISNT) (|bfNOT| (|bfIS| |left| |right|))) +(DEFUN |bfISApplication| (|tu| |op| |left| |right|) + (COND ((EQ |op| 'IS) (|bfIS| |tu| |left| |right|)) + ((EQ |op| 'ISNT) (|bfNOT| (|bfIS| |tu| |left| |right|))) (T (LIST |op| |left| |right|)))) -(DEFUN |bfIS| (|left| |right|) +(DEFUN |bfIS| (|tu| |left| |right|) (LET* ((|$isGenVarCounter| 0) (|$inDefIS| T)) (DECLARE (SPECIAL |$isGenVarCounter| |$inDefIS|)) - (|bfIS1| |left| |right|))) + (|bfIS1| |tu| |left| |right|))) (DEFUN |bfISReverse| (|x| |a|) (LET* (|y|) @@ -1048,7 +1081,7 @@ (RPLACA (CDR (CDR |y|)) (LIST 'CONS (CADR |x|) |a|)) |y|))) (T (|bfSpecificErrorHere| "Error in bfISReverse"))))) -(DEFUN |bfIS1| (|lhs| |rhs|) +(DEFUN |bfIS1| (|tu| |lhs| |rhs|) (LET* (|l2| |rev| |patrev| @@ -1076,8 +1109,9 @@ (LIST (LIST 'STRINGP |lhs|) (LIST 'STRING= |lhs| |a|)))) (T (LIST 'EQUAL |lhs| |rhs|)))) ((EQ (CAR |rhs|) 'L%T) (SETQ |c| (CADR . #1=(|rhs|))) - (SETQ |d| (CADDR . #1#)) (SETQ |l| (|bfLET| |c| |lhs|)) - (|bfAND| (LIST (|bfIS1| |lhs| |d|) (|bfMKPROGN| (LIST |l| 'T))))) + (SETQ |d| (CADDR . #1#)) (SETQ |l| (|bfLET| |tu| |c| |lhs|)) + (|bfAND| + (LIST (|bfIS1| |tu| |lhs| |d|) (|bfMKPROGN| (LIST |l| 'T))))) ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'EQUAL) (PROGN (SETQ |ISTMP#1| (CDR |rhs|)) @@ -1096,7 +1130,7 @@ (EQ |a| 'DOT) (EQ |b| 'DOT)) (LIST 'CONSP |lhs|)) ((CONSP |lhs|) (SETQ |g| (|bfIsVar|)) - (|bfMKPROGN| (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|)))) + (|bfMKPROGN| (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |tu| |g| |rhs|)))) ((EQ (CAR |rhs|) 'CONS) (SETQ |a| (CADR . #2=(|rhs|))) (SETQ |b| (CADDR . #2#)) (COND @@ -1108,16 +1142,17 @@ ((EQ |b| 'DOT) (LIST 'CONSP |lhs|)) (T (|bfAND| - (LIST (LIST 'CONSP |lhs|) (|bfIS1| (LIST 'CDR |lhs|) |b|)))))) + (LIST (LIST 'CONSP |lhs|) + (|bfIS1| |tu| (LIST 'CDR |lhs|) |b|)))))) ((NULL |b|) (|bfAND| (LIST (LIST 'CONSP |lhs|) (LIST 'NULL (LIST 'CDR |lhs|)) - (|bfIS1| (LIST 'CAR |lhs|) |a|)))) + (|bfIS1| |tu| (LIST 'CAR |lhs|) |a|)))) ((EQ |b| 'DOT) (|bfAND| - (LIST (LIST 'CONSP |lhs|) (|bfIS1| (LIST 'CAR |lhs|) |a|)))) - (T (SETQ |a1| (|bfIS1| (LIST 'CAR |lhs|) |a|)) - (SETQ |b1| (|bfIS1| (LIST 'CDR |lhs|) |b|)) + (LIST (LIST 'CONSP |lhs|) (|bfIS1| |tu| (LIST 'CAR |lhs|) |a|)))) + (T (SETQ |a1| (|bfIS1| |tu| (LIST 'CAR |lhs|) |a|)) + (SETQ |b1| (|bfIS1| |tu| (LIST 'CDR |lhs|) |b|)) (COND ((AND (CONSP |a1|) (EQ (CAR |a1|) 'PROGN) (PROGN @@ -1141,7 +1176,7 @@ (LIST (LIST 'CONSP |lhs|) (LIST 'PROGN (LIST 'L%T |g| (LIST '|reverse| |lhs|)) 'T)))) - (SETQ |l2| (|bfIS1| |g| |patrev|)) + (SETQ |l2| (|bfIS1| |tu| |g| |patrev|)) (COND ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|)))) (SETQ |l2| (CONS |l2| NIL)))) @@ -1465,7 +1500,7 @@ (SETQ |vars| (COND ((|bfTupleP| |vars|) (CDR |vars|)) (T (LIST |vars|)))) (LIST 'LAMBDA |vars| |body|))) -(DEFUN |bfMDef| (|op| |args| |body|) +(DEFUN |bfMDef| (|tu| |op| |args| |body|) (LET* (|def| |lamex| |argl|) (DECLARE (SPECIAL |$wheredefs|)) (PROGN @@ -1483,7 +1518,8 @@ (PROGN (SETQ |d| (CAR |bfVar#1|)) NIL)) (RETURN |bfVar#2|)) (T - (LET ((|bfVar#4| (|copyList| (|shoeComps| (|bfDef1| |d|))))) + (LET ((|bfVar#4| + (|copyList| (|shoeComps| (|bfDef1| |tu| |d|))))) (COND ((NULL |bfVar#4|) NIL) ((NULL |bfVar#2|) (SETQ |bfVar#2| |bfVar#4|) (SETQ |bfVar#3| (|lastNode| |bfVar#2|))) @@ -1491,39 +1527,39 @@ (SETQ |bfVar#3| (|lastNode| |bfVar#3|))))))) (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) -(DEFUN |bfGargl| (|argl|) +(DEFUN |bfGargl| (|tu| |argl|) (LET* (|f| |d| |c| |b| |a| |LETTMP#1|) (COND ((NULL |argl|) (LIST NIL NIL NIL NIL)) - (T (SETQ |LETTMP#1| (|bfGargl| (CDR |argl|))) + (T (SETQ |LETTMP#1| (|bfGargl| |tu| (CDR |argl|))) (SETQ |a| (CAR |LETTMP#1|)) (SETQ |b| (CADR . #1=(|LETTMP#1|))) (SETQ |c| (CADDR . #1#)) (SETQ |d| (CADDDR . #1#)) (COND ((EQ (CAR |argl|) '&REST) (LIST (CONS (CAR |argl|) |b|) |b| |c| (CONS (LIST 'CONS (|quote| 'LIST) (CAR |d|)) (CDR |d|)))) - (T (SETQ |f| (|bfGenSymbol|)) + (T (SETQ |f| (|bfGenSymbol| |tu|)) (LIST (CONS |f| |a|) (CONS |f| |b|) (CONS (CAR |argl|) |c|) (CONS |f| |d|)))))))) -(DEFUN |bfDef1| (|bfVar#1|) +(DEFUN |bfDef1| (|tu| |bfVar#1|) (LET* (|arglp| |control| |quotes| |LETTMP#1| |argl| |body| |args| |op|) (PROGN (SETQ |op| (CAR |bfVar#1|)) (SETQ |args| (CADR . #1=(|bfVar#1|))) (SETQ |body| (CADDR . #1#)) (SETQ |argl| (COND ((|bfTupleP| |args|) (CDR |args|)) (T (LIST |args|)))) - (SETQ |LETTMP#1| (|bfInsertLet| |argl| |body|)) + (SETQ |LETTMP#1| (|bfInsertLet| |tu| |argl| |body|)) (SETQ |quotes| (CAR |LETTMP#1|)) (SETQ |control| (CADR . #2=(|LETTMP#1|))) (SETQ |arglp| (CADDR . #2#)) (SETQ |body| (CADDDR . #2#)) - (COND (|quotes| (|shoeLAM| |op| |arglp| |control| |body|)) + (COND (|quotes| (|shoeLAM| |tu| |op| |arglp| |control| |body|)) (T (LIST (LIST |op| (LIST 'LAMBDA |arglp| |body|)))))))) -(DEFUN |shoeLAM| (|op| |args| |control| |body|) +(DEFUN |shoeLAM| (|tu| |op| |args| |control| |body|) (LET* (|innerfunc| |margs|) (PROGN - (SETQ |margs| (|bfGenSymbol|)) + (SETQ |margs| (|bfGenSymbol| |tu|)) (SETQ |innerfunc| (INTERN (CONCAT (SYMBOL-NAME |op|) ",LAM"))) (LIST (LIST |innerfunc| (LIST 'LAMBDA |args| |body|)) (LIST |op| @@ -1531,14 +1567,15 @@ (LIST 'CONS (|quote| |innerfunc|) (LIST 'WRAP |margs| (|quote| |control|))))))))) -(DEFUN |bfDef| (|op| |args| |body|) +(DEFUN |bfDef| (|tu| |op| |args| |body|) (LET* (|body1| |arg1| |op1| |LETTMP#1|) (DECLARE (SPECIAL |$wheredefs| |$bfClamming|)) (COND (|$bfClamming| - (SETQ |LETTMP#1| (|shoeComp| (CAR (|bfDef1| (LIST |op| |args| |body|))))) + (SETQ |LETTMP#1| + (|shoeComp| (CAR (|bfDef1| |tu| (LIST |op| |args| |body|))))) (SETQ |op1| (CADR . #1=(|LETTMP#1|))) (SETQ |arg1| (CADDR . #1#)) - (SETQ |body1| (CDDDR . #1#)) (|bfCompHash| |op1| |arg1| |body1|)) + (SETQ |body1| (CDDDR . #1#)) (|bfCompHash| |tu| |op1| |arg1| |body1|)) (T (|bfTuple| (LET ((|bfVar#2| NIL) @@ -1550,7 +1587,7 @@ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |d| (CAR |bfVar#1|)) NIL)) (RETURN |bfVar#2|)) (T - (LET ((|bfVar#4| (|copyList| (|shoeComps| (|bfDef1| |d|))))) + (LET ((|bfVar#4| (|copyList| (|shoeComps| (|bfDef1| |tu| |d|))))) (COND ((NULL |bfVar#4|) NIL) ((NULL |bfVar#2|) (SETQ |bfVar#2| |bfVar#4|) (SETQ |bfVar#3| (|lastNode| |bfVar#2|))) @@ -1589,7 +1626,7 @@ (CONS |p1| (CONS (CAR |p2|) (CDR |p2|)))) (T (CONS |p1| |p2|)))) -(DEFUN |bfInsertLet| (|x| |body|) +(DEFUN |bfInsertLet| (|tu| |x| |body|) (LET* (|body2| |name2| |norq1| @@ -1615,16 +1652,16 @@ (PROGN (SETQ |b| (CAR |ISTMP#1|)) T)))) (LIST T 'QUOTE (LIST '&REST |b|) |body|)) (T (LIST NIL NIL |x| |body|)))) - (T (SETQ |LETTMP#1| (|bfInsertLet1| (CAR |x|) |body|)) + (T (SETQ |LETTMP#1| (|bfInsertLet1| |tu| (CAR |x|) |body|)) (SETQ |b| (CAR |LETTMP#1|)) (SETQ |norq| (CADR . #1=(|LETTMP#1|))) (SETQ |name1| (CADDR . #1#)) (SETQ |body1| (CADDDR . #1#)) - (SETQ |LETTMP#1| (|bfInsertLet| (CDR |x|) |body1|)) + (SETQ |LETTMP#1| (|bfInsertLet| |tu| (CDR |x|) |body1|)) (SETQ |b1| (CAR |LETTMP#1|)) (SETQ |norq1| (CADR . #2=(|LETTMP#1|))) (SETQ |name2| (CADDR . #2#)) (SETQ |body2| (CADDDR . #2#)) (LIST (OR |b| |b1|) (CONS |norq| |norq1|) (|bfParameterList| |name1| |name2|) |body2|))))) -(DEFUN |bfInsertLet1| (|y| |body|) +(DEFUN |bfInsertLet1| (|tu| |y| |body|) (LET* (|g| |b| |r| |ISTMP#2| |l| |ISTMP#1|) (COND ((AND (CONSP |y|) (EQ (CAR |y|) 'L%T) @@ -1636,7 +1673,7 @@ (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) (PROGN (SETQ |r| (CAR |ISTMP#2|)) T)))))) - (LIST NIL NIL |l| (|bfMKPROGN| (LIST (|bfLET| |r| |l|) |body|)))) + (LIST NIL NIL |l| (|bfMKPROGN| (LIST (|bfLET| |tu| |r| |l|) |body|)))) ((SYMBOLP |y|) (LIST NIL NIL |y| |body|)) ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE) (PROGN @@ -1644,7 +1681,7 @@ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) (PROGN (SETQ |b| (CAR |ISTMP#1|)) T)))) (LIST T 'QUOTE |b| |body|)) - (T (SETQ |g| (|bfGenSymbol|)) + (T (SETQ |g| (|bfGenSymbol| |tu|)) (COND ((NOT (CONSP |y|)) (LIST NIL NIL |g| |body|)) (T (CASE (CAR |y|) @@ -1654,7 +1691,7 @@ (T (LIST NIL NIL |g| (|bfMKPROGN| - (LIST (|bfLET| (|compFluidize| |y|) |g|) + (LIST (|bfLET| |tu| (|compFluidize| |y|) |g|) |body|))))))))))) (DEFUN |shoeCompTran| (|x|) @@ -2016,23 +2053,23 @@ (LIST 'LET* |inits| (LIST 'DECLARE (CONS 'SPECIAL |vars|)) (|bfMKPROGN| |stmts|)))))) -(DEFUN |bfTagged| (|a| |b|) +(DEFUN |bfTagged| (|tu| |a| |b|) (DECLARE (SPECIAL |$typings| |$op|)) (COND ((NULL |$op|) (|%Signature| |a| |b|)) ((SYMBOLP |a|) - (COND ((EQ |b| '|local|) (|bfLET| (|compFluid| |a|) NIL)) + (COND ((EQ |b| '|local|) (|bfLET| |tu| (|compFluid| |a|) NIL)) (T (SETQ |$typings| (CONS (LIST 'TYPE |b| |a|) |$typings|)) |a|))) (T (LIST 'THE |b| |a|)))) (DEFUN |bfRestrict| (|x| |t|) (LIST 'THE |t| |x|)) -(DEFUN |bfAssign| (|l| |r|) +(DEFUN |bfAssign| (|tu| |l| |r|) (LET* (|l'|) (COND ((|bfTupleP| |l|) (|bfSetelt| (CADR |l|) (CDDR |l|) |r|)) ((AND (CONSP |l|) (EQ (CAR |l|) '|%Place|)) (SETQ |l'| (CDR |l|)) (LIST 'SETF |l'| |r|)) - (T (|bfLET| |l| |r|))))) + (T (|bfLET| |tu| |l| |r|))))) (DEFUN |bfSetelt| (|e| |l| |r|) (COND ((NULL (CDR |l|)) (|defSETELT| |e| (CAR |l|) |r|)) @@ -2241,17 +2278,17 @@ (SETQ |$wheredefs| (|append| |a| |$wheredefs|)) (|bfMKPROGN| (|bfSUBLIS| |opassoc| (|append!| |nondefs| (LIST |expr|))))))) -(DEFUN |bfCompHash| (|op| |argl| |body|) +(DEFUN |bfCompHash| (|tu| |op| |argl| |body|) (LET* (|computeFunction| |auxfn|) (PROGN (SETQ |auxfn| (INTERN (CONCAT (SYMBOL-NAME |op|) ";"))) (SETQ |computeFunction| (CONS 'DEFUN (CONS |auxfn| (CONS |argl| |body|)))) - (|bfTuple| (CONS |computeFunction| (|bfMain| |auxfn| |op|)))))) + (|bfTuple| (CONS |computeFunction| (|bfMain| |tu| |auxfn| |op|)))))) (DEFUN |shoeCompileTimeEvaluation| (|x|) (LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL) |x|)) -(DEFUN |bfMain| (|auxfn| |op|) +(DEFUN |bfMain| (|tu| |auxfn| |op|) (LET* (|defCode| |cacheVector| |cacheCountCode| @@ -2269,11 +2306,11 @@ |arg| |g1|) (PROGN - (SETQ |g1| (|bfGenSymbol|)) + (SETQ |g1| (|bfGenSymbol| |tu|)) (SETQ |arg| (LIST '&REST |g1|)) (SETQ |computeValue| (LIST 'APPLY (LIST 'FUNCTION |auxfn|) |g1|)) (SETQ |cacheName| (INTERN (CONCAT (SYMBOL-NAME |op|) ";AL"))) - (SETQ |g2| (|bfGenSymbol|)) + (SETQ |g2| (|bfGenSymbol| |tu|)) (SETQ |getCode| (LIST 'GETHASH |g1| |cacheName|)) (SETQ |secondPredPair| (LIST (LIST 'SETQ |g2| |getCode|) |g2|)) (SETQ |putCode| (LIST 'SETF |getCode| |computeValue|)) @@ -2312,9 +2349,9 @@ (T (LIST |y|)))) (CONS |x| |y|))) -(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Form|) |bfCreateDef|)) +(DECLAIM (FTYPE (FUNCTION (|%LoadUnit| |%Thing|) |%Form|) |bfCreateDef|)) -(DEFUN |bfCreateDef| (|x|) +(DEFUN |bfCreateDef| (|tu| |x|) (LET* (|a| |f|) (COND ((AND (CONSP |x|) (NULL (CDR |x|))) (SETQ |f| (CAR |x|)) @@ -2331,7 +2368,7 @@ (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) (RETURN |bfVar#2|)) ((NULL |bfVar#2|) - (SETQ |bfVar#2| #1=(CONS (|bfGenSymbol|) NIL)) + (SETQ |bfVar#2| #1=(CONS (|bfGenSymbol| |tu|) NIL)) (SETQ |bfVar#3| |bfVar#2|)) (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) (SETQ |bfVar#1| (CDR |bfVar#1|))))) @@ -2342,12 +2379,12 @@ (DEFUN |bfCaseItem| (|x| |y|) (LIST |x| |y|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) |%Form|) |bfCase|)) +(DECLAIM (FTYPE (FUNCTION (|%LoadUnit| |%Thing| |%Thing|) |%Form|) |bfCase|)) -(DEFUN |bfCase| (|x| |y|) +(DEFUN |bfCase| (|tu| |x| |y|) (LET* (|body| |g|) (PROGN - (SETQ |g| (COND ((NOT (CONSP |x|)) |x|) (T (|bfGenSymbol|)))) + (SETQ |g| (COND ((NOT (CONSP |x|)) |x|) (T (|bfGenSymbol| |tu|)))) (SETQ |body| (CONS 'CASE (CONS (LIST 'CAR |g|) (|bfCaseItems| |g| |y|)))) (COND ((EQ |g| |x|) |body|) (T (LIST 'LET (LIST (LIST |g| |x|)) |body|)))))) @@ -2424,7 +2461,7 @@ (DEFUN |bfEnum| (|t| |csts|) (LIST 'DEFTYPE |t| NIL (|backquote| (CONS 'MEMBER |csts|) NIL))) -(DEFUN |bfRecordDef| (|s| |fields| |accessors|) +(DEFUN |bfRecordDef| (|tu| |s| |fields| |accessors|) (LET* (|accDefs| |f| |acc| @@ -2525,7 +2562,7 @@ (CONS 'LIST (CONS (|quote| |ctor|) |args|))))) (SETQ |accDefs| (COND ((NULL |accessors|) NIL) - (T (SETQ |x| (|bfGenSymbol|)) + (T (SETQ |x| (|bfGenSymbol| |tu|)) (LET ((|bfVar#14| NIL) (|bfVar#15| NIL) (|bfVar#13| |accessors|) @@ -3414,11 +3451,11 @@ (CONS |foreignDecl| |$foreignsDefsForCLisp|)) (LIST |forwardingFun|)))) -(DEFUN |genCLISPnativeTranslation,copyBack| (|bfVar#26|) +(DEFUN |genCLISPnativeTranslation,copyBack| (|bfVar#1|) (LET* (|a| |y| |x| |p|) (PROGN - (SETQ |p| (CAR |bfVar#26|)) - (SETQ |x| (CADR . #1=(|bfVar#26|))) + (SETQ |p| (CAR |bfVar#1|)) + (SETQ |x| (CADR . #1=(|bfVar#1|))) (SETQ |y| (CADDR . #1#)) (SETQ |a| (CDDDR . #1#)) (COND ((AND (CONSP |x|) (EQ (CAR |x|) '|readonly|)) NIL) diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp index cf7acb25..cf602e8a 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -14,11 +14,12 @@ |trees| |pren| |scp| - |cur|) + |cur| + |tu|) -(DEFMACRO |mk%ParserState| (|toks| |trees| |pren| |scp| |cur|) +(DEFMACRO |mk%ParserState| (|toks| |trees| |pren| |scp| |cur| |tu|) (LIST '|MAKE-%ParserState| :|toks| |toks| :|trees| |trees| :|pren| |pren| - :|scp| |scp| :|cur| |cur|)) + :|scp| |scp| :|cur| |cur| :|tu| |tu|)) (DEFMACRO |parserTokens| (|bfVar#1|) (LIST '|%ParserState-toks| |bfVar#1|)) @@ -30,7 +31,10 @@ (DEFMACRO |parserCurrentToken| (|bfVar#1|) (LIST '|%ParserState-cur| |bfVar#1|)) -(DEFUN |makeParserState| (|toks|) (|mk%ParserState| |toks| NIL 0 0 NIL)) +(DEFMACRO |parserLoadUnit| (|bfVar#1|) (LIST '|%ParserState-tu| |bfVar#1|)) + +(DEFUN |makeParserState| (|toks|) + (|mk%ParserState| |toks| NIL 0 0 NIL (|makeLoadUnit|))) (DEFMACRO |parserTokenValue| (|ps|) (LIST '|tokenValue| (LIST '|parserCurrentToken| |ps|))) @@ -41,29 +45,8 @@ (DEFMACRO |parserTokenPosition| (|ps|) (LIST '|tokenPosition| (LIST '|parserCurrentToken| |ps|))) -(DEFSTRUCT (|%Translator| (:COPIER |copy%Translator|)) - |ipath| - |fdefs| - |sigs| - |xports| - |csts|) - -(DEFMACRO |mk%Translator| (|ipath| |fdefs| |sigs| |xports| |csts|) - (LIST '|MAKE-%Translator| :|ipath| |ipath| :|fdefs| |fdefs| :|sigs| |sigs| - :|xports| |xports| :|csts| |csts|)) - -(DEFMACRO |inputFilePath| (|bfVar#1|) (LIST '|%Translator-ifile| |bfVar#1|)) - -(DEFMACRO |functionDefinitions| (|bfVar#1|) - (LIST '|%Translator-fdefs| |bfVar#1|)) - -(DEFMACRO |globalSignatures| (|bfVar#1|) (LIST '|%Translator-sigs| |bfVar#1|)) - -(DEFMACRO |exportedNames| (|bfVar#1|) (LIST '|%Translator-xports| |bfVar#1|)) - -(DEFMACRO |constantBindings| (|bfVar#1|) (LIST '|%Translator-csts| |bfVar#1|)) - -(DEFUN |makeTranslator| (|ip|) (|mk%Translator| |ip| NIL NIL NIL NIL)) +(DEFMACRO |parserGensymSequenceNumber| (|ps|) + (LIST '|currentGensymNumber| (LIST '|parserLoadUnit| |ps|))) (DEFUN |bpFirstToken| (|ps|) (PROGN @@ -292,7 +275,7 @@ (DEFUN |bpAndOr| (|ps| |keyword| |p| |f|) (AND (|bpEqKey| |ps| |keyword|) (|bpRequire| |ps| |p|) - (|bpPush| |ps| (FUNCALL |f| (|bpPop1| |ps|))))) + (|bpPush| |ps| (FUNCALL |f| (|parserLoadUnit| |ps|) (|bpPop1| |ps|))))) (DEFUN |bpConditional| (|ps| |f|) (COND @@ -718,7 +701,9 @@ (COND ((|bpEqKey| |ps| 'COLON) (AND (|bpRequire| |ps| #'|bpTyping|) - (|bpPush| |ps| (|bfTagged| (|bpPop2| |ps|) (|bpPop1| |ps|))))) + (|bpPush| |ps| + (|bfTagged| (|parserLoadUnit| |ps|) (|bpPop2| |ps|) + (|bpPop1| |ps|))))) ((|bpEqKey| |ps| 'AT) (AND (|bpRequire| |ps| #'|bpTyping|) (|bpPush| |ps| (|bfRestrict| (|bpPop2| |ps|) (|bpPop1| |ps|))))) @@ -797,10 +782,13 @@ ((|bpEqPeek| |ps| 'OBRACK) (AND (|bpRequire| |ps| #'|bpDConstruct|) (|bpPush| |ps| - (|bfReduceCollect| (|bpPop2| |ps|) (|bpPop1| |ps|))))) + (|bfReduceCollect| (|parserLoadUnit| |ps|) + (|bpPop2| |ps|) (|bpPop1| |ps|))))) (T (AND (|bpRequire| |ps| #'|bpApplication|) - (|bpPush| |ps| (|bfReduce| (|bpPop2| |ps|) (|bpPop1| |ps|))))))) + (|bpPush| |ps| + (|bfReduce| (|parserLoadUnit| |ps|) (|bpPop2| |ps|) + (|bpPop1| |ps|))))))) (T (|bpRestore| |ps| |a|) NIL))))) (DEFUN |bpTimes| (|ps|) @@ -821,8 +809,8 @@ (COND ((AND (|bpInfKey| |ps| '(IS ISNT)) (|bpRequire| |ps| #'|bpPattern|)) (|bpPush| |ps| - (|bfISApplication| (|bpPop2| |ps|) (|bpPop2| |ps|) - (|bpPop1| |ps|)))) + (|bfISApplication| (|parserLoadUnit| |ps|) (|bpPop2| |ps|) + (|bpPop2| |ps|) (|bpPop1| |ps|)))) ((AND (|bpEqKey| |ps| 'HAS) (|bpRequire| |ps| #'|bpApplication|)) (|bpPush| |ps| (|bfHas| (|bpPop2| |ps|) (|bpPop1| |ps|)))) (T T)))) @@ -937,9 +925,11 @@ (OR (AND (|bpIterators| |ps|) (|bpCompMissing| |ps| 'REPEAT) (|bpRequire| |ps| #'|bpWhere|) - (|bpPush| |ps| (|bfLp| (|bpPop2| |ps|) (|bpPop1| |ps|)))) + (|bpPush| |ps| + (|bfLp| (|parserLoadUnit| |ps|) (|bpPop2| |ps|) + (|bpPop1| |ps|)))) (AND (|bpEqKey| |ps| 'REPEAT) (|bpRequire| |ps| #'|bpLogical|) - (|bpPush| |ps| (|bfLoop1| (|bpPop1| |ps|)))))) + (|bpPush| |ps| (|bfLoop1| (|parserLoadUnit| |ps|) (|bpPop1| |ps|)))))) (DEFUN |bpSuchThat| (|ps|) (|bpAndOr| |ps| 'BAR #'|bpWhere| #'|bfSuchthat|)) @@ -956,9 +946,11 @@ (AND (|bpRequire| |ps| #'|bpSeg|) (|bpEqKey| |ps| 'BY) (|bpRequire| |ps| #'|bpArith|) (|bpPush| |ps| - (|bfForInBy| (|bpPop3| |ps|) (|bpPop2| |ps|) - (|bpPop1| |ps|)))) - (|bpPush| |ps| (|bfForin| (|bpPop2| |ps|) (|bpPop1| |ps|)))))) + (|bfForInBy| (|parserLoadUnit| |ps|) (|bpPop3| |ps|) + (|bpPop2| |ps|) (|bpPop1| |ps|)))) + (|bpPush| |ps| + (|bfForin| (|parserLoadUnit| |ps|) (|bpPop2| |ps|) + (|bpPop1| |ps|)))))) (DEFUN |bpSeg| (|ps|) (AND (|bpArith| |ps|) @@ -1003,7 +995,9 @@ (DEFUN |bpAssignment| (|ps|) (AND (|bpAssignVariable| |ps|) (|bpEqKey| |ps| 'BEC) (|bpRequire| |ps| #'|bpAssign|) - (|bpPush| |ps| (|bfAssign| (|bpPop2| |ps|) (|bpPop1| |ps|))))) + (|bpPush| |ps| + (|bfAssign| (|parserLoadUnit| |ps|) (|bpPop2| |ps|) + (|bpPop1| |ps|))))) (DEFUN |bpLambda| (|ps|) (AND (|bpVariable| |ps|) (|bpEqKey| |ps| 'GIVES) @@ -1133,7 +1127,9 @@ (AND (|bpComma| |ps|) (OR (AND (|bpIteratorTail| |ps|) - (|bpPush| |ps| (|bfCollect| (|bpPop2| |ps|) (|bpPop1| |ps|)))) + (|bpPush| |ps| + (|bfCollect| (|parserLoadUnit| |ps|) (|bpPop2| |ps|) + (|bpPop1| |ps|)))) (|bpPush| |ps| (|bfTupleConstruct| (|bpPop1| |ps|)))))) (DEFUN |bpDConstruct| (|ps|) (|bpBracket| |ps| #'|bpDConstruction|)) @@ -1159,7 +1155,9 @@ (AND (|bpName| |ps|) (OR (AND (|bpEqKey| |ps| 'BEC) (|bpRequire| |ps| #'|bpPattern|) - (|bpPush| |ps| (|bfAssign| (|bpPop2| |ps|) (|bpPop1| |ps|)))) + (|bpPush| |ps| + (|bfAssign| (|parserLoadUnit| |ps|) (|bpPop2| |ps|) + (|bpPop1| |ps|)))) T)) (|bpBracketConstruct| |ps| #'|bpPatternL|))) @@ -1206,11 +1204,17 @@ (DEFUN |bpRegularBVItemTail| (|ps|) (OR (AND (|bpEqKey| |ps| 'COLON) (|bpRequire| |ps| #'|bpApplication|) - (|bpPush| |ps| (|bfTagged| (|bpPop2| |ps|) (|bpPop1| |ps|)))) + (|bpPush| |ps| + (|bfTagged| (|parserLoadUnit| |ps|) (|bpPop2| |ps|) + (|bpPop1| |ps|)))) (AND (|bpEqKey| |ps| 'BEC) (|bpRequire| |ps| #'|bpPattern|) - (|bpPush| |ps| (|bfAssign| (|bpPop2| |ps|) (|bpPop1| |ps|)))) + (|bpPush| |ps| + (|bfAssign| (|parserLoadUnit| |ps|) (|bpPop2| |ps|) + (|bpPop1| |ps|)))) (AND (|bpEqKey| |ps| 'IS) (|bpRequire| |ps| #'|bpPattern|) - (|bpPush| |ps| (|bfAssign| (|bpPop2| |ps|) (|bpPop1| |ps|)))) + (|bpPush| |ps| + (|bfAssign| (|parserLoadUnit| |ps|) (|bpPop2| |ps|) + (|bpPop1| |ps|)))) (AND (|bpEqKey| |ps| 'DEF) (|bpRequire| |ps| #'|bpApplication|) (|bpPush| |ps| (|%DefaultValue| (|bpPop2| |ps|) (|bpPop1| |ps|)))))) @@ -1353,7 +1357,9 @@ (DEFUN |bpPiledCaseItems| (|ps|) (AND (|bpPileBracketed| |ps| #'|bpCaseItemList|) - (|bpPush| |ps| (|bfCase| (|bpPop2| |ps|) (|bpPop1| |ps|))))) + (|bpPush| |ps| + (|bfCase| (|parserLoadUnit| |ps|) (|bpPop2| |ps|) + (|bpPop1| |ps|))))) (DEFUN |bpCaseItemList| (|ps|) (|bpListAndRecover| |ps| #'|bpCaseItem|)) @@ -1368,21 +1374,27 @@ (|bpPush| |ps| (|bfCaseItem| (|bpPop2| |ps|) (|bpPop1| |ps|))))) (DEFUN |bpOutItem| (|ps|) - (LET* (|t| |r| |ISTMP#2| |l| |ISTMP#1| |b|) + (LET* (|t| |r| |ISTMP#2| |l| |ISTMP#1| |b| |varno|) (DECLARE (SPECIAL |$InteractiveMode|)) - (LET* ((|$op| NIL) (|$GenVarCounter| 0)) - (DECLARE (SPECIAL |$op| |$GenVarCounter|)) + (LET ((|$op| NIL)) + (DECLARE (SPECIAL |$op|)) (PROGN - (LET ((#1=#:G721 - (CATCH :OPEN-AXIOM-CATCH-POINT (|bpRequire| |ps| #'|bpComma|)))) - (COND - ((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT)) - (COND - ((EQUAL (CAR #2=(CDR #1#)) '(|BootSpecificError|)) - (LET ((|e| (CDR #2#))) - (PROGN (|bpSpecificErrorHere| |ps| |e|) (|bpTrap| |ps|)))) - (T (THROW :OPEN-AXIOM-CATCH-POINT #1#)))) - (T #1#))) + (SETQ |varno| (|parserGensymSequenceNumber| |ps|)) + (UNWIND-PROTECT + (LET ((#1=#:G721 + (CATCH :OPEN-AXIOM-CATCH-POINT + (PROGN + (SETF (|parserGensymSequenceNumber| |ps|) 0) + (|bpRequire| |ps| #'|bpComma|))))) + (COND + ((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT)) + (COND + ((EQUAL (CAR #2=(CDR #1#)) '(|BootSpecificError|)) + (LET ((|e| (CDR #2#))) + (PROGN (|bpSpecificErrorHere| |ps| |e|) (|bpTrap| |ps|)))) + (T (THROW :OPEN-AXIOM-CATCH-POINT #1#)))) + (T #1#))) + (SETF (|parserGensymSequenceNumber| |ps|) |varno|)) (SETQ |b| (|bpPop1| |ps|)) (SETQ |t| (COND ((AND (CONSP |b|) (EQ (CAR |b|) '+LINE)) (LIST |b|)) @@ -1398,6 +1410,6 @@ (SYMBOLP |l|)) (COND (|$InteractiveMode| (LIST (LIST 'SETQ |l| |r|))) (T (LIST (LIST 'DEFPARAMETER |l| |r|))))) - (T (|translateToplevel| |b| NIL)))) + (T (|translateToplevel| |ps| |b| NIL)))) (|bpPush| |ps| |t|))))) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index 6dd616b2..675bd292 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -581,7 +581,7 @@ (SETQ |bfVar#1| (CDR |bfVar#1|)))))) (T |x|))))) -(DEFUN |translateToplevel| (|b| |export?|) +(DEFUN |translateToplevel| (|ps| |b| |export?|) (LET* (|csts| |accessors| |fields| @@ -608,7 +608,7 @@ (LET ((|op| (CADR |b|)) (|args| (CADDR |b|)) (|body| (CADDDR |b|))) - (CDR (|bfDef| |op| |args| |body|)))) + (CDR (|bfDef| (|parserLoadUnit| |ps|) |op| |args| |body|)))) (|%Module| (LET ((|m| (CADR |b|)) (|ns| (CADDR |b|)) (|ds| (CADDDR |b|))) (PROGN @@ -631,7 +631,8 @@ (SETQ |bfVar#2| #1=(CONS (CAR - (|translateToplevel| |d| T)) + (|translateToplevel| |ps| + |d| T)) NIL)) (SETQ |bfVar#3| |bfVar#2|)) (T (RPLACD |bfVar#3| #1#) @@ -703,7 +704,7 @@ (LET ((|op| (CADR |b|)) (|args| (CADDR |b|)) (|body| (CADDDR |b|))) - (|bfMDef| |op| |args| |body|))) + (|bfMDef| (|parserLoadUnit| |ps|) |op| |args| |body|))) (|%Structure| (LET ((|t| (CADR |b|)) (|alts| (CADDR |b|))) (COND @@ -718,7 +719,8 @@ (PROGN (SETQ |accessors| (CAR |ISTMP#2|)) T)))))) - (|bfRecordDef| |t| |fields| |accessors|)) + (|bfRecordDef| (|parserLoadUnit| |ps|) |t| |fields| + |accessors|)) ((AND (CONSP |alts|) (NULL (CDR |alts|)) (PROGN (SETQ |ISTMP#1| (CAR |alts|)) @@ -737,7 +739,11 @@ (PROGN (SETQ |alt| (CAR |bfVar#4|)) NIL)) (RETURN |bfVar#5|)) ((NULL |bfVar#5|) - (SETQ |bfVar#5| #2=(CONS (|bfCreateDef| |alt|) NIL)) + (SETQ |bfVar#5| + #2=(CONS + (|bfCreateDef| (|parserLoadUnit| |ps|) + |alt|) + NIL)) (SETQ |bfVar#6| |bfVar#5|)) (T (RPLACD |bfVar#6| #2#) (SETQ |bfVar#6| (CDR |bfVar#6|)))) diff --git a/src/boot/translator.boot b/src/boot/translator.boot index c350bd7c..82da1f34 100644 --- a/src/boot/translator.boot +++ b/src/boot/translator.boot @@ -430,18 +430,18 @@ packageBody(x,p) == x is ['PROGN,:.] => [x.op,:[packageBody(y,p) for y in x.args]] x -translateToplevel(b,export?) == +translateToplevel(ps,b,export?) == b isnt [.,:.] => [b] -- generally happens in interactive mode. b is ["TUPLE",:xs] => coreError '"invalid AST" case b of %Signature(op,t) => [genDeclaration(op,t)] - %Definition(op,args,body) => bfDef(op,args,body).args + %Definition(op,args,body) => bfDef(parserLoadUnit ps,op,args,body).args %Module(m,ns,ds) => $currentModuleName := m $foreignsDefsForCLisp := nil [["PROVIDE", symbolName m], :exportNames ns, - :[first translateToplevel(d,true) for d in ds]] + :[first translateToplevel(ps,d,true) for d in ds]] %Import(m) => m is ['%Namespace,n] => [inAllContexts packageBody(b,nil)] @@ -472,12 +472,13 @@ translateToplevel(b,export?) == $InteractiveMode => [["SETF",lhs,rhs]] [["DEFPARAMETER",lhs,rhs]] - %Macro(op,args,body) => bfMDef(op,args,body) + %Macro(op,args,body) => bfMDef(parserLoadUnit ps,op,args,body) %Structure(t,alts) => - alts is ['%Record,fields,accessors] => bfRecordDef(t,fields,accessors) + alts is ['%Record,fields,accessors] => + bfRecordDef(parserLoadUnit ps,t,fields,accessors) alts is [['Enumeration,:csts]] => [bfEnum(t,csts)] - [bfCreateDef alt for alt in alts] + [bfCreateDef(parserLoadUnit ps,alt) for alt in alts] %Namespace n => $activeNamespace := symbolName n |