diff options
| -rw-r--r-- | src/boot/ast.boot | 142 | ||||
| -rw-r--r-- | src/boot/strap/ast.clisp | 79 | ||||
| -rw-r--r-- | src/boot/strap/parser.clisp | 15 | ||||
| -rw-r--r-- | src/boot/strap/translator.clisp | 32 |
4 files changed, 211 insertions, 57 deletions
diff --git a/src/boot/ast.boot b/src/boot/ast.boot index 958ad11c..2b52c761 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -48,32 +48,35 @@ import '"includer" ++ translated with the obvious semantics, e.g. no caching. $bfClamming := false -++ A Boot string is no different from a Lisp string. Same holds -++ for symbols and sequences. In an ideal world, these would be -++ built-in/library data types. -String <=> STRING -Symbol <=> SYMBOL -Sequence <=> SEQUENCE +++ Basic types used in Boot codes. +%Thing <=> true +%Boolean <=> BOOLEAN +%String <=> STRING +%Symbol <=> SYMBOL +%Short <=> FIXNUM +%List <=> LIST +%Vector <=> VECTOR +%Sequence <=> SEQUENCE ++ Ideally, we would like to say that a List T if either nil or a ++ cons of a T and List of T. However, we don't support parameterized ++ alias definitions yet. -List <=> nil or cons +%List <=> LIST ++ Currently, the Boot processor uses Lisp symbol datatype for names. ++ That causes the BOOTTRAN package to contain more symbols than we would ++ like. In the future, we want want to intern `on demand'. How that ++ interacts with renaming is to be worked out. -structure Name == Name(Symbol) +structure Name == Name(%Symbol) structure Ast == - Command(String) -- includer command - Module(String) -- module declaration - Import(String) -- import module + Command(%String) -- includer command + Module(%String) -- module declaration + Import(%String) -- import module ImportSignature(Name, Signature) -- import function declaration - TypeAlias(Name, List, List) -- type alias definition + TypeAlias(Name, %List, %List) -- type alias definition Signature(Name, Mapping) -- op: S -> T - Mapping(Ast, List) -- (S1, S2) -> T + Mapping(Ast, %List) -- (S1, S2) -> T SuffixDot(Ast) -- x . Quote(Ast) -- 'x EqualName(Name) -- =x -- patterns @@ -88,7 +91,7 @@ structure Ast == Isnt(Ast, Ast) -- e isnt p -- patterns Reduce(Ast, Ast) -- +/[...] PrefixExpr(Name, Ast) -- #v - Call(Ast, Sequence) -- f(x, y , z) + Call(Ast,%Sequence) -- f(x, y , z) InfixExpr(Name, Ast, Ast) -- x + y ConstantDefinition(Name, Ast) -- x == y Definition(Name, List, Ast, Ast) -- f x == y @@ -101,59 +104,81 @@ structure Ast == Exit(Ast, Ast) -- p => x Iterators(List) -- list of iterators Cross(List) -- iterator cross product - Repeat(Sequence, Ast) -- while p repeat s - Pile(Sequence) -- pile of expression sequence - Append(Sequence) -- concatenate lists - Case(Ast, Sequence) -- case x of ... + Repeat(%Sequence,Ast) -- while p repeat s + Pile(%Sequence) -- pile of expression sequence + Append(%Sequence) -- concatenate lists + Case(Ast,%Sequence) -- case x of ... Return(Ast) -- return x - Where(Ast, Sequence) -- e where f x == y - Structure(Ast, Sequence) -- structure Foo == ... + Where(Ast,%Sequence) -- e where f x == y + Structure(Ast,%Sequence) -- structure Foo == ... -- TRUE if we are currently building the syntax tree for an 'is' -- expression. $inDefIS := false - + +bfGenSymbol: () -> %Symbol bfGenSymbol()== $GenVarCounter:=$GenVarCounter+1 INTERN(CONCAT ('"bfVar#",STRINGIMAGE $GenVarCounter)) - + +bfListOf: %List -> %list bfListOf x==x +bfListOf: %Thing -> %List bfColon x== ["COLON",x] +bfColonColon: (%Thing,%Symbol) -> %Symbol bfColonColon(package, name) == INTERN(SYMBOL_-NAME name, package) - + +bfSymbol: %Thing -> %Thing bfSymbol x== STRINGP x=> x ['QUOTE,x] + -bfDot()== "DOT" - -bfSuffixDot x==[x,"DOT"] - -bfEqual(name)== ["EQUAL",name] +bfDot: () -> %Symbol +bfDot() == + "DOT" -bfBracket(part) == part +bfSuffixDot: %Thing -> %List +bfSuffixDot x == + [x,"DOT"] + +bfEqual: %Thing -> %List +bfEqual(name) == + ["EQUAL",name] + +bfBracket: %Thing -> %Thing +bfBracket(part) == + part -bfPile(part) == part +bfPile: %List -> %List +bfPile(part) == + part -bfAppend x== APPLY(function APPEND,x) +bfAppend: %List -> %List +bfAppend x== + APPLY(function APPEND,x) -bfColonAppend (x,y) == +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(CAR x,bfColonAppend(CDR x,y)) - + +bfDefinition: (%Thing,%Thing,%Thing) -> %List bfDefinition(bflhsitems, bfrhs,body) == ['DEF,bflhsitems,bfrhs,body] +bfMDefinition: (%Thing,%Thing,%Thing) -> %List bfMDefinition(bflhsitems, bfrhs,body) == bfMDef('MDEF,bflhsitems,bfrhs,body) - + +bfCompDef: %Thing -> %List bfCompDef x == case x of ConstantDefinition(n, e) => x @@ -161,10 +186,13 @@ bfCompDef x == x is [def, op, args, body] => bfDef(def,op,args,body) coreError '"invalid AST" + +bfBeginsDollar: %Thing -> %Boolean +bfBeginsDollar x == + EQL('"$".0,(PNAME x).0) -bfBeginsDollar x== EQL('"$".0,(PNAME x).0) - -compFluid id== ["FLUID",id] +compFluid id == + ["FLUID",id] compFluidize x== IDENTP x and bfBeginsDollar x=>compFluid x @@ -1045,19 +1073,23 @@ bfMain(auxfn,op)== ["SETF",["GET", ["QUOTE", op],["QUOTE",'cacheInfo]],["QUOTE", cacheVector]], shoeEVALANDFILEACTQ cacheResetCode ] - + +bfNameOnly: %Thing -> %List bfNameOnly x== if x="t" then ["T"] else [x] - + +bfNameArgs: (%Thing,%Thing) -> %List bfNameArgs (x,y)== y:=if EQCAR(y,"TUPLE") then CDR y else [y] cons(x,y) +bfStruct: (%Thing,%List) -> %List bfStruct(name,arglist)== bfTuple [bfCreateDef i for i in arglist] - + +bfCreateDef: %Thing -> %List bfCreateDef x== if null cdr x then @@ -1066,9 +1098,12 @@ bfCreateDef x== else a:=[bfGenSymbol() for i in cdr x] ["DEFUN",car x,a,["CONS",["QUOTE",car x],["LIST",:a]]] - -bfCaseItem(x,y)==[x,y] - + +bfCaseItem: (%Thing,%Thing) -> %List +bfCaseItem(x,y) == + [x,y] + +bfCase: (%Thing,%Thing) -> %List bfCase(x,y)== g:=bfGenSymbol() g1:=bfGenSymbol() @@ -1076,9 +1111,12 @@ bfCase(x,y)== b:=bfLET(g1,["CDR",g]) c:=bfCaseItems (g1,y) bfMKPROGN [a,b,["CASE",["CAR", g],:c]] - -bfCaseItems(g,x)== [bfCI(g,i,j) for [i,j] in x] - + +bfCaseItem: (%thing,%List) -> %List +bfCaseItems(g,x) == + [bfCI(g,i,j) for [i,j] in x] + +bfCI: (%Thing,%Thing,%Thing) -> %List bfCI(g,x,y)== a:=cdr x if null a @@ -1086,8 +1124,12 @@ bfCI(g,x,y)== else b:=[[i,bfCARCDR(j,g)] for i in a for j in 0..] [car x,["LET",b,y]] - -bfCARCDR (n,g)==[INTERN CONCAT ('"CA",bfDs n,'"R"),g] - -bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1)) + +bfCARCDR: (%Short,%Thing) -> %List +bfCARCDR(n,g) == + [INTERN CONCAT ('"CA",bfDs n,'"R"),g] + +bfDs: %Short -> %Symbol +bfDs n== + if n=0 then '"" else CONCAT('"D",bfDs(n-1)) diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index 591bd9bf..83d6f8c1 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -6,13 +6,23 @@ (DEFPARAMETER |$bfClamming| NIL) -(DEFTYPE |String| () 'STRING) +(DEFTYPE |%Thing| () 'T) -(DEFTYPE |Symbol| () 'SYMBOL) +(DEFTYPE |%Boolean| () 'BOOLEAN) -(DEFTYPE |Sequence| () 'SEQUENCE) +(DEFTYPE |%String| () 'STRING) -(DEFTYPE |List| () '(OR NIL CONS)) +(DEFTYPE |%Symbol| () 'SYMBOL) + +(DEFTYPE |%Short| () 'FIXNUM) + +(DEFTYPE |%List| () 'LIST) + +(DEFTYPE |%Vector| () 'VECTOR) + +(DEFTYPE |%Sequence| () 'SEQUENCE) + +(DEFTYPE |%List| () 'LIST) (DEFUN |Name| #0=(|bfVar#1|) (CONS '|Name| (LIST . #0#))) @@ -119,6 +129,8 @@ (DEFPARAMETER |$inDefIS| NIL) +(DECLAIM (FTYPE (FUNCTION NIL |%Symbol|) |bfGenSymbol|)) + (DEFUN |bfGenSymbol| () (PROG () (DECLARE (SPECIAL |$GenVarCounter|)) @@ -127,28 +139,51 @@ (SETQ |$GenVarCounter| (+ |$GenVarCounter| 1)) (INTERN (CONCAT "bfVar#" (STRINGIMAGE |$GenVarCounter|))))))) +(DECLAIM (FTYPE (FUNCTION (|%List|) |%list|) |bfListOf|)) + (DEFUN |bfListOf| (|x|) (PROG () (RETURN |x|))) +(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%List|) |bfListOf|)) + (DEFUN |bfColon| (|x|) (PROG () (RETURN (LIST 'COLON |x|)))) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Symbol|) |%Symbol|) + |bfColonColon|)) + (DEFUN |bfColonColon| (|package| |name|) (PROG () (RETURN (INTERN (SYMBOL-NAME |name|) |package|)))) +(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Thing|) |bfSymbol|)) + (DEFUN |bfSymbol| (|x|) (PROG () (RETURN (COND ((STRINGP |x|) |x|) ('T (LIST 'QUOTE |x|)))))) +(DECLAIM (FTYPE (FUNCTION NIL |%Symbol|) |bfDot|)) + (DEFUN |bfDot| () (PROG () (RETURN 'DOT))) +(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%List|) |bfSuffixDot|)) + (DEFUN |bfSuffixDot| (|x|) (PROG () (RETURN (LIST |x| 'DOT)))) +(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%List|) |bfEqual|)) + (DEFUN |bfEqual| (|name|) (PROG () (RETURN (LIST 'EQUAL |name|)))) +(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Thing|) |bfBracket|)) + (DEFUN |bfBracket| (|part|) (PROG () (RETURN |part|))) +(DECLAIM (FTYPE (FUNCTION (|%List|) |%List|) |bfPile|)) + (DEFUN |bfPile| (|part|) (PROG () (RETURN |part|))) +(DECLAIM (FTYPE (FUNCTION (|%List|) |%List|) |bfAppend|)) + (DEFUN |bfAppend| (|x|) (PROG () (RETURN (APPLY #'APPEND |x|)))) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Thing|) |%List|) |bfColonAppend|)) + (DEFUN |bfColonAppend| (|x| |y|) (PROG (|a|) (RETURN @@ -161,12 +196,20 @@ (#0='T (LIST '&REST |y|)))) (#0# (CONS (CAR |x|) (|bfColonAppend| (CDR |x|) |y|))))))) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%List|) + |bfDefinition|)) + (DEFUN |bfDefinition| (|bflhsitems| |bfrhs| |body|) (PROG () (RETURN (LIST 'DEF |bflhsitems| |bfrhs| |body|)))) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%List|) + |bfMDefinition|)) + (DEFUN |bfMDefinition| (|bflhsitems| |bfrhs| |body|) (PROG () (RETURN (|bfMDef| 'MDEF |bflhsitems| |bfrhs| |body|)))) +(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%List|) |bfCompDef|)) + (DEFUN |bfCompDef| (|x|) (PROG (|body| |ISTMP#3| |args| |ISTMP#2| |op| |ISTMP#1| |def| |bfVar#73| |bfVar#72|) @@ -199,6 +242,8 @@ (|bfDef| |def| |op| |args| |body|)) ('T (|coreError| "invalid AST"))))))))) +(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Boolean|) |bfBeginsDollar|)) + (DEFUN |bfBeginsDollar| (|x|) (PROG () (RETURN (EQL (ELT "$" 0) (ELT (PNAME |x|) 0))))) @@ -218,6 +263,9 @@ (DEFUN |bfTupleP| (|x|) (PROG () (RETURN (EQCAR |x| 'TUPLE)))) +(DEFUN |bfUntuple| (|bf|) + (PROG () (RETURN (COND ((|bfTupleP| |bf|) (CDR |bf|)) ('T |bf|))))) + (DEFUN |bfTupleIf| (|x|) (PROG () (RETURN (COND ((|bfTupleP| |x|) |x|) ('T (|bfTuple| |x|)))))) @@ -1669,9 +1717,10 @@ (DEFUN |bfTagged| (|a| |b|) (PROG () - (DECLARE (SPECIAL |$typings|)) + (DECLARE (SPECIAL |$typings| |$op|)) (RETURN (COND + ((NULL |$op|) (|Signature| |a| |b|)) ((IDENTP |a|) (COND ((EQ |b| 'FLUID) (|bfLET| (|compFluid| |a|) NIL)) @@ -1969,9 +2018,13 @@ (LIST 'QUOTE |cacheVector|))) (|shoeEVALANDFILEACTQ| |cacheResetCode|)))))) +(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%List|) |bfNameOnly|)) + (DEFUN |bfNameOnly| (|x|) (PROG () (RETURN (COND ((EQ |x| '|t|) (LIST 'T)) ('T (LIST |x|)))))) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) |%List|) |bfNameArgs|)) + (DEFUN |bfNameArgs| (|x| |y|) (PROG () (RETURN @@ -1980,6 +2033,8 @@ (COND ((EQCAR |y| 'TUPLE) (CDR |y|)) ('T (LIST |y|)))) (CONS |x| |y|))))) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%List|) |%List|) |bfStruct|)) + (DEFUN |bfStruct| (|name| |arglist|) (PROG () (RETURN @@ -1995,6 +2050,8 @@ (CONS (|bfCreateDef| |i|) |bfVar#110|)))) (SETQ |bfVar#109| (CDR |bfVar#109|)))))))) +(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%List|) |bfCreateDef|)) + (DEFUN |bfCreateDef| (|x|) (PROG (|a| |f|) (RETURN @@ -2017,8 +2074,12 @@ (LIST 'DEFUN (CAR |x|) |a| (LIST 'CONS (LIST 'QUOTE (CAR |x|)) (CONS 'LIST |a|)))))))) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) |%List|) |bfCaseItem|)) + (DEFUN |bfCaseItem| (|x| |y|) (PROG () (RETURN (LIST |x| |y|)))) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) |%List|) |bfCase|)) + (DEFUN |bfCase| (|x| |y|) (PROG (|c| |b| |a| |g1| |g|) (RETURN @@ -2031,6 +2092,8 @@ (|bfMKPROGN| (LIST |a| |b| (CONS 'CASE (CONS (LIST 'CAR |g|) |c|)))))))) +(DECLAIM (FTYPE (FUNCTION (|%thing| |%List|) |%List|) |bfCaseItem|)) + (DEFUN |bfCaseItems| (|g| |x|) (PROG (|j| |ISTMP#1| |i|) (RETURN @@ -2051,6 +2114,8 @@ (CONS (|bfCI| |g| |i| |j|) |bfVar#115|))))) (SETQ |bfVar#114| (CDR |bfVar#114|))))))) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%List|) |bfCI|)) + (DEFUN |bfCI| (|g| |x| |y|) (PROG (|b| |a|) (RETURN @@ -2075,10 +2140,14 @@ (SETQ |j| (+ |j| 1))))) (LIST (CAR |x|) (LIST 'LET |b| |y|)))))))) +(DECLAIM (FTYPE (FUNCTION (|%Short| |%Thing|) |%List|) |bfCARCDR|)) + (DEFUN |bfCARCDR| (|n| |g|) (PROG () (RETURN (LIST (INTERN (CONCAT "CA" (|bfDs| |n|) "R")) |g|)))) +(DECLAIM (FTYPE (FUNCTION (|%Short|) |%Symbol|) |bfDs|)) + (DEFUN |bfDs| (|n|) (PROG () (RETURN diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp index cfc9b0fa..279926e5 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -667,12 +667,23 @@ (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) T))))) +(DEFUN |bpTyping| () + (PROG () + (RETURN + (OR (AND (|bpApplication|) + (OR (AND (|bpEqKey| 'ARROW) + (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| + (|Mapping| (|bpPop1|) + (|bfUntuple| (|bpPop1|))))) + T)) + (|bpMapping|))))) + (DEFUN |bpTagged| () (PROG () (RETURN (AND (|bpApplication|) - (OR (AND (|bpEqKey| 'COLON) - (OR (|bpApplication|) (|bpTrap|)) + (OR (AND (|bpEqKey| 'COLON) (OR (|bpTyping|) (|bpTrap|)) (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|)))) T))))) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index 0b849cfc..2d480526 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -469,10 +469,39 @@ ((NULL |$stack|) (|bpGeneralErrorHere|) NIL) ('T (CAR |$stack|))))))) +(DEFUN |genDeclaration| (|n| |t|) + (PROG (|argTypes| |ISTMP#2| |valType| |ISTMP#1|) + (RETURN + (COND + ((AND (CONSP |t|) (EQ (CAR |t|) '|Mapping|) + (PROGN + (SETQ |ISTMP#1| (CDR |t|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |valType| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN + (SETQ |argTypes| (CAR |ISTMP#2|)) + 'T)))))) + (PROGN + (COND + ((|bfTupleP| |argTypes|) + (SETQ |argTypes| (CDR |argTypes|)))) + (COND + ((AND (NULL (NULL |argTypes|)) (SYMBOLP |argTypes|)) + (SETQ |argTypes| (LIST |argTypes|)))) + (LIST 'DECLAIM + (LIST 'FTYPE (LIST 'FUNCTION |argTypes| |valType|) + |n|)))) + ('T (LIST 'DECLAIM (LIST 'TYPE |t| |n|))))))) + (DEFUN |bpOutItem| () (PROG (|bfVar#6| |bfVar#5| |r| |ISTMP#2| |l| |ISTMP#1| |b|) + (DECLARE (SPECIAL |$op|)) (RETURN (PROGN + (SETQ |$op| NIL) (OR (|bpComma|) (|bpTrap|)) (SETQ |b| (|bpPop1|)) (COND @@ -495,6 +524,9 @@ (SETQ |bfVar#5| |b|) (SETQ |bfVar#6| (CDR |bfVar#5|)) (CASE (CAR |bfVar#5|) + (|Signature| + (LET ((|op| (CAR |bfVar#6|)) (|t| (CADR |bfVar#6|))) + (|bpPush| (LIST (|genDeclaration| |op| |t|))))) (|Module| (LET ((|m| (CAR |bfVar#6|))) (|bpPush| |