diff options
Diffstat (limited to 'src/boot/strap')
-rw-r--r-- | src/boot/strap/includer.clisp | 4 | ||||
-rw-r--r-- | src/boot/strap/scanner.clisp | 7 | ||||
-rw-r--r-- | src/boot/strap/translator.clisp | 45 | ||||
-rw-r--r-- | src/boot/strap/utility.clisp | 32 |
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|))) |