From 8cf4c7d7040078b651859fbd998f6bbf7b68127e Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Sun, 15 May 2011 16:56:22 +0000
Subject: 	* boot/ast.boot (shoeCompTran1): Don't indiscriminately walk
 CASE 	forms.  Translate %Namespace forms too. 	* boot/parser.boot
 (bpApplication): Include Namespace too.

---
 src/boot/strap/ast.clisp        | 29 ++++++++++++++++++++++++++++-
 src/boot/strap/parser.clisp     | 11 ++++++-----
 src/boot/strap/translator.clisp |  4 ++--
 3 files changed, 36 insertions(+), 8 deletions(-)

(limited to 'src/boot/strap')

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))
-- 
cgit v1.2.3