(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 |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 " (WRITE-TO-STRING (|lineNo| |pos|)) ", column "
                (WRITE-TO-STRING (|lineCharacter| |pos|)))))))

(DEFUN |SoftShoeError| (|posn| |key|)
  (PROGN
    (|coreError| (LIST "in line " (WRITE-TO-STRING (|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 "
                (WRITE-TO-STRING (|lineNo| |pos1|))))
    (|shoeConsole| (|lineString| |pos1|))
    (|shoeConsole|
        (CONCAT (|shoeSpaces| (|lineCharacter| |pos1|)) "|"))
    (|shoeConsole|
        (CONCAT "ignored through line "
                (WRITE-TO-STRING (|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))
                   (STRING= (|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)
        (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)
             ((NULL |lines|) (|shoeConsole| ")package not found"))
             (T (APPEND (REVERSE |lines|) (CAR |b|)))))))))

(DEFPARAMETER |$bStreamNil| (LIST '|nullstream|))

(DEFUN |bStreamNull| (|x|)
  (PROG (|st|)
    (RETURN
      (COND
        ((OR (NULL |x|) (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|)))
         T)
        (T (LOOP
             (COND
               ((NOT (AND (CONSP |x|) (EQ (CAR |x|) '|nonnullstream|)))
                (RETURN NIL))
               (T (PROGN
                    (SETQ |st| (APPLY (CADR |x|) (CDDR |x|)))
                    (RPLACA |x| (CAR |st|))
                    (RPLACD |x| (CDR |st|))))))
           (AND (CONSP |x|) (EQ (CAR |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|))
       (T (CADR |z|))))
    (T (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|)))
             (T |good|)))))))

(DEFUN |shoePlainLine?| (|s|)
  (COND
    ((EQL (LENGTH |s|) 0) T)
    (T (NOT (CHAR= (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)
          (T (SETQ |n1| (STRPOSL " " |x| |n| NIL))
             (COND
               ((NULL |n1|) (LIST (|subString| |x| |n|) ""))
               (T (LIST (|subString| |x| |n| (- |n1| |n|))
                        (|subString| |x| |n1|))))))))))

(DEFUN |shoeFileName| (|x|)
  (PROG (|c| |a|)
    (RETURN
      (PROGN
        (SETQ |a| (|shoeBiteOff| |x|))
        (COND
          ((NULL |a|) "")
          (T (SETQ |c| (|shoeBiteOff| (CADR |a|)))
             (COND
               ((NULL |c|) (CAR |a|))
               (T (CONCAT (CAR |a|) "." (CAR |c|))))))))))

(DEFUN |shoeFnFileName| (|x|)
  (PROG (|c| |a|)
    (RETURN
      (PROGN
        (SETQ |a| (|shoeBiteOff| |x|))
        (COND
          ((NULL |a|) (LIST "" ""))
          (T (SETQ |c| (|shoeFileName| (CADR |a|)))
             (COND
               ((NULL |c|) (LIST (CAR |a|) ""))
               (T (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|)
        (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|))
             (T (|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|)
        (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
           (SETQ |string| (CAR |h|))
           (COND
             ((SETQ |command| (|shoeFin?| |string|))
              (|bPremStreamNil| |h|))
             (T (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|))
                     (T (|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|))
                     (T (|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|))
                     (T (|shoeElse| (CONS NIL (CDR |keep|))
                            (CONS NIL (CDR |b|)) |t|))))
                  ((SETQ |command| (|shoeEndIf?| |string|))
                   (COND
                     ((NULL (CDR |b|)) (|shoeInclude| |t|))
                     (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
                  ((AND |keep1| |b1|)
                   (|bAppend| (|shoeSimpleLine| |h|)
                       (|shoeThen| |keep| |b| |t|)))
                  (T (|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|)
        (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
           (SETQ |string| (CAR |h|))
           (COND
             ((SETQ |command| (|shoeFin?| |string|))
              (|bPremStreamNil| |h|))
             (T (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|))
                     (T (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|)
                            |t|))))
                  ((SETQ |command| (|shoeEndIf?| |string|))
                   (COND
                     ((NULL (CDR |b|)) (|shoeInclude| |t|))
                     (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
                  ((AND |keep1| |b1|)
                   (|bAppend| (|shoeSimpleLine| |h|)
                       (|shoeElse| |keep| |b| |t|)))
                  (T (|shoeElse| |keep| |b| |t|))))))))))

(DEFUN |shoeLineSyntaxError| (|h|)
  (PROGN
    (|shoeConsole|
        (CONCAT "INCLUSION SYNTAX ERROR IN LINE "
                (WRITE-TO-STRING (CDR |h|))))
    (|shoeConsole| (CAR |h|))
    (|shoeConsole| "LINE IGNORED")))

(DEFUN |bPremStreamNil| (|h|)
  (DECLARE (SPECIAL |$bStreamNil|))
  (PROGN
    (|shoeConsole|
        (CONCAT "UNEXPECTED )fin IN LINE " (WRITE-TO-STRING (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)))