diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/ChangeLog | 7 | ||||
-rw-r--r-- | src/boot/ast.boot | 351 | ||||
-rw-r--r-- | src/boot/includer.boot | 9 | ||||
-rw-r--r-- | src/boot/parser.boot | 47 | ||||
-rw-r--r-- | src/boot/pile.boot | 6 | ||||
-rw-r--r-- | src/boot/scanner.boot | 2 | ||||
-rw-r--r-- | src/boot/strap/ast.clisp | 94 | ||||
-rw-r--r-- | src/boot/strap/includer.clisp | 10 | ||||
-rw-r--r-- | src/boot/strap/parser.clisp | 52 | ||||
-rw-r--r-- | src/boot/strap/pile.clisp | 2 | ||||
-rw-r--r-- | src/boot/strap/translator.clisp | 3 | ||||
-rw-r--r-- | src/boot/translator.boot | 2 |
12 files changed, 301 insertions, 284 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 12e0a19c..13d6c5f6 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,10 @@ +2009-09-02 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * boot/ast.boot: More cleanup. + * boot/includer.boot: Likewise. + * boot/parser.boot: Likewise. + * boot/scanner.boot: Likewise. + 2009-08-30 Gabriel Dos Reis <gdr@cs.tamu.edu> * boot/ast.boot (bfSequence): Simplify COND branch bodies. diff --git a/src/boot/ast.boot b/src/boot/ast.boot index 13a813e0..ee531a0f 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -189,12 +189,10 @@ bfAppend x== bfColonAppend: (%List,%Thing) -> %List bfColonAppend(x,y) == - if null x - then - if y is ["BVQUOTE",:a] - then ["&REST",["QUOTE",:a]] - else ["&REST",y] - else cons(first x,bfColonAppend(rest x,y)) + null x => + y is ["BVQUOTE",:a] => ["&REST",["QUOTE",:a]] + ["&REST",y] + cons(first x,bfColonAppend(rest x,y)) bfBeginsDollar: %Thing -> %Boolean bfBeginsDollar x == @@ -205,23 +203,24 @@ compFluid id == compFluidize x== IDENTP x and bfBeginsDollar x=>compFluid x - atom x =>x - EQCAR(x,"QUOTE")=>x + atom x => x + x is ["QUOTE",:.] => x cons(compFluidize(first x),compFluidize(rest x)) -bfTuple x== ["TUPLE",:x] +bfTuple x == + ["TUPLE",:x] -bfTupleP x==EQCAR(x,"TUPLE") +bfTupleP x == + x is ["TUPLE",:.] ++ If `bf' is a tuple return its elements; otherwise `bf'. bfUntuple bf == - bfTupleP bf => cdr bf + bfTupleP bf => rest bf bf bfTupleIf x== - if bfTupleP x - then x - else bfTuple x + bfTupleP x => x + bfTuple x bfTupleConstruct b == a:= if bfTupleP b @@ -244,18 +243,15 @@ bfMakeCons l == ['CONS,first l,bfMakeCons rest l] bfFor(bflhs,U,step) == - if EQCAR (U,'tails) - then bfForTree('ON, bflhs, second U) - else - if EQCAR(U,"SEGMENT") - then bfSTEP(bflhs,second U,step,third U) - else bfForTree('IN, bflhs, U) + U is ["tails",:.] => bfForTree('ON, bflhs, second U) + U is ["SEGMENT",:.] => bfSTEP(bflhs,second U,step,third U) + bfForTree('IN, bflhs, U) bfForTree(OP,lhs,whole)== whole:=if bfTupleP whole then bfMakeCons cdr whole else whole atom lhs =>bfINON [OP,lhs,whole] lhs:=if bfTupleP lhs then second lhs else lhs - EQCAR(lhs,"L%T") => + lhs is ["L%T",:.] => G:=second lhs [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,third lhs)] G:=bfGenSymbol() @@ -291,10 +287,9 @@ bfSTEP(id,fst,step,lst)== bfINON x== - [op,id,whole]:=x - if EQ(op,"ON") - then bfON(id,whole) - else bfIN(id,whole) + [op,id,whole]:=x + op = "ON" => bfON(id,whole) + bfIN(id,whole) bfIN(x,E)== g:=bfGenSymbol() @@ -318,154 +313,146 @@ bfIterators x==["ITERATORS",:x] bfCross x== ["CROSS",:x] bfLp(iters,body)== - EQCAR (iters,"ITERATORS")=>bfLp1(rest iters,body) - bfLpCross(rest iters,body) + iters is ["ITERATORS",:.] => bfLp1(rest iters,body) + bfLpCross(rest iters,body) bfLpCross(iters,body)== - if null cdr iters - then bfLp(first iters,body) - else bfLp(first iters,bfLpCross(rest iters,body)) + null rest iters => bfLp(first iters,body) + bfLp(first iters,bfLpCross(rest iters,body)) bfSep(iters)== - if null iters - then [[],[],[],[],[],[]] - else - f:=first iters - r:=bfSep rest iters - [append(i,j) for i in f for j in r] + null iters => [[],[],[],[],[],[]] + f := first iters + r := bfSep rest iters + [append(i,j) for i in f for j in r] bfReduce(op,y)== - a:=if EQCAR(op,"QUOTE") then second op else op - op:=bfReName a - init := GET(a,"SHOETHETA") or GET(op,"SHOETHETA") - g:=bfGenSymbol() - g1:=bfGenSymbol() - body:=['SETQ,g,[op,g,g1]] - if null init - then - g2:=bfGenSymbol() - init:=['CAR,g2] - ny:=['CDR,g2] - it:= ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,ny)]] - bfMKPROGN [['L%T,g2,y],bfLp(it,body)] - else - init:=car init - it:= ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,y)]] - bfLp(it,body) + a :=if op is ["QUOTE",:.] then second op else op + op := bfReName a + init := GET(a,"SHOETHETA") or GET(op,"SHOETHETA") + g := bfGenSymbol() + g1 := bfGenSymbol() + body := ['SETQ,g,[op,g,g1]] + null init => + g2 := bfGenSymbol() + init := ['CAR,g2] + ny := ['CDR,g2] + it := ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,ny)]] + bfMKPROGN [['L%T,g2,y],bfLp(it,body)] + init := first init + it := ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,y)]] + bfLp(it,body) bfReduceCollect(op,y)== - if EQCAR (y,"COLLECT") - then - body:=y.1 - itl:=y.2 - a:=if EQCAR(op,"QUOTE") then second op else op - op:=bfReName a - init := GET(a, "SHOETHETA") or GET(op,"SHOETHETA") - bfOpReduce(op,init,body,itl) - else - a:=bfTupleConstruct (y.1) - bfReduce(op,a) + y is ["COLLECT",:.] => + body := y.1 + itl := y.2 + a := if op is ["QUOTE",:.] then second op else op + op := bfReName a + init := GET(a, "SHOETHETA") or GET(op,"SHOETHETA") + bfOpReduce(op,init,body,itl) + bfReduce(op,bfTupleConstruct (y.1)) -- delayed collect -bfDCollect(y,itl)== ["COLLECT",y,itl] +bfDCollect(y,itl) == + ["COLLECT",y,itl] -bfDTuple x== ["DTUPLE",x] +bfDTuple x == + ["DTUPLE",x] bfCollect(y,itl) == - y is ["COLON",a] => bf0APPEND(a,itl) - y is ["TUPLE",:.] => - newBody:=bfConstruct y - bf0APPEND(newBody,itl) - bf0COLLECT(y,itl) + y is ["COLON",a] => bf0APPEND(a,itl) + y is ["TUPLE",:.] => + newBody := bfConstruct y + bf0APPEND(newBody,itl) + bf0COLLECT(y,itl) -bf0COLLECT(y,itl)==bfListReduce('CONS,y,itl) +bf0COLLECT(y,itl) == + bfListReduce('CONS,y,itl) bf0APPEND(y,itl)== - g:=bfGenSymbol() - body:=['SETQ,g,['APPEND,['REVERSE,y],g]] - extrait:= [[[g],[nil],[],[],[],[['NREVERSE,g]]]] - bfLp2(extrait,itl,body) + g := bfGenSymbol() + body := ['SETQ,g,['APPEND,['REVERSE,y],g]] + extrait := [[[g],[nil],[],[],[],[['NREVERSE,g]]]] + bfLp2(extrait,itl,body) bfListReduce(op,y,itl)== - g:=bfGenSymbol() - body:=['SETQ,g,[op,y,g]] - extrait:= [[[g],[nil],[],[],[],[['NREVERSE,g]]]] - bfLp2(extrait,itl,body) + g := bfGenSymbol() + body := ['SETQ,g,[op,y,g]] + extrait := [[[g],[nil],[],[],[],[['NREVERSE,g]]]] + bfLp2(extrait,itl,body) bfLp1(iters,body)== - [vars,inits,sucs,filters,exits,value]:=bfSep bfAppend iters - nbody:=if null filters then body else bfAND [:filters,body] - value:=if null value then "NIL" else first value - exits:= ["COND",[bfOR exits,["RETURN",value]], - ['(QUOTE T),nbody]] - loop := ["LOOP",exits,:sucs] - if vars then loop := - ["LET",[[v, i] for v in vars for i in inits], loop] - loop + [vars,inits,sucs,filters,exits,value] := bfSep bfAppend iters + nbody := if null filters then body else bfAND [:filters,body] + value := if null value then "NIL" else first value + exits := ["COND",[bfOR exits,["RETURN",value]], + ['(QUOTE T),nbody]] + loop := ["LOOP",exits,:sucs] + if vars then loop := + ["LET",[[v, i] for v in vars for i in inits], loop] + loop bfLp2(extrait,itl,body)== - EQCAR (itl,"ITERATORS")=>bfLp1(cons(extrait,rest itl),body) - iters:=rest itl - bfLpCross - ([["ITERATORS",extrait,:CDAR iters],:rest iters],body) + itl is ["ITERATORS",:.] => bfLp1(cons(extrait,rest itl),body) + iters := rest itl + bfLpCross([["ITERATORS",extrait,:CDAR iters],:rest iters],body) bfOpReduce(op,init,y,itl)== - g:=bfGenSymbol() - body:= - EQ(op,"AND")=> - bfMKPROGN [["SETQ",g,y], - ['COND, [['NOT,g],['RETURN,'NIL]]]] - EQ(op,"OR") => - bfMKPROGN [["SETQ",g,y], - ['COND, [g,['RETURN,g]]]] - ['SETQ,g,[op,g,y]] - if null init - then - g1:=bfGenSymbol() - init:=['CAR,g1] - y:=['CDR,g1] -- ??? bogus self-assignment/initialization - extrait:= [[[g],[init],[],[],[],[g]]] - bfMKPROGN [['L%T,g1,y],bfLp2(extrait,itl,body)] - else - init:=first init - extrait:= [[[g],[init],[],[],[],[g]]] - bfLp2(extrait,itl,body) - -bfLoop1 body == bfLp (bfIterators nil,body) - -bfSegment1(lo)== ["SEGMENT",lo,nil] - -bfSegment2(lo,hi)== ["SEGMENT",lo,hi] + g := bfGenSymbol() + body:= + op = "AND" => + bfMKPROGN [["SETQ",g,y], ['COND, [['NOT,g],['RETURN,'NIL]]]] + op = "OR" => bfMKPROGN [["SETQ",g,y], ['COND, [g,['RETURN,g]]]] + ['SETQ,g,[op,g,y]] + null init => + g1 := bfGenSymbol() + init := ['CAR,g1] + y := ['CDR,g1] -- ??? bogus self-assignment/initialization + extrait := [[[g],[init],[],[],[],[g]]] + bfMKPROGN [['L%T,g1,y],bfLp2(extrait,itl,body)] + init := first init + extrait := [[[g],[init],[],[],[],[g]]] + bfLp2(extrait,itl,body) + +bfLoop1 body == + bfLp (bfIterators nil,body) + +bfSegment1(lo) == + ["SEGMENT",lo,nil] + +bfSegment2(lo,hi) == + ["SEGMENT",lo,hi] bfForInBy(variable,collection,step)== - bfFor(variable,collection,step) + bfFor(variable,collection,step) -bfForin(lhs,U)==bfFor(lhs,U,1) +bfForin(lhs,U)== + bfFor(lhs,U,1) bfLocal(a,b)== - EQ(b,"FLUID")=> compFluid a - EQ(b,"fluid")=> compFluid a - EQ(b,"local") => compFluid a - -- $typings:=cons(["TYPE",b,a],$typings) - a + b = "FLUID" => compFluid a + b = "fluid" => compFluid a + b = "local" => compFluid a + a bfTake(n,x)== - null x=>x - n=0 => nil - cons(first x,bfTake(n-1,rest x)) + null x=>x + n=0 => nil + cons(first x,bfTake(n-1,rest x)) bfDrop(n,x)== - null x or n=0 =>x - bfDrop(n-1,rest x) + null x or n=0 =>x + bfDrop(n-1,rest x) bfReturnNoName a == - ["RETURN",a] + ["RETURN",a] bfSUBLIS(p,e)== atom e=>bfSUBLIS1(p,e) - EQCAR(e,"QUOTE")=>e + e is ["QUOTE",:.] => e cons(bfSUBLIS(p,first e),bfSUBLIS(p,rest e)) +++ Returns e/p, where e is an atom. We assume that the @@ -498,13 +485,10 @@ defSheepAndGoats(x)== otherwise => [[],[],[x]] defSheepAndGoatsList(x)== - if null x - then [[],[],[]] - else - [opassoc,defs,nondefs] := defSheepAndGoats first x - [opassoc1,defs1,nondefs1] := defSheepAndGoatsList rest x - [append(opassoc,opassoc1),append(defs,defs1), - append(nondefs,nondefs1)] + null x => [[],[],[]] + [opassoc,defs,nondefs] := defSheepAndGoats first x + [opassoc1,defs1,nondefs1] := defSheepAndGoatsList rest x + [append(opassoc,opassoc1),append(defs,defs1), append(nondefs,nondefs1)] --% LET @@ -516,22 +500,22 @@ bfLET1(lhs,rhs) == lhs is ['FLUID,.] => bfLetForm(lhs,rhs) IDENTP rhs and not bfCONTAINED(rhs,lhs) => rhs1 := bfLET2(lhs,rhs) - EQCAR(rhs1,'L%T) => bfMKPROGN [rhs1,rhs] - EQCAR(rhs1,'PROGN) => APPEND(rhs1,[rhs]) + rhs1 is ["L%T",:.] => bfMKPROGN [rhs1,rhs] + rhs1 is ["PROGN",:.] => APPEND(rhs1,[rhs]) if IDENTP first rhs1 then rhs1 := CONS(rhs1,NIL) bfMKPROGN [:rhs1,rhs] - CONSP(rhs) and EQCAR(rhs,'L%T) and IDENTP(name := second rhs) => + rhs is ["L%T",:.] and IDENTP(name := second rhs) => -- handle things like [a] := x := foo l1 := bfLET1(name,third rhs) l2 := bfLET1(lhs,name) - EQCAR(l2,'PROGN) => bfMKPROGN [l1,:rest l2] + l2 is ["PROGN",:.] => bfMKPROGN [l1,:rest l2] if IDENTP first l2 then l2 := cons(l2,nil) bfMKPROGN [l1,:l2,name] g := INTERN CONCAT('"LETTMP#",STRINGIMAGE $letGenVarCounter) $letGenVarCounter := $letGenVarCounter + 1 rhs1 := ['L%T,g,rhs] let1 := bfLET1(lhs,g) - EQCAR(let1,'PROGN) => bfMKPROGN [rhs1,:rest let1] + let1 is ["PROGN",:.] => bfMKPROGN [rhs1,:rest let1] if IDENTP first let1 then let1 := CONS(let1,NIL) bfMKPROGN [rhs1,:let1,g] @@ -551,10 +535,10 @@ bfLET2(lhs,rhs) == CONSP first b => CONS(a,b) [a,b] lhs is ['CONS,var1,var2] => - var1 = "DOT" or (CONSP(var1) and EQCAR(var1,'QUOTE)) => + var1 = "DOT" or var1 is ["QUOTE",:.] => bfLET2(var2,addCARorCDR('CDR,rhs)) l1 := bfLET2(var1,addCARorCDR('CAR,rhs)) - null var2 or EQ(var2,"DOT") =>l1 + null var2 or var2 = "DOT" =>l1 if CONSP l1 and atom first l1 then l1 := cons(l1,nil) IDENTP var2 => [:l1,bfLetForm(var2,addCARorCDR('CDR,rhs))] @@ -594,7 +578,7 @@ bfLET(lhs,rhs) == addCARorCDR(acc,expr) == NULL CONSP expr => [acc,expr] - acc = 'CAR and EQCAR(expr,'REVERSE) => + acc = 'CAR and expr is ["REVERSE",:.] => ["CAR",["LAST",:rest expr]] -- cons('last,rest expr) funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR @@ -617,8 +601,8 @@ bfPosn(x,l,n) == --% IS bfISApplication(op,left,right)== - EQ(op ,"IS") => bfIS(left,right) - EQ(op ,"ISNT") => bfNOT bfIS(left,right) + op = "IS" => bfIS(left,right) + op = "ISNT" => bfNOT bfIS(left,right) [op ,left,right] bfIS(left,right)== @@ -696,14 +680,14 @@ bfReName x== x bfInfApplication(op,left,right)== - EQ(op,"EQUAL") => bfQ(left,right) - EQ(op,"/=") => bfNOT bfQ(left,right) - EQ(op,">") => bfLessp(right,left) - EQ(op,"<") => bfLessp(left,right) - EQ(op,"<=") => bfNOT bfLessp(right,left) - EQ(op,">=") => bfNOT bfLessp(left,right) - EQ(op,"OR") => bfOR [left,right] - EQ(op,"AND") => bfAND [left,right] + op = "EQUAL" => bfQ(left,right) + op = "/=" => bfNOT bfQ(left,right) + op = ">" => bfLessp(right,left) + op = "<" => bfLessp(left,right) + op = "<=" => bfNOT bfLessp(right,left) + op = ">=" => bfNOT bfLessp(left,right) + op = "OR" => bfOR [left,right] + op = "AND" => bfAND [left,right] [op,left,right] bfNOT x== @@ -712,7 +696,7 @@ bfNOT x== ["NOT",x] bfFlatten(op, x) == - EQCAR(x,op) => rest x + x is [=op,:.] => rest x [x] bfOR l == @@ -726,7 +710,8 @@ bfAND l == ["AND",:[:bfFlatten("AND",c) for c in l]] -defQuoteId x== EQCAR(x,"QUOTE") and IDENTP second x +defQuoteId x== + x is ["QUOTE",:.] and IDENTP second x bfSmintable x== INTEGERP x or CONSP x and @@ -737,13 +722,12 @@ bfQ(l,r)== defQuoteId l or defQuoteId r => ["EQ",l,r] null l => ["NULL",r] null r => ["NULL",l] - EQ(l,true) or EQ(r,true) => ["EQ",l,r] + l = true or r = true => ["EQ",l,r] ["EQUAL",l,r] bfLessp(l,r)== - if r=0 - then ["MINUSP", l] - else ["<",l,r] + r=0 => ["MINUSP", l] + ["<",l,r] bfMDef (op,args,body) == argl:=if bfTupleP args then cdr args else [args] @@ -793,9 +777,8 @@ shoeComps x== shoeComp x== a:=shoeCompTran second x - if EQCAR(a,"LAMBDA") - then ["DEFUN",first x,second a,:CDDR a] - else ["DEFMACRO",first x,second a,:CDDR a] + a is ["LAMBDA",:.] => ["DEFUN",first x,second a,:CDDR a] + ["DEFMACRO",first x,second a,:CDDR a] ++ Translate function parameter list to Lisp. @@ -880,7 +863,7 @@ shoeFluids x== null x => nil IDENTP x and bfBeginsDollar x => [x] atom x => nil - EQCAR(x,"QUOTE") => nil + x is ["QUOTE",:.] => nil [:shoeFluids first x,:shoeFluids rest x] shoeATOMs x == @@ -907,7 +890,7 @@ shoeCompTran1 x== cons(x,$dollarVars) nil U:=car x - EQ(U,"QUOTE")=>nil + U = "QUOTE" => nil x is ["L%T",l,r]=> RPLACA (x,"SETQ") shoeCompTran1 r @@ -919,7 +902,7 @@ shoeCompTran1 x== $dollarVars:= MEMQ(l,$dollarVars)=>$dollarVars cons(l,$dollarVars) - EQCAR(l,"FLUID")=> + l is ["FLUID",:.] => $fluidVars:= MEMQ(second l,$fluidVars)=>$fluidVars cons(second l,$fluidVars) @@ -938,9 +921,9 @@ shoeCompTran1 x== bfTagged(a,b)== null $op => %Signature(a,b) -- surely a toplevel decl IDENTP a => - EQ(b,"FLUID") => bfLET(compFluid a,NIL) - EQ(b,"fluid") => bfLET(compFluid a,NIL) - EQ(b,"local") => bfLET(compFluid a,NIL) + b = "FLUID" => bfLET(compFluid a,NIL) + b = "fluid" => bfLET(compFluid a,NIL) + b = "local" => bfLET(compFluid a,NIL) $typings:=cons(["TYPE",b,a],$typings) a ["THE",b,a] @@ -968,13 +951,13 @@ defSETELT(var,sel,expr)== ["SETF",["ELT",var,sel],expr] bfIfThenOnly(a,b)== - b1:=if EQCAR (b,"PROGN") then rest b else [b] + b1:=if b is ["PROGN",:.] then rest b else [b] ["COND",[a,:b1]] bfIf(a,b,c)== - b1:=if EQCAR (b,"PROGN") then rest b else [b] - EQCAR (c,"COND") => ["COND",[a,:b1],:rest c] - c1:=if EQCAR (c,"PROGN") then rest c else [c] + b1:=if b is ["PROGN",:.] then rest b else [b] + c is ["COND",:.] => ["COND",[a,:b1],:rest c] + c1:=if c is ["PROGN",:.] then rest c else [c] ["COND",[a,:b1],['(QUOTE T),:c1]] bfExit(a,b)== @@ -990,7 +973,7 @@ bfFlattenSeq x == null x=>NIL f:=first x atom f =>if rest x then nil else [f] - EQCAR(f,"PROGN") => + f is ["PROGN",:.] => rest x=> [i for i in rest f| not atom i] rest f [f] @@ -1076,18 +1059,14 @@ bfNameOnly x== bfNameArgs: (%Thing,%Thing) -> %List bfNameArgs (x,y)== - y:=if EQCAR(y,"TUPLE") then rest y else [y] + y:=if y is ["TUPLE",:.] then rest y else [y] cons(x,y) bfCreateDef: %Thing -> %List bfCreateDef x== - if null rest x - then - f:=first x - ["DEFCONSTANT",f,["LIST",["QUOTE",f]]] - else - a:=[bfGenSymbol() for i in rest x] - ["DEFUN",first x,a,["CONS",["QUOTE",first x],["LIST",:a]]] + x is [f] => ["DEFCONSTANT",f,["LIST",["QUOTE",f]]] + a := [bfGenSymbol() for i in rest x] + ["DEFUN",first x,a,["CONS",["QUOTE",first x],["LIST",:a]]] bfCaseItem: (%Thing,%Thing) -> %List bfCaseItem(x,y) == diff --git a/src/boot/includer.boot b/src/boot/includer.boot index 86f3a648..554b6b36 100644 --- a/src/boot/includer.boot +++ b/src/boot/includer.boot @@ -77,9 +77,6 @@ PNAME x == char x == CHAR(PNAME x, 0) -EQCAR(x,y)== - CONSP x and EQ(first x,y) - -- returns the string representation of object X. STRINGIMAGE x == WRITE_-TO_-STRING x @@ -186,12 +183,12 @@ shoeFindLines(fn,name,a)== $bStreamNil:=["nullstream"] bStreamNull x== - null x or EQCAR (x,"nullstream") => true - while EQCAR(x,"nonnullstream") repeat + null x or x is ["nullstream",:.] => true + while x is ["nonnullstream",:.] repeat st:=apply(second x,CDDR x) RPLACA(x,first st) RPLACD(x,rest st) - EQCAR(x,"nullstream") + x is ["nullstream",:.] bMap(f,x) == bDelay(function bMap1, [f,x]) diff --git a/src/boot/parser.boot b/src/boot/parser.boot index eb070e8a..68ec4ea0 100644 --- a/src/boot/parser.boot +++ b/src/boot/parser.boot @@ -60,14 +60,14 @@ bpFirstTok()== then shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok) else first $inputStream $ttok:=shoeTokPart $stok - $bpParenCount>0 and EQCAR($stok,"KEY") => - EQ($ttok,"SETTAB")=> + $bpParenCount>0 and $stok is ["KEY",:.] => + $ttok = "SETTAB" => $bpCount:=$bpCount+1 bpNext() - EQ($ttok,"BACKTAB")=> + $ttok = "BACKTAB" => $bpCount:=$bpCount-1 bpNext() - EQ($ttok,"BACKSET")=> + $ttok = "BACKSET" => bpNext() true true @@ -265,11 +265,14 @@ bpBacksetElse()== then bpEqKey "ELSE" else bpEqKey "ELSE" -bpEqPeek s == EQCAR($stok,"KEY") and EQ(s,$ttok) +bpEqPeek s == + $stok is ["KEY",:.] and EQ(s,$ttok) -bpEqKey s == EQCAR($stok,"KEY") and EQ(s,$ttok) and bpNext() -bpEqKeyNextTok s == EQCAR($stok,"KEY") and EQ(s,$ttok) and - bpNextToken() +bpEqKey s == + $stok is ["KEY",:.] and EQ(s,$ttok) and bpNext() + +bpEqKeyNextTok s == + $stok is ["KEY",:.] and EQ(s,$ttok) and bpNextToken() bpPileTrap() == bpMissing "BACKTAB" bpBrackTrap(x) == bpMissingMate("]",x) @@ -370,7 +373,7 @@ bpMoveTo n== bpQualifiedName() == bpEqPeek "COLON-COLON" => bpNext() - EQCAR($stok, "ID") and bpPushId() and bpNext() + $stok is ["ID",:.] and bpPushId() and bpNext() and bpPush bfColonColon(bpPop2(), bpPop1()) false @@ -378,7 +381,7 @@ bpQualifiedName() == ++ ID ++ Name :: ID bpName() == - EQCAR( $stok,"ID") => + $stok is ["ID",:.] => bpPushId() bpNext() bpAnyNo function bpQualifiedName @@ -397,9 +400,9 @@ bpConstTok() == MEMQ(shoeTokType $stok, '(INTEGER FLOAT)) => bpPush $ttok bpNext() - EQCAR($stok,"LISP")=> bpPush %Lisp $ttok and bpNext() - EQCAR($stok,"LISPEXP")=> bpPush $ttok and bpNext() - EQCAR($stok,"LINE")=> bpPush ["+LINE", $ttok] and bpNext() + $stok is ["LISP",:.] => bpPush %Lisp $ttok and bpNext() + $stok is ["LISPEXP",:.] => bpPush $ttok and bpNext() + $stok is ["LINE",:.] => bpPush ["+LINE", $ttok] and bpNext() bpEqPeek "QUOTE" => bpNext() (bpSexp() or bpTrap()) and @@ -548,14 +551,14 @@ bpExceptions()== bpSexpKey()== - EQCAR( $stok,"KEY") and not bpExceptions()=> + $stok is ["KEY",:.] and not bpExceptions()=> a:=GET($ttok,"SHOEINF") null a=> bpPush $ttok and bpNext() bpPush a and bpNext() false bpAnyId()== - bpEqKey "MINUS" and (EQCAR($stok,"INTEGER") or bpTrap()) and + bpEqKey "MINUS" and ($stok is ["INTEGER",:.] or bpTrap()) and bpPush MINUS $ttok and bpNext() or bpSexpKey() or MEMQ(shoeTokType $stok, '(ID INTEGER STRING FLOAT)) @@ -588,11 +591,11 @@ bpPrimary()== bpFirstTok() and (bpPrimary1() or bpPrefixOperator()) bpDot()== bpEqKey "DOT" and bpPush bfDot () bpPrefixOperator()== - EQCAR( $stok,"KEY") and + $stok is ["KEY",:.] and GET($ttok,"SHOEPRE") and bpPushId() and bpNext() bpInfixOperator()== - EQCAR( $stok,"KEY") and + $stok is ["KEY",:.] and GET($ttok,"SHOEINF") and bpPushId() and bpNext() bpSelector()== @@ -625,7 +628,7 @@ bpTagged()== bpExpt()== bpRightAssoc('(POWER),function bpTagged) bpInfKey s== - EQCAR( $stok,"KEY") and + $stok is ["KEY",:.] and MEMBER($ttok,s) and bpPushId() and bpNext() bpInfGeneric s== bpInfKey s and (bpEqKey "BACKSET" or true) @@ -652,11 +655,11 @@ bpLeftAssoc(operations,parser)== else false bpString()== - EQ(shoeTokType $stok,"STRING") and + shoeTokType $stok = "STRING" and bpPush(["QUOTE",INTERN $ttok]) and bpNext() bpThetaName() == - if EQCAR( $stok,"ID") and GET($ttok,"SHOETHETA") + if $stok is ["ID",:.] and GET($ttok,"SHOETHETA") then bpPushId() bpNext() @@ -1047,7 +1050,7 @@ bpRegularBVItem() == or bpBracketConstruct function bpPatternL bpBVString()== - EQ(shoeTokType $stok,"STRING") and + shoeTokType $stok = "STRING" and bpPush(["BVQUOTE",INTERN $ttok]) and bpNext() bpRegularBVItemL() == @@ -1148,7 +1151,7 @@ bpOutItem()== bpComma() or bpTrap() b:=bpPop1() bpPush - EQCAR(b,"+LINE")=> [ b ] + b is ["+LINE",:.] => [ b ] b is ["L%T",l,r] and IDENTP l => $InteractiveMode => [["SETQ",l,r]] [["DEFPARAMETER",l,r]] diff --git a/src/boot/pile.boot b/src/boot/pile.boot index df1b0ecb..f9c667ee 100644 --- a/src/boot/pile.boot +++ b/src/boot/pile.boot @@ -123,13 +123,13 @@ shoePileCoagulate(a,b)== then [a] else c:=first b - if EQ(shoeTokPart CAAR c,"THEN") or EQ(shoeTokPart CAAR c,"ELSE") + if shoeTokPart CAAR c = "THEN" or shoeTokPart CAAR c = "ELSE" then shoePileCoagulate (dqAppend(a,c),rest b) else d:=second a e:=shoeTokPart d - if EQCAR(d,"KEY") and - (GET(e,"SHOEINF") or EQ(e,"COMMA") or EQ(e,"SEMICOLON")) + if d is ["KEY",:.] and + (GET(e,"SHOEINF") or e = "COMMA" or e = "SEMICOLON") then shoePileCoagulate(dqAppend(a,c),rest b) else cons(a,shoePileCoagulate(c,rest b)) diff --git a/src/boot/scanner.boot b/src/boot/scanner.boot index 8872c9df..aed1df0e 100644 --- a/src/boot/scanner.boot +++ b/src/boot/scanner.boot @@ -310,7 +310,7 @@ shoePunct()== shoeKeyTr sss shoeKeyTr w== - if EQ(shoeKeyWord w,"DOT") + if shoeKeyWord w = "DOT" then if $floatok then shoePossFloat(w) else shoeLeafKey w diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index 64b6779a..79e71325 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -226,12 +226,12 @@ (COND ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) (|compFluid| |x|)) ((ATOM |x|) |x|) - ((EQCAR |x| 'QUOTE) |x|) + ((AND (CONSP |x|) (EQ (CAR |x|) 'QUOTE)) |x|) ('T (CONS (|compFluidize| (CAR |x|)) (|compFluidize| (CDR |x|)))))) (DEFUN |bfTuple| (|x|) (CONS 'TUPLE |x|)) -(DEFUN |bfTupleP| (|x|) (EQCAR |x| 'TUPLE)) +(DEFUN |bfTupleP| (|x|) (AND (CONSP |x|) (EQ (CAR |x|) 'TUPLE))) (DEFUN |bfUntuple| (|bf|) (COND ((|bfTupleP| |bf|) (CDR |bf|)) ('T |bf|))) @@ -292,8 +292,10 @@ (DEFUN |bfFor| (|bflhs| U |step|) (COND - ((EQCAR U '|tails|) (|bfForTree| 'ON |bflhs| (CADR U))) - ((EQCAR U 'SEGMENT) (|bfSTEP| |bflhs| (CADR U) |step| (CADDR U))) + ((AND (CONSP U) (EQ (CAR U) '|tails|)) + (|bfForTree| 'ON |bflhs| (CADR U))) + ((AND (CONSP U) (EQ (CAR U) 'SEGMENT)) + (|bfSTEP| |bflhs| (CADR U) |step| (CADDR U))) ('T (|bfForTree| 'IN |bflhs| U)))) (DEFUN |bfForTree| (OP |lhs| |whole|) @@ -310,7 +312,8 @@ (SETQ |lhs| (COND ((|bfTupleP| |lhs|) (CADR |lhs|)) (#0# |lhs|))) (COND - ((EQCAR |lhs| 'L%T) (SETQ G (CADR |lhs|)) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'L%T)) + (SETQ G (CADR |lhs|)) (APPEND (|bfINON| (LIST OP G |whole|)) (|bfSuchthat| (|bfIS| G (CADDR |lhs|))))) (#1# (SETQ G (|bfGenSymbol|)) @@ -398,7 +401,8 @@ (DEFUN |bfLp| (|iters| |body|) (COND - ((EQCAR |iters| 'ITERATORS) (|bfLp1| (CDR |iters|) |body|)) + ((AND (CONSP |iters|) (EQ (CAR |iters|) 'ITERATORS)) + (|bfLp1| (CDR |iters|) |body|)) ('T (|bfLpCross| (CDR |iters|) |body|)))) (DEFUN |bfLpCross| (|iters| |body|) @@ -431,7 +435,9 @@ (RETURN (PROGN (SETQ |a| - (COND ((EQCAR |op| 'QUOTE) (CADR |op|)) (#0='T |op|))) + (COND + ((AND (CONSP |op|) (EQ (CAR |op|) 'QUOTE)) (CADR |op|)) + ('T |op|))) (SETQ |op| (|bfReName| |a|)) (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA))) (SETQ |g| (|bfGenSymbol|)) @@ -447,7 +453,7 @@ (|bfIN| |g1| |ny|)))) (|bfMKPROGN| (LIST (LIST 'L%T |g2| |y|) (|bfLp| |it| |body|)))) - (#0# (SETQ |init| (CAR |init|)) + ('T (SETQ |init| (CAR |init|)) (SETQ |it| (CONS 'ITERATORS (LIST (LIST (LIST (LIST |g|) (LIST |init|) NIL @@ -459,15 +465,17 @@ (PROG (|init| |a| |itl| |body|) (RETURN (COND - ((EQCAR |y| 'COLLECT) (SETQ |body| (ELT |y| 1)) - (SETQ |itl| (ELT |y| 2)) + ((AND (CONSP |y|) (EQ (CAR |y|) 'COLLECT)) + (SETQ |body| (ELT |y| 1)) (SETQ |itl| (ELT |y| 2)) (SETQ |a| - (COND ((EQCAR |op| 'QUOTE) (CADR |op|)) (#0='T |op|))) + (COND + ((AND (CONSP |op|) (EQ (CAR |op|) 'QUOTE)) + (CADR |op|)) + ('T |op|))) (SETQ |op| (|bfReName| |a|)) (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA))) (|bfOpReduce| |op| |init| |body| |itl|)) - (#0# (SETQ |a| (|bfTupleConstruct| (ELT |y| 1))) - (|bfReduce| |op| |a|)))))) + ('T (|bfReduce| |op| (|bfTupleConstruct| (ELT |y| 1)))))))) (DEFUN |bfDCollect| (|y| |itl|) (LIST 'COLLECT |y| |itl|)) @@ -564,7 +572,7 @@ (PROG (|iters|) (RETURN (COND - ((EQCAR |itl| 'ITERATORS) + ((AND (CONSP |itl|) (EQ (CAR |itl|) 'ITERATORS)) (|bfLp1| (CONS |extrait| (CDR |itl|)) |body|)) ('T (SETQ |iters| (CDR |itl|)) (|bfLpCross| @@ -589,7 +597,7 @@ (|bfMKPROGN| (LIST (LIST 'SETQ |g| |y|) (LIST 'COND (LIST |g| (LIST 'RETURN |g|)))))) - ('T (LIST 'SETQ |g| (LIST |op| |g| |y|))))) + (#0='T (LIST 'SETQ |g| (LIST |op| |g| |y|))))) (COND ((NULL |init|) (SETQ |g1| (|bfGenSymbol|)) (SETQ |init| (LIST 'CAR |g1|)) (SETQ |y| (LIST 'CDR |g1|)) @@ -599,7 +607,7 @@ (|bfMKPROGN| (LIST (LIST 'L%T |g1| |y|) (|bfLp2| |extrait| |itl| |body|)))) - ('T (SETQ |init| (CAR |init|)) + (#0# (SETQ |init| (CAR |init|)) (SETQ |extrait| (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|)))) @@ -639,7 +647,7 @@ (DEFUN |bfSUBLIS| (|p| |e|) (COND ((ATOM |e|) (|bfSUBLIS1| |p| |e|)) - ((EQCAR |e| 'QUOTE) |e|) + ((AND (CONSP |e|) (EQ (CAR |e|) 'QUOTE)) |e|) ('T (CONS (|bfSUBLIS| |p| (CAR |e|)) (|bfSUBLIS| |p| (CDR |e|)))))) (DEFUN |bfSUBLIS1| (|p| |e|) @@ -713,18 +721,21 @@ ((AND (IDENTP |rhs|) (NOT (|bfCONTAINED| |rhs| |lhs|))) (SETQ |rhs1| (|bfLET2| |lhs| |rhs|)) (COND - ((EQCAR |rhs1| 'L%T) (|bfMKPROGN| (LIST |rhs1| |rhs|))) - ((EQCAR |rhs1| 'PROGN) (APPEND |rhs1| (LIST |rhs|))) + ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'L%T)) + (|bfMKPROGN| (LIST |rhs1| |rhs|))) + ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'PROGN)) + (APPEND |rhs1| (LIST |rhs|))) (#0='T (COND ((IDENTP (CAR |rhs1|)) (SETQ |rhs1| (CONS |rhs1| NIL)))) (|bfMKPROGN| (APPEND |rhs1| (CONS |rhs| NIL)))))) - ((AND (CONSP |rhs|) (EQCAR |rhs| 'L%T) + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'L%T) (IDENTP (SETQ |name| (CADR |rhs|)))) (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|))) (SETQ |l2| (|bfLET1| |lhs| |name|)) (COND - ((EQCAR |l2| 'PROGN) (|bfMKPROGN| (CONS |l1| (CDR |l2|)))) + ((AND (CONSP |l2|) (EQ (CAR |l2|) 'PROGN)) + (|bfMKPROGN| (CONS |l1| (CDR |l2|)))) (#0# (COND ((IDENTP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL)))) (|bfMKPROGN| (CONS |l1| (APPEND |l2| (CONS |name| NIL))))))) @@ -736,7 +747,7 @@ (SETQ |rhs1| (LIST 'L%T |g| |rhs|)) (SETQ |let1| (|bfLET1| |lhs| |g|)) (COND - ((EQCAR |let1| 'PROGN) + ((AND (CONSP |let1|) (EQ (CAR |let1|) 'PROGN)) (|bfMKPROGN| (CONS |rhs1| (CDR |let1|)))) (#0# (COND @@ -789,7 +800,7 @@ (PROGN (SETQ |var2| (CAR |ISTMP#2|)) #0#)))))) (COND ((OR (EQ |var1| 'DOT) - (AND (CONSP |var1|) (EQCAR |var1| 'QUOTE))) + (AND (CONSP |var1|) (EQ (CAR |var1|) 'QUOTE))) (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) (#1# (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|))) @@ -882,7 +893,8 @@ (RETURN (COND ((NULL (CONSP |expr|)) (LIST |acc| |expr|)) - ((AND (EQ |acc| 'CAR) (EQCAR |expr| 'REVERSE)) + ((AND (EQ |acc| 'CAR) (CONSP |expr|) + (EQ (CAR |expr|) 'REVERSE)) (LIST 'CAR (CONS 'LAST (CDR |expr|)))) (#0='T (SETQ |funs| @@ -1100,7 +1112,9 @@ ('T (LIST 'NOT |x|)))))) (DEFUN |bfFlatten| (|op| |x|) - (COND ((EQCAR |x| |op|) (CDR |x|)) ('T (LIST |x|)))) + (COND + ((AND (CONSP |x|) (EQUAL (CAR |x|) |op|)) (CDR |x|)) + ('T (LIST |x|)))) (DEFUN |bfOR| (|l|) (COND @@ -1139,7 +1153,7 @@ (SETQ |bfVar#89| (CDR |bfVar#89|)))))))) (DEFUN |defQuoteId| (|x|) - (AND (EQCAR |x| 'QUOTE) (IDENTP (CADR |x|)))) + (AND (CONSP |x|) (EQ (CAR |x|) 'QUOTE) (IDENTP (CADR |x|)))) (DEFUN |bfSmintable| (|x|) (OR (INTEGERP |x|) @@ -1319,7 +1333,7 @@ (PROGN (SETQ |a| (|shoeCompTran| (CADR |x|))) (COND - ((EQCAR |a| 'LAMBDA) + ((AND (CONSP |a|) (EQ (CAR |a|) 'LAMBDA)) (CONS 'DEFUN (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|))))) ('T (CONS 'DEFMACRO @@ -1487,7 +1501,7 @@ ((NULL |x|) NIL) ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) (LIST |x|)) ((ATOM |x|) NIL) - ((EQCAR |x| 'QUOTE) NIL) + ((AND (CONSP |x|) (EQ (CAR |x|) 'QUOTE)) NIL) ('T (APPEND (|shoeFluids| (CAR |x|)) (|shoeFluids| (CDR |x|)))))) (DEFUN |shoeATOMs| (|x|) @@ -1551,7 +1565,7 @@ (COND ((MEMQ |l| |$dollarVars|) |$dollarVars|) (#0# (CONS |l| |$dollarVars|))))))) - ((EQCAR |l| 'FLUID) + ((AND (CONSP |l|) (EQ (CAR |l|) 'FLUID)) (SETQ |$fluidVars| (COND ((MEMQ (CADR |l|) |$fluidVars|) |$fluidVars|) @@ -1640,7 +1654,9 @@ (RETURN (PROGN (SETQ |b1| - (COND ((EQCAR |b| 'PROGN) (CDR |b|)) ('T (LIST |b|)))) + (COND + ((AND (CONSP |b|) (EQ (CAR |b|) 'PROGN)) (CDR |b|)) + ('T (LIST |b|)))) (LIST 'COND (CONS |a| |b1|)))))) (DEFUN |bfIf| (|a| |b| |c|) @@ -1648,14 +1664,16 @@ (RETURN (PROGN (SETQ |b1| - (COND ((EQCAR |b| 'PROGN) (CDR |b|)) (#0='T (LIST |b|)))) + (COND + ((AND (CONSP |b|) (EQ (CAR |b|) 'PROGN)) (CDR |b|)) + (#0='T (LIST |b|)))) (COND - ((EQCAR |c| 'COND) + ((AND (CONSP |c|) (EQ (CAR |c|) 'COND)) (CONS 'COND (CONS (CONS |a| |b1|) (CDR |c|)))) ('T (SETQ |c1| (COND - ((EQCAR |c| 'PROGN) (CDR |c|)) + ((AND (CONSP |c|) (EQ (CAR |c|) 'PROGN)) (CDR |c|)) (#0# (LIST |c|)))) (LIST 'COND (CONS |a| |b1|) (CONS ''T |c1|)))))))) @@ -1689,7 +1707,7 @@ (#0='T (SETQ |f| (CAR |x|)) (COND ((ATOM |f|) (COND ((CDR |x|) NIL) ('T (LIST |f|)))) - ((EQCAR |f| 'PROGN) + ((AND (CONSP |f|) (EQ (CAR |f|) 'PROGN)) (COND ((CDR |x|) (LET ((|bfVar#111| NIL) (|bfVar#110| (CDR |f|)) @@ -1881,7 +1899,10 @@ (DEFUN |bfNameArgs| (|x| |y|) (PROGN - (SETQ |y| (COND ((EQCAR |y| 'TUPLE) (CDR |y|)) ('T (LIST |y|)))) + (SETQ |y| + (COND + ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) (CDR |y|)) + ('T (LIST |y|)))) (CONS |x| |y|))) (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%List|) |bfCreateDef|)) @@ -1890,7 +1911,8 @@ (PROG (|a| |f|) (RETURN (COND - ((NULL (CDR |x|)) (SETQ |f| (CAR |x|)) + ((AND (CONSP |x|) (EQ (CDR |x|) NIL) + (PROGN (SETQ |f| (CAR |x|)) 'T)) (LIST 'DEFCONSTANT |f| (LIST 'LIST (LIST 'QUOTE |f|)))) ('T (SETQ |a| diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp index 6146ddc7..94aee881 100644 --- a/src/boot/strap/includer.clisp +++ b/src/boot/strap/includer.clisp @@ -13,8 +13,6 @@ (DEFUN |char| (|x|) (CHAR (PNAME |x|) 0)) -(DEFUN EQCAR (|x| |y|) (AND (CONSP |x|) (EQ (CAR |x|) |y|))) - (DEFUN STRINGIMAGE (|x|) (WRITE-TO-STRING |x|)) (DEFUN |shoeCLOSE| (|stream|) (CLOSE |stream|)) @@ -134,17 +132,19 @@ (PROG (|st|) (RETURN (COND - ((OR (NULL |x|) (EQCAR |x| '|nullstream|)) T) + ((OR (NULL |x|) (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|))) + T) ('T (LOOP (COND - ((NOT (EQCAR |x| '|nonnullstream|)) (RETURN NIL)) + ((NOT (AND (CONSP |x|) (EQ (CAR |x|) '|nonnullstream|))) + (RETURN NIL)) ('T (PROGN (SETQ |st| (APPLY (CADR |x|) (CDDR |x|))) (RPLACA |x| (CAR |st|)) (RPLACD |x| (CDR |st|)))))) - (EQCAR |x| '|nullstream|)))))) + (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|))))))) (DEFUN |bMap| (|f| |x|) (|bDelay| #'|bMap1| (LIST |f| |x|))) diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp index 15e77276..44e1a285 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -33,7 +33,8 @@ ('T (CAR |$inputStream|)))) (SETQ |$ttok| (|shoeTokPart| |$stok|)) (COND - ((AND (< 0 |$bpParenCount|) (EQCAR |$stok| 'KEY)) + ((AND (< 0 |$bpParenCount|) (CONSP |$stok|) + (EQ (CAR |$stok|) 'KEY)) (COND ((EQ |$ttok| 'SETTAB) (SETQ |$bpCount| (+ |$bpCount| 1)) (|bpNext|)) @@ -291,15 +292,17 @@ (DEFUN |bpEqPeek| (|s|) (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|))) + (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|))) (DEFUN |bpEqKey| (|s|) (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|) (|bpNext|))) + (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|) + (|bpNext|))) (DEFUN |bpEqKeyNextTok| (|s|) (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|) (|bpNextToken|))) + (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|) + (|bpNextToken|))) (DEFUN |bpPileTrap| () (|bpMissing| 'BACKTAB)) @@ -391,15 +394,15 @@ (DECLARE (SPECIAL |$stok|)) (COND ((|bpEqPeek| 'COLON-COLON) (|bpNext|) - (AND (EQCAR |$stok| 'ID) (|bpPushId|) (|bpNext|) - (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|))))) + (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (|bpPushId|) + (|bpNext|) (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|))))) ('T NIL))) (DEFUN |bpName| () (DECLARE (SPECIAL |$stok|)) (COND - ((EQCAR |$stok| 'ID) (|bpPushId|) (|bpNext|) - (|bpAnyNo| #'|bpQualifiedName|)) + ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID)) (|bpPushId|) + (|bpNext|) (|bpAnyNo| #'|bpQualifiedName|)) ('T NIL))) (DEFUN |bpConstTok| () @@ -407,10 +410,11 @@ (COND ((MEMQ (|shoeTokType| |$stok|) '(INTEGER FLOAT)) (|bpPush| |$ttok|) (|bpNext|)) - ((EQCAR |$stok| 'LISP) + ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LISP)) (AND (|bpPush| (|%Lisp| |$ttok|)) (|bpNext|))) - ((EQCAR |$stok| 'LISPEXP) (AND (|bpPush| |$ttok|) (|bpNext|))) - ((EQCAR |$stok| 'LINE) + ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LISPEXP)) + (AND (|bpPush| |$ttok|) (|bpNext|))) + ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LINE)) (AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|))) ((|bpEqPeek| 'QUOTE) (|bpNext|) (AND (OR (|bpSexp|) (|bpTrap|)) @@ -533,7 +537,8 @@ (DECLARE (SPECIAL |$ttok| |$stok|)) (RETURN (COND - ((AND (EQCAR |$stok| 'KEY) (NOT (|bpExceptions|))) + ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) + (NOT (|bpExceptions|))) (SETQ |a| (GET |$ttok| 'SHOEINF)) (COND ((NULL |a|) (AND (|bpPush| |$ttok|) (|bpNext|))) @@ -542,7 +547,9 @@ (DEFUN |bpAnyId| () (DECLARE (SPECIAL |$ttok| |$stok|)) - (OR (AND (|bpEqKey| 'MINUS) (OR (EQCAR |$stok| 'INTEGER) (|bpTrap|)) + (OR (AND (|bpEqKey| 'MINUS) + (OR (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'INTEGER)) + (|bpTrap|)) (|bpPush| (- |$ttok|)) (|bpNext|)) (|bpSexpKey|) (AND (MEMQ (|shoeTokType| |$stok|) '(ID INTEGER STRING FLOAT)) @@ -573,13 +580,13 @@ (DEFUN |bpPrefixOperator| () (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQCAR |$stok| 'KEY) (GET |$ttok| 'SHOEPRE) (|bpPushId|) - (|bpNext|))) + (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (GET |$ttok| 'SHOEPRE) + (|bpPushId|) (|bpNext|))) (DEFUN |bpInfixOperator| () (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQCAR |$stok| 'KEY) (GET |$ttok| 'SHOEINF) (|bpPushId|) - (|bpNext|))) + (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (GET |$ttok| 'SHOEINF) + (|bpPushId|) (|bpNext|))) (DEFUN |bpSelector| () (AND (|bpEqKey| 'DOT) @@ -615,8 +622,8 @@ (DEFUN |bpInfKey| (|s|) (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQCAR |$stok| 'KEY) (MEMBER |$ttok| |s|) (|bpPushId|) - (|bpNext|))) + (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (MEMBER |$ttok| |s|) + (|bpPushId|) (|bpNext|))) (DEFUN |bpInfGeneric| (|s|) (AND (|bpInfKey| |s|) (OR (|bpEqKey| 'BACKSET) T))) @@ -662,8 +669,9 @@ (DEFUN |bpThetaName| () (DECLARE (SPECIAL |$ttok| |$stok|)) (COND - ((AND (EQCAR |$stok| 'ID) (GET |$ttok| 'SHOETHETA)) (|bpPushId|) - (|bpNext|)) + ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) + (GET |$ttok| 'SHOETHETA)) + (|bpPushId|) (|bpNext|)) ('T NIL))) (DEFUN |bpReduceOperator| () @@ -1138,7 +1146,7 @@ (SETQ |b| (|bpPop1|)) (|bpPush| (COND - ((EQCAR |b| '+LINE) (LIST |b|)) + ((AND (CONSP |b|) (EQ (CAR |b|) '+LINE)) (LIST |b|)) ((AND (CONSP |b|) (EQ (CAR |b|) 'L%T) (PROGN (SETQ |ISTMP#1| (CDR |b|)) diff --git a/src/boot/strap/pile.clisp b/src/boot/strap/pile.clisp index 4b624e7e..79b45cc0 100644 --- a/src/boot/strap/pile.clisp +++ b/src/boot/strap/pile.clisp @@ -119,7 +119,7 @@ (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|))) (#0# (SETQ |d| (CADR |a|)) (SETQ |e| (|shoeTokPart| |d|)) (COND - ((AND (EQCAR |d| 'KEY) + ((AND (CONSP |d|) (EQ (CAR |d|) 'KEY) (OR (GET |e| 'SHOEINF) (EQ |e| 'COMMA) (EQ |e| 'SEMICOLON))) (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|))) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index dfb850cb..341c0200 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -470,7 +470,8 @@ (PROGN (SETQ |a| (CAR |s|)) (COND - ((EQCAR |a| '+LINE) (|shoeFileLine| (CADR |a|) |st|)) + ((AND (CONSP |a|) (EQ (CAR |a|) '+LINE)) + (|shoeFileLine| (CADR |a|) |st|)) ('T (REALLYPRETTYPRINT |a| |st|) (TERPRI |st|))) (SETQ |s| (CDR |s|))))))))) diff --git a/src/boot/translator.boot b/src/boot/translator.boot index ff7f2840..679bfafd 100644 --- a/src/boot/translator.boot +++ b/src/boot/translator.boot @@ -330,7 +330,7 @@ shoeFileLine(x, stream) == shoeFileTrees(s,st)== while not bStreamNull s repeat a:= first s - if EQCAR (a,"+LINE") + if a is ["+LINE",:.] then shoeFileLine(second a,st) else REALLYPRETTYPRINT(a,st) |