aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/boot/ast.boot142
-rw-r--r--src/boot/strap/ast.clisp79
-rw-r--r--src/boot/strap/parser.clisp15
-rw-r--r--src/boot/strap/translator.clisp32
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|