aboutsummaryrefslogtreecommitdiff
path: root/src/boot/strap
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot/strap')
-rw-r--r--src/boot/strap/includer.clisp112
-rw-r--r--src/boot/strap/scanner.clisp11
-rw-r--r--src/boot/strap/tokens.clisp1
-rw-r--r--src/boot/strap/translator.clisp88
4 files changed, 23 insertions, 189 deletions
diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp
index 323a23a9..7d47a96c 100644
--- a/src/boot/strap/includer.clisp
+++ b/src/boot/strap/includer.clisp
@@ -82,59 +82,27 @@
(DEFUN |lineCharacter| (|p|) (CDR |p|))
-(DEFUN |shoePackageStartsAt| (|lines| |sz| |name| |stream|)
- (PROG (|a|)
- (RETURN
- (COND
- ((|bStreamNull| |stream|) (LIST NIL (LIST '|nullstream|)))
- (T (SETQ |a| (CAAR |stream|))
- (COND
- ((AND (NOT (< (LENGTH |a|) 8))
- (STRING= (|subString| |a| 0 8) ")package"))
- (|shoePackageStartsAt| (CONS (CAAR |stream|) |lines|)
- |sz| |name| (CDR |stream|)))
- ((< (LENGTH |a|) |sz|)
- (|shoePackageStartsAt| |lines| |sz| |name|
- (CDR |stream|)))
- ((AND (STRING= (|subString| |a| 0 |sz|) |name|)
- (< |sz| (LENGTH |a|))
- (NOT (|shoeIdChar| (ELT |a| |sz|))))
- (LIST |lines| |stream|))
- (T (|shoePackageStartsAt| |lines| |sz| |name|
- (CDR |stream|)))))))))
-
-(DEFUN |shoeFindLines| (|fn| |name| |a|)
- (PROG (|b| |lines| |LETTMP#1|)
- (RETURN
- (COND
- ((NULL |a|) (|shoeNotFound| |fn|) NIL)
- (T (SETQ |LETTMP#1|
- (|shoePackageStartsAt| NIL (LENGTH |name|) |name|
- (|shoeInclude|
- (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0)))))
- (SETQ |lines| (CAR |LETTMP#1|)) (SETQ |b| (CADR |LETTMP#1|))
- (SETQ |b| (|shoeTransform2| |b|))
- (COND
- ((|bStreamNull| |b|)
- (|shoeConsole| (CONCAT |name| " not found in " |fn|))
- NIL)
- ((NULL |lines|) (|shoeConsole| ")package not found"))
- (T (APPEND (REVERSE |lines|) (CAR |b|)))))))))
-
-(DEFPARAMETER |$bStreamNil| (LIST '|nullstream|))
+(DEFCONSTANT |$bStreamNil| (LIST '|nullstream|))
(DEFUN |bStreamNull| (|x|)
- (PROG (|st|)
+ (PROG (|st| |args| |op| |ISTMP#1|)
(RETURN
(COND
((OR (NULL |x|) (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|)))
T)
(T (LOOP
(COND
- ((NOT (AND (CONSP |x|) (EQ (CAR |x|) '|nonnullstream|)))
+ ((NOT (AND (CONSP |x|) (EQ (CAR |x|) '|nonnullstream|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |op| (CAR |ISTMP#1|))
+ (SETQ |args| (CDR |ISTMP#1|))
+ T)))))
(RETURN NIL))
(T (PROGN
- (SETQ |st| (APPLY (CADR |x|) (CDDR |x|)))
+ (SETQ |st| (APPLY |op| |args|))
(RPLACA |x| (CAR |st|))
(RPLACD |x| (CDR |st|))))))
(AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|)))))))
@@ -143,28 +111,13 @@
(DEFUN |bMap1| (&REST |z|)
(PROG (|x| |f|)
- (DECLARE (SPECIAL |$bStreamNil|))
(RETURN
(PROGN
(SETQ |f| (CAR |z|))
(SETQ |x| (CADR |z|))
(COND
((|bStreamNull| |x|) |$bStreamNil|)
- (T (CONS (FUNCALL |f| (CAR |x|)) (|bMap| |f| (CDR |x|)))))))))
-
-(DEFUN |shoeFileMap| (|f| |fn|)
- (PROG (|a|)
- (DECLARE (SPECIAL |$bStreamNil|))
- (RETURN
- (PROGN
- (SETQ |a| (|shoeInputFile| |fn|))
- (COND
- ((NULL |a|) (|shoeConsole| (CONCAT |fn| " NOT FOUND"))
- |$bStreamNil|)
- (T (|shoeConsole| (CONCAT "READING " |fn|))
- (|shoeInclude|
- (|bAddLineNumber| (|bMap| |f| (|bRgen| |a|))
- (|bIgen| 0)))))))))
+ (T (CONS (APPLY |f| (LIST (CAR |x|))) (|bMap| |f| (CDR |x|)))))))))
(DEFUN |bDelay| (|f| |x|) (CONS '|nonnullstream| (CONS |f| |x|)))
@@ -219,18 +172,10 @@
(T (CONS (CONS (CAR |f1|) (CAR |f2|))
(|bAddLineNumber| (CDR |f1|) (CDR |f2|)))))))))
-(DEFUN |shoeFileInput| (|fn|) (|shoeFileMap| #'IDENTITY |fn|))
-
(DEFUN |shoePrefixLisp| (|x|) (CONCAT ")lisp" |x|))
-(DEFUN |shoeLispFileInput| (|fn|)
- (|shoeFileMap| #'|shoePrefixLisp| |fn|))
-
(DEFUN |shoePrefixLine| (|x|) (CONCAT ")line" |x|))
-(DEFUN |shoeLineFileInput| (|fn|)
- (|shoeFileMap| #'|shoePrefixLine| |fn|))
-
(DEFUN |shoePrefix?| (|prefix| |whole|)
(PROG (|good|)
(RETURN
@@ -259,8 +204,6 @@
(DEFUN |shoeEval?| (|s|) (|shoePrefix?| ")eval" |s|))
-(DEFUN |shoeInclude?| (|s|) (|shoePrefix?| ")include" |s|))
-
(DEFUN |shoeFin?| (|s|) (|shoePrefix?| ")fin" |s|))
(DEFUN |shoeIf?| (|s|) (|shoePrefix?| ")if" |s|))
@@ -271,19 +214,10 @@
(DEFUN |shoeElseIf?| (|s|) (|shoePrefix?| ")elseif" |s|))
-(DEFUN |shoePackage?| (|s|) (|shoePrefix?| ")package" |s|))
-
(DEFUN |shoeLisp?| (|s|) (|shoePrefix?| ")lisp" |s|))
-(DEFUN |shoeIncludeLisp?| (|s|) (|shoePrefix?| ")includelisp" |s|))
-
(DEFUN |shoeLine?| (|s|) (|shoePrefix?| ")line" |s|))
-(DEFUN |shoeIncludeLines?| (|s|) (|shoePrefix?| ")includelines" |s|))
-
-(DEFUN |shoeIncludeFunction?| (|s|)
- (|shoePrefix?| ")includefunction" |s|))
-
(DEFUN |shoeBiteOff| (|x|)
(PROG (|n1| |n|)
(RETURN
@@ -321,22 +255,10 @@
((NULL |c|) (LIST (CAR |a|) ""))
(T (LIST (CAR |a|) |c|)))))))))
-(DEFUN |shoeFunctionFileInput| (|bfVar#2|)
- (PROG (|fn| |fun|)
- (RETURN
- (PROGN
- (SETQ |fun| (CAR |bfVar#2|))
- (SETQ |fn| (CADR |bfVar#2|))
- (|shoeOpenInputFile| |a| |fn|
- (|shoeInclude|
- (|bAddLineNumber| (|shoeFindLines| |fn| |fun| |a|)
- (|bIgen| 0))))))))
-
(DEFUN |shoeInclude| (|s|) (|bDelay| #'|shoeInclude1| (LIST |s|)))
(DEFUN |shoeInclude1| (|s|)
(PROG (|command| |string| |t| |h|)
- (DECLARE (SPECIAL |$bStreamNil|))
(RETURN
(COND
((|bStreamNull| |s|) |s|)
@@ -356,16 +278,7 @@
(COND
((|shoePlainLine?| |string|) (LIST |h|))
((SETQ |command| (|shoeLisp?| |string|)) (LIST |h|))
- ((SETQ |command| (|shoeIncludeLisp?| |string|))
- (|shoeLispFileInput| (|shoeFileName| |command|)))
- ((SETQ |command| (|shoeIncludeFunction?| |string|))
- (|shoeFunctionFileInput| (|shoeFnFileName| |command|)))
((SETQ |command| (|shoeLine?| |string|)) (LIST |h|))
- ((SETQ |command| (|shoeIncludeLines?| |string|))
- (|shoeLineFileInput| (|shoeFileName| |command|)))
- ((SETQ |command| (|shoeInclude?| |string|))
- (|shoeFileInput| (|shoeFileName| |command|)))
- ((SETQ |command| (|shoePackage?| |string|)) (LIST |h|))
((SETQ |command| (|shoeSay?| |string|))
(|shoeConsole| |command|) NIL)
((SETQ |command| (|shoeEval?| |string|)) (STTOMC |command|)
@@ -457,7 +370,6 @@
(|shoeConsole| "LINE IGNORED")))
(DEFUN |bPremStreamNil| (|h|)
- (DECLARE (SPECIAL |$bStreamNil|))
(PROGN
(|shoeConsole|
(CONCAT "UNEXPECTED )fin IN LINE " (WRITE-TO-STRING (CDR |h|))))
diff --git a/src/boot/strap/scanner.clisp b/src/boot/strap/scanner.clisp
index 2df8e320..36c8ef05 100644
--- a/src/boot/strap/scanner.clisp
+++ b/src/boot/strap/scanner.clisp
@@ -60,8 +60,8 @@
(T T)))))))
(DEFUN |shoeLineToks| (|s|)
- (PROG (|$linepos| |$floatok| |$sz| |$n| |$ln| |$r| |$f| |toks| |a|
- |dq| |command|)
+ (PROG (|$linepos| |$floatok| |$sz| |$n| |$ln| |$r| |$f| |toks| |dq|
+ |command|)
(DECLARE (SPECIAL |$floatok| |$f| |$sz| |$linepos| |$ln| |$r| |$n|))
(RETURN
(PROGN
@@ -85,13 +85,6 @@
(CONS (LIST |dq|) |$r|))
((SETQ |command| (|shoeLisp?| |$ln|))
(|shoeLispToken| |$r| |command|))
- ((SETQ |command| (|shoePackage?| |$ln|))
- (SETQ |a| (CONCAT "(IN-PACKAGE " |command| ")"))
- (SETQ |dq|
- (|dqUnit|
- (|shoeConstructToken| |$ln| |$linepos|
- (|shoeLeafLisp| |a|) 0)))
- (CONS (LIST |dq|) |$r|))
(T (|shoeLineToks| |$r|))))
(T (SETQ |toks| NIL)
(LOOP
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index b33cbc0b..80875ca7 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -203,6 +203,7 @@
(LIST '|apply| 'APPLY) (LIST '|arrayRef| 'AREF)
(LIST '|atom| 'ATOM) (LIST '|bitmask| 'SBIT)
(LIST '|canonicalFilename| 'PROBE-FILE)
+ (LIST '|charByName| 'NAME-CHAR)
(LIST '|charString| 'STRING)
(LIST '|char?| 'CHARACTERP)
(LIST '|codePoint| 'CHAR-CODE) (LIST '|cons?| 'CONSP)
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index 5800bc33..0968b9ea 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -1069,79 +1069,24 @@
|stream| |a|))))
(SETQ |bfVar#23| (CDR |bfVar#23|))))))))
-(DEFUN FBO (|name| |fn|) (|shoeGeneralFC| #'BO |name| |fn|))
-
-(DEFUN FEV (|name| |fn|)
- (|shoeGeneralFC| #'EVAL-BOOT-FILE |name| |fn|))
-
-(DEFUN |shoeGeneralFC| (|f| |name| |fn|)
- (PROG (|filename| |a| |infn|)
- (DECLARE (SPECIAL |$GenVarCounter| |$bfClamming|))
- (RETURN
- (PROGN
- (SETQ |$bfClamming| NIL)
- (SETQ |$GenVarCounter| 0)
- (SETQ |infn| (|shoeAddbootIfNec| |fn|))
- (SETQ |a|
- (|shoeOpenInputFile| |a| |infn|
- (|shoeFindName2| |fn| |name| |a|)))
- (SETQ |filename|
- (COND
- ((< 8 (LENGTH |name|)) (|subString| |name| 0 8))
- (T |name|)))
- (COND (|a| (FUNCALL |f| (CONCAT "/tmp/" |filename|))) (T NIL))))))
-
-(DEFUN |shoeFindName2| (|fn| |name| |a|)
- (PROG (|filename| |lines|)
- (RETURN
- (PROGN
- (SETQ |lines| (|shoeFindLines| |fn| |name| |a|))
- (COND
- (|lines| (SETQ |filename|
- (COND
- ((< 8 (LENGTH |name|))
- (|subString| |name| 0 8))
- (T |name|)))
- (SETQ |filename|
- (CONCAT "/tmp/" |filename| ".boot"))
- (|shoeOpenOutputFile| |stream| |filename|
- (LET ((|bfVar#24| |lines|) (|line| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#24|)
- (PROGN
- (SETQ |line| (CAR |bfVar#24|))
- NIL))
- (RETURN NIL))
- (T (|shoeFileLine| |line| |stream|)))
- (SETQ |bfVar#24| (CDR |bfVar#24|)))))
- T)
- (T NIL))))))
-
-(DEFUN |shoeTransform2| (|str|)
- (|bNext| #'|shoeItem|
- (|streamTake| 1
- (|bNext| #'|shoePileInsert|
- (|bNext| #'|shoeLineToks| |str|)))))
-
(DEFUN |shoeItem| (|str|)
(PROG (|dq|)
(RETURN
(PROGN
(SETQ |dq| (CAR |str|))
- (CONS (LIST (LET ((|bfVar#26| NIL)
- (|bfVar#25| (|shoeDQlines| |dq|))
+ (CONS (LIST (LET ((|bfVar#25| NIL)
+ (|bfVar#24| (|shoeDQlines| |dq|))
(|line| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#25|)
+ ((OR (ATOM |bfVar#24|)
(PROGN
- (SETQ |line| (CAR |bfVar#25|))
+ (SETQ |line| (CAR |bfVar#24|))
NIL))
- (RETURN (NREVERSE |bfVar#26|)))
- (T (SETQ |bfVar#26|
- (CONS (CAR |line|) |bfVar#26|))))
- (SETQ |bfVar#25| (CDR |bfVar#25|)))))
+ (RETURN (NREVERSE |bfVar#25|)))
+ (T (SETQ |bfVar#25|
+ (CONS (CAR |line|) |bfVar#25|))))
+ (SETQ |bfVar#24| (CDR |bfVar#24|)))))
(CDR |str|))))))
(DEFUN |stripm| (|x| |pk| |bt|)
@@ -1177,23 +1122,6 @@
(COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|))))
(T (EVAL |fn|)))))))
-(DEFUN FC (|name| |fn|)
- (PROG (|infn|)
- (DECLARE (SPECIAL |$GenVarCounter|))
- (RETURN
- (PROGN
- (SETQ |$GenVarCounter| 0)
- (SETQ |infn| (|shoeAddbootIfNec| |fn|))
- (|shoeOpenInputFile| |a| |infn|
- (|shoeFindName| |fn| |name| |a|))))))
-
-(DEFUN |shoeFindName| (|fn| |name| |a|)
- (PROG (|lines|)
- (RETURN
- (PROGN
- (SETQ |lines| (|shoeFindLines| |fn| |name| |a|))
- (|shoePCompileTrees| (|shoeTransformString| |lines|))))))
-
(DEFUN |shoePCompileTrees| (|s|)
(LOOP
(COND
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-13 12:55:40 +0000