Update Boot code

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|