aboutsummaryrefslogtreecommitdiff
path: root/src/boot
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot')
-rw-r--r--src/boot/ast.boot12
-rw-r--r--src/boot/parser.boot3
-rw-r--r--src/boot/strap/ast.clisp29
-rw-r--r--src/boot/strap/parser.clisp11
-rw-r--r--src/boot/strap/translator.clisp4
-rw-r--r--src/boot/translator.boot36
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-07 21:34:08 +0000