diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 6 | ||||
| -rw-r--r-- | src/boot/ast.boot | 12 | ||||
| -rw-r--r-- | src/boot/parser.boot | 3 | ||||
| -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 | ||||
| -rw-r--r-- | src/boot/translator.boot | 36 |
7 files changed, 74 insertions, 27 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 79f51db3..bcab568f 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,9 @@ +2011-05-15 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * boot/ast.boot (shoeCompTran1): Don't indiscriminately walk CASE + forms. Translate %Namespace forms too. + * boot/parser.boot (bpApplication): Include Namespace too. + 2011-05-14 Gabriel Dos Reis <gdr@cs.tamu.edu> * boot/parser.boot (bpNamedScope): New. 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 |