diff options
| author | dos-reis <gdr@axiomatics.org> | 2011-05-15 16:56:22 +0000 |
|---|---|---|
| committer | dos-reis <gdr@axiomatics.org> | 2011-05-15 16:56:22 +0000 |
| commit | 8cf4c7d7040078b651859fbd998f6bbf7b68127e (patch) | |
| tree | 478d9f7f40133f10583a0538c8a3ee28262b023f /src/boot/strap | |
| parent | e3790da8fee54ede09e8126213a10da0aa555d06 (diff) | |
| download | open-axiom-8cf4c7d7040078b651859fbd998f6bbf7b68127e.tar.gz | |
* boot/ast.boot (shoeCompTran1): Don't indiscriminately walk CASE
forms. Translate %Namespace forms too.
* boot/parser.boot (bpApplication): Include Namespace too.
Diffstat (limited to 'src/boot/strap')
| -rw-r--r-- | src/boot/strap/ast.clisp | 29 | ||||
| -rw-r--r-- | src/boot/strap/parser.clisp | 11 | ||||
| -rw-r--r-- | src/boot/strap/translator.clisp | 4 |
3 files changed, 36 insertions, 8 deletions
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)) |