diff options
Diffstat (limited to 'src/boot/strap/pile.clisp')
| -rw-r--r-- | src/boot/strap/pile.clisp | 154 |
1 files changed, 154 insertions, 0 deletions
diff --git a/src/boot/strap/pile.clisp b/src/boot/strap/pile.clisp new file mode 100644 index 00000000..caa56d3e --- /dev/null +++ b/src/boot/strap/pile.clisp @@ -0,0 +1,154 @@ +(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-pile")) + +(IMPORT-MODULE "includer") + +(IMPORT-MODULE "scanner") + +(IN-PACKAGE "BOOTTRAN") + +(DEFUN |shoeFirstTokPosn| (|t|) + (PROG () (RETURN (|shoeTokPosn| (CAAR |t|))))) + +(DEFUN |shoeLastTokPosn| (|t|) + (PROG () (RETURN (|shoeTokPosn| (CADR |t|))))) + +(DEFUN |shoePileColumn| (|t|) + (PROG () (RETURN (CDR (|shoeTokPosn| (CAAR |t|)))))) + +(DEFUN |shoePileInsert| (|s|) + (PROG (|a| |toktype|) + (RETURN + (COND + ((|bStreamNull| |s|) (CONS NIL |s|)) + (#0='T (SETQ |toktype| (|shoeTokType| (CAAAR |s|))) + (COND + ((OR (EQ |toktype| 'LISP) (EQ |toktype| 'LINE)) + (CONS (LIST (CAR |s|)) (CDR |s|))) + (#0# (SETQ |a| (|shoePileTree| (- 1) |s|)) + (CONS (LIST (ELT |a| 2)) (ELT |a| 3))))))))) + +(DEFUN |shoePileTree| (|n| |s|) + (PROG (|hh| |t| |h| |LETTMP#1|) + (RETURN + (COND + ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|)) + (#0='T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|))) + (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|)) + (SETQ |hh| (|shoePileColumn| |h|)) + (COND + ((< |n| |hh|) (|shoePileForests| |h| |hh| |t|)) + (#0# (LIST NIL |n| NIL |s|)))))))) + +(DEFUN |eqshoePileTree| (|n| |s|) + (PROG (|hh| |t| |h| |LETTMP#1|) + (RETURN + (COND + ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|)) + (#0='T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|))) + (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|)) + (SETQ |hh| (|shoePileColumn| |h|)) + (COND + ((EQUAL |hh| |n|) (|shoePileForests| |h| |hh| |t|)) + (#0# (LIST NIL |n| NIL |s|)))))))) + +(DEFUN |shoePileForest| (|n| |s|) + (PROG (|t1| |h1| |t| |h| |hh| |b| |LETTMP#1|) + (RETURN + (PROGN + (SETQ |LETTMP#1| (|shoePileTree| |n| |s|)) + (SETQ |b| (CAR |LETTMP#1|)) + (SETQ |hh| (CADR . #0=(|LETTMP#1|))) + (SETQ |h| (CADDR . #0#)) + (SETQ |t| (CADDDR . #0#)) + (COND + (|b| (SETQ |LETTMP#1| (|shoePileForest1| |hh| |t|)) + (SETQ |h1| (CAR |LETTMP#1|)) + (SETQ |t1| (CADR |LETTMP#1|)) + (LIST (CONS |h| |h1|) |t1|)) + ('T (LIST NIL |s|))))))) + +(DEFUN |shoePileForest1| (|n| |s|) + (PROG (|t1| |h1| |t| |h| |n1| |b| |LETTMP#1|) + (RETURN + (PROGN + (SETQ |LETTMP#1| (|eqshoePileTree| |n| |s|)) + (SETQ |b| (CAR |LETTMP#1|)) + (SETQ |n1| (CADR . #0=(|LETTMP#1|))) + (SETQ |h| (CADDR . #0#)) + (SETQ |t| (CADDDR . #0#)) + (COND + (|b| (SETQ |LETTMP#1| (|shoePileForest1| |n| |t|)) + (SETQ |h1| (CAR |LETTMP#1|)) + (SETQ |t1| (CADR |LETTMP#1|)) + (LIST (CONS |h| |h1|) |t1|)) + ('T (LIST NIL |s|))))))) + +(DEFUN |shoePileForests| (|h| |n| |s|) + (PROG (|t1| |h1| |LETTMP#1|) + (RETURN + (PROGN + (SETQ |LETTMP#1| (|shoePileForest| |n| |s|)) + (SETQ |h1| (CAR |LETTMP#1|)) + (SETQ |t1| (CADR |LETTMP#1|)) + (COND + ((|bStreamNull| |h1|) (LIST T |n| |h| |s|)) + ('T (|shoePileForests| (|shoePileCtree| |h| |h1|) |n| |t1|))))))) + +(DEFUN |shoePileCtree| (|x| |y|) + (PROG () (RETURN (|dqAppend| |x| (|shoePileCforest| |y|))))) + +(DEFUN |shoePileCforest| (|x|) + (PROG (|b| |a|) + (RETURN + (COND + ((NULL |x|) NIL) + ((NULL (CDR |x|)) (CAR |x|)) + (#0='T (SETQ |a| (CAR |x|)) + (SETQ |b| (|shoePileCoagulate| |a| (CDR |x|))) + (COND + ((NULL (CDR |b|)) (CAR |b|)) + (#0# (|shoeEnPile| (|shoeSeparatePiles| |b|))))))))) + +(DEFUN |shoePileCoagulate| (|a| |b|) + (PROG (|e| |d| |c|) + (RETURN + (COND + ((NULL |b|) (LIST |a|)) + (#0='T (SETQ |c| (CAR |b|)) + (COND + ((OR (EQ (|shoeTokPart| (CAAR |c|)) 'THEN) + (EQ (|shoeTokPart| (CAAR |c|)) 'ELSE)) + (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|))) + (#0# (SETQ |d| (CADR |a|)) (SETQ |e| (|shoeTokPart| |d|)) + (COND + ((AND (EQCAR |d| 'KEY) + (OR (GET |e| 'SHOEINF) (EQ |e| 'COMMA) + (EQ |e| 'SEMICOLON))) + (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|))) + (#0# (CONS |a| (|shoePileCoagulate| |c| (CDR |b|)))))))))))) + +(DEFUN |shoeSeparatePiles| (|x|) + (PROG (|semicolon| |a|) + (RETURN + (COND + ((NULL |x|) NIL) + ((NULL (CDR |x|)) (CAR |x|)) + ('T (SETQ |a| (CAR |x|)) + (SETQ |semicolon| + (|dqUnit| + (|shoeTokConstruct| 'KEY 'BACKSET + (|shoeLastTokPosn| |a|)))) + (|dqConcat| + (LIST |a| |semicolon| (|shoeSeparatePiles| (CDR |x|))))))))) + +(DEFUN |shoeEnPile| (|x|) + (PROG () + (RETURN + (|dqConcat| (LIST (|dqUnit| + (|shoeTokConstruct| 'KEY 'SETTAB + (|shoeFirstTokPosn| |x|))) + |x| + (|dqUnit| + (|shoeTokConstruct| 'KEY 'BACKTAB + (|shoeLastTokPosn| |x|)))))))) + |