aboutsummaryrefslogtreecommitdiff
path: root/src/boot/strap
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot/strap')
-rw-r--r--src/boot/strap/includer.clisp4
-rw-r--r--src/boot/strap/scanner.clisp7
-rw-r--r--src/boot/strap/translator.clisp45
-rw-r--r--src/boot/strap/utility.clisp32
4 files changed, 64 insertions, 24 deletions
diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp
index 61c7e369..28ade94d 100644
--- a/src/boot/strap/includer.clisp
+++ b/src/boot/strap/includer.clisp
@@ -186,9 +186,9 @@
(PROG (|n1| |n|)
(RETURN
(PROGN
- (SETQ |n| (STRPOSL " " |x| 0 T))
+ (SETQ |n| (|firstNonblankPosition| |x| 0))
(COND ((NULL |n|) NIL)
- (T (SETQ |n1| (STRPOSL " " |x| |n| NIL))
+ (T (SETQ |n1| (|firstBlankPosittion| |x| |n|))
(COND ((NULL |n1|) (LIST (|subString| |x| |n|) ""))
(T
(LIST (|subString| |x| |n| (- |n1| |n|))
diff --git a/src/boot/strap/scanner.clisp b/src/boot/strap/scanner.clisp
index 78c63d07..166a9dce 100644
--- a/src/boot/strap/scanner.clisp
+++ b/src/boot/strap/scanner.clisp
@@ -41,7 +41,8 @@
(RETURN
(COND ((|bStreamNull| |s|) NIL)
(T (SETQ |$linepos| |s|) (SETQ |$f| (CAR |s|)) (SETQ |$r| (CDR |s|))
- (SETQ |$ln| (CAR |$f|)) (SETQ |$n| (STRPOSL " " |$ln| 0 T))
+ (SETQ |$ln| (CAR |$f|))
+ (SETQ |$n| (|firstNonblankPosition| |$ln| 0))
(SETQ |$sz| (LENGTH |$ln|))
(COND ((NULL |$n|) T)
((CHAR= (SCHAR |$ln| |$n|) |shoeTAB|)
@@ -216,7 +217,7 @@
(LOOP (COND (|$n| (RETURN NIL)) (T (|shoeNextLine| |$r|))))
(|shoeEsc|) NIL)
(T NIL)))
- (T (SETQ |n1| (STRPOSL " " |$ln| |$n| T))
+ (T (SETQ |n1| (|firstNonblankPosition| |$ln| |$n|))
(COND
((NULL |n1|) (|shoeNextLine| |$r|)
(LOOP (COND (|$n| (RETURN NIL)) (T (|shoeNextLine| |$r|))))
@@ -296,7 +297,7 @@
(RETURN
(PROGN
(SETQ |n| |$n|)
- (SETQ |$n| (STRPOSL " " |$ln| |$n| T))
+ (SETQ |$n| (|firstNonblankPosition| |$ln| |$n|))
(SETQ |$floatok| T)
(COND ((NULL |$n|) (|shoeLeafSpaces| 0) (SETQ |$n| (LENGTH |$ln|)))
(T (|shoeLeafSpaces| (- |$n| |n|))))))))
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index 22d6f918..4ab03112 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -22,6 +22,9 @@
(DEFPARAMETER |$foreignsDefsForCLisp| NIL)
+(DEFUN |reallyPrettyPrint| (|x| &OPTIONAL (|st| *STANDARD-OUTPUT*))
+ (PROGN (|prettyPrint| |x| |st|) (TERPRI |st|)))
+
(DEFUN |genModuleFinalization| (|stream|)
(PROG (|init|)
(DECLARE (SPECIAL |$foreignsDefsForCLisp| |$currentModuleName|))
@@ -83,11 +86,11 @@
(T (RPLACD |bfVar#6| #2#)
(SETQ |bfVar#6| (CDR |bfVar#6|))))
(SETQ |bfVar#4| (CDR |bfVar#4|)))))))))
- (REALLYPRETTYPRINT |init| |stream|))))
+ (|reallyPrettyPrint| |init| |stream|))))
(T NIL)))))
(DEFUN |genOptimizeOptions| (|stream|)
- (REALLYPRETTYPRINT
+ (|reallyPrettyPrint|
(LIST 'PROCLAIM (|quote| (CONS 'OPTIMIZE |$LispOptimizeOptions|))) |stream|))
(DEFUN |AxiomCore|::|%sysInit| ()
@@ -226,8 +229,7 @@
(SETQ |b| *PACKAGE*)
(IN-PACKAGE "BOOTTRAN")
(SETQ |infn| (|shoeAddbootIfNec| |fn|))
- (SETQ |outfn|
- (CONCAT (|shoeRemovebootIfNec| |fn|) "." *LISP-SOURCE-FILETYPE*))
+ (SETQ |outfn| (CONCAT (|shoeRemovebootIfNec| |fn|) "." "lisp"))
(UNWIND-PROTECT
(PROGN
(SETQ |a| (|inputTextFile| |infn|))
@@ -434,12 +436,9 @@
(COND
((AND (CONSP |a|) (EQ (CAR |a|) '+LINE))
(|shoeFileLine| (CADR |a|) |st|))
- (T (REALLYPRETTYPRINT |a| |st|) (TERPRI |st|)))
+ (T (|reallyPrettyPrint| |a| |st|) (TERPRI |st|)))
(SETQ |s| (CDR |s|))))))))
-(DEFUN |shoePPtoFile| (|x| |stream|)
- (PROGN (SHOENOTPRETTYPRINT |x| |stream|) |x|))
-
(DEFUN |shoeConsoleTrees| (|s|)
(PROG (|fn|)
(RETURN
@@ -448,7 +447,7 @@
(T
(SETQ |fn|
(|stripm| (CAR |s|) *PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
- (REALLYPRETTYPRINT |fn|) (SETQ |s| (CDR |s|))))))))
+ (|reallyPrettyPrint| |fn|) (SETQ |s| (CDR |s|))))))))
(DEFUN |shoeAddComment| (|l|) (CONCAT "; " (CAR |l|)))
@@ -702,16 +701,26 @@
(|shoeReadLispString| |s| 0)))
(T (LIST (|translateToplevelExpression| |b|)))))))))
-(DEFUN |shoeAddbootIfNec| (|s|) (|shoeAddStringIfNec| ".boot" |s|))
-
-(DEFUN |shoeRemovebootIfNec| (|s|) (|shoeRemoveStringIfNec| ".boot" |s|))
-
-(DEFUN |shoeAddStringIfNec| (|str| |s|)
- (PROG (|a|)
+(DEFUN |shoeAddbootIfNec| (|s|)
+ (PROG (|n2| |n1| |ext|)
(RETURN
(PROGN
- (SETQ |a| (STRPOS |str| |s| 0 NIL))
- (COND ((NULL |a|) (CONCAT |s| |str|)) (T |s|))))))
+ (SETQ |ext| ".boot")
+ (SETQ |n1| (- (LENGTH |ext|) 1))
+ (SETQ |n2| (- (- (LENGTH |s|) |n1|) 1))
+ (COND
+ ((LET ((|bfVar#1| T) (|k| 0))
+ (LOOP
+ (COND ((> |k| |n1|) (RETURN |bfVar#1|))
+ (T
+ (SETQ |bfVar#1|
+ (CHAR= (SCHAR |ext| |k|) (SCHAR |s| (+ |n2| |k|))))
+ (COND ((NOT |bfVar#1|) (RETURN NIL)))))
+ (SETQ |k| (+ |k| 1))))
+ |s|)
+ (T (CONCAT |s| |ext|)))))))
+
+(DEFUN |shoeRemovebootIfNec| (|s|) (|shoeRemoveStringIfNec| ".boot" |s|))
(DEFUN |shoeRemoveStringIfNec| (|str| |s|)
(PROG (|n|)
@@ -1120,7 +1129,7 @@
(DEFUN |shoePCompileTrees| (|s|)
(LOOP
(COND ((|bStreamNull| |s|) (RETURN NIL))
- (T (REALLYPRETTYPRINT (|shoePCompile| (CAR |s|)))
+ (T (|reallyPrettyPrint| (|shoePCompile| (CAR |s|)))
(SETQ |s| (CDR |s|))))))
(DEFUN |bStreamPackageNull| (|s|)
diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp
index 4c2f649b..a4c6aa61 100644
--- a/src/boot/strap/utility.clisp
+++ b/src/boot/strap/utility.clisp
@@ -12,7 +12,7 @@
|lastNode| |append| |append!| |copyList| |substitute|
|substitute!| |setDifference| |applySubst| |applySubst!|
|applySubstNQ| |remove| |removeSymbol| |atomic?|
- |finishLine|)))
+ |finishLine| |subStringMatch?|)))
(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute|))
@@ -43,6 +43,14 @@
(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Void|) |finishLine|))
+(DECLAIM
+ (FTYPE (FUNCTION (|%String| |%Short|) (|%Maybe| |%Short|))
+ |firstNonblankPosition|))
+
+(DECLAIM
+ (FTYPE (FUNCTION (|%String| |%Short|) (|%Maybe| |%Short|))
+ |firstBlankPosition|))
+
(DEFUN |atomic?| (|x|) (OR (NOT (CONSP |x|)) (EQ (CAR |x|) 'QUOTE)))
(DEFUN |objectMember?| (|x| |l|)
@@ -274,5 +282,27 @@
((CHAR= (SCHAR |s| |k|) |c|) (RETURN |k|))
(T (SETQ |k| (+ |k| 1)))))))))
+(DEFUN |firstNonblankPosition| (|s| |k|)
+ (LET ((|bfVar#2| NIL) (|bfVar#1| (- (LENGTH |s|) 1)) (|i| |k|))
+ (LOOP
+ (COND ((> |i| |bfVar#1|) (RETURN |bfVar#2|))
+ (T
+ (AND (NOT (CHAR= (SCHAR |s| |i|) (|char| '| |)))
+ (PROGN
+ (SETQ |bfVar#2| |i|)
+ (COND (|bfVar#2| (RETURN |bfVar#2|)))))))
+ (SETQ |i| (+ |i| 1)))))
+
+(DEFUN |firstBlankPosition| (|s| |k|)
+ (LET ((|bfVar#2| NIL) (|bfVar#1| (- (LENGTH |s|) 1)) (|i| |k|))
+ (LOOP
+ (COND ((> |i| |bfVar#1|) (RETURN |bfVar#2|))
+ (T
+ (AND (CHAR= (SCHAR |s| |i|) (|char| '| |))
+ (PROGN
+ (SETQ |bfVar#2| |i|)
+ (COND (|bfVar#2| (RETURN |bfVar#2|)))))))
+ (SETQ |i| (+ |i| 1)))))
+
(DEFUN |finishLine| (|out|) (PROGN (TERPRI |out|) (FORCE-OUTPUT |out|)))
generated by cgit v1.2.3 (git 2.39.1) at 2024-08-25 15:23:10 +0000