* boot/ast.boot (shoeCompTran1): Don't indiscriminately walk CASE

	forms.  Translate %Namespace forms too.
	* boot/parser.boot (bpApplication): Include Namespace too.

6 files changed, 68 insertions, 27 deletions

diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 32d6af8d..2ab77036 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -969,6 +969,12 @@ shoeCompTran1 x ==
     x
   U := first x
   U is "QUOTE" => x
+  x is ["CASE",y,:zs] =>
+    second(x) := shoeCompTran1 y
+    while zs ~= nil repeat
+      second(first zs) := shoeCompTran1 second first zs
+      zs := rest zs
+    x
   x is ["L%T",l,r] =>
     x.op := "SETQ"
     third(x) := shoeCompTran1 r
@@ -998,6 +1004,9 @@ shoeCompTran1 x ==
   -- literal vectors.
   x is ['vector,['LIST,:args]] => (x.op := 'VECTOR; x.args := args; x)
   x is ['vector,'NIL] => (x.op := 'VECTOR; x.args := nil; x)
+  x is ['%Namespace,n] =>
+    n is "DOT" => "*PACKAGE*"
+    ["FIND-PACKAGE",symbolName n]
   x.first := shoeCompTran1 first x
   x.rest := shoeCompTran1 rest x
   x
@@ -1151,6 +1160,9 @@ bfMain(auxfn,op)==
            ["QUOTE", op],["QUOTE",'cacheInfo]],["QUOTE", cacheVector]]]
 
 
+bfNamespace x ==
+  ['%Namespace,x]
+
 bfNameOnly: %Thing -> %Form
 bfNameOnly x==
   x is "t" => ["T"]
diff --git a/src/boot/parser.boot b/src/boot/parser.boot
index 1fd714dc..f7a0ba8f 100644
--- a/src/boot/parser.boot
+++ b/src/boot/parser.boot
@@ -465,7 +465,7 @@ bpImport() ==
 ++    NAMESPACE Name
 bpNamespace() ==
   bpEqKey "NAMESPACE" and (bpName() or bpDot()) and
-    bpPush %Namespace bpPop1()
+    bpPush bfNamespace bpPop1()
 
 -- Parse a type alias defnition:
 --    type-alias-definition: 
@@ -596,6 +596,7 @@ bpApplication()==
    bpPrimary() and bpAnyNo function bpSelector and
       (bpApplication() and
             bpPush(bfApplication(bpPop2(),bpPop1())) or true)
+              or bpNamespace()
  
 ++ Typing:
 ++   SimpleType
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index c43b3c3e..6fcee2ea 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -1826,7 +1826,8 @@
         (T NIL)))))
 
 (DEFUN |shoeCompTran1| (|x|)
-  (PROG (|args| |newbindings| |r| |ISTMP#2| |l| |ISTMP#1| U)
+  (PROG (|n| |args| |newbindings| |r| |ISTMP#2| |l| |zs| |y| |ISTMP#1|
+             U)
     (DECLARE (SPECIAL |$fluidVars| |$locVars| |$dollarVars|))
     (RETURN
       (COND
@@ -1839,6 +1840,22 @@
         (T (SETQ U (CAR |x|))
            (COND
              ((EQ U 'QUOTE) |x|)
+             ((AND (CONSP |x|) (EQ (CAR |x|) 'CASE)
+                   (PROGN
+                     (SETQ |ISTMP#1| (CDR |x|))
+                     (AND (CONSP |ISTMP#1|)
+                          (PROGN
+                            (SETQ |y| (CAR |ISTMP#1|))
+                            (SETQ |zs| (CDR |ISTMP#1|))
+                            T))))
+              (SETF (CADR |x|) (|shoeCompTran1| |y|))
+              (LOOP
+                (COND
+                  ((NOT |zs|) (RETURN NIL))
+                  (T (SETF (CADR (CAR |zs|))
+                           (|shoeCompTran1| (CADR (CAR |zs|))))
+                     (SETQ |zs| (CDR |zs|)))))
+              |x|)
              ((AND (CONSP |x|) (EQ (CAR |x|) 'L%T)
                    (PROGN
                      (SETQ |ISTMP#1| (CDR |x|))
@@ -1925,6 +1942,14 @@
                      (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
                           (EQ (CAR |ISTMP#1|) 'NIL))))
               (RPLACA |x| 'VECTOR) (RPLACD |x| NIL) |x|)
+             ((AND (CONSP |x|) (EQ (CAR |x|) '|%Namespace|)
+                   (PROGN
+                     (SETQ |ISTMP#1| (CDR |x|))
+                     (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+                          (PROGN (SETQ |n| (CAR |ISTMP#1|)) T))))
+              (COND
+                ((EQ |n| 'DOT) '*PACKAGE*)
+                (T (LIST 'FIND-PACKAGE (SYMBOL-NAME |n|)))))
              (T (RPLACA |x| (|shoeCompTran1| (CAR |x|)))
                 (RPLACD |x| (|shoeCompTran1| (CDR |x|))) |x|)))))))
 
@@ -2262,6 +2287,8 @@
                               (LIST 'QUOTE '|cacheInfo|))
                         (LIST 'QUOTE |cacheVector|))))))))
 
+(DEFUN |bfNamespace| (|x|) (LIST '|%Namespace| |x|))
+
 (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Form|) |bfNameOnly|))
 
 (DEFUN |bfNameOnly| (|x|)
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index e780b7a7..867d52e9 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -500,7 +500,7 @@
 
 (DEFUN |bpNamespace| ()
   (AND (|bpEqKey| 'NAMESPACE) (OR (|bpName|) (|bpDot|))
-       (|bpPush| (|%Namespace| (|bpPop1|)))))
+       (|bpPush| (|bfNamespace| (|bpPop1|)))))
 
 (DEFUN |bpTypeAliasDefition| ()
   (AND (OR (|bpTerm| #'|bpIdList|) (|bpTrap|)) (|bpEqKey| 'TDEF)
@@ -628,10 +628,11 @@
            (|bpPush| (|bfSuffixDot| (|bpPop1|))))))
 
 (DEFUN |bpApplication| ()
-  (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|)
-       (OR (AND (|bpApplication|)
-                (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|))))
-           T)))
+  (OR (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|)
+           (OR (AND (|bpApplication|)
+                    (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|))))
+               T))
+      (|bpNamespace|)))
 
 (DEFUN |bpTyping| ()
   (COND
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index dc23cc1f..cff39c1b 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -843,7 +843,7 @@
       (COND
         ((NULL |a|) (|shoeNotFound| |fn|))
         (T (SETQ |$lispWordTable| (|makeTable| #'EQ))
-           (DO-SYMBOLS (|i| (FIND-PACKAGE 'LISP))
+           (DO-SYMBOLS (|i| (FIND-PACKAGE "LISP"))
              (SETF (|tableValue| |$lispWordTable| |i|) T))
            (SETQ |$bootDefined| (|makeTable| #'EQ))
            (SETQ |$bootUsed| (|makeTable| #'EQ))
@@ -1145,7 +1145,7 @@
       (COND
         ((NULL |a|) (|shoeNotFound| |fn|))
         (T (SETQ |$lispWordTable| (|makeTable| #'EQ))
-           (DO-SYMBOLS (|i| (FIND-PACKAGE 'LISP))
+           (DO-SYMBOLS (|i| (FIND-PACKAGE "LISP"))
              (SETF (|tableValue| |$lispWordTable| |i|) T))
            (SETQ |$bootDefined| (|makeTable| #'EQ))
            (SETQ |$bootUsed| (|makeTable| #'EQ))
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
index 84eebde8..646e876d 100644
--- a/src/boot/translator.boot
+++ b/src/boot/translator.boot
@@ -86,7 +86,7 @@ shoeCOMPILE_-FILE lspFileName ==
 BOOTTOCL(fn, out) ==
   try
     startCompileDuration()
-    callingPackage := _*PACKAGE_*
+    callingPackage := namespace .
     IN_-PACKAGE '"BOOTTRAN"
     result := BOOTTOCLLINES(nil,fn, out)
     setCurrentPackage callingPackage
@@ -129,7 +129,7 @@ shoeClLines(a,fn,lines,outfn)==
 BOOTTOCLC(fn, out)==
   try
     startCompileDuration()
-    callingPackage := _*PACKAGE_*
+    callingPackage := namespace .
     IN_-PACKAGE '"BOOTTRAN"
     result := BOOTTOCLCLINES(nil, fn, out)
     setCurrentPackage callingPackage
@@ -160,7 +160,7 @@ shoeClCLines(a,fn,lines,outfn)==
 ++ to machine code and loads it one item at a time
 BOOTTOMC: %String -> %Thing 
 BOOTTOMC fn==
-   callingPackage := _*PACKAGE_*
+   callingPackage := namespace .
    IN_-PACKAGE '"BOOTTRAN"
    $GenVarCounter: local  := 0
    try
@@ -176,7 +176,7 @@ shoeMc(a,fn)==
   shoeConsole strconc(fn,'" COMPILED AND LOADED")
  
 evalBootFile fn ==
-   b := _*PACKAGE_*
+   b := namespace .
    IN_-PACKAGE '"BOOTTRAN"
    infn:=shoeAddbootIfNec fn
    outfn := strconc(shoeRemovebootIfNec fn,'".",_*LISP_-SOURCE_-FILETYPE_*)
@@ -192,7 +192,7 @@ evalBootFile fn ==
 ++ and prints the result at the console
 BO: %String -> %Thing 
 BO fn==
-  b := _*PACKAGE_*
+  b := namespace .
   IN_-PACKAGE '"BOOTTRAN"
   $GenVarCounter: local := 0
   try
@@ -203,7 +203,7 @@ BO fn==
     setCurrentPackage b
  
 BOCLAM fn==
-  callingPackage := _*PACKAGE_*
+  callingPackage := namespace .
   IN_-PACKAGE '"BOOTTRAN"
   $GenVarCounter: local := 0
   $bfClamming: local := true
@@ -226,25 +226,25 @@ STOUT string ==
   PSTOUT [string]
  
 string2BootTree string ==   
-  callingPackage := _*PACKAGE_*
+  callingPackage := namespace .
   IN_-PACKAGE '"BOOTTRAN"
   $GenVarCounter: local := 0
   a := shoeTransformString [string]
   result :=
     bStreamNull a => nil
-    stripm(first a,callingPackage,FIND_-PACKAGE '"BOOTTRAN")
+    stripm(first a,callingPackage,namespace BOOTTRAN)
   setCurrentPackage callingPackage
   result
 
  
 STEVAL string==
-   callingPackage := _*PACKAGE_*
+   callingPackage := namespace .
    IN_-PACKAGE '"BOOTTRAN"
    $GenVarCounter: local := 0
    a:=  shoeTransformString [string]
    result := 
       bStreamNull a => nil
-      fn:=stripm(first a,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN")
+      fn:=stripm(first a,namespace .,namespace BOOTTRAN)
       EVAL fn
    setCurrentPackage callingPackage
    result
@@ -253,7 +253,7 @@ STEVAL string==
 -- to common lisp, and compiles it.
  
 STTOMC string==
-   callingPackage := _*PACKAGE_*
+   callingPackage := namespace .
    IN_-PACKAGE '"BOOTTRAN"
    $GenVarCounter: local := 0
    a:=  shoeTransformString [string]
@@ -362,7 +362,7 @@ shoePPtoFile(x, stream) ==
  
 shoeConsoleTrees s ==
   while not bStreamPackageNull s repeat
-    fn:=stripm(first s,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN")
+    fn:=stripm(first s,namespace .,namespace BOOTTRAN)
     REALLYPRETTYPRINT fn
     s:= rest s
  
@@ -526,7 +526,7 @@ $lispWordTable := nil
 shoeDfu(a,fn)==
   a=nil => shoeNotFound fn
   $lispWordTable: local := makeTable function symbolEq?
-  DO_-SYMBOLS(i(FIND_-PACKAGE "LISP"),tableValue($lispWordTable,i) := true)
+  DO_-SYMBOLS(i(namespace LISP),tableValue($lispWordTable,i) := true)
   $bootDefined: local := makeTable function symbolEq?
   $bootUsed:local := makeTable function symbolEq?
   $bootDefinedTwice: local := nil
@@ -559,7 +559,7 @@ shoeDefUse(s)==
     s:=rest s
  
 defuse(e,x)==
-  x:=stripm(x,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN")
+  x:=stripm(x,namespace .,namespace BOOTTRAN)
   $used :=nil
   [nee,niens]:=
      x is ['DEFUN,name,bv,:body] => [name,['LAMBDA,bv,:body]]
@@ -643,7 +643,7 @@ XREF fn==
 shoeXref(a,fn)==
   a = nil => shoeNotFound fn
   $lispWordTable: local := makeTable function symbolEq?
-  DO_-SYMBOLS(i(FIND_-PACKAGE "LISP"),tableValue($lispWordTable,i) := true)
+  DO_-SYMBOLS(i(namespace LISP),tableValue($lispWordTable,i) := true)
   $bootDefined: local := makeTable function symbolEq?
   $bootUsed: local := makeTable function symbolEq?
   $GenVarCounter: local := 0
@@ -677,7 +677,7 @@ stripm (x,pk,bt)==
   [stripm(first x,pk,bt),:stripm(rest x,pk,bt)]
  
 shoePCompile  fn==
-    fn:=stripm(fn,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN")
+    fn:=stripm(fn,namespace .,namespace BOOTTRAN)
     fn is ['DEFUN,name,bv,:body]=>
           COMPILE (name,['LAMBDA,bv,:body])
     EVAL fn
@@ -688,7 +688,7 @@ shoePCompileTrees s==
     s := rest s
  
 bStreamPackageNull s==
-  a := _*PACKAGE_*
+  a := namespace .
   IN_-PACKAGE '"BOOTTRAN"
   b:=bStreamNull s
   setCurrentPackage a
@@ -727,7 +727,7 @@ BOOTPO() ==
   BOOTPO()
  
 PSTOUT string==
-  callingPackage := _*PACKAGE_*
+  callingPackage := namespace .
   IN_-PACKAGE '"BOOTTRAN"
   $GenVarCounter: local := 0
   result := shoeConsoleTrees shoeTransformString string