diff options
Diffstat (limited to 'src/boot/strap/includer.clisp')
| -rw-r--r-- | src/boot/strap/includer.clisp | 553 |
1 files changed, 553 insertions, 0 deletions
diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp new file mode 100644 index 00000000..a2324315 --- /dev/null +++ b/src/boot/strap/includer.clisp @@ -0,0 +1,553 @@ +(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-includer")) + +(IMPORT-MODULE "tokens") + +(IN-PACKAGE "BOOTTRAN") + +(DEFUN PNAME (|x|) + (PROG () + (RETURN + (COND + ((SYMBOLP |x|) (SYMBOL-NAME |x|)) + ((CHARACTERP |x|) (STRING |x|)) + ('T NIL))))) + +(DEFUN |char| (|x|) (PROG () (RETURN (CHAR (PNAME |x|) 0)))) + +(DEFUN EQCAR (|x| |y|) + (PROG () (RETURN (AND (CONSP |x|) (EQ (CAR |x|) |y|))))) + +(DEFUN STRINGIMAGE (|x|) (PROG () (RETURN (WRITE-TO-STRING |x|)))) + +(DEFUN |shoeCLOSE| (|stream|) (PROG () (RETURN (CLOSE |stream|)))) + +(DEFUN |shoeNotFound| (|fn|) + (PROG () + (RETURN (PROGN (|coreError| (LIST |fn| " not found")) NIL)))) + +(DEFUN |shoeReadLispString| (|s| |n|) + (PROG (|l|) + (RETURN + (PROGN + (SETQ |l| (LENGTH |s|)) + (COND + ((NOT (< |n| |l|)) NIL) + ('T + (READ-FROM-STRING + (CONCAT '|(| (SUBSTRING |s| |n| (- |l| |n|)) '|)|)))))))) + +(DEFUN |shoeReadLine| (|stream|) + (PROG () (RETURN (READ-LINE |stream| NIL NIL)))) + +(DEFUN |shoeConsole| (|line|) + (PROG () (RETURN (WRITE-LINE |line| *TERMINAL-IO*)))) + +(DEFUN |shoeSpaces| (|n|) (PROG () (RETURN (MAKE-FULL-CVEC |n| ".")))) + +(DEFUN |SoftShoeError| (|posn| |key|) + (PROG () + (RETURN + (PROGN + (|coreError| (LIST "in line " (STRINGIMAGE (|lineNo| |posn|)))) + (|shoeConsole| (|lineString| |posn|)) + (|shoeConsole| + (CONCAT (|shoeSpaces| (|lineCharacter| |posn|)) "|")) + (|shoeConsole| |key|))))) + +(DEFUN |bpSpecificErrorAtToken| (|tok| |key|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|shoeTokPosn| |tok|)) + (|SoftShoeError| |a| |key|))))) + +(DEFUN |bpSpecificErrorHere| (|key|) + (PROG () + (DECLARE (SPECIAL |$stok|)) + (RETURN (|bpSpecificErrorAtToken| |$stok| |key|)))) + +(DEFUN |bpGeneralErrorHere| () + (PROG () (RETURN (|bpSpecificErrorHere| "syntax error")))) + +(DEFUN |bpIgnoredFromTo| (|pos1| |pos2|) + (PROG () + (RETURN + (PROGN + (|shoeConsole| + (CONCAT "ignored from line " + (STRINGIMAGE (|lineNo| |pos1|)))) + (|shoeConsole| (|lineString| |pos1|)) + (|shoeConsole| + (CONCAT (|shoeSpaces| (|lineCharacter| |pos1|)) "|")) + (|shoeConsole| + (CONCAT "ignored through line " + (STRINGIMAGE (|lineNo| |pos2|)))) + (|shoeConsole| (|lineString| |pos2|)) + (|shoeConsole| + (CONCAT (|shoeSpaces| (|lineCharacter| |pos2|)) "|")))))) + +(DEFUN |lineNo| (|p|) (PROG () (RETURN (CDAAR |p|)))) + +(DEFUN |lineString| (|p|) (PROG () (RETURN (CAAAR |p|)))) + +(DEFUN |lineCharacter| (|p|) (PROG () (RETURN (CDR |p|)))) + +(DEFUN |shoePackageStartsAt| (|lines| |sz| |name| |stream|) + (PROG (|a|) + (RETURN + (COND + ((|bStreamNull| |stream|) (LIST NIL (LIST '|nullstream|))) + ('T + (PROGN + (SETQ |a| (CAAR |stream|)) + (COND + ((AND (NOT (< (LENGTH |a|) 8)) + (EQUAL (SUBSTRING |a| 0 8) ")package")) + (|shoePackageStartsAt| (CONS (CAAR |stream|) |lines|) + |sz| |name| (CDR |stream|))) + ((< (LENGTH |a|) |sz|) + (|shoePackageStartsAt| |lines| |sz| |name| + (CDR |stream|))) + ((AND (EQUAL (SUBSTRING |a| 0 |sz|) |name|) + (< |sz| (LENGTH |a|)) + (NULL (|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) + (#0='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) + (#0# + (COND + ((NULL |lines|) (|shoeConsole| ")package not found"))) + (APPEND (REVERSE |lines|) (CAR |b|))))))))) + +(DEFPARAMETER |$bStreamNil| (LIST '|nullstream|)) + +(DEFUN |bStreamNull| (|x|) + (PROG (|st|) + (RETURN + (COND + ((OR (NULL |x|) (EQCAR |x| '|nullstream|)) T) + ('T + (PROGN + (LOOP + (COND + ((NOT (EQCAR |x| '|nonnullstream|)) (RETURN NIL)) + ('T + (PROGN + (SETQ |st| (APPLY (CADR |x|) (CDDR |x|))) + (RPLACA |x| (CAR |st|)) + (RPLACD |x| (CDR |st|)))))) + (EQCAR |x| '|nullstream|))))))) + +(DEFUN |bMap| (|f| |x|) + (PROG () (RETURN (|bDelay| #'|bMap1| (LIST |f| |x|))))) + +(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|) + (PROGN + (|shoeConsole| (CONCAT |fn| " NOT FOUND")) + |$bStreamNil|)) + ('T + (PROGN + (|shoeConsole| (CONCAT "READING " |fn|)) + (|shoeInclude| + (|bAddLineNumber| (|bMap| |f| (|bRgen| |a|)) + (|bIgen| 0)))))))))) + +(DEFUN |bDelay| (|f| |x|) + (PROG () (RETURN (CONS '|nonnullstream| (CONS |f| |x|))))) + +(DEFUN |bAppend| (|x| |y|) + (PROG () (RETURN (|bDelay| #'|bAppend1| (LIST |x| |y|))))) + +(DEFUN |bAppend1| (&REST |z|) + (PROG () + (RETURN + (COND + ((|bStreamNull| (CAR |z|)) + (COND + ((|bStreamNull| (CADR |z|)) (LIST '|nullstream|)) + (#0='T (CADR |z|)))) + (#0# (CONS (CAAR |z|) (|bAppend| (CDAR |z|) (CADR |z|)))))))) + +(DEFUN |bNext| (|f| |s|) + (PROG () (RETURN (|bDelay| #'|bNext1| (LIST |f| |s|))))) + +(DEFUN |bNext1| (|f| |s|) + (PROG (|h|) + (RETURN + (COND + ((|bStreamNull| |s|) (LIST '|nullstream|)) + ('T + (PROGN + (SETQ |h| (APPLY |f| (LIST |s|))) + (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|))))))))) + +(DEFUN |bRgen| (|s|) + (PROG () (RETURN (|bDelay| #'|bRgen1| (LIST |s|))))) + +(DEFUN |bRgen1| (&REST |s|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|shoeReadLine| (CAR |s|))) + (COND + ((|shoePLACEP| |a|) (LIST '|nullstream|)) + ('T (CONS |a| (|bRgen| (CAR |s|))))))))) + +(DEFUN |bIgen| (|n|) + (PROG () (RETURN (|bDelay| #'|bIgen1| (LIST |n|))))) + +(DEFUN |bIgen1| (&REST |n|) + (PROG () + (RETURN + (PROGN (SETQ |n| (+ (CAR |n|) 1)) (CONS |n| (|bIgen| |n|)))))) + +(DEFUN |bAddLineNumber| (|f1| |f2|) + (PROG () (RETURN (|bDelay| #'|bAddLineNumber1| (LIST |f1| |f2|))))) + +(DEFUN |bAddLineNumber1| (&REST |f|) + (PROG (|f2| |f1|) + (RETURN + (PROGN + (SETQ |f1| (CAR |f|)) + (SETQ |f2| (CADR |f|)) + (COND + ((|bStreamNull| |f1|) (LIST '|nullstream|)) + ((|bStreamNull| |f2|) (LIST '|nullstream|)) + ('T + (CONS (CONS (CAR |f1|) (CAR |f2|)) + (|bAddLineNumber| (CDR |f1|) (CDR |f2|))))))))) + +(DEFUN |shoeFileInput| (|fn|) + (PROG () (RETURN (|shoeFileMap| #'IDENTITY |fn|)))) + +(DEFUN |shoePrefixLisp| (|x|) (PROG () (RETURN (CONCAT ")lisp" |x|)))) + +(DEFUN |shoeLispFileInput| (|fn|) + (PROG () (RETURN (|shoeFileMap| #'|shoePrefixLisp| |fn|)))) + +(DEFUN |shoePrefixLine| (|x|) (PROG () (RETURN (CONCAT ")line" |x|)))) + +(DEFUN |shoeLineFileInput| (|fn|) + (PROG () (RETURN (|shoeFileMap| #'|shoePrefixLine| |fn|)))) + +(DEFUN |shoePrefix?| (|prefix| |whole|) + (PROG (|good|) + (RETURN + (COND + ((< (LENGTH |whole|) (LENGTH |prefix|)) NIL) + ('T + (PROGN + (SETQ |good| T) + (LET ((|bfVar#1| (- (LENGTH |prefix|) 1)) (|i| 0) (|j| 0)) + (LOOP + (COND + ((OR (> |i| |bfVar#1|) (NOT |good|)) (RETURN NIL)) + ('T + (SETQ |good| + (EQUAL (ELT |prefix| |i|) (ELT |whole| |j|))))) + (SETQ |i| (+ |i| 1)) + (SETQ |j| (+ |j| 1)))) + (COND + (|good| (SUBSTRING |whole| (LENGTH |prefix|) NIL)) + ('T |good|)))))))) + +(DEFUN |shoePlainLine?| (|s|) + (PROG () + (RETURN + (COND + ((EQL (LENGTH |s|) 0) T) + ('T (NOT (EQUAL (ELT |s| 0) (|char| '|)|)))))))) + +(DEFUN |shoeSay?| (|s|) (PROG () (RETURN (|shoePrefix?| ")say" |s|)))) + +(DEFUN |shoeEval?| (|s|) + (PROG () (RETURN (|shoePrefix?| ")eval" |s|)))) + +(DEFUN |shoeInclude?| (|s|) + (PROG () (RETURN (|shoePrefix?| ")include" |s|)))) + +(DEFUN |shoeFin?| (|s|) (PROG () (RETURN (|shoePrefix?| ")fin" |s|)))) + +(DEFUN |shoeIf?| (|s|) (PROG () (RETURN (|shoePrefix?| ")if" |s|)))) + +(DEFUN |shoeEndIf?| (|s|) + (PROG () (RETURN (|shoePrefix?| ")endif" |s|)))) + +(DEFUN |shoeElse?| (|s|) + (PROG () (RETURN (|shoePrefix?| ")else" |s|)))) + +(DEFUN |shoeElseIf?| (|s|) + (PROG () (RETURN (|shoePrefix?| ")elseif" |s|)))) + +(DEFUN |shoePackage?| (|s|) + (PROG () (RETURN (|shoePrefix?| ")package" |s|)))) + +(DEFUN |shoeLisp?| (|s|) + (PROG () (RETURN (|shoePrefix?| ")lisp" |s|)))) + +(DEFUN |shoeIncludeLisp?| (|s|) + (PROG () (RETURN (|shoePrefix?| ")includelisp" |s|)))) + +(DEFUN |shoeLine?| (|s|) + (PROG () (RETURN (|shoePrefix?| ")line" |s|)))) + +(DEFUN |shoeIncludeLines?| (|s|) + (PROG () (RETURN (|shoePrefix?| ")includelines" |s|)))) + +(DEFUN |shoeIncludeFunction?| (|s|) + (PROG () (RETURN (|shoePrefix?| ")includefunction" |s|)))) + +(DEFUN |shoeBiteOff| (|x|) + (PROG (|n1| |n|) + (RETURN + (PROGN + (SETQ |n| (STRPOSL " " |x| 0 T)) + (COND + ((NULL |n|) NIL) + (#0='T + (PROGN + (SETQ |n1| (STRPOSL " " |x| |n| NIL)) + (COND + ((NULL |n1|) (LIST (SUBSTRING |x| |n| NIL) "")) + (#0# + (LIST (SUBSTRING |x| |n| (- |n1| |n|)) + (SUBSTRING |x| |n1| NIL))))))))))) + +(DEFUN |shoeFileName| (|x|) + (PROG (|c| |a|) + (RETURN + (PROGN + (SETQ |a| (|shoeBiteOff| |x|)) + (COND + ((NULL |a|) "") + (#0='T + (PROGN + (SETQ |c| (|shoeBiteOff| (CADR |a|))) + (COND + ((NULL |c|) (CAR |a|)) + (#0# (CONCAT (CAR |a|) "." (CAR |c|))))))))))) + +(DEFUN |shoeFnFileName| (|x|) + (PROG (|c| |a|) + (RETURN + (PROGN + (SETQ |a| (|shoeBiteOff| |x|)) + (COND + ((NULL |a|) (LIST "" "")) + (#0='T + (PROGN + (SETQ |c| (|shoeFileName| (CADR |a|))) + (COND + ((NULL |c|) (LIST (CAR |a|) "")) + (#0# (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|) + (PROG () (RETURN (|bDelay| #'|shoeInclude1| (LIST |s|))))) + +(DEFUN |shoeInclude1| (|s|) + (PROG (|command| |string| |t| |h|) + (DECLARE (SPECIAL |$bStreamNil|)) + (RETURN + (COND + ((|bStreamNull| |s|) |s|) + (#0='T + (PROGN + (SETQ |h| (CAR |s|)) + (SETQ |t| (CDR |s|)) + (SETQ |string| (CAR |h|)) + (COND + ((SETQ |command| (|shoeFin?| |string|)) |$bStreamNil|) + ((SETQ |command| (|shoeIf?| |string|)) + (|shoeThen| (LIST T) (LIST (STTOMC |command|)) |t|)) + (#0# + (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|)))))))))) + +(DEFUN |shoeSimpleLine| (|h|) + (PROG (|command| |string|) + (RETURN + (PROGN + (SETQ |string| (CAR |h|)) + (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|)) + (PROGN (|shoeConsole| |command|) NIL)) + ((SETQ |command| (|shoeEval?| |string|)) + (PROGN (STTOMC |command|) NIL)) + ('T (PROGN (|shoeLineSyntaxError| |h|) NIL))))))) + +(DEFUN |shoeThen| (|keep| |b| |s|) + (PROG () (RETURN (|bDelay| #'|shoeThen1| (LIST |keep| |b| |s|))))) + +(DEFUN |shoeThen1| (|keep| |b| |s|) + (PROG (|b1| |keep1| |command| |string| |t| |h|) + (RETURN + (COND + ((|bPremStreamNull| |s|) |s|) + (#0='T + (PROGN + (SETQ |h| (CAR |s|)) + (SETQ |t| (CDR |s|)) + (SETQ |string| (CAR |h|)) + (COND + ((SETQ |command| (|shoeFin?| |string|)) + (|bPremStreamNil| |h|)) + (#0# + (PROGN + (SETQ |keep1| (CAR |keep|)) + (SETQ |b1| (CAR |b|)) + (COND + ((SETQ |command| (|shoeIf?| |string|)) + (COND + ((AND |keep1| |b1|) + (|shoeThen| (CONS T |keep|) + (CONS (STTOMC |command|) |b|) |t|)) + (#0# + (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|)))) + ((SETQ |command| (|shoeElseIf?| |string|)) + (COND + ((AND |keep1| (NULL |b1|)) + (|shoeThen| (CONS T (CDR |keep|)) + (CONS (STTOMC |command|) (CDR |b|)) |t|)) + (#0# + (|shoeThen| (CONS NIL (CDR |keep|)) + (CONS NIL (CDR |b|)) |t|)))) + ((SETQ |command| (|shoeElse?| |string|)) + (COND + ((AND |keep1| (NULL |b1|)) + (|shoeElse| (CONS T (CDR |keep|)) + (CONS T (CDR |b|)) |t|)) + (#0# + (|shoeElse| (CONS NIL (CDR |keep|)) + (CONS NIL (CDR |b|)) |t|)))) + ((SETQ |command| (|shoeEndIf?| |string|)) + (COND + ((NULL (CDR |b|)) (|shoeInclude| |t|)) + (#0# (|shoeThen| (CDR |keep|) (CDR |b|) |t|)))) + ((AND |keep1| |b1|) + (|bAppend| (|shoeSimpleLine| |h|) + (|shoeThen| |keep| |b| |t|))) + (#0# (|shoeThen| |keep| |b| |t|)))))))))))) + +(DEFUN |shoeElse| (|keep| |b| |s|) + (PROG () (RETURN (|bDelay| #'|shoeElse1| (LIST |keep| |b| |s|))))) + +(DEFUN |shoeElse1| (|keep| |b| |s|) + (PROG (|keep1| |b1| |command| |string| |t| |h|) + (RETURN + (COND + ((|bPremStreamNull| |s|) |s|) + (#0='T + (PROGN + (SETQ |h| (CAR |s|)) + (SETQ |t| (CDR |s|)) + (SETQ |string| (CAR |h|)) + (COND + ((SETQ |command| (|shoeFin?| |string|)) + (|bPremStreamNil| |h|)) + (#0# + (PROGN + (SETQ |b1| (CAR |b|)) + (SETQ |keep1| (CAR |keep|)) + (COND + ((SETQ |command| (|shoeIf?| |string|)) + (COND + ((AND |keep1| |b1|) + (|shoeThen| (CONS T |keep|) + (CONS (STTOMC |command|) |b|) |t|)) + (#0# + (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|)))) + ((SETQ |command| (|shoeEndIf?| |string|)) + (COND + ((NULL (CDR |b|)) (|shoeInclude| |t|)) + (#0# (|shoeThen| (CDR |keep|) (CDR |b|) |t|)))) + ((AND |keep1| |b1|) + (|bAppend| (|shoeSimpleLine| |h|) + (|shoeElse| |keep| |b| |t|))) + (#0# (|shoeElse| |keep| |b| |t|)))))))))))) + +(DEFUN |shoeLineSyntaxError| (|h|) + (PROG () + (RETURN + (PROGN + (|shoeConsole| + (CONCAT "INCLUSION SYNTAX ERROR IN LINE " + (STRINGIMAGE (CDR |h|)))) + (|shoeConsole| (CAR |h|)) + (|shoeConsole| "LINE IGNORED"))))) + +(DEFUN |bPremStreamNil| (|h|) + (PROG () + (DECLARE (SPECIAL |$bStreamNil|)) + (RETURN + (PROGN + (|shoeConsole| + (CONCAT "UNEXPECTED )fin IN LINE " (STRINGIMAGE (CDR |h|)))) + (|shoeConsole| (CAR |h|)) + (|shoeConsole| "REST OF FILE IGNORED") + |$bStreamNil|)))) + +(DEFUN |bPremStreamNull| (|s|) + (PROG () + (RETURN + (COND + ((|bStreamNull| |s|) + (|shoeConsole| "FILE TERMINATED BEFORE )endif") T) + ('T NIL))))) + |