aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2012-05-31 23:48:40 +0000
committerdos-reis <gdr@axiomatics.org>2012-05-31 23:48:40 +0000
commit71cc09979c4cde3fc47190273050af50cd2038c9 (patch)
treecb923078615f38079d31eae82d9da8926c1fe933 /src
parent96a0d6b9d7002c6ced564c398eb9b576f1c85119 (diff)
downloadopen-axiom-71cc09979c4cde3fc47190273050af50cd2038c9.tar.gz
* boot/ast.boot: Add a %LoadUnit parameter to most functions.
Adjust callers. * boot/translator.boot: Tidy.
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog6
-rw-r--r--src/boot/ast.boot324
-rw-r--r--src/boot/parser.boot75
-rw-r--r--src/boot/strap/ast.clisp353
-rw-r--r--src/boot/strap/parser.clisp130
-rw-r--r--src/boot/strap/translator.clisp18
-rw-r--r--src/boot/translator.boot13
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-27 01:35:21 +0000