diff options
Diffstat (limited to 'src/boot')
| -rw-r--r-- | src/boot/ast.boot | 151 | ||||
| -rw-r--r-- | src/boot/strap/ast.clisp | 14 |
2 files changed, 90 insertions, 75 deletions
diff --git a/src/boot/ast.boot b/src/boot/ast.boot index 15a720bc..e45047aa 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -273,7 +273,7 @@ bfSTEP(id,fst,step,lst)== bfINON x== [op,id,whole] := x - op = "ON" => bfON(id,whole) + op is "ON" => bfON(id,whole) bfIN(id,whole) bfIN(x,E)== @@ -420,9 +420,9 @@ bfLp2(extrait,itl,body)== bfOpReduce(op,init,y,itl)== g := bfGenSymbol() body:= - op = "AND" => + op is "AND" => bfMKPROGN [["SETQ",g,y], ['COND, [['NOT,g],['RETURN,'NIL]]]] - op = "OR" => bfMKPROGN [["SETQ",g,y], ['COND, [g,['RETURN,g]]]] + op is "OR" => bfMKPROGN [["SETQ",g,y], ['COND, [g,['RETURN,g]]]] ['SETQ,g,[op,g,y]] init = nil => g1 := bfGenSymbol() @@ -450,9 +450,9 @@ bfForin(lhs,U)== bfFor(lhs,U,1) bfLocal(a,b)== - b = "FLUID" => compFluid a - b = "fluid" => compFluid a - b = "local" => compFluid a + b is "FLUID" => compFluid a + b is "fluid" => compFluid a + b is "local" => compFluid a a bfTake(n,x)== @@ -553,10 +553,10 @@ bfLET2(lhs,rhs) == cons? first b => [a,:b] [a,b] lhs is ['CONS,var1,var2] => - var1 = "DOT" or var1 is ["QUOTE",:.] => + var1 is "DOT" or var1 is ["QUOTE",:.] => bfLET2(var2,addCARorCDR('CDR,rhs)) l1 := bfLET2(var1,addCARorCDR('CAR,rhs)) - var2 = nil or var2 = "DOT" =>l1 + var2 = nil or var2 is "DOT" =>l1 if cons? l1 and atom first l1 then l1 := [l1,:nil] symbol? var2 => [:l1,bfLetForm(var2,addCARorCDR('CDR,rhs))] @@ -571,7 +571,7 @@ bfLET2(lhs,rhs) == l2 := bfLET2(patrev,g) if cons? l2 and atom first l2 then l2 := [l2,:nil] - var1 = "DOT" => [['L%T,g,rev],:l2] + var1 is "DOT" => [['L%T,g,rev],:l2] last l2 is ['L%T, =var1, val1] => [['L%T,g,rev],:reverse rest reverse l2, bfLetForm(var1,['reverse!,val1])] @@ -596,7 +596,7 @@ bfLET(lhs,rhs) == addCARorCDR(acc,expr) == atom expr => [acc,expr] - acc = 'CAR and expr is ["reverse",:.] => + acc is 'CAR and expr is ["reverse",:.] => ["CAR",["lastNode",:rest expr]] funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR CDAAR CDDAR CDADR CDDDR) @@ -606,7 +606,7 @@ addCARorCDR(acc,expr) == CAADDR CADAAR CADDAR CADADR CADDDR) funsR := '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR CDADDR CDDAAR CDDDAR CDDADR CDDDDR) - acc = 'CAR => [funsA.p,:rest expr] + acc is 'CAR => [funsA.p,:rest expr] [funsR.p,:rest expr] bfPosition(x,l) == bfPosn(x,l,0) @@ -618,8 +618,8 @@ bfPosn(x,l,n) == --% IS bfISApplication(op,left,right)== - op = "IS" => bfIS(left,right) - op = "ISNT" => bfNOT bfIS(left,right) + op is "IS" => bfIS(left,right) + op is "ISNT" => bfNOT bfIS(left,right) [op ,left,right] bfIS(left,right)== @@ -654,12 +654,12 @@ bfIS1(lhs,rhs) == $isGenVarCounter := $isGenVarCounter + 1 bfMKPROGN [['L%T,g,lhs],bfIS1(g,rhs)] rhs is ['CONS,a,b] => - a = "DOT" => + a is "DOT" => b = nil => bfAND [['CONSP,lhs],['NULL,['CDR,lhs]]] bfAND [['CONSP,lhs],bfIS1(['CDR,lhs],b)] b = nil => bfAND [['CONSP,lhs],['NULL,['CDR,lhs]],bfIS1(['CAR,lhs],a)] - b = "DOT" => bfAND [['CONSP,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) a1 is ['PROGN,c,'T] and b1 is ['PROGN,:cls] => @@ -672,7 +672,7 @@ bfIS1(lhs,rhs) == rev := bfAND [['CONSP,lhs],['PROGN,['L%T,g,['reverse,lhs]],'T]] l2 := bfIS1(g,patrev) if cons? l2 and atom first l2 then l2 := [l2,:nil] - a = "DOT" => bfAND [rev,:l2] + a is "DOT" => bfAND [rev,:l2] bfAND [rev,:l2,['PROGN,bfLetForm(a,['reverse!,a]),'T]] bpSpecificErrorHere '"bad IS code is generated" bpTrap() @@ -713,15 +713,15 @@ bfMember(var,seq) == ["MEMBER",var,seq] bfInfApplication(op,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 = "IN" => bfMember(left,right) + op is "EQUAL" => bfQ(left,right) + op is "/=" => bfNOT bfQ(left,right) + op is ">" => bfLessp(right,left) + op is "<" => bfLessp(left,right) + op is "<=" => bfNOT bfLessp(right,left) + op is ">=" => bfNOT bfLessp(left,right) + op is "OR" => bfOR [left,right] + op is "AND" => bfAND [left,right] + op is "IN" => bfMember(left,right) [op,left,right] bfNOT x== @@ -798,7 +798,7 @@ bfMDef (op,args,body) == bfGargl argl== argl = nil => [[],[],[],[]] [a,b,c,d] := bfGargl rest argl - first argl="&REST" => + first argl is "&REST" => [[first argl,:b],b,c, [["CONS",["QUOTE","LIST"],first d],:rest d]] f := bfGenSymbol() @@ -929,17 +929,17 @@ isDynamicVariable x == true false -shoeCompTran1 x== - atom x=> +shoeCompTran1 x == + atom x => isDynamicVariable x => $dollarVars:= symbolMember?(x,$dollarVars)=>$dollarVars [x,:$dollarVars] nil - U:=first x - U = "QUOTE" => nil + U := first x + U is "QUOTE" => nil x is ["L%T",l,r] => - x.first := "SETQ" + x.op := "SETQ" shoeCompTran1 r symbol? l => not bfBeginsDollar l=> @@ -954,24 +954,27 @@ shoeCompTran1 x== symbolMember?(second l,$fluidVars)=>$fluidVars [second l,:$fluidVars] x.rest.first := second l - U = "%Leave" => x.first := "RETURN" + U is "%Leave" => x.op := "RETURN" U in '(PROG LAMBDA) => - newbindings:=nil + newbindings := nil for y in second x repeat not symbolMember?(y,$locVars)=> $locVars := [y,:$locVars] newbindings := [y,:newbindings] res := shoeCompTran1 CDDR x $locVars := [y for y in $locVars | not symbolMember?(y,newbindings)] + -- literal vectors. + x is ['vector,['LIST,:args]] => (x.op := 'VECTOR; x.args := args) + x is ['vector,'NIL] => (x.op := 'VECTOR; x.args := nil) shoeCompTran1 first x shoeCompTran1 rest x bfTagged(a,b)== $op = nil => %Signature(a,b) -- surely a toplevel decl symbol? a => - b = "FLUID" => bfLET(compFluid a,nil) - b = "fluid" => bfLET(compFluid a,nil) - b = "local" => bfLET(compFluid a,nil) + b is "FLUID" => bfLET(compFluid a,nil) + b is "fluid" => bfLET(compFluid a,nil) + b is "local" => bfLET(compFluid a,nil) $typings := [["TYPE",b,a],:$typings] a ["THE",b,a] @@ -996,8 +999,8 @@ defSETELT(var,sel,expr)== y := symbol? sel and sel has SHOESELFUNCTION y => integer? y => ["SETF",["ELT",var,y],expr] - y = "CAR" => ["RPLACA",var,expr] - y = "CDR" => ["RPLACD",var,expr] + y is "CAR" => ["RPLACA",var,expr] + y is "CDR" => ["RPLACD",var,expr] ["SETF",[y,var],expr] ["SETF",["ELT",var,sel],expr] @@ -1118,7 +1121,7 @@ bfMain(auxfn,op)== bfNameOnly: %Thing -> %Form bfNameOnly x== - x="t" => ["T"] + x is "t" => ["T"] [x] bfNameArgs: (%Thing,%Thing) -> %List %Form @@ -1158,7 +1161,7 @@ bfCI: (%Thing,%Thing,%Thing) -> %Form bfCI(g,x,y)== a := rest x a = nil => [first x,y] - b := [[i,bfCARCDR(j,g)] for i in a for j in 1.. | i ~= "DOT"] + b := [[i,bfCARCDR(j,g)] for i in a for j in 1.. | i isnt "DOT"] b = nil => [first x,y] [first x,["LET",b,y]] @@ -1334,7 +1337,7 @@ nativeType t == %hasFeature KEYWORD::CLISP => bfColonColon("FFI",t') t' -- ??? decree we have not discovered Unicode yet. - t = "string" and %hasFeature KEYWORD::SBCL => + t is "string" and %hasFeature KEYWORD::SBCL => [t',KEYWORD::EXTERNAL_-FORMAT,KEYWORD::ASCII, KEYWORD::ELEMENT_-TYPE, "BASE-CHAR"] t' @@ -1344,51 +1347,51 @@ nativeType t == %hasFeature KEYWORD::ECL or %hasFeature KEYWORD::CLOZURE => KEYWORD::UNSIGNED_-BYTE nativeType "char" -- approximate by 'char' for GCL - t = "int16" => + t is "int16" => %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),16] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT16") %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT16_-T => KEYWORD::INT16_-T %hasFeature KEYWORD::CLOZURE => KEYWORD::SIGNED_-HALFWORD unknownNativeTypeError t - t = "uint16" => + t is "uint16" => %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),16] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT16") %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT16_-T => KEYWORD::UINT16_-T %hasFeature KEYWORD::CLOZURE => KEYWORD::UNSIGNED_-HALFWORD unknownNativeTypeError t - t = "int32" => + t is "int32" => %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),32] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT32") %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT32_-T => KEYWORD::INT32_-T %hasFeature KEYWORD::CLOZURE => KEYWORD::SIGNED_-FULLWORD unknownNativeTypeError t - t = "uint32" => + t is "uint32" => %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),32] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT32") %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT32_-T => KEYWORD::UINT32_-T %hasFeature KEYWORD::CLOZURE => KEYWORD::UNSIGNED_-FULLWORD unknownNativeTypeError t - t = "int64" => + t is "int64" => %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),64] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT64") %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT64_-T => KEYWORD::INT64_-T %hasFeature KEYWORD::CLOZURE => KEYWORD::SIGNED_-DOUBLEWORD unknownNativeTypeError t - t = "uint64" => + t is "uint64" => %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),64] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT64") %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT64_-T => KEYWORD::UINT64_-T %hasFeature KEYWORD::CLOZURE => KEYWORD::UNSIGNED_-DOUBLEWORD unknownNativeTypeError t - t = "float32" => nativeType "float" - t = "float64" => nativeType "double" - t = "pointer" => + t is "float32" => nativeType "float" + t is "float64" => nativeType "double" + t is "pointer" => %hasFeature KEYWORD::GCL => "fixnum" %hasFeature KEYWORD::ECL => KEYWORD::POINTER_-VOID %hasFeature KEYWORD::SBCL => ["*",bfColonColon("SB-ALIEN","VOID")] @@ -1397,14 +1400,14 @@ nativeType t == unknownNativeTypeError t unknownNativeTypeError t -- composite, reference type. - first t = "buffer" => + first t is "buffer" => %hasFeature KEYWORD::GCL => "OBJECT" %hasFeature KEYWORD::ECL => KEYWORD::OBJECT %hasFeature KEYWORD::SBCL => ["*",nativeType second t] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","C-POINTER") %hasFeature KEYWORD::CLOZURE => [KEYWORD::_*, nativeType second t] unknownNativeTypeError t - first t = "pointer" => + first t is "pointer" => -- we don't bother looking at what the pointer points to. nativeType "pointer" unknownNativeTypeError t @@ -1421,7 +1424,7 @@ nativeReturnType t == nativeArgumentType t == t in $NativeSimpleDataTypes => nativeType t -- Allow 'string' for `pass-by-value' - t = "string" => nativeType t + t is "string" => nativeType t -- anything else must use a modified reference type. atom t or #t ~= 2 => coreError '"invalid argument type for a native function" @@ -1449,8 +1452,8 @@ coerceToNativeType(a,t) == %hasFeature KEYWORD::SBCL => not needsStableReference? t => a [.,[c,y]] := t - c = "buffer" => [bfColonColon("SB-SYS","VECTOR-SAP"),a] - c = "pointer" => [bfColonColon("SB-SYS","ALIEN-SAP"),a] + c is "buffer" => [bfColonColon("SB-SYS","VECTOR-SAP"),a] + c is "pointer" => [bfColonColon("SB-SYS","ALIEN-SAP"),a] needsStableReference? t => fatalError strconc('"don't know how to coerce argument for native type", PNAME c) @@ -1472,7 +1475,7 @@ genGCLnativeTranslation(op,s,t,op') == ccode := "strconc"/[gclTypeInC t, '" ", cop, '"(", :[cparm(x,a) for x in tails s for a in tails cargs], - '") { ", (t ~= "void" => '"return "; ""), + '") { ", (t isnt "void" => '"return "; ""), PNAME op', '"(", :[gclArgsInC(x,a) for x in tails s for a in tails cargs], '"); }" ] @@ -1483,20 +1486,20 @@ genGCLnativeTranslation(op,s,t,op') == (rest x => '", "; '"")) gclTypeInC x == x in $NativeSimpleDataTypes => PNAME x - x = "void" => '"void" - x = "string" => '"char*" + x is "void" => '"void" + x is "string" => '"char*" x is [.,["pointer",.]] => "fixnum" '"object" gclArgInC(x,a) == x in $NativeSimpleDataTypes => a - x = "string" => a -- GCL takes responsability for the conversion + x is "string" => a -- GCL takes responsability for the conversion [.,[c,y]] := x - c = "pointer" => a - y = "char" => strconc(a,'"->st.st__self") - y = "byte" => strconc(a,'"->ust.ust__self") - y = "int" => strconc(a,'"->fixa.fixa__self") - y = "float" => strconc(a,'"->sfa.sfa__self") - y = "double" => strconc(a,'"->lfa.lfa__self") + c is "pointer" => a + y is "char" => strconc(a,'"->st.st__self") + y is "byte" => strconc(a,'"->ust.ust__self") + y is "int" => strconc(a,'"->fixa.fixa__self") + y is "float" => strconc(a,'"->sfa.sfa__self") + y is "double" => strconc(a,'"->lfa.lfa__self") coreError '"unknown argument type" gclArgsInC(x,a) == strconc(gclArgInC(first x, first a), @@ -1523,16 +1526,16 @@ genECLnativeTranslation(op,s,t,op') == selectDatum x == isSimpleNativeType x => '"" [.,[c,y]] := x - c = "buffer" => - y = "char" or y = "byte" => + c is "buffer" => + y is "char" or y is "byte" => AxiomCore::$ECLVersionNumber < 90100 => '"->vector.self.ch" - y = "char" => '"->vector.self.i8" + y is "char" => '"->vector.self.i8" '"->vector.self.b8" - y = "int" => '"->vector.self.fix" - y = "float" => '"->vector.self.sf" - y = "double" => '"->vector.self.df" + y is "int" => '"->vector.self.fix" + y is "float" => '"->vector.self.sf" + y is "double" => '"->vector.self.df" coreError '"unknown argument to buffer type constructor" - c = "pointer" => '"" + c is "pointer" => '"" coreError '"unknown type constructor" genCLISPnativeTranslation(op,s,t,op') == @@ -1651,7 +1654,7 @@ genCLOZUREnativeTranslation(op,s,t,op') == strPairs := nil aryPairs := nil for p in parms for x in s repeat - x = "string" => strPairs := [[p,:gensym '"loc"], :strPairs] + x is "string" => strPairs := [[p,:gensym '"loc"], :strPairs] x is [.,["buffer",.]] => aryPairs := [[p,:gensym '"loc"], :aryPairs] -- Build the actual foreign function call. @@ -1669,7 +1672,7 @@ genCLOZUREnativeTranslation(op,s,t,op') == -- If the foreign call returns a C-string, turn it into a Lisp string. -- Note that if the C-string was malloc-ed, this will leak storage. - if t = "string" then + if t is "string" then call := [bfColonColon("CCL","GET-CSTRING"), call] -- If we have array arguments from Boot, bind pointers to initial data. diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index 9597b66d..1ab3b6dd 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -1708,7 +1708,7 @@ (T NIL))))) (DEFUN |shoeCompTran1| (|x|) - (PROG (|res| |newbindings| |r| |ISTMP#2| |l| |ISTMP#1| U) + (PROG (|args| |res| |newbindings| |r| |ISTMP#2| |l| |ISTMP#1| U) (DECLARE (SPECIAL |$fluidVars| |$locVars| |$dollarVars|)) (RETURN (COND @@ -1793,6 +1793,18 @@ (SETQ |bfVar#131| (CDR |bfVar#131|))))))) (SETQ |bfVar#129| (CDR |bfVar#129|)))))) + ((AND (CONSP |x|) (EQ (CAR |x|) '|vector|) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN + (SETQ |ISTMP#2| (CAR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CAR |ISTMP#2|) 'LIST) + (PROGN + (SETQ |args| (CDR |ISTMP#2|)) + T)))))) + (CONS 'VECTOR |args|)) (T (|shoeCompTran1| (CAR |x|)) (|shoeCompTran1| (CDR |x|))))))))) |