(PROCLAIM '(OPTIMIZE SPEED))
(IMPORT-MODULE "tokens")

(IN-PACKAGE "BOOTTRAN")

(PROVIDE "includer")

(DEFUN PNAME (|x|)
  (COND
    ((SYMBOLP |x|) (SYMBOL-NAME |x|))
    ((CHARACTERP |x|) (STRING |x|))
    ('T NIL)))

(DEFUN |char| (|x|) (CHAR (PNAME |x|) 0))

(DEFUN EQCAR (|x| |y|) (AND (CONSP |x|) (EQ (CAR |x|) |y|)))

(DEFUN STRINGIMAGE (|x|) (WRITE-TO-STRING |x|))

(DEFUN |shoeCLOSE| (|stream|) (CLOSE |stream|))

(DEFUN |shoeNotFound| (|fn|)
  (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|) (READ-LINE |stream| NIL NIL))

(DEFUN |shoeConsole| (|line|) (WRITE-LINE |line| *TERMINAL-IO*))

(DEFUN |shoeSpaces| (|n|) (MAKE-FULL-CVEC |n| "."))

(DEFUN |diagnosticLocation| (|tok|)
  (PROG (|pos|)
    (RETURN
      (PROGN
        (SETQ |pos| (|shoeTokPosn| |tok|))
        (CONCAT "line " (STRINGIMAGE (|lineNo| |pos|)) ", column "
                (STRINGIMAGE (|lineCharacter| |pos|)))))))

(DEFUN |SoftShoeError| (|posn| |key|)
  (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|)
  (DECLARE (SPECIAL |$stok|))
  (|bpSpecificErrorAtToken| |$stok| |key|))

(DEFUN |bpGeneralErrorHere| () (|bpSpecificErrorHere| "syntax error"))

(DEFUN |bpIgnoredFromTo| (|pos1| |pos2|)
  (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|) (CDAAR |p|))

(DEFUN |lineString| (|p|) (CAAAR |p|))

(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))
                 (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|))
                 (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)
        (#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
         (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|) (|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|) (|shoeConsole| (CONCAT |fn| " NOT FOUND"))
           |$bStreamNil|)
          ('T (|shoeConsole| (CONCAT "READING " |fn|))
           (|shoeInclude|
               (|bAddLineNumber| (|bMap| |f| (|bRgen| |a|))
                   (|bIgen| 0)))))))))

(DEFUN |bDelay| (|f| |x|) (CONS '|nonnullstream| (CONS |f| |x|)))

(DEFUN |bAppend| (|x| |y|) (|bDelay| #'|bAppend1| (LIST |x| |y|)))

(DEFUN |bAppend1| (&REST |z|)
  (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|) (|bDelay| #'|bNext1| (LIST |f| |s|)))

(DEFUN |bNext1| (|f| |s|)
  (PROG (|h|)
    (RETURN
      (COND
        ((|bStreamNull| |s|) (LIST '|nullstream|))
        ('T (SETQ |h| (APPLY |f| (LIST |s|)))
         (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|))))))))

(DEFUN |bRgen| (|s|) (|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|) (|bDelay| #'|bIgen1| (LIST |n|)))

(DEFUN |bIgen1| (&REST |n|)
  (PROGN (SETQ |n| (+ (CAR |n|) 1)) (CONS |n| (|bIgen| |n|))))

(DEFUN |bAddLineNumber| (|f1| |f2|)
  (|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|) (|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
      (COND
        ((< (LENGTH |whole|) (LENGTH |prefix|)) NIL)
        ('T (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|)
  (COND
    ((EQL (LENGTH |s|) 0) T)
    ('T (NOT (EQL (ELT |s| 0) (|char| '|)|))))))

(DEFUN |shoeSay?| (|s|) (|shoePrefix?| ")say" |s|))

(DEFUN |shoeEval?| (|s|) (|shoePrefix?| ")eval" |s|))

(DEFUN |shoeInclude?| (|s|) (|shoePrefix?| ")include" |s|))

(DEFUN |shoeFin?| (|s|) (|shoePrefix?| ")fin" |s|))

(DEFUN |shoeIf?| (|s|) (|shoePrefix?| ")if" |s|))

(DEFUN |shoeEndIf?| (|s|) (|shoePrefix?| ")endif" |s|))

(DEFUN |shoeElse?| (|s|) (|shoePrefix?| ")else" |s|))

(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
      (PROGN
        (SETQ |n| (STRPOSL " " |x| 0 T))
        (COND
          ((NULL |n|) NIL)
          (#0='T (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 (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 (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|) (|bDelay| #'|shoeInclude1| (LIST |s|)))

(DEFUN |shoeInclude1| (|s|)
  (PROG (|command| |string| |t| |h|)
    (DECLARE (SPECIAL |$bStreamNil|))
    (RETURN
      (COND
        ((|bStreamNull| |s|) |s|)
        (#0='T (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|))
           (|shoeConsole| |command|) NIL)
          ((SETQ |command| (|shoeEval?| |string|)) (STTOMC |command|)
           NIL)
          ('T (|shoeLineSyntaxError| |h|) NIL))))))

(DEFUN |shoeThen| (|keep| |b| |s|)
  (|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 (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
         (SETQ |string| (CAR |h|))
         (COND
           ((SETQ |command| (|shoeFin?| |string|))
            (|bPremStreamNil| |h|))
           (#0# (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| (NOT |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| (NOT |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|)
  (|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 (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
         (SETQ |string| (CAR |h|))
         (COND
           ((SETQ |command| (|shoeFin?| |string|))
            (|bPremStreamNil| |h|))
           (#0# (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|)
  (PROGN
    (|shoeConsole|
        (CONCAT "INCLUSION SYNTAX ERROR IN LINE "
                (STRINGIMAGE (CDR |h|))))
    (|shoeConsole| (CAR |h|))
    (|shoeConsole| "LINE IGNORED")))

(DEFUN |bPremStreamNil| (|h|)
  (DECLARE (SPECIAL |$bStreamNil|))
  (PROGN
    (|shoeConsole|
        (CONCAT "UNEXPECTED )fin IN LINE " (STRINGIMAGE (CDR |h|))))
    (|shoeConsole| (CAR |h|))
    (|shoeConsole| "REST OF FILE IGNORED")
    |$bStreamNil|))

(DEFUN |bPremStreamNull| (|s|)
  (COND
    ((|bStreamNull| |s|)
     (|shoeConsole| "FILE TERMINATED BEFORE )endif") T)
    ('T NIL)))