aboutsummaryrefslogtreecommitdiff
path: root/src/boot
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot')
-rw-r--r--src/boot/includer.boot4
-rw-r--r--src/boot/initial-env.lisp55
-rw-r--r--src/boot/scanner.boot8
-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
-rw-r--r--src/boot/translator.boot35
-rw-r--r--src/boot/utility.boot11
9 files changed, 96 insertions, 105 deletions
diff --git a/src/boot/includer.boot b/src/boot/includer.boot
index a878844d..1095031c 100644
--- a/src/boot/includer.boot
+++ b/src/boot/includer.boot
@@ -219,9 +219,9 @@ shoeLisp? s == shoePrefix?('")lisp", s)
shoeLine? s == shoePrefix?('")line", s)
shoeBiteOff x ==
- n :=STRPOSL('" ",x,0,true)
+ n := firstNonblankPosition(x,0)
n = nil => false
- n1 := STRPOSL ('" ",x,n,nil)
+ n1 := firstBlankPosittion(x,n)
n1 = nil => [subString(x,n),'""]
[subString(x,n,n1-n),subString(x,n1)]
diff --git a/src/boot/initial-env.lisp b/src/boot/initial-env.lisp
index 855ac0da..ecf4963d 100644
--- a/src/boot/initial-env.lisp
+++ b/src/boot/initial-env.lisp
@@ -54,58 +54,3 @@
(progn
(setq *read-default-float-format* 'double-float)
(setq *load-verbose* nil)))
-
-;## need the conditional here so it appears in boottran
-#+:ieee-floating-point (defparameter $ieee t)
-#-:ieee-floating-point (defparameter $ieee nil)
-
-(defvar *lisp-bin-filetype* "o")
-
-(defvar *lisp-source-filetype* "lisp")
-
-(defun shoeprettyprin1 (x &optional (stream *standard-output*))
- (let ((*print-pretty* t)
- (*print-array* t)
- (*print-circle* t)
- (*print-level* nil)
- (*print-length* nil))
- (prin1 x stream)))
-
-(defun reallyprettyprint (x &optional (stream *terminal-io*))
- (shoeprettyprin1 x stream) (terpri stream))
-
-(defun shoeprettyprin0 (x &optional (stream *standard-output*))
- (let ((*print-pretty* nil)
- (*print-array* t)
- (*print-circle* t)
- (*print-level* nil)
- (*print-length* nil))
- (prin1 x stream)))
-
-(defun shoenotprettyprint (x &optional (stream *terminal-io*))
- (shoeprettyprin0 x stream)
- (terpri stream))
-
-(defun strpos (what in start dontcare)
- (setq what (string what) in (string in))
- (if dontcare
- (progn
- (setq dontcare (character dontcare))
- (search what in :start2 start
- :test #'(lambda (x y) (or (eql x dontcare)
- (eql x y)))))
- (search what in :start2 start)))
-
-
-(defun strposl (table cvec sint item)
- (setq cvec (string cvec))
- (if (not item)
- (position table cvec
- :test #'(lambda (x y) (position y x))
- :start sint)
- (position table cvec
- :test-not #'(lambda (x y) (position y x))
- :start sint)))
-
-(defun |shoeReadLisp| (s n)
- (multiple-value-list (read-from-string s nil nil :start n)))
diff --git a/src/boot/scanner.boot b/src/boot/scanner.boot
index 7a84cb96..a419a9a4 100644
--- a/src/boot/scanner.boot
+++ b/src/boot/scanner.boot
@@ -85,8 +85,8 @@ shoeNextLine(s)==
$f:= first s
$r:= rest s
$ln:=first $f
- $n:=STRPOSL('" ",$ln,0,true)
- $sz :=# $ln
+ $n := firstNonblankPosition($ln,0)
+ $sz := #$ln
$n = nil => true
stringChar($ln,$n) = shoeTAB =>
a := makeString(7-REM($n,8),char " ")
@@ -240,7 +240,7 @@ shoeEsc()==
shoeEsc()
false
false
- n1:=STRPOSL('" ",$ln,$n,true)
+ n1 := firstNonblankPosition($ln,$n)
n1 = nil =>
shoeNextLine($r)
while $n = nil repeat
@@ -296,7 +296,7 @@ shoePossFloat (w)==
shoeSpace()==
n := $n
- $n := STRPOSL('" ",$ln,$n,true)
+ $n := firstNonblankPosition($ln,$n)
$floatok := true
$n = nil =>
shoeLeafSpaces 0
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|)))
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
index 8904cb00..35db495f 100644
--- a/src/boot/translator.boot
+++ b/src/boot/translator.boot
@@ -48,6 +48,10 @@ $currentModuleName := nil
++ Stack of foreign definitions to cope with CLisp's odd FFI interface.
$foreignsDefsForCLisp := []
+reallyPrettyPrint(x,st == _*STANDARD_-OUTPUT_*) ==
+ prettyPrint(x,st)
+ writeNewline st
+
genModuleFinalization(stream) ==
%hasFeature KEYWORD::CLISP =>
$foreignsDefsForCLisp = nil => nil
@@ -58,11 +62,11 @@ genModuleFinalization(stream) ==
["MAPC",["FUNCTION", "FMAKUNBOUND"],
quote [second d for d in $foreignsDefsForCLisp]],
:[["EVAL",quote d] for d in $foreignsDefsForCLisp]]
- REALLYPRETTYPRINT(init,stream)
+ reallyPrettyPrint(init,stream)
nil
genOptimizeOptions stream ==
- REALLYPRETTYPRINT
+ reallyPrettyPrint
(["PROCLAIM",quote ["OPTIMIZE",:$LispOptimizeOptions]],stream)
AxiomCore::%sysInit() ==
@@ -170,7 +174,7 @@ evalBootFile fn ==
b := namespace .
IN_-PACKAGE '"BOOTTRAN"
infn:=shoeAddbootIfNec fn
- outfn := strconc(shoeRemovebootIfNec fn,'".",_*LISP_-SOURCE_-FILETYPE_*)
+ outfn := strconc(shoeRemovebootIfNec fn,'".",'"lisp")
try
a := inputTextFile infn
shoeClLines(a,infn,[],outfn)
@@ -337,19 +341,14 @@ shoeFileTrees(s,st)==
if a is ["+LINE",:.]
then shoeFileLine(second a,st)
else
- REALLYPRETTYPRINT(a,st)
+ reallyPrettyPrint(a,st)
TERPRI st
s:= rest s
-
-shoePPtoFile(x, stream) ==
- SHOENOTPRETTYPRINT(x, stream)
- x
-
shoeConsoleTrees s ==
while not bStreamPackageNull s repeat
fn:=stripm(first s,namespace .,namespace BOOTTRAN)
- REALLYPRETTYPRINT fn
+ reallyPrettyPrint fn
s:= rest s
shoeAddComment l==
@@ -474,18 +473,16 @@ translateToplevel(b,export?) ==
otherwise =>
[translateToplevelExpression b]
-
-shoeAddbootIfNec s ==
- shoeAddStringIfNec('".boot",s)
+shoeAddbootIfNec s ==
+ ext := '".boot"
+ n1 := #ext - 1
+ n2 := #s - n1 - 1
+ and/[stringChar(ext,k) = stringChar(s,n2 + k) for k in 0..n1] => s
+ strconc(s,ext)
shoeRemovebootIfNec s ==
shoeRemoveStringIfNec('".boot",s)
-shoeAddStringIfNec(str,s)==
- a:=STRPOS(str,s,0,nil)
- a=nil => strconc(s,str)
- s
-
shoeRemoveStringIfNec(str,s)==
n := SEARCH(str,s,KEYWORD::FROM_-END,true)
n = nil => s
@@ -664,7 +661,7 @@ shoePCompile fn==
shoePCompileTrees s==
while not bStreamNull s repeat
- REALLYPRETTYPRINT shoePCompile first s
+ reallyPrettyPrint shoePCompile first s
s := rest s
bStreamPackageNull s==
diff --git a/src/boot/utility.boot b/src/boot/utility.boot
index 1e60c8e2..5e620d82 100644
--- a/src/boot/utility.boot
+++ b/src/boot/utility.boot
@@ -44,7 +44,7 @@ module utility (objectMember?, symbolMember?, stringMember?,
charMember?, scalarMember?, listMember?, reverse, reverse!,
lastNode, append, append!, copyList, substitute, substitute!,
setDifference, applySubst, applySubst!, applySubstNQ,
- remove,removeSymbol,atomic?,finishLine) where
+ remove,removeSymbol,atomic?,finishLine,subStringMatch?) where
substitute: (%Thing,%Thing,%Thing) -> %Thing
substitute!: (%Thing,%Thing,%Thing) -> %Thing
append: (%List %Thing,%List %Thing) -> %List %Thing
@@ -55,6 +55,8 @@ module utility (objectMember?, symbolMember?, stringMember?,
remove: (%List %Thing, %Thing) -> %List %Thing
atomic?: %Thing -> %Boolean
finishLine: %Thing -> %Void
+ firstNonblankPosition: (%String,%Short) -> %Maybe %Short
+ firstBlankPosition: (%String,%Short) -> %Maybe %Short
--%
@@ -276,6 +278,13 @@ charPosition(c,s,k) ==
stringChar(s,k) = c => return k
k := k + 1
+firstNonblankPosition(s,k) ==
+ or/[i for i in k..#s - 1 | stringChar(s,i) ~= char " "]
+
+firstBlankPosition(s,k) ==
+ or/[i for i in k..#s - 1 | stringChar(s,i) = char " "]
+
+
--% I/O
++ Add a newline character and flush the output stream.
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-27 09:12:59 +0000