aboutsummaryrefslogtreecommitdiff
path: root/src/boot/strap
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot/strap')
-rw-r--r--src/boot/strap/ast.clisp4
-rw-r--r--src/boot/strap/parser.clisp4
-rw-r--r--src/boot/strap/tokens.clisp22
-rw-r--r--src/boot/strap/translator.clisp88
-rw-r--r--src/boot/strap/utility.clisp2
5 files changed, 58 insertions, 62 deletions
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index fdd34743..94f3cce2 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -3739,8 +3739,11 @@
|call|))))
(LIST (LIST 'DEFUN |op| |parms| |call|)))))
+(DEFPARAMETER |$ffs| NIL)
+
(DEFUN |genImportDeclaration| (|op| |sig|)
(LET* (|s| |t| |m| |ISTMP#2| |op'| |ISTMP#1|)
+ (DECLARE (SPECIAL |$ffs|))
(COND
((NOT
(AND (CONSP |sig|) (EQ (CAR |sig|) '|%Signature|)
@@ -3765,6 +3768,7 @@
(PROGN (SETQ |s| (CAR |ISTMP#2|)) T)))))))
(|coreError| "invalid function type"))
(T (COND ((AND |s| (SYMBOLP |s|)) (SETQ |s| (LIST |s|))))
+ (SETQ |$ffs| (CONS |op| |$ffs|))
(COND
((|%hasFeature| :GCL) (|genGCLnativeTranslation| |op| |s| |t| |op'|))
((|%hasFeature| :SBCL) (|genSBCLnativeTranslation| |op| |s| |t| |op'|))
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index 985611d3..b6c95484 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -388,7 +388,7 @@
(COND (|done| (RETURN NIL))
(T
(SETQ |found|
- (LET ((#1=#:G720
+ (LET ((#1=#:G725
(CATCH :OPEN-AXIOM-CATCH-POINT
(APPLY |f| |ps| NIL))))
(COND
@@ -1371,7 +1371,7 @@
(SETQ |op| (|enclosingFunction| (|parserLoadUnit| |ps|)))
(SETQ |varno| (|parserGensymSequenceNumber| |ps|))
(UNWIND-PROTECT
- (LET ((#1=#:G721
+ (LET ((#1=#:G726
(CATCH :OPEN-AXIOM-CATCH-POINT
(PROGN
(SETF (|enclosingFunction| (|parserLoadUnit| |ps|)) NIL)
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index 4c088f8d..b606644b 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -84,10 +84,10 @@
(LET* (|s|)
(COND
((SETQ |s|
- (WITH-HASH-TABLE-ITERATOR (#1=#:G719 |shoeKeyTable|)
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|)
(LET ((|bfVar#1| NIL))
(LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G720 |k| |v|)
+ (MULTIPLE-VALUE-BIND (#2=#:G725 |k| |v|)
(#1#)
(COND ((NOT #2#) (RETURN |bfVar#1|))
(T
@@ -138,9 +138,9 @@
(COND ((> |i| 255) (RETURN NIL)) (T (SETF (ELT |a| |i|) |b|)))
(SETQ |i| (+ |i| 1))))
|a|))
- (WITH-HASH-TABLE-ITERATOR (#1=#:G721 |shoeKeyTable|)
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G726 |shoeKeyTable|)
(LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G722 |s| #:G723)
+ (MULTIPLE-VALUE-BIND (#2=#:G727 |s| #:G728)
(#1#)
(COND ((NOT #2#) (RETURN NIL)) (T (|shoeInsert| |s| |d|))))))
|d|)))
@@ -154,9 +154,9 @@
(LET ((|i| 0))
(LOOP (COND ((> |i| 255) (RETURN NIL)) (T (SETF (SBIT |a| |i|) 0)))
(SETQ |i| (+ |i| 1))))
- (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|)
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G729 |shoeKeyTable|)
(LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G725 |k| #:G726)
+ (MULTIPLE-VALUE-BIND (#2=#:G730 |k| #:G731)
(#1#)
(COND ((NOT #2#) (RETURN NIL)) ((|shoeStartsId| (SCHAR |k| 0)) NIL)
(T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1))))))
@@ -216,13 +216,19 @@
(LIST '|copyString| 'COPY-SEQ) (LIST '|copyVector| 'COPY-SEQ)
(LIST '|croak| 'CROAK) (LIST '|digit?| 'DIGIT-CHAR-P)
(LIST '|exit| 'EXIT) (LIST '|false| 'NIL) (LIST '|fifth| 'FIFTH)
- (LIST '|first| 'CAR) (LIST '|float?| 'FLOATP)
+ (LIST '|first| 'CAR) (LIST '|filePath| 'PATHNAME)
+ (LIST '|filePath?| 'PATHNAMEP)
+ (LIST '|filePathDirectory| 'PATHNAME-DIRECTORY)
+ (LIST '|filePathName| 'PATHNAME-NAME)
+ (LIST '|filePathString| 'NAMESTRING)
+ (LIST '|filePathType| 'PATHNAME-TYPE) (LIST '|float?| 'FLOATP)
(LIST '|flushOutput| 'FORCE-OUTPUT) (LIST '|fourth| 'CADDDR)
(LIST '|freshLine| 'FRESH-LINE) (LIST '|function?| 'FUNCTIONP)
(LIST '|functionSymbol?| 'FBOUNDP) (LIST '|gensym| 'GENSYM)
(LIST '|genvar| 'GENVAR) (LIST '|integer?| 'INTEGERP)
(LIST 'LAST '|last|) (LIST '|list| 'LIST) (LIST '|listEq?| 'EQUAL)
- (LIST '|lowerCase?| 'LOWER-CASE-P) (LIST '|makeSymbol| 'INTERN)
+ (LIST '|lowerCase?| 'LOWER-CASE-P)
+ (LIST '|makeFilePath| 'MAKE-PATHNAME) (LIST '|makeSymbol| 'INTERN)
(LIST '|mkpf| 'MKPF) (LIST '|newVector| 'MAKE-ARRAY)
(LIST '|nil| NIL) (LIST '|not| 'NOT) (LIST '|null| 'NULL)
(LIST '|odd?| 'ODDP) (LIST '|or| 'OR) (LIST '|otherwise| 'T)
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index c681da73..4cc7a1bb 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -26,63 +26,46 @@
(PROGN (|prettyPrint| |x| |st|) (TERPRI |st|)))
(DEFUN |genModuleFinalization| (|stream|)
- (LET* (|init|)
- (DECLARE (SPECIAL |$currentModuleName| |$foreignsDefsForCLisp|))
- (COND
- ((|%hasFeature| :CLISP)
- (COND ((NULL |$foreignsDefsForCLisp|) NIL)
- ((NULL |$currentModuleName|)
- (|coreError| "current module has no name"))
- (T
- (SETQ |init|
- (LIST 'EVAL-WHEN (LIST :LOAD-TOPLEVEL :EXECUTE)
- (CONS 'PROGN
- (CONS
- (LIST 'MAPC (LIST 'FUNCTION 'FMAKUNBOUND)
- (|quote|
- (LET ((|bfVar#2| NIL)
- (|bfVar#3| NIL)
- (|bfVar#1|
- |$foreignsDefsForCLisp|)
- (|d| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN
- (SETQ |d| (CAR |bfVar#1|))
- NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #1=(CONS (CADR |d|) NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #1#)
- (SETQ |bfVar#3|
- (CDR |bfVar#3|))))
- (SETQ |bfVar#1|
- (CDR |bfVar#1|))))))
- (LET ((|bfVar#5| NIL)
- (|bfVar#6| NIL)
- (|bfVar#4| |$foreignsDefsForCLisp|)
+ (LET* (|init| |setFFS|)
+ (DECLARE (SPECIAL |$foreignsDefsForCLisp| |$currentModuleName| |$ffs|))
+ (COND ((NULL |$ffs|) NIL)
+ ((NULL |$currentModuleName|)
+ (|coreError| "current module has no name"))
+ (T
+ (SETQ |setFFS|
+ (LIST 'SETQ '|$dynamicForeignFunctions|
+ (LIST '|append!| (|quote| |$ffs|)
+ '|$dynamicForeignFunctions|)))
+ (|reallyPrettyPrint| (|atLoadOrExecutionTime| |setFFS|) |stream|)
+ (COND
+ ((|%hasFeature| :CLISP)
+ (COND ((NULL |$foreignsDefsForCLisp|) NIL)
+ (T
+ (SETQ |init|
+ (CONS 'PROGN
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| |$foreignsDefsForCLisp|)
(|d| NIL))
(LOOP
(COND
- ((OR (NOT (CONSP |bfVar#4|))
+ ((OR (NOT (CONSP |bfVar#1|))
(PROGN
- (SETQ |d| (CAR |bfVar#4|))
+ (SETQ |d| (CAR |bfVar#1|))
NIL))
- (RETURN |bfVar#5|))
- ((NULL |bfVar#5|)
- (SETQ |bfVar#5|
- #2=(CONS
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2|
+ #1=(CONS
(LIST 'EVAL (|quote| |d|))
NIL))
- (SETQ |bfVar#6| |bfVar#5|))
- (T (RPLACD |bfVar#6| #2#)
- (SETQ |bfVar#6| (CDR |bfVar#6|))))
- (SETQ |bfVar#4| (CDR |bfVar#4|))))))))
- (|reallyPrettyPrint| |init| |stream|))))
- (T NIL))))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#)
+ (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))))
+ (|reallyPrettyPrint| (|atLoadOrExecutionTime| |init|)
+ |stream|))))
+ (T NIL))))))
(DEFUN |genOptimizeOptions| (|stream|)
(|reallyPrettyPrint|
@@ -433,7 +416,7 @@
(SETQ |ps| (|makeParserState| |toks|))
(|bpFirstTok| |ps|)
(SETQ |found|
- (LET ((#1=#:G729
+ (LET ((#1=#:G734
(CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem| |ps|))))
(COND
((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT))
@@ -512,6 +495,9 @@
(DEFUN |inAllContexts| (|x|)
(LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) |x|))
+(DEFUN |atLoadOrExecutionTime| (|x|)
+ (LIST 'EVAL-WHEN (LIST :LOAD-TOPLEVEL :EXECUTE) |x|))
+
(DEFUN |exportNames| (|ns|)
(COND ((NULL |ns|) NIL)
(T (LIST (|inAllContexts| (LIST 'EXPORT (|quote| |ns|)))))))
diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp
index 20efc228..2e303001 100644
--- a/src/boot/strap/utility.clisp
+++ b/src/boot/strap/utility.clisp
@@ -287,7 +287,7 @@
((NOT
(AND (CONSP |l|) (PROGN (SETQ |p| (CAR |l|)) (SETQ |l| (CDR |l|)) T)))
(RETURN NIL))
- ((AND (CONSP |p|) (EQ (CAR |p|) |x|)) (RETURN |p|))))))
+ ((AND (CONSP |p|) (EQ |x| (CAR |p|))) (RETURN |p|))))))
(DEFUN |substitute!| (|y| |x| |s|)
(COND ((NULL |s|) NIL) ((EQ |x| |s|) |y|)
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-23 10:24:56 +0000