aboutsummaryrefslogtreecommitdiff
path: root/src/boot
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot')
-rw-r--r--src/boot/Makefile.in17
-rw-r--r--src/boot/initial-env.lisp56
-rw-r--r--src/boot/parser.boot4
-rw-r--r--src/boot/strap/parser.clisp6
-rw-r--r--src/boot/strap/tokens.clisp7
-rw-r--r--src/boot/strap/translator.clisp89
-rw-r--r--src/boot/strap/utility.clisp66
-rw-r--r--src/boot/tokens.boot10
-rw-r--r--src/boot/translator.boot20
-rw-r--r--src/boot/utility.boot28
10 files changed, 193 insertions, 110 deletions
diff --git a/src/boot/Makefile.in b/src/boot/Makefile.in
index dac491f3..c569b408 100644
--- a/src/boot/Makefile.in
+++ b/src/boot/Makefile.in
@@ -48,16 +48,14 @@
## entire bootstrap process.
DRIVER = $(top_builddir)/src/driver/open-axiom$(EXEEXT)
-AXIOM_LOCAL_LISP_sources = initial-env.lisp
AXIOM_LOCAL_LISP = ../lisp/lisp$(EXEEXT)
## FASLs that comprises `bootsys'
-boot_SOURCES = initial-env.lisp $(boot_sources)
-boot_sources = utility.boot tokens.boot includer.boot scanner.boot \
+boot_SOURCES = utility.boot tokens.boot includer.boot scanner.boot \
pile.boot ast.boot parser.boot translator.boot
-boot_clisp = $(boot_sources:.boot=.clisp)
-boot_objects = initial-env.$(LNKEXT) $(boot_sources:.boot=.$(LNKEXT))
+boot_clisp = $(boot_SOURCES:.boot=.clisp)
+boot_objects = $(boot_SOURCES:.boot=.$(LNKEXT))
oa_target_bootdir = $(axiom_targetdir)/boot
ifeq (@axiom_lisp_flavor@,ecl)
@@ -67,8 +65,8 @@ oa_boot_linkset =
endif
# Garbage produced by GCL during compilation
-boot_data = $(boot_sources:.boot=.data)
-boot_fn = $(boot_sources:.boot=.fn)
+boot_data = $(boot_SOURCES:.boot=.data)
+boot_fn = $(boot_SOURCES:.boot=.fn)
# reference to this directory from toplevel
subdir = src/boot/
@@ -187,10 +185,7 @@ stage2/%.clisp: %.boot stage1/stamp stage2/.started
## FIXME: This should be automatically extracted from the
## Boot source file at packaging time.
-%/initial-env.$(LNKEXT): initial-env.lisp %/.started
- $(DRIVER) --execpath=$(AXIOM_LOCAL_LISP) --compile --output=$@ $<
-
-%/utility.$(LNKEXT): %/utility.clisp %/initial-env.$(LNKEXT)
+%/utility.$(LNKEXT): %/utility.clisp %/.started
$(DRIVER) --execpath=$(AXIOM_LOCAL_LISP) --output=$@ --compile --load-directory=$* $<
%/tokens.$(LNKEXT): %/tokens.clisp %/utility.$(LNKEXT)
diff --git a/src/boot/initial-env.lisp b/src/boot/initial-env.lisp
deleted file mode 100644
index ecf4963d..00000000
--- a/src/boot/initial-env.lisp
+++ /dev/null
@@ -1,56 +0,0 @@
-;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-;; All rights reserved.
-;; Copyright (C) 2007-2011, Gabriel Dos Reis.
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are
-;; met:
-;;
-;; - Redistributions of source code must retain the above copyright
-;; notice, this list of conditions and the following disclaimer.
-;;
-;; - Redistributions in binary form must reproduce the above copyright
-;; notice, this list of conditions and the following disclaimer in
-;; the documentation and/or other materials provided with the
-;; distribution.
-;;
-;; - Neither the name of The Numerical Algorithms Group Ltd. nor the
-;; names of its contributors may be used to endorse or promote products
-;; derived from this software without specific prior written permission.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
-;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-;;
-
-
-;;
-;; Abstract:
-;; This file defines the base initial environment for building
-;; a Boot translator image. It essentially etablishes a namespace
-;; (package BOOTTRAN) for the Boot translator, and defines
-;; some macros that need to be present during translation of Boot
-;; source files.
-;;
-
-(defpackage "BOOTTRAN"
- (:use "AxiomCore")
- #+:common-lisp (:use "COMMON-LISP")
- #-:common-lisp (:use "LISP")
- )
-
-(in-package "BOOTTRAN")
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (progn
- (setq *read-default-float-format* 'double-float)
- (setq *load-verbose* nil)))
diff --git a/src/boot/parser.boot b/src/boot/parser.boot
index 35608364..8c67c7c6 100644
--- a/src/boot/parser.boot
+++ b/src/boot/parser.boot
@@ -895,6 +895,7 @@ bpStoreName()==
bpDef() ==
bpName() and bpStoreName() and bpDefTail function %Definition
+ or bpNamespace() and bpSimpleDefinitionTail()
bpDDef() == bpName() and bpDefTail function %Definition
@@ -946,8 +947,7 @@ bpPDefinitionItems()==
bpParenthesized function bpSemiColonDefinition
bpComma()==
- bpModule() or bpImport() or bpNamespace() or
- bpTuple function bpWhere
+ bpModule() or bpImport() or bpTuple function bpWhere
bpTuple(p) ==
bpListofFun(p,function bpCommaBackSet,function bfTuple)
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index 898c6192..7b470d05 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -884,7 +884,8 @@
T))
(DEFUN |bpDef| ()
- (AND (|bpName|) (|bpStoreName|) (|bpDefTail| #'|%Definition|)))
+ (OR (AND (|bpName|) (|bpStoreName|) (|bpDefTail| #'|%Definition|))
+ (AND (|bpNamespace|) (|bpSimpleDefinitionTail|))))
(DEFUN |bpDDef| () (AND (|bpName|) (|bpDefTail| #'|%Definition|)))
@@ -930,8 +931,7 @@
(DEFUN |bpPDefinitionItems| () (|bpParenthesized| #'|bpSemiColonDefinition|))
-(DEFUN |bpComma| ()
- (OR (|bpModule|) (|bpImport|) (|bpNamespace|) (|bpTuple| #'|bpWhere|)))
+(DEFUN |bpComma| () (OR (|bpModule|) (|bpImport|) (|bpTuple| #'|bpWhere|)))
(DEFUN |bpTuple| (|p|) (|bpListofFun| |p| #'|bpCommaBackSet| #'|bfTuple|))
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index 12192b72..ba4e28a2 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -160,7 +160,7 @@
(LIST '|strconc| "") (LIST 'CONCAT "") (LIST 'MAX (- 999999))
(LIST 'MIN 999999) (LIST '* 1) (LIST '|times| 1) (LIST 'CONS NIL)
(LIST '|append| NIL) (LIST '|append!| NIL) (LIST 'UNION NIL)
- (LIST 'UNIONQ NIL) (LIST '|union| NIL) (LIST '|and| T)
+ (LIST '|setUnion| NIL) (LIST '|union| NIL) (LIST '|and| T)
(LIST '|or| NIL) (LIST 'AND T) (LIST 'OR NIL)))
(|i| NIL))
(LOOP
@@ -176,7 +176,7 @@
(LIST '|alphanumeric?| 'ALPHANUMERICP) (LIST '|and| 'AND)
(LIST '|apply| 'APPLY) (LIST '|array?| 'ARRAYP)
(LIST '|arrayRef| 'AREF) (LIST '|atom| 'ATOM)
- (LIST '|bitmask| 'SBIT) (LIST '|canonicalFilename| 'PROBE-FILE)
+ (LIST '|bitref| 'SBIT) (LIST '|canonicalFilename| 'PROBE-FILE)
(LIST '|charByName| 'NAME-CHAR)
(LIST '|charDowncase| 'CHAR-DOWNCASE) (LIST '|charEq?| 'CHAR=)
(LIST '|charUpcase| 'CHAR-UPCASE) (LIST '|charString| 'STRING)
@@ -201,8 +201,7 @@
(LIST '|readOnly?| 'CONSTANTP) (LIST '|removeDuplicates| 'REMDUP)
(LIST '|rest| 'CDR) (LIST '|sameObject?| 'EQ)
(LIST '|scalarEq?| 'EQL) (LIST '|scalarEqual?| 'EQL)
- (LIST '|second| 'CADR) (LIST '|setIntersection| 'INTERSECTION)
- (LIST '|setPart| 'SETELT) (LIST '|setUnion| 'UNION)
+ (LIST '|second| 'CADR) (LIST '|setPart| 'SETELT)
(LIST '|strconc| 'CONCAT) (LIST '|stringChar| 'SCHAR)
(LIST '|stringDowncase| 'STRING-DOWNCASE)
(LIST '|string?| 'STRINGP) (LIST '|stringEq?| 'STRING=)
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index 4ab03112..95ad05d9 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -565,8 +565,49 @@
(COND ((NULL |ns|) NIL)
(T (LIST (|inAllContexts| (LIST 'EXPORT (|quote| |ns|)))))))
+(DEFUN |packageBody| (|x| |p|)
+ (PROG (|user| |ns| |ISTMP#3| |ISTMP#2| |ISTMP#1|)
+ (RETURN
+ (COND
+ ((AND (CONSP |x|) (EQ (CAR |x|) '|%Import|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN
+ (SETQ |ISTMP#2| (CAR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (EQ (CAR |ISTMP#2|) '|%Namespace|)
+ (PROGN
+ (SETQ |ISTMP#3| (CDR |ISTMP#2|))
+ (AND (CONSP |ISTMP#3|) (NULL (CDR |ISTMP#3|))
+ (PROGN (SETQ |ns| (CAR |ISTMP#3|)) T))))))))
+ (SETQ |user| (COND ((NULL |p|) NIL) (T (LIST (SYMBOL-NAME |p|)))))
+ (COND
+ ((EQ |ns| '|System|)
+ (LIST 'COND
+ (LIST (LIST '|%hasFeature| :COMMON-LISP)
+ (CONS 'USE-PACKAGE (CONS "COMMON-LISP" |user|)))
+ (LIST 'T (CONS 'USE-PACKAGE (CONS "LISP" |user|)))))
+ (T (CONS 'USE-PACKAGE (CONS (SYMBOL-NAME |ns|) |user|)))))
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN))
+ (CONS (CAR |x|)
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| (CDR |x|))
+ (|y| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |y| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2| #1=(CONS (|packageBody| |y| |p|) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))))
+ (T |x|)))))
+
(DEFUN |translateToplevel| (|b| |export?|)
- (PROG (|lhs| |t| |ISTMP#2| |sig| |n| |ISTMP#1| |xs|)
+ (PROG (|lhs| |t| |ISTMP#2| |sig| |def| |ns| |n| |ISTMP#1| |xs|)
(DECLARE
(SPECIAL |$currentModuleName| |$foreignsDefsForCLisp|
|$constantIdentifiers| |$InteractiveMode| |$activeNamespace|))
@@ -621,8 +662,7 @@
(SETQ |ISTMP#1| (CDR |m|))
(AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
(PROGN (SETQ |n| (CAR |ISTMP#1|)) T))))
- (LIST
- (|inAllContexts| (LIST 'USE-PACKAGE (SYMBOL-NAME |n|)))))
+ (LIST (|inAllContexts| (|packageBody| |m| NIL))))
(T
(COND
((NOT (STRING= (|getOptionValue| '|import|) "skip"))
@@ -636,22 +676,33 @@
(LIST (|genTypeAlias| |lhs| |rhs|))))
(|%ConstantDefinition|
(LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|)))
- (PROGN
- (SETQ |sig| NIL)
- (COND
- ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Signature|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |lhs|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |n| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |t| (CAR |ISTMP#2|)) T))))))
- (SETQ |sig| (|genDeclaration| |n| |t|)) (SETQ |lhs| |n|)))
- (SETQ |$constantIdentifiers|
- (CONS |lhs| |$constantIdentifiers|))
- (LIST (LIST 'DEFCONSTANT |lhs| |rhs|)))))
+ (COND
+ ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Namespace|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |lhs|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |ns| (CAR |ISTMP#1|)) T))))
+ (SETQ |def|
+ (LIST 'UNLESS
+ (LIST 'FIND-PACKAGE (SYMBOL-NAME |ns|))
+ (LIST 'MAKE-PACKAGE (SYMBOL-NAME |ns|))))
+ (LIST (|inAllContexts| |def|)
+ (|inAllContexts| (|packageBody| |rhs| |ns|))))
+ (T (SETQ |sig| NIL)
+ (COND
+ ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Signature|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |lhs|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |n| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |t| (CAR |ISTMP#2|)) T))))))
+ (SETQ |sig| (|genDeclaration| |n| |t|)) (SETQ |lhs| |n|)))
+ (SETQ |$constantIdentifiers|
+ (CONS |lhs| |$constantIdentifiers|))
+ (LIST (LIST 'DEFCONSTANT |lhs| |rhs|))))))
(|%Assignment|
(LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|)))
(PROGN
diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp
index a4c6aa61..7137a1c6 100644
--- a/src/boot/strap/utility.clisp
+++ b/src/boot/strap/utility.clisp
@@ -1,5 +1,14 @@
(PROCLAIM '(OPTIMIZE SPEED))
-(IMPORT-MODULE "initial-env")
+(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
+ (UNLESS (FIND-PACKAGE #1="BOOTTRAN") (MAKE-PACKAGE #1#)))
+
+(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
+ (PROGN
+ (COND
+ ((|%hasFeature| :COMMON-LISP)
+ (USE-PACKAGE "COMMON-LISP" . #1=(#2="BOOTTRAN")))
+ (T (USE-PACKAGE "LISP" . #1#)))
+ (USE-PACKAGE "AxiomCore" #2#)))
(IN-PACKAGE "BOOTTRAN")
@@ -10,9 +19,9 @@
'(|objectMember?| |symbolMember?| |stringMember?| |charMember?|
|scalarMember?| |listMember?| |reverse| |reverse!|
|lastNode| |append| |append!| |copyList| |substitute|
- |substitute!| |setDifference| |applySubst| |applySubst!|
- |applySubstNQ| |remove| |removeSymbol| |atomic?|
- |finishLine| |subStringMatch?|)))
+ |substitute!| |setDifference| |setUnion| |setIntersection|
+ |applySubst| |applySubst!| |applySubstNQ| |remove|
+ |removeSymbol| |atomic?| |finishLine|)))
(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute|))
@@ -39,6 +48,18 @@
(DECLAIM
(FTYPE (FUNCTION ((|%List| |%Thing|) |%Thing|) (|%List| |%Thing|)) |remove|))
+(DECLAIM
+ (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|))
+ |setDifference|))
+
+(DECLAIM
+ (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|))
+ |setUnion|))
+
+(DECLAIM
+ (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|))
+ |setIntersection|))
+
(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Boolean|) |atomic?|))
(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Void|) |finishLine|))
@@ -51,6 +72,8 @@
(FTYPE (FUNCTION (|%String| |%Short|) (|%Maybe| |%Short|))
|firstBlankPosition|))
+(|%defaultReadAndLoadSettings|)
+
(DEFUN |atomic?| (|x|) (OR (NOT (CONSP |x|)) (EQ (CAR |x|) 'QUOTE)))
(DEFUN |objectMember?| (|x| |l|)
@@ -224,6 +247,41 @@
(SETQ |bfVar#1| (CDR |bfVar#1|))))
(CDR |l|))))))
+(DEFUN |setUnion| (|x| |y|)
+ (PROG (|z|)
+ (RETURN
+ (PROGN
+ (SETQ |z| NIL)
+ (LET ((|bfVar#1| |x|) (|a| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |a| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (AND (NOT (|objectMember?| |a| |z|)) (SETQ |z| (CONS |a| |z|)))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (LET ((|bfVar#2| |y|) (|a| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#2|)) (PROGN (SETQ |a| (CAR |bfVar#2|)) NIL))
+ (RETURN NIL))
+ (T (AND (NOT (|objectMember?| |a| |z|)) (SETQ |z| (CONS |a| |z|)))))
+ (SETQ |bfVar#2| (CDR |bfVar#2|))))
+ (|reverse!| |z|)))))
+
+(DEFUN |setIntersection| (|x| |y|)
+ (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |x|) (|a| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |a| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ (T
+ (AND (|objectMember?| |a| |y|)
+ (COND
+ ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS |a| NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+
(DEFUN |removeSymbol| (|l| |x|)
(PROG (|y| |LETTMP#1| |l'| |before|)
(RETURN
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index e39cee89..2bacc64c 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -166,10 +166,10 @@ shoeDict:=shoeDictCons()
shoePunCons()==
a := makeBitVector 256
for i in 0..255 repeat
- bitmask(a,i) := 0
+ bitref(a,i) := 0
for [k,:.] in entries shoeKeyTable repeat
shoeStartsId stringChar(k,0) => nil
- bitmask(a,codePoint stringChar(k,0)) := 1
+ bitref(a,codePoint stringChar(k,0)) := 1
a
shoePun:=shoePunCons()
@@ -224,7 +224,7 @@ for i in [ _
["append", nil] , _
["append!", nil] , _
["UNION", nil] , _
- ["UNIONQ", nil] , _
+ ["setUnion", nil] , _
["union", nil] , _
["and", true] , _
["or", false] , _
@@ -244,7 +244,7 @@ for i in [ _
["array?", "ARRAYP"] , _
["arrayRef", "AREF"] , _
["atom", "ATOM"] , _
- ["bitmask", "SBIT"] , _
+ ["bitref", "SBIT"] , _
["canonicalFilename", "PROBE-FILE"], _
["charByName", "NAME-CHAR"] , _
["charDowncase", "CHAR-DOWNCASE"], _
@@ -297,9 +297,7 @@ for i in [ _
["scalarEq?", "EQL" ] , _
["scalarEqual?","EQL" ] , _
["second", "CADR"] , _
- ["setIntersection", "INTERSECTION"] , _
["setPart", "SETELT"] , _
- ["setUnion", "UNION"] , _
["strconc", "CONCAT"] , _
["stringChar", "SCHAR"] , _
["stringDowncase", "STRING-DOWNCASE"] , _
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
index 35db495f..2ff8870c 100644
--- a/src/boot/translator.boot
+++ b/src/boot/translator.boot
@@ -419,6 +419,19 @@ exportNames ns ==
ns = nil => nil
[inAllContexts ["EXPORT",quote ns]]
+packageBody(x,p) ==
+ x is ['%Import,['%Namespace,ns]] =>
+ user :=
+ p = nil => nil
+ [symbolName p]
+ ns is 'System =>
+ ['COND,
+ [['%hasFeature,KEYWORD::COMMON_-LISP],['USE_-PACKAGE,'"COMMON-LISP",:user]],
+ ['T,['USE_-PACKAGE,'"LISP",:user]]]
+ ['USE_-PACKAGE,symbolName ns,:user]
+ x is ['PROGN,:.] => [x.op,:[packageBody(y,p) for y in x.args]]
+ x
+
translateToplevel(b,export?) ==
b isnt [.,:.] => [b] -- generally happens in interactive mode.
b is ["TUPLE",:xs] => coreError '"invalid AST"
@@ -433,8 +446,7 @@ translateToplevel(b,export?) ==
:[first translateToplevel(d,true) for d in ds]]
%Import(m) =>
- m is ['%Namespace,n] =>
- [inAllContexts ["USE-PACKAGE",symbolName n]]
+ m is ['%Namespace,n] => [inAllContexts packageBody(m,nil)]
if getOptionValue "import" ~= '"skip" then
bootImport symbolName m
[["IMPORT-MODULE", symbolName m]]
@@ -445,6 +457,10 @@ translateToplevel(b,export?) ==
%TypeAlias(lhs, rhs) => [genTypeAlias(lhs,rhs)]
%ConstantDefinition(lhs,rhs) =>
+ lhs is ['%Namespace,ns] =>
+ def := ['UNLESS,['FIND_-PACKAGE,symbolName ns],
+ ['MAKE_-PACKAGE,symbolName ns]]
+ [inAllContexts def,inAllContexts packageBody(rhs,ns)]
sig := nil
if lhs is ["%Signature",n,t] then
sig := genDeclaration(n,t)
diff --git a/src/boot/utility.boot b/src/boot/utility.boot
index 5e620d82..4d4d5961 100644
--- a/src/boot/utility.boot
+++ b/src/boot/utility.boot
@@ -37,14 +37,18 @@
--% by the Boot translator. Others are handy library functions.
--%
-import initial_-env
+namespace BOOTTRAN ==
+ import namespace System
+ import namespace AxiomCore
+
namespace BOOTTRAN
module utility (objectMember?, symbolMember?, stringMember?,
charMember?, scalarMember?, listMember?, reverse, reverse!,
lastNode, append, append!, copyList, substitute, substitute!,
- setDifference, applySubst, applySubst!, applySubstNQ,
- remove,removeSymbol,atomic?,finishLine,subStringMatch?) where
+ setDifference, setUnion, setIntersection,
+ applySubst, applySubst!, applySubstNQ,
+ remove,removeSymbol,atomic?,finishLine) where
substitute: (%Thing,%Thing,%Thing) -> %Thing
substitute!: (%Thing,%Thing,%Thing) -> %Thing
append: (%List %Thing,%List %Thing) -> %List %Thing
@@ -53,11 +57,16 @@ module utility (objectMember?, symbolMember?, stringMember?,
lastNode: %List %Thing -> %Maybe %Node %Thing
removeSymbol: (%List %Thing, %Symbol) -> %List %Thing
remove: (%List %Thing, %Thing) -> %List %Thing
+ setDifference: (%List %Thing,%List %Thing) -> %List %Thing
+ setUnion: (%List %Thing,%List %Thing) -> %List %Thing
+ setIntersection: (%List %Thing,%List %Thing) -> %List %Thing
atomic?: %Thing -> %Boolean
finishLine: %Thing -> %Void
firstNonblankPosition: (%String,%Short) -> %Maybe %Short
firstBlankPosition: (%String,%Short) -> %Maybe %Short
+%defaultReadAndLoadSettings()
+
--%
++ Return true if `x' is an atom of a quotation.
@@ -233,6 +242,19 @@ setDifference(x,y) ==
p := rest p
rest l
+++ Return the union of two lists of objects, with no duplicates.
+setUnion(x,y) ==
+ z := nil
+ for a in x | not objectMember?(a,z) repeat
+ z := [a,:z]
+ for a in y | not objectMember?(a,z) repeat
+ z := [a,:z]
+ reverse! z
+
+++ Return the intersection of two lists of objects, with no duplicates.
+setIntersection(x,y) ==
+ [a for a in x | objectMember?(a,y)]
+
--% removal
removeSymbol(l,x) ==
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-07 21:25:38 +0000