From a27cc2ac7bf6a0ad60cc6c9f949a988d0444bb4e Mon Sep 17 00:00:00 2001 From: dos-reis Date: Mon, 28 Jan 2008 04:16:25 +0000 Subject: * boot/Makefile.pamphlet: Remove. * boot/translator.boot: New. * boot/translator.boot: Remove. * boot/tokens.boot: New. * boot/tokens.boot.pamphlet: Remove. * boot/scanner.boot: New. * boot/scanner.boot.pamphlet: Remove. * boot/pile.boot: New. * boot/pile.boot.pamphlet: Remove. * boot/parser.boot: New. * boot/parser.boot.pamphlet: New. * boot/initial-env.lisp: New. * boot/initial-env.lisp.pamphlet: Remove. * boot/includer.boot: New. * boot/includer.boot.pamphlet: Remove. * boot/ast.boot: New. * boot/ast.boot.pamphlet: Remove. --- src/boot/strap/ast.clisp | 2086 +++++++++++++++++++++++++++++++++++++++ src/boot/strap/includer.clisp | 553 +++++++++++ src/boot/strap/parser.clisp | 1331 +++++++++++++++++++++++++ src/boot/strap/pile.clisp | 154 +++ src/boot/strap/scanner.clisp | 626 ++++++++++++ src/boot/strap/tokens.clisp | 352 +++++++ src/boot/strap/translator.clisp | 1156 ++++++++++++++++++++++ 7 files changed, 6258 insertions(+) create mode 100644 src/boot/strap/ast.clisp create mode 100644 src/boot/strap/includer.clisp create mode 100644 src/boot/strap/parser.clisp create mode 100644 src/boot/strap/pile.clisp create mode 100644 src/boot/strap/scanner.clisp create mode 100644 src/boot/strap/tokens.clisp create mode 100644 src/boot/strap/translator.clisp (limited to 'src/boot/strap') diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp new file mode 100644 index 00000000..591bd9bf --- /dev/null +++ b/src/boot/strap/ast.clisp @@ -0,0 +1,2086 @@ +(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-ast")) + +(IMPORT-MODULE "includer") + +(IN-PACKAGE "BOOTTRAN") + +(DEFPARAMETER |$bfClamming| NIL) + +(DEFTYPE |String| () 'STRING) + +(DEFTYPE |Symbol| () 'SYMBOL) + +(DEFTYPE |Sequence| () 'SEQUENCE) + +(DEFTYPE |List| () '(OR NIL CONS)) + +(DEFUN |Name| #0=(|bfVar#1|) (CONS '|Name| (LIST . #0#))) + +(DEFUN |Command| #0=(|bfVar#2|) (CONS '|Command| (LIST . #0#))) + +(DEFUN |Module| #0=(|bfVar#3|) (CONS '|Module| (LIST . #0#))) + +(DEFUN |Import| #0=(|bfVar#4|) (CONS '|Import| (LIST . #0#))) + +(DEFUN |ImportSignature| #0=(|bfVar#5| |bfVar#6|) + (CONS '|ImportSignature| (LIST . #0#))) + +(DEFUN |TypeAlias| #0=(|bfVar#7| |bfVar#8| |bfVar#9|) + (CONS '|TypeAlias| (LIST . #0#))) + +(DEFUN |Signature| #0=(|bfVar#10| |bfVar#11|) + (CONS '|Signature| (LIST . #0#))) + +(DEFUN |Mapping| #0=(|bfVar#12| |bfVar#13|) + (CONS '|Mapping| (LIST . #0#))) + +(DEFUN |SuffixDot| #0=(|bfVar#14|) (CONS '|SuffixDot| (LIST . #0#))) + +(DEFUN |Quote| #0=(|bfVar#15|) (CONS '|Quote| (LIST . #0#))) + +(DEFUN |EqualName| #0=(|bfVar#16|) (CONS '|EqualName| (LIST . #0#))) + +(DEFUN |Colon| #0=(|bfVar#17|) (CONS '|Colon| (LIST . #0#))) + +(DEFUN |QualifiedName| #0=(|bfVar#18| |bfVar#19|) + (CONS '|QualifiedName| (LIST . #0#))) + +(DEFUN |Bracket| #0=(|bfVar#20|) (CONS '|Bracket| (LIST . #0#))) + +(DEFUN |UnboundedSegment| #0=(|bfVar#21|) + (CONS '|UnboundedSegment| (LIST . #0#))) + +(DEFUN |BoundedSgement| #0=(|bfVar#22| |bfVar#23|) + (CONS '|BoundedSgement| (LIST . #0#))) + +(DEFUN |Tuple| #0=(|bfVar#24|) (CONS '|Tuple| (LIST . #0#))) + +(DEFUN |ColonAppend| #0=(|bfVar#25| |bfVar#26|) + (CONS '|ColonAppend| (LIST . #0#))) + +(DEFUN |Is| #0=(|bfVar#27| |bfVar#28|) (CONS '|Is| (LIST . #0#))) + +(DEFUN |Isnt| #0=(|bfVar#29| |bfVar#30|) (CONS '|Isnt| (LIST . #0#))) + +(DEFUN |Reduce| #0=(|bfVar#31| |bfVar#32|) + (CONS '|Reduce| (LIST . #0#))) + +(DEFUN |PrefixExpr| #0=(|bfVar#33| |bfVar#34|) + (CONS '|PrefixExpr| (LIST . #0#))) + +(DEFUN |Call| #0=(|bfVar#35| |bfVar#36|) (CONS '|Call| (LIST . #0#))) + +(DEFUN |InfixExpr| #0=(|bfVar#37| |bfVar#38| |bfVar#39|) + (CONS '|InfixExpr| (LIST . #0#))) + +(DEFUN |ConstantDefinition| #0=(|bfVar#40| |bfVar#41|) + (CONS '|ConstantDefinition| (LIST . #0#))) + +(DEFUN |Definition| #0=(|bfVar#42| |bfVar#43| |bfVar#44| |bfVar#45|) + (CONS '|Definition| (LIST . #0#))) + +(DEFUN |Macro| #0=(|bfVar#46| |bfVar#47| |bfVar#48|) + (CONS '|Macro| (LIST . #0#))) + +(DEFUN |SuchThat| #0=(|bfVar#49|) (CONS '|SuchThat| (LIST . #0#))) + +(DEFUN |Assignment| #0=(|bfVar#50| |bfVar#51|) + (CONS '|Assignment| (LIST . #0#))) + +(DEFUN |While| #0=(|bfVar#52|) (CONS '|While| (LIST . #0#))) + +(DEFUN |Until| #0=(|bfVar#53|) (CONS '|Until| (LIST . #0#))) + +(DEFUN |For| #0=(|bfVar#54| |bfVar#55| |bfVar#56|) + (CONS '|For| (LIST . #0#))) + +(DEFUN |Exit| #0=(|bfVar#57| |bfVar#58|) (CONS '|Exit| (LIST . #0#))) + +(DEFUN |Iterators| #0=(|bfVar#59|) (CONS '|Iterators| (LIST . #0#))) + +(DEFUN |Cross| #0=(|bfVar#60|) (CONS '|Cross| (LIST . #0#))) + +(DEFUN |Repeat| #0=(|bfVar#61| |bfVar#62|) + (CONS '|Repeat| (LIST . #0#))) + +(DEFUN |Pile| #0=(|bfVar#63|) (CONS '|Pile| (LIST . #0#))) + +(DEFUN |Append| #0=(|bfVar#64|) (CONS '|Append| (LIST . #0#))) + +(DEFUN |Case| #0=(|bfVar#65| |bfVar#66|) (CONS '|Case| (LIST . #0#))) + +(DEFUN |Return| #0=(|bfVar#67|) (CONS '|Return| (LIST . #0#))) + +(DEFUN |Where| #0=(|bfVar#68| |bfVar#69|) + (CONS '|Where| (LIST . #0#))) + +(DEFUN |Structure| #0=(|bfVar#70| |bfVar#71|) + (CONS '|Structure| (LIST . #0#))) + +(DEFPARAMETER |$inDefIS| NIL) + +(DEFUN |bfGenSymbol| () + (PROG () + (DECLARE (SPECIAL |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |$GenVarCounter| (+ |$GenVarCounter| 1)) + (INTERN (CONCAT "bfVar#" (STRINGIMAGE |$GenVarCounter|))))))) + +(DEFUN |bfListOf| (|x|) (PROG () (RETURN |x|))) + +(DEFUN |bfColon| (|x|) (PROG () (RETURN (LIST 'COLON |x|)))) + +(DEFUN |bfColonColon| (|package| |name|) + (PROG () (RETURN (INTERN (SYMBOL-NAME |name|) |package|)))) + +(DEFUN |bfSymbol| (|x|) + (PROG () (RETURN (COND ((STRINGP |x|) |x|) ('T (LIST 'QUOTE |x|)))))) + +(DEFUN |bfDot| () (PROG () (RETURN 'DOT))) + +(DEFUN |bfSuffixDot| (|x|) (PROG () (RETURN (LIST |x| 'DOT)))) + +(DEFUN |bfEqual| (|name|) (PROG () (RETURN (LIST 'EQUAL |name|)))) + +(DEFUN |bfBracket| (|part|) (PROG () (RETURN |part|))) + +(DEFUN |bfPile| (|part|) (PROG () (RETURN |part|))) + +(DEFUN |bfAppend| (|x|) (PROG () (RETURN (APPLY #'APPEND |x|)))) + +(DEFUN |bfColonAppend| (|x| |y|) + (PROG (|a|) + (RETURN + (COND + ((NULL |x|) + (COND + ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE) + (PROGN (SETQ |a| (CDR |y|)) 'T)) + (LIST '&REST (CONS 'QUOTE |a|))) + (#0='T (LIST '&REST |y|)))) + (#0# (CONS (CAR |x|) (|bfColonAppend| (CDR |x|) |y|))))))) + +(DEFUN |bfDefinition| (|bflhsitems| |bfrhs| |body|) + (PROG () (RETURN (LIST 'DEF |bflhsitems| |bfrhs| |body|)))) + +(DEFUN |bfMDefinition| (|bflhsitems| |bfrhs| |body|) + (PROG () (RETURN (|bfMDef| 'MDEF |bflhsitems| |bfrhs| |body|)))) + +(DEFUN |bfCompDef| (|x|) + (PROG (|body| |ISTMP#3| |args| |ISTMP#2| |op| |ISTMP#1| |def| + |bfVar#73| |bfVar#72|) + (RETURN + (PROGN + (SETQ |bfVar#72| |x|) + (SETQ |bfVar#73| (CDR |bfVar#72|)) + (CASE (CAR |bfVar#72|) + (|ConstantDefinition| + (LET ((|n| (CAR |bfVar#73|)) (|e| (CADR |bfVar#73|))) + |x|)) + (T (COND + ((AND (CONSP |x|) + (PROGN + (SETQ |def| (CAR |x|)) + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |op| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |args| (CAR |ISTMP#2|)) + (SETQ |ISTMP#3| (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CDR |ISTMP#3|) NIL) + (PROGN + (SETQ |body| (CAR |ISTMP#3|)) + 'T)))))))) + (|bfDef| |def| |op| |args| |body|)) + ('T (|coreError| "invalid AST"))))))))) + +(DEFUN |bfBeginsDollar| (|x|) + (PROG () (RETURN (EQL (ELT "$" 0) (ELT (PNAME |x|) 0))))) + +(DEFUN |compFluid| (|id|) (PROG () (RETURN (LIST 'FLUID |id|)))) + +(DEFUN |compFluidize| (|x|) + (PROG () + (RETURN + (COND + ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) (|compFluid| |x|)) + ((ATOM |x|) |x|) + ((EQCAR |x| 'QUOTE) |x|) + ('T + (CONS (|compFluidize| (CAR |x|)) (|compFluidize| (CDR |x|)))))))) + +(DEFUN |bfTuple| (|x|) (PROG () (RETURN (CONS 'TUPLE |x|)))) + +(DEFUN |bfTupleP| (|x|) (PROG () (RETURN (EQCAR |x| 'TUPLE)))) + +(DEFUN |bfTupleIf| (|x|) + (PROG () + (RETURN (COND ((|bfTupleP| |x|) |x|) ('T (|bfTuple| |x|)))))) + +(DEFUN |bfTupleConstruct| (|b|) + (PROG (|ISTMP#1| |a|) + (RETURN + (PROGN + (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) ('T (LIST |b|)))) + (COND + ((LET ((|bfVar#75| NIL) (|bfVar#74| |a|) (|x| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#74|) + (PROGN (SETQ |x| (CAR |bfVar#74|)) NIL)) + (RETURN |bfVar#75|)) + ('T + (PROGN + (SETQ |bfVar#75| + (AND (CONSP |x|) (EQ (CAR |x|) 'COLON) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (EQ (CDR |ISTMP#1|) NIL))))) + (COND (|bfVar#75| (RETURN |bfVar#75|)))))) + (SETQ |bfVar#74| (CDR |bfVar#74|)))) + (|bfMakeCons| |a|)) + ('T (CONS 'LIST |a|))))))) + +(DEFUN |bfConstruct| (|b|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) ('T (LIST |b|)))) + (|bfMakeCons| |a|))))) + +(DEFUN |bfMakeCons| (|l|) + (PROG (|l1| |a| |ISTMP#2| |ISTMP#1|) + (RETURN + (COND + ((NULL |l|) NIL) + ((AND (CONSP |l|) + (PROGN + (SETQ |ISTMP#1| (CAR |l|)) + (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'COLON) + (PROGN + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |a| (CAR |ISTMP#2|)) #0='T))))) + (PROGN (SETQ |l1| (CDR |l|)) #0#)) + (COND + (|l1| (LIST 'APPEND |a| (|bfMakeCons| |l1|))) + (#1='T |a|))) + (#1# (LIST 'CONS (CAR |l|) (|bfMakeCons| (CDR |l|)))))))) + +(DEFUN |bfFor| (|bflhs| U |step|) + (PROG () + (RETURN + (COND + ((EQCAR U '|tails|) (|bfForTree| 'ON |bflhs| (CADR U))) + ((EQCAR U 'SEGMENT) + (|bfSTEP| |bflhs| (CADR U) |step| (CADDR U))) + ('T (|bfForTree| 'IN |bflhs| U)))))) + +(DEFUN |bfForTree| (OP |lhs| |whole|) + (PROG (G) + (RETURN + (PROGN + (SETQ |whole| + (COND + ((|bfTupleP| |whole|) (|bfMakeCons| (CDR |whole|))) + (#0='T |whole|))) + (COND + ((ATOM |lhs|) (|bfINON| (LIST OP |lhs| |whole|))) + (#1='T + (PROGN + (SETQ |lhs| + (COND + ((|bfTupleP| |lhs|) (CADR |lhs|)) + (#0# |lhs|))) + (COND + ((EQCAR |lhs| 'L%T) + (PROGN + (SETQ G (CADR |lhs|)) + (APPEND (|bfINON| (LIST OP G |whole|)) + (|bfSuchthat| (|bfIS| G (CADDR |lhs|)))))) + (#1# + (PROGN + (SETQ G (|bfGenSymbol|)) + (APPEND (|bfINON| (LIST OP G |whole|)) + (|bfSuchthat| (|bfIS| G |lhs|))))))))))))) + +(DEFUN |bfSTEP| (|id| |fst| |step| |lst|) + (PROG (|suc| |ex| |pred| |final| |g2| |inc| |g1| |initval| |initvar|) + (RETURN + (PROGN + (SETQ |initvar| (LIST |id|)) + (SETQ |initval| (LIST |fst|)) + (SETQ |inc| + (COND + ((ATOM |step|) |step|) + (#0='T (SETQ |g1| (|bfGenSymbol|)) + (SETQ |initvar| (CONS |g1| |initvar|)) + (SETQ |initval| (CONS |step| |initval|)) |g1|))) + (SETQ |final| + (COND + ((ATOM |lst|) |lst|) + (#0# (SETQ |g2| (|bfGenSymbol|)) + (SETQ |initvar| (CONS |g2| |initvar|)) + (SETQ |initval| (CONS |lst| |initval|)) |g2|))) + (SETQ |ex| + (COND + ((NULL |lst|) NIL) + ((INTEGERP |inc|) + (PROGN + (SETQ |pred| (COND ((MINUSP |inc|) '<) (#0# '>))) + (LIST (LIST |pred| |id| |final|)))) + ('T + (LIST (LIST 'COND + (LIST (LIST 'MINUSP |inc|) + (LIST '< |id| |final|)) + (LIST 'T (LIST '> |id| |final|))))))) + (SETQ |suc| (LIST (LIST 'SETQ |id| (LIST '+ |id| |inc|)))) + (LIST (LIST |initvar| |initval| |suc| NIL |ex| NIL)))))) + +(DEFUN |bfINON| (|x|) + (PROG (|whole| |id| |op|) + (RETURN + (PROGN + (SETQ |op| (CAR |x|)) + (SETQ |id| (CADR . #0=(|x|))) + (SETQ |whole| (CADDR . #0#)) + (COND + ((EQ |op| 'ON) (|bfON| |id| |whole|)) + ('T (|bfIN| |id| |whole|))))))) + +(DEFUN |bfIN| (|x| E) + (PROG (|g|) + (RETURN + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (LIST (LIST (LIST |g| |x|) (LIST E NIL) + (LIST (LIST 'SETQ |g| (LIST 'CDR |g|))) NIL + (LIST (LIST 'OR (LIST 'ATOM |g|) + (LIST 'PROGN + (LIST 'SETQ |x| (LIST 'CAR |g|)) + 'NIL))) + NIL)))))) + +(DEFUN |bfON| (|x| E) + (PROG () + (RETURN + (LIST (LIST (LIST |x|) (LIST E) + (LIST (LIST 'SETQ |x| (LIST 'CDR |x|))) NIL + (LIST (LIST 'ATOM |x|)) NIL))))) + +(DEFUN |bfSuchthat| (|p|) + (PROG () (RETURN (LIST (LIST NIL NIL NIL (LIST |p|) NIL NIL))))) + +(DEFUN |bfWhile| (|p|) + (PROG () + (RETURN (LIST (LIST NIL NIL NIL NIL (LIST (|bfNOT| |p|)) NIL))))) + +(DEFUN |bfUntil| (|p|) + (PROG (|g|) + (RETURN + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (LIST (LIST (LIST |g|) (LIST NIL) (LIST (LIST 'SETQ |g| |p|)) + NIL (LIST |g|) NIL)))))) + +(DEFUN |bfIterators| (|x|) (PROG () (RETURN (CONS 'ITERATORS |x|)))) + +(DEFUN |bfCross| (|x|) (PROG () (RETURN (CONS 'CROSS |x|)))) + +(DEFUN |bfLp| (|iters| |body|) + (PROG () + (RETURN + (COND + ((EQCAR |iters| 'ITERATORS) (|bfLp1| (CDR |iters|) |body|)) + ('T (|bfLpCross| (CDR |iters|) |body|)))))) + +(DEFUN |bfLpCross| (|iters| |body|) + (PROG () + (RETURN + (COND + ((NULL (CDR |iters|)) (|bfLp| (CAR |iters|) |body|)) + ('T (|bfLp| (CAR |iters|) (|bfLpCross| (CDR |iters|) |body|))))))) + +(DEFUN |bfSep| (|iters|) + (PROG (|r| |f|) + (RETURN + (COND + ((NULL |iters|) (LIST NIL NIL NIL NIL NIL NIL)) + ('T (SETQ |f| (CAR |iters|)) (SETQ |r| (|bfSep| (CDR |iters|))) + (LET ((|bfVar#78| NIL) (|bfVar#76| |f|) (|i| NIL) + (|bfVar#77| |r|) (|j| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#76|) + (PROGN (SETQ |i| (CAR |bfVar#76|)) NIL) + (ATOM |bfVar#77|) + (PROGN (SETQ |j| (CAR |bfVar#77|)) NIL)) + (RETURN (NREVERSE |bfVar#78|))) + ('T + (SETQ |bfVar#78| (CONS (APPEND |i| |j|) |bfVar#78|)))) + (SETQ |bfVar#76| (CDR |bfVar#76|)) + (SETQ |bfVar#77| (CDR |bfVar#77|))))))))) + +(DEFUN |bfReduce| (|op| |y|) + (PROG (|it| |ny| |g2| |body| |g1| |g| |init| |a|) + (RETURN + (PROGN + (SETQ |a| + (COND ((EQCAR |op| 'QUOTE) (CADR |op|)) (#0='T |op|))) + (SETQ |op| (|bfReName| |a|)) + (SETQ |init| (GET |op| 'SHOETHETA)) + (SETQ |g| (|bfGenSymbol|)) + (SETQ |g1| (|bfGenSymbol|)) + (SETQ |body| (LIST 'SETQ |g| (LIST |op| |g| |g1|))) + (COND + ((NULL |init|) (SETQ |g2| (|bfGenSymbol|)) + (SETQ |init| (LIST 'CAR |g2|)) (SETQ |ny| (LIST 'CDR |g2|)) + (SETQ |it| + (CONS 'ITERATORS + (LIST (LIST (LIST (LIST |g|) (LIST |init|) NIL + NIL NIL (LIST |g|))) + (|bfIN| |g1| |ny|)))) + (|bfMKPROGN| + (LIST (LIST 'L%T |g2| |y|) (|bfLp| |it| |body|)))) + (#0# (SETQ |init| (CAR |init|)) + (SETQ |it| + (CONS 'ITERATORS + (LIST (LIST (LIST (LIST |g|) (LIST |init|) NIL + NIL NIL (LIST |g|))) + (|bfIN| |g1| |y|)))) + (|bfLp| |it| |body|))))))) + +(DEFUN |bfReduceCollect| (|op| |y|) + (PROG (|init| |a| |itl| |body|) + (RETURN + (COND + ((EQCAR |y| 'COLLECT) (SETQ |body| (ELT |y| 1)) + (SETQ |itl| (ELT |y| 2)) + (SETQ |a| + (COND ((EQCAR |op| 'QUOTE) (CADR |op|)) (#0='T |op|))) + (SETQ |op| (|bfReName| |a|)) + (SETQ |init| (GET |op| 'SHOETHETA)) + (|bfOpReduce| |op| |init| |body| |itl|)) + (#0# (SETQ |a| (|bfTupleConstruct| (ELT |y| 1))) + (|bfReduce| |op| |a|)))))) + +(DEFUN |bfDCollect| (|y| |itl|) + (PROG () (RETURN (LIST 'COLLECT |y| |itl|)))) + +(DEFUN |bfDTuple| (|x|) (PROG () (RETURN (LIST 'DTUPLE |x|)))) + +(DEFUN |bfCollect| (|y| |itl|) + (PROG (|newBody| |a| |ISTMP#1|) + (RETURN + (COND + ((AND (CONSP |y|) (EQ (CAR |y|) 'COLON) + (PROGN + (SETQ |ISTMP#1| (CDR |y|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) 'T)))) + (|bf0APPEND| |a| |itl|)) + ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) + (PROGN + (SETQ |newBody| (|bfConstruct| |y|)) + (|bf0APPEND| |newBody| |itl|))) + ('T (|bf0COLLECT| |y| |itl|)))))) + +(DEFUN |bf0COLLECT| (|y| |itl|) + (PROG () (RETURN (|bfListReduce| 'CONS |y| |itl|)))) + +(DEFUN |bf0APPEND| (|y| |itl|) + (PROG (|extrait| |body| |g|) + (RETURN + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (SETQ |body| + (LIST 'SETQ |g| (LIST 'APPEND (LIST 'REVERSE |y|) |g|))) + (SETQ |extrait| + (LIST (LIST (LIST |g|) (LIST NIL) NIL NIL NIL + (LIST (LIST 'NREVERSE |g|))))) + (|bfLp2| |extrait| |itl| |body|))))) + +(DEFUN |bfListReduce| (|op| |y| |itl|) + (PROG (|extrait| |body| |g|) + (RETURN + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (SETQ |body| (LIST 'SETQ |g| (LIST |op| |y| |g|))) + (SETQ |extrait| + (LIST (LIST (LIST |g|) (LIST NIL) NIL NIL NIL + (LIST (LIST 'NREVERSE |g|))))) + (|bfLp2| |extrait| |itl| |body|))))) + +(DEFUN |bfLp1| (|iters| |body|) + (PROG (|loop| |nbody| |value| |exits| |filters| |sucs| |inits| |vars| + |LETTMP#1|) + (RETURN + (PROGN + (SETQ |LETTMP#1| (|bfSep| (|bfAppend| |iters|))) + (SETQ |vars| (CAR |LETTMP#1|)) + (SETQ |inits| (CADR . #0=(|LETTMP#1|))) + (SETQ |sucs| (CADDR . #0#)) + (SETQ |filters| (CADDDR . #0#)) + (SETQ |exits| (CAR #1=(CDDDDR . #0#))) + (SETQ |value| (CADR #1#)) + (SETQ |nbody| + (COND + ((NULL |filters|) |body|) + (#2='T (|bfAND| (APPEND |filters| (CONS |body| NIL)))))) + (SETQ |value| (COND ((NULL |value|) 'NIL) (#2# (CAR |value|)))) + (SETQ |exits| + (LIST 'COND + (LIST (|bfOR| |exits|) (LIST 'RETURN |value|)) + (LIST ''T |nbody|))) + (SETQ |loop| (CONS 'LOOP (CONS |exits| |sucs|))) + (COND + (|vars| (SETQ |loop| + (LIST 'LET + (LET ((|bfVar#81| NIL) + (|bfVar#79| |vars|) (|v| NIL) + (|bfVar#80| |inits|) (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#79|) + (PROGN + (SETQ |v| (CAR |bfVar#79|)) + NIL) + (ATOM |bfVar#80|) + (PROGN + (SETQ |i| (CAR |bfVar#80|)) + NIL)) + (RETURN (NREVERSE |bfVar#81|))) + ('T + (SETQ |bfVar#81| + (CONS (LIST |v| |i|) |bfVar#81|)))) + (SETQ |bfVar#79| (CDR |bfVar#79|)) + (SETQ |bfVar#80| (CDR |bfVar#80|)))) + |loop|)))) + |loop|)))) + +(DEFUN |bfLp2| (|extrait| |itl| |body|) + (PROG (|iters|) + (RETURN + (COND + ((EQCAR |itl| 'ITERATORS) + (|bfLp1| (CONS |extrait| (CDR |itl|)) |body|)) + ('T + (PROGN + (SETQ |iters| (CDR |itl|)) + (|bfLpCross| + (CONS (CONS 'ITERATORS (CONS |extrait| (CDAR |iters|))) + (CDR |iters|)) + |body|))))))) + +(DEFUN |bfOpReduce| (|op| |init| |y| |itl|) + (PROG (|extrait| |g1| |body| |g|) + (RETURN + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (SETQ |body| + (COND + ((EQ |op| 'AND) + (|bfMKPROGN| + (LIST (LIST 'SETQ |g| |y|) + (LIST 'COND + (LIST (LIST 'NOT |g|) + (LIST 'RETURN 'NIL)))))) + ((EQ |op| 'OR) + (|bfMKPROGN| + (LIST (LIST 'SETQ |g| |y|) + (LIST 'COND (LIST |g| (LIST 'RETURN |g|)))))) + ('T (LIST 'SETQ |g| (LIST |op| |g| |y|))))) + (COND + ((NULL |init|) (SETQ |g1| (|bfGenSymbol|)) + (SETQ |init| (LIST 'CAR |g1|)) (SETQ |y| (LIST 'CDR |g1|)) + (SETQ |extrait| + (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL + (LIST |g|)))) + (|bfMKPROGN| + (LIST (LIST 'L%T |g1| |y|) + (|bfLp2| |extrait| |itl| |body|)))) + ('T (SETQ |init| (CAR |init|)) + (SETQ |extrait| + (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL + (LIST |g|)))) + (|bfLp2| |extrait| |itl| |body|))))))) + +(DEFUN |bfLoop1| (|body|) + (PROG () (RETURN (|bfLp| (|bfIterators| NIL) |body|)))) + +(DEFUN |bfSegment1| (|lo|) + (PROG () (RETURN (LIST 'SEGMENT |lo| NIL)))) + +(DEFUN |bfSegment2| (|lo| |hi|) + (PROG () (RETURN (LIST 'SEGMENT |lo| |hi|)))) + +(DEFUN |bfForInBy| (|variable| |collection| |step|) + (PROG () (RETURN (|bfFor| |variable| |collection| |step|)))) + +(DEFUN |bfForin| (|lhs| U) (PROG () (RETURN (|bfFor| |lhs| U 1)))) + +(DEFUN |bfLocal| (|a| |b|) + (PROG () + (RETURN + (COND + ((EQ |b| 'FLUID) (|compFluid| |a|)) + ((EQ |b| '|fluid|) (|compFluid| |a|)) + ((EQ |b| '|local|) (|compFluid| |a|)) + ('T |a|))))) + +(DEFUN |bfTake| (|n| |x|) + (PROG () + (RETURN + (COND + ((NULL |x|) |x|) + ((EQL |n| 0) NIL) + ('T (CONS (CAR |x|) (|bfTake| (- |n| 1) (CDR |x|)))))))) + +(DEFUN |bfDrop| (|n| |x|) + (PROG () + (RETURN + (COND + ((OR (NULL |x|) (EQL |n| 0)) |x|) + ('T (|bfDrop| (- |n| 1) (CDR |x|))))))) + +(DEFUN |bfDefSequence| (|l|) (PROG () (RETURN (CONS 'SEQ |l|)))) + +(DEFUN |bfReturnNoName| (|a|) (PROG () (RETURN (LIST 'RETURN |a|)))) + +(DEFUN |bfSUBLIS| (|p| |e|) + (PROG () + (RETURN + (COND + ((ATOM |e|) (|bfSUBLIS1| |p| |e|)) + ((EQCAR |e| 'QUOTE) |e|) + ('T + (CONS (|bfSUBLIS| |p| (CAR |e|)) (|bfSUBLIS| |p| (CDR |e|)))))))) + +(DEFUN |bfSUBLIS1| (|p| |e|) + (PROG (|f|) + (RETURN + (COND + ((NULL |p|) |e|) + (#0='T + (PROGN + (SETQ |f| (CAR |p|)) + (COND + ((EQ (CAR |f|) |e|) (|bfSUBLIS| |p| (CDR |f|))) + (#0# (|bfSUBLIS1| (CDR |p|) |e|))))))))) + +(DEFUN |defSheepAndGoats| (|x|) + (PROG (|defstack| |op1| |opassoc| |argl| |body| |args| |op| |def|) + (DECLARE (SPECIAL |$op|)) + (RETURN + (COND + ((EQCAR |x| 'DEF) + (PROGN + (SETQ |def| (CAR |x|)) + (SETQ |op| (CADR . #0=(|x|))) + (SETQ |args| (CADDR . #0#)) + (SETQ |body| (CADDDR . #0#)) + (SETQ |argl| + (COND + ((|bfTupleP| |args|) (CDR |args|)) + (#1='T (LIST |args|)))) + (COND + ((NULL |argl|) (SETQ |opassoc| (LIST (CONS |op| |body|))) + (LIST |opassoc| NIL NIL)) + (#1# + (SETQ |op1| + (INTERN (CONCAT (PNAME |$op|) "," (PNAME |op|)))) + (SETQ |opassoc| (LIST (CONS |op| |op1|))) + (SETQ |defstack| (LIST (LIST 'DEF |op1| |args| |body|))) + (LIST |opassoc| |defstack| NIL))))) + ((EQCAR |x| 'SEQ) (|defSheepAndGoatsList| (CDR |x|))) + ('T (LIST NIL NIL (LIST |x|))))))) + +(DEFUN |defSheepAndGoatsList| (|x|) + (PROG (|nondefs1| |defs1| |opassoc1| |nondefs| |defs| |opassoc| + |LETTMP#1|) + (RETURN + (COND + ((NULL |x|) (LIST NIL NIL NIL)) + ('T (SETQ |LETTMP#1| (|defSheepAndGoats| (CAR |x|))) + (SETQ |opassoc| (CAR |LETTMP#1|)) + (SETQ |defs| (CADR . #0=(|LETTMP#1|))) + (SETQ |nondefs| (CADDR . #0#)) + (SETQ |LETTMP#1| (|defSheepAndGoatsList| (CDR |x|))) + (SETQ |opassoc1| (CAR |LETTMP#1|)) + (SETQ |defs1| (CADR . #1=(|LETTMP#1|))) + (SETQ |nondefs1| (CADDR . #1#)) + (LIST (APPEND |opassoc| |opassoc1|) (APPEND |defs| |defs1|) + (APPEND |nondefs| |nondefs1|))))))) + +(DEFUN |bfLetForm| (|lhs| |rhs|) + (PROG () (RETURN (LIST 'L%T |lhs| |rhs|)))) + +(DEFUN |bfLET1| (|lhs| |rhs|) + (PROG (|let1| |g| |l2| |l1| |name| |rhs1| |ISTMP#1|) + (DECLARE (SPECIAL |$letGenVarCounter|)) + (RETURN + (COND + ((IDENTP |lhs|) (|bfLetForm| |lhs| |rhs|)) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL)))) + (|bfLetForm| |lhs| |rhs|)) + ((AND (IDENTP |rhs|) (NULL (|bfCONTAINED| |rhs| |lhs|))) + (PROGN + (SETQ |rhs1| (|bfLET2| |lhs| |rhs|)) + (COND + ((EQCAR |rhs1| 'L%T) (|bfMKPROGN| (LIST |rhs1| |rhs|))) + ((EQCAR |rhs1| 'PROGN) (APPEND |rhs1| (LIST |rhs|))) + (#0='T + (PROGN + (COND + ((IDENTP (CAR |rhs1|)) + (SETQ |rhs1| (CONS |rhs1| NIL)))) + (|bfMKPROGN| (APPEND |rhs1| (CONS |rhs| NIL)))))))) + ((AND (CONSP |rhs|) (EQCAR |rhs| 'L%T) + (IDENTP (SETQ |name| (CADR |rhs|)))) + (PROGN + (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|))) + (SETQ |l2| (|bfLET1| |lhs| |name|)) + (COND + ((EQCAR |l2| 'PROGN) (|bfMKPROGN| (CONS |l1| (CDR |l2|)))) + (#0# + (PROGN + (COND + ((IDENTP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL)))) + (|bfMKPROGN| + (CONS |l1| (APPEND |l2| (CONS |name| NIL))))))))) + (#0# + (PROGN + (SETQ |g| + (INTERN (CONCAT "LETTMP#" + (STRINGIMAGE |$letGenVarCounter|)))) + (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1)) + (SETQ |rhs1| (LIST 'L%T |g| |rhs|)) + (SETQ |let1| (|bfLET1| |lhs| |g|)) + (COND + ((EQCAR |let1| 'PROGN) + (|bfMKPROGN| (CONS |rhs1| (CDR |let1|)))) + (#0# + (PROGN + (COND + ((IDENTP (CAR |let1|)) + (SETQ |let1| (CONS |let1| NIL)))) + (|bfMKPROGN| + (CONS |rhs1| (APPEND |let1| (CONS |g| NIL))))))))))))) + +(DEFUN |bfCONTAINED| (|x| |y|) + (PROG () + (RETURN + (COND + ((EQ |x| |y|) T) + ((ATOM |y|) NIL) + ('T + (OR (|bfCONTAINED| |x| (CAR |y|)) + (|bfCONTAINED| |x| (CDR |y|)))))))) + +(DEFUN |bfLET2| (|lhs| |rhs|) + (PROG (|isPred| |val1| |ISTMP#3| |g| |rev| |patrev| |l2| |l1| |var2| + |var1| |b| |ISTMP#2| |a| |ISTMP#1|) + (DECLARE (SPECIAL |$inDefIS| |$letGenVarCounter|)) + (RETURN + (COND + ((IDENTP |lhs|) (|bfLetForm| |lhs| |rhs|)) + ((NULL |lhs|) NIL) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL)))) + (|bfLetForm| |lhs| |rhs|)) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'L%T) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |a| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |b| (CAR |ISTMP#2|)) #0='T)))))) + (PROGN + (SETQ |a| (|bfLET2| |a| |rhs|)) + (COND + ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|) + ((ATOM |b|) (LIST |a| |b|)) + ((CONSP (CAR |b|)) (CONS |a| |b|)) + (#1='T (LIST |a| |b|))))) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'CONS) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |var1| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |var2| (CAR |ISTMP#2|)) #0#)))))) + (COND + ((OR (EQ |var1| 'DOT) + (AND (CONSP |var1|) (EQCAR |var1| 'QUOTE))) + (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) + (#1# + (PROGN + (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|))) + (COND + ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|) + (#1# + (PROGN + (COND + ((AND (CONSP |l1|) (ATOM (CAR |l1|))) + (SETQ |l1| (CONS |l1| NIL)))) + (COND + ((IDENTP |var2|) + (APPEND |l1| + (CONS (|bfLetForm| |var2| + (|addCARorCDR| 'CDR |rhs|)) + NIL))) + (#1# + (PROGN + (SETQ |l2| + (|bfLET2| |var2| + (|addCARorCDR| 'CDR |rhs|))) + (COND + ((AND (CONSP |l2|) (ATOM (CAR |l2|))) + (SETQ |l2| (CONS |l2| NIL)))) + (APPEND |l1| |l2|))))))))))) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'APPEND) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |var1| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |var2| (CAR |ISTMP#2|)) #0#)))))) + (PROGN + (SETQ |patrev| (|bfISReverse| |var2| |var1|)) + (SETQ |rev| (LIST 'REVERSE |rhs|)) + (SETQ |g| + (INTERN (CONCAT "LETTMP#" + (STRINGIMAGE |$letGenVarCounter|)))) + (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1)) + (SETQ |l2| (|bfLET2| |patrev| |g|)) + (COND + ((AND (CONSP |l2|) (ATOM (CAR |l2|))) + (SETQ |l2| (CONS |l2| NIL)))) + (COND + ((EQ |var1| 'DOT) (CONS (LIST 'L%T |g| |rev|) |l2|)) + ((PROGN + (SETQ |ISTMP#1| (|last| |l2|)) + (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'L%T) + (PROGN + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQUAL (CAR |ISTMP#2|) |var1|) + (PROGN + (SETQ |ISTMP#3| (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CDR |ISTMP#3|) NIL) + (PROGN + (SETQ |val1| (CAR |ISTMP#3|)) + #0#))))))) + (CONS (LIST 'L%T |g| |rev|) + (APPEND (REVERSE (CDR (REVERSE |l2|))) + (CONS (|bfLetForm| |var1| + (LIST 'NREVERSE |val1|)) + NIL)))) + (#1# + (CONS (LIST 'L%T |g| |rev|) + (APPEND |l2| + (CONS (|bfLetForm| |var1| + (LIST 'NREVERSE |var1|)) + NIL))))))) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'EQUAL) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |var1| (CAR |ISTMP#1|)) #0#)))) + (LIST 'COND (LIST (LIST 'EQUAL |var1| |rhs|) |var1|))) + (#1# + (PROGN + (SETQ |isPred| + (COND + (|$inDefIS| (|bfIS1| |rhs| |lhs|)) + (#1# (|bfIS| |rhs| |lhs|)))) + (LIST 'COND (LIST |isPred| |rhs|)))))))) + +(DEFUN |bfLET| (|lhs| |rhs|) + (PROG (|$letGenVarCounter|) + (DECLARE (SPECIAL |$letGenVarCounter|)) + (RETURN + (PROGN (SETQ |$letGenVarCounter| 1) (|bfLET1| |lhs| |rhs|))))) + +(DEFUN |addCARorCDR| (|acc| |expr|) + (PROG (|funsR| |funsA| |p| |funs|) + (RETURN + (COND + ((NULL (CONSP |expr|)) (LIST |acc| |expr|)) + ((AND (EQ |acc| 'CAR) (EQCAR |expr| 'REVERSE)) + (LIST 'CAR (CONS 'LAST (CDR |expr|)))) + (#0='T + (PROGN + (SETQ |funs| + '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR + CDAAR CDDAR CDADR CDDDR)) + (SETQ |p| (|bfPosition| (CAR |expr|) |funs|)) + (COND + ((EQUAL |p| (- 1)) (LIST |acc| |expr|)) + (#0# + (PROGN + (SETQ |funsA| + '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR + CAAADR CAADDR CADAAR CADDAR CADADR CADDDR)) + (SETQ |funsR| + '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR + CDAADR CDADDR CDDAAR CDDDAR CDDADR CDDDDR)) + (COND + ((EQ |acc| 'CAR) + (CONS (ELT |funsA| |p|) (CDR |expr|))) + ('T (CONS (ELT |funsR| |p|) (CDR |expr|))))))))))))) + +(DEFUN |bfPosition| (|x| |l|) (PROG () (RETURN (|bfPosn| |x| |l| 0)))) + +(DEFUN |bfPosn| (|x| |l| |n|) + (PROG () + (RETURN + (COND + ((NULL |l|) (- 1)) + ((EQUAL |x| (CAR |l|)) |n|) + ('T (|bfPosn| |x| (CDR |l|) (+ |n| 1))))))) + +(DEFUN |bfISApplication| (|op| |left| |right|) + (PROG () + (RETURN + (COND + ((EQ |op| 'IS) (|bfIS| |left| |right|)) + ((EQ |op| 'ISNT) (|bfNOT| (|bfIS| |left| |right|))) + ('T (LIST |op| |left| |right|)))))) + +(DEFUN |bfIS| (|left| |right|) + (PROG (|$inDefIS| |$isGenVarCounter|) + (DECLARE (SPECIAL |$inDefIS| |$isGenVarCounter|)) + (RETURN + (PROGN + (SETQ |$isGenVarCounter| 1) + (SETQ |$inDefIS| T) + (|bfIS1| |left| |right|))))) + +(DEFUN |bfISReverse| (|x| |a|) + (PROG (|y|) + (RETURN + (COND + ((AND (CONSP |x|) (EQ (CAR |x|) 'CONS)) + (COND + ((NULL (CADDR |x|)) (LIST 'CONS (CADR |x|) |a|)) + (#0='T + (PROGN + (SETQ |y| (|bfISReverse| (CADDR |x|) NIL)) + (RPLACA (CDDR |y|) (LIST 'CONS (CADR |x|) |a|)) + |y|)))) + (#0# + (PROGN + (|bpSpecificErrorHere| "Error in bfISReverse") + (|bpTrap|))))))) + +(DEFUN |bfIS1| (|lhs| |rhs|) + (PROG (|l2| |rev| |patrev| |cls| |b1| |a1| |b| |g| |l| |d| |ISTMP#2| + |c| |a| |ISTMP#1|) + (DECLARE (SPECIAL |$isGenVarCounter|)) + (RETURN + (COND + ((NULL |rhs|) (LIST 'NULL |lhs|)) + ((STRINGP |rhs|) (LIST 'EQ |lhs| (LIST 'QUOTE (INTERN |rhs|)))) + ((NUMBERP |rhs|) (LIST 'EQUAL |lhs| |rhs|)) + ((ATOM |rhs|) (LIST 'PROGN (|bfLetForm| |rhs| |lhs|) ''T)) + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'QUOTE) + (PROGN + (SETQ |ISTMP#1| (CDR |rhs|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0='T)))) + (COND + ((IDENTP |a|) (LIST 'EQ |lhs| |rhs|)) + (#1='T (LIST 'EQUAL |lhs| |rhs|)))) + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'L%T) + (PROGN + (SETQ |ISTMP#1| (CDR |rhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |c| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |d| (CAR |ISTMP#2|)) #0#)))))) + (PROGN + (SETQ |l| (|bfLET| |c| |lhs|)) + (|bfAND| (LIST (|bfIS1| |lhs| |d|) + (|bfMKPROGN| (LIST |l| ''T)))))) + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'EQUAL) + (PROGN + (SETQ |ISTMP#1| (CDR |rhs|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0#)))) + (LIST 'EQUAL |lhs| |a|)) + ((CONSP |lhs|) + (PROGN + (SETQ |g| + (INTERN (CONCAT "ISTMP#" + (STRINGIMAGE |$isGenVarCounter|)))) + (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1)) + (|bfMKPROGN| + (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|))))) + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'CONS) + (PROGN + (SETQ |ISTMP#1| (CDR |rhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |a| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |b| (CAR |ISTMP#2|)) #0#)))))) + (COND + ((EQ |a| 'DOT) + (COND + ((NULL |b|) + (|bfAND| (LIST (LIST 'CONSP |lhs|) + (LIST 'EQ (LIST 'CDR |lhs|) 'NIL)))) + (#1# + (|bfAND| (LIST (LIST 'CONSP |lhs|) + (|bfIS1| (LIST 'CDR |lhs|) |b|)))))) + ((NULL |b|) + (|bfAND| (LIST (LIST 'CONSP |lhs|) + (LIST 'EQ (LIST 'CDR |lhs|) 'NIL) + (|bfIS1| (LIST 'CAR |lhs|) |a|)))) + ((EQ |b| 'DOT) + (|bfAND| (LIST (LIST 'CONSP |lhs|) + (|bfIS1| (LIST 'CAR |lhs|) |a|)))) + (#1# + (PROGN + (SETQ |a1| (|bfIS1| (LIST 'CAR |lhs|) |a|)) + (SETQ |b1| (|bfIS1| (LIST 'CDR |lhs|) |b|)) + (COND + ((AND (CONSP |a1|) (EQ (CAR |a1|) 'PROGN) + (PROGN + (SETQ |ISTMP#1| (CDR |a1|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |c| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (EQUAL (CAR |ISTMP#2|) ''T))))) + (CONSP |b1|) (EQ (CAR |b1|) 'PROGN) + (PROGN (SETQ |cls| (CDR |b1|)) #0#)) + (|bfAND| (LIST (LIST 'CONSP |lhs|) + (|bfMKPROGN| (CONS |c| |cls|))))) + (#1# (|bfAND| (LIST (LIST 'CONSP |lhs|) |a1| |b1|)))))))) + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'APPEND) + (PROGN + (SETQ |ISTMP#1| (CDR |rhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |a| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |b| (CAR |ISTMP#2|)) #0#)))))) + (PROGN + (SETQ |patrev| (|bfISReverse| |b| |a|)) + (SETQ |g| + (INTERN (CONCAT "ISTMP#" + (STRINGIMAGE |$isGenVarCounter|)))) + (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1)) + (SETQ |rev| + (|bfAND| (LIST (LIST 'CONSP |lhs|) + (LIST 'PROGN + (LIST 'L%T |g| + (LIST 'REVERSE |lhs|)) + ''T)))) + (SETQ |l2| (|bfIS1| |g| |patrev|)) + (COND + ((AND (CONSP |l2|) (ATOM (CAR |l2|))) + (SETQ |l2| (CONS |l2| NIL)))) + (COND + ((EQ |a| 'DOT) (|bfAND| (CONS |rev| |l2|))) + (#1# + (|bfAND| (CONS |rev| + (APPEND |l2| + (CONS + (LIST 'PROGN + (|bfLetForm| |a| + (LIST 'NREVERSE |a|)) + ''T) + NIL)))))))) + (#1# + (PROGN + (|bpSpecificErrorHere| "bad IS code is generated") + (|bpTrap|))))))) + +(DEFUN |bfApplication| (|bfop| |bfarg|) + (PROG () + (RETURN + (COND + ((|bfTupleP| |bfarg|) (CONS |bfop| (CDR |bfarg|))) + ('T (CONS |bfop| (LIST |bfarg|))))))) + +(DEFUN |bfGetOldBootName| (|x|) + (PROG (|a|) + (RETURN + (COND ((SETQ |a| (GET |x| 'OLD-BOOT)) (CAR |a|)) ('T |x|))))) + +(DEFUN |bfSameMeaning| (|x|) (PROG () (RETURN (GET |x| 'RENAME-OK)))) + +(DEFUN |bfReName| (|x|) + (PROG (|oldName| |newName| |a|) + (DECLARE (SPECIAL |$translatingOldBoot|)) + (RETURN + (PROGN + (SETQ |newName| + (COND + ((SETQ |a| (GET |x| 'SHOERENAME)) (CAR |a|)) + (#0='T |x|))) + (COND + ((AND |$translatingOldBoot| (NULL (|bfSameMeaning| |x|))) + (PROGN + (SETQ |oldName| (|bfGetOldBootName| |x|)) + (COND + ((NOT (EQUAL |newName| |oldName|)) + (|warn| (LIST (PNAME |x|) " as `" (PNAME |newName|) + "' differs from Old Boot `" + (PNAME |oldName|) "'")))) + |oldName|)) + (#0# |newName|)))))) + +(DEFUN |bfInfApplication| (|op| |left| |right|) + (PROG () + (RETURN + (COND + ((EQ |op| 'EQUAL) (|bfQ| |left| |right|)) + ((EQ |op| '/=) (|bfNOT| (|bfQ| |left| |right|))) + ((EQ |op| '>) (|bfLessp| |right| |left|)) + ((EQ |op| '<) (|bfLessp| |left| |right|)) + ((EQ |op| '<=) (|bfNOT| (|bfLessp| |right| |left|))) + ((EQ |op| '>=) (|bfNOT| (|bfLessp| |left| |right|))) + ((EQ |op| 'OR) (|bfOR| (LIST |left| |right|))) + ((EQ |op| 'AND) (|bfAND| (LIST |left| |right|))) + ('T (LIST |op| |left| |right|)))))) + +(DEFUN |bfNOT| (|x|) + (PROG (|a| |ISTMP#1|) + (RETURN + (COND + ((AND (CONSP |x|) (EQ (CAR |x|) 'NOT) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0='T)))) + |a|) + ((AND (CONSP |x|) (EQ (CAR |x|) 'NULL) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0#)))) + |a|) + ('T (LIST 'NOT |x|)))))) + +(DEFUN |bfFlatten| (|op| |x|) + (PROG () + (RETURN (COND ((EQCAR |x| |op|) (CDR |x|)) ('T (LIST |x|)))))) + +(DEFUN |bfOR| (|l|) + (PROG () + (RETURN + (COND + ((NULL |l|) NIL) + ((NULL (CDR |l|)) (CAR |l|)) + ('T + (CONS 'OR + (LET ((|bfVar#83| NIL) (|bfVar#82| |l|) (|c| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#82|) + (PROGN (SETQ |c| (CAR |bfVar#82|)) NIL)) + (RETURN (NREVERSE |bfVar#83|))) + ('T + (SETQ |bfVar#83| + (APPEND (REVERSE (|bfFlatten| 'OR |c|)) + |bfVar#83|)))) + (SETQ |bfVar#82| (CDR |bfVar#82|)))))))))) + +(DEFUN |bfAND| (|l|) + (PROG () + (RETURN + (COND + ((NULL |l|) 'T) + ((NULL (CDR |l|)) (CAR |l|)) + ('T + (CONS 'AND + (LET ((|bfVar#85| NIL) (|bfVar#84| |l|) (|c| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#84|) + (PROGN (SETQ |c| (CAR |bfVar#84|)) NIL)) + (RETURN (NREVERSE |bfVar#85|))) + ('T + (SETQ |bfVar#85| + (APPEND (REVERSE (|bfFlatten| 'AND |c|)) + |bfVar#85|)))) + (SETQ |bfVar#84| (CDR |bfVar#84|)))))))))) + +(DEFUN |defQuoteId| (|x|) + (PROG () (RETURN (AND (EQCAR |x| 'QUOTE) (IDENTP (CADR |x|)))))) + +(DEFUN |bfSmintable| (|x|) + (PROG () + (RETURN + (OR (INTEGERP |x|) + (AND (CONSP |x|) (MEMQ (CAR |x|) '(SIZE LENGTH))))))) + +(DEFUN |bfQ| (|l| |r|) + (PROG () + (RETURN + (COND + ((OR (|bfSmintable| |l|) (|bfSmintable| |r|)) + (LIST 'EQL |l| |r|)) + ((OR (|defQuoteId| |l|) (|defQuoteId| |r|)) (LIST 'EQ |l| |r|)) + ((NULL |l|) (LIST 'NULL |r|)) + ((NULL |r|) (LIST 'NULL |l|)) + ('T (LIST 'EQUAL |l| |r|)))))) + +(DEFUN |bfLessp| (|l| |r|) + (PROG () + (RETURN + (COND ((EQL |r| 0) (LIST 'MINUSP |l|)) ('T (LIST '< |l| |r|)))))) + +(DEFUN |bfMDef| (|defOp| |op| |args| |body|) + (PROG (|def| |lamex| |sb2| |sb| |largl| |nargl| |sgargl| |gargl| + |LETTMP#1| |argl|) + (DECLARE (SPECIAL |$wheredefs|)) + (RETURN + (PROGN + (SETQ |argl| + (COND + ((|bfTupleP| |args|) (CDR |args|)) + ('T (LIST |args|)))) + (SETQ |LETTMP#1| (|bfGargl| |argl|)) + (SETQ |gargl| (CAR |LETTMP#1|)) + (SETQ |sgargl| (CADR . #0=(|LETTMP#1|))) + (SETQ |nargl| (CADDR . #0#)) + (SETQ |largl| (CADDDR . #0#)) + (SETQ |sb| + (LET ((|bfVar#88| NIL) (|bfVar#86| |nargl|) (|i| NIL) + (|bfVar#87| |sgargl|) (|j| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#86|) + (PROGN (SETQ |i| (CAR |bfVar#86|)) NIL) + (ATOM |bfVar#87|) + (PROGN (SETQ |j| (CAR |bfVar#87|)) NIL)) + (RETURN (NREVERSE |bfVar#88|))) + (#1='T + (SETQ |bfVar#88| (CONS (CONS |i| |j|) |bfVar#88|)))) + (SETQ |bfVar#86| (CDR |bfVar#86|)) + (SETQ |bfVar#87| (CDR |bfVar#87|))))) + (SETQ |body| (SUBLIS |sb| |body|)) + (SETQ |sb2| + (LET ((|bfVar#91| NIL) (|bfVar#89| |sgargl|) (|i| NIL) + (|bfVar#90| |largl|) (|j| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#89|) + (PROGN (SETQ |i| (CAR |bfVar#89|)) NIL) + (ATOM |bfVar#90|) + (PROGN (SETQ |j| (CAR |bfVar#90|)) NIL)) + (RETURN (NREVERSE |bfVar#91|))) + (#1# + (SETQ |bfVar#91| + (CONS (LIST 'CONS (LIST 'QUOTE |i|) |j|) + |bfVar#91|)))) + (SETQ |bfVar#89| (CDR |bfVar#89|)) + (SETQ |bfVar#90| (CDR |bfVar#90|))))) + (SETQ |body| + (LIST 'SUBLIS (CONS 'LIST |sb2|) (LIST 'QUOTE |body|))) + (SETQ |lamex| (LIST 'MLAMBDA |gargl| |body|)) + (SETQ |def| (LIST |op| |lamex|)) + (|bfTuple| + (CONS (|shoeComp| |def|) + (LET ((|bfVar#93| NIL) (|bfVar#92| |$wheredefs|) + (|d| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#92|) + (PROGN (SETQ |d| (CAR |bfVar#92|)) NIL)) + (RETURN (NREVERSE |bfVar#93|))) + (#1# + (SETQ |bfVar#93| + (APPEND (REVERSE + (|shoeComps| (|bfDef1| |d|))) + |bfVar#93|)))) + (SETQ |bfVar#92| (CDR |bfVar#92|)))))))))) + +(DEFUN |bfGargl| (|argl|) + (PROG (|f| |d| |c| |b| |a| |LETTMP#1|) + (RETURN + (COND + ((NULL |argl|) (LIST NIL NIL NIL NIL)) + (#0='T (SETQ |LETTMP#1| (|bfGargl| (CDR |argl|))) + (SETQ |a| (CAR |LETTMP#1|)) + (SETQ |b| (CADR . #1=(|LETTMP#1|))) (SETQ |c| (CADDR . #1#)) + (SETQ |d| (CADDDR . #1#)) + (COND + ((EQ (CAR |argl|) '&REST) + (LIST (CONS (CAR |argl|) |b|) |b| |c| + (CONS (LIST 'CONS (LIST 'QUOTE 'LIST) (CAR |d|)) + (CDR |d|)))) + (#0# (SETQ |f| (|bfGenSymbol|)) + (LIST (CONS |f| |a|) (CONS |f| |b|) (CONS (CAR |argl|) |c|) + (CONS |f| |d|))))))))) + +(DEFUN |bfDef1| (|bfVar#94|) + (PROG (|arglp| |control| |quotes| |LETTMP#1| |argl| |body| |args| + |op| |defOp|) + (RETURN + (PROGN + (SETQ |defOp| (CAR |bfVar#94|)) + (SETQ |op| (CADR . #0=(|bfVar#94|))) + (SETQ |args| (CADDR . #0#)) + (SETQ |body| (CADDDR . #0#)) + (SETQ |argl| + (COND + ((|bfTupleP| |args|) (CDR |args|)) + ('T (LIST |args|)))) + (SETQ |LETTMP#1| (|bfInsertLet| |argl| |body|)) + (SETQ |quotes| (CAR |LETTMP#1|)) + (SETQ |control| (CADR . #1=(|LETTMP#1|))) + (SETQ |arglp| (CADDR . #1#)) + (SETQ |body| (CADDDR . #1#)) + (COND + (|quotes| (|shoeLAM| |op| |arglp| |control| |body|)) + ('T (LIST (LIST |op| (LIST 'LAMBDA |arglp| |body|))))))))) + +(DEFUN |shoeLAM| (|op| |args| |control| |body|) + (PROG (|innerfunc| |margs|) + (RETURN + (PROGN + (SETQ |margs| (|bfGenSymbol|)) + (SETQ |innerfunc| (INTERN (CONCAT (PNAME |op|) '|,LAM|))) + (LIST (LIST |innerfunc| (LIST 'LAMBDA |args| |body|)) + (LIST |op| + (LIST 'MLAMBDA (LIST '&REST |margs|) + (LIST 'CONS (LIST 'QUOTE |innerfunc|) + (LIST 'WRAP |margs| + (LIST 'QUOTE |control|)))))))))) + +(DEFUN |bfDef| (|defOp| |op| |args| |body|) + (PROG (|body1| |arg1| |op1| |LETTMP#1|) + (DECLARE (SPECIAL |$wheredefs| |$bfClamming|)) + (RETURN + (COND + (|$bfClamming| + (PROGN + (SETQ |LETTMP#1| + (|shoeComp| + (CAR (|bfDef1| + (LIST |defOp| |op| |args| |body|))))) + (SETQ |op1| (CADR . #0=(|LETTMP#1|))) + (SETQ |arg1| (CADDR . #0#)) + (SETQ |body1| (CDDDR . #0#)) + (|bfCompHash| |op1| |arg1| |body1|))) + ('T + (|bfTuple| + (LET ((|bfVar#96| NIL) + (|bfVar#95| + (CONS (LIST |defOp| |op| |args| |body|) + |$wheredefs|)) + (|d| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#95|) + (PROGN (SETQ |d| (CAR |bfVar#95|)) NIL)) + (RETURN (NREVERSE |bfVar#96|))) + ('T + (SETQ |bfVar#96| + (APPEND (REVERSE (|shoeComps| (|bfDef1| |d|))) + |bfVar#96|)))) + (SETQ |bfVar#95| (CDR |bfVar#95|)))))))))) + +(DEFUN |shoeComps| (|x|) + (PROG () + (RETURN + (LET ((|bfVar#98| NIL) (|bfVar#97| |x|) (|def| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#97|) + (PROGN (SETQ |def| (CAR |bfVar#97|)) NIL)) + (RETURN (NREVERSE |bfVar#98|))) + ('T (SETQ |bfVar#98| (CONS (|shoeComp| |def|) |bfVar#98|)))) + (SETQ |bfVar#97| (CDR |bfVar#97|))))))) + +(DEFUN |shoeComp| (|x|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|shoeCompTran| (CADR |x|))) + (COND + ((EQCAR |a| 'LAMBDA) + (CONS 'DEFUN (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|))))) + ('T + (CONS 'DEFMACRO + (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|)))))))))) + +(DEFUN |bfInsertLet| (|x| |body|) + (PROG (|body2| |name2| |norq1| |b1| |body1| |name1| |norq| |LETTMP#1| + |b| |a| |ISTMP#1|) + (RETURN + (COND + ((NULL |x|) (LIST NIL NIL |x| |body|)) + ((AND (CONSP |x|) (EQ (CAR |x|) '&REST) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0='T)))) + (COND + ((AND (CONSP |a|) (EQ (CAR |a|) 'QUOTE) + (PROGN + (SETQ |ISTMP#1| (CDR |a|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |b| (CAR |ISTMP#1|)) #0#)))) + (LIST T 'QUOTE (LIST '&REST |b|) |body|)) + (#1='T (LIST NIL NIL |x| |body|)))) + (#1# (SETQ |LETTMP#1| (|bfInsertLet1| (CAR |x|) |body|)) + (SETQ |b| (CAR |LETTMP#1|)) + (SETQ |norq| (CADR . #2=(|LETTMP#1|))) + (SETQ |name1| (CADDR . #2#)) (SETQ |body1| (CADDDR . #2#)) + (SETQ |LETTMP#1| (|bfInsertLet| (CDR |x|) |body1|)) + (SETQ |b1| (CAR |LETTMP#1|)) + (SETQ |norq1| (CADR . #3=(|LETTMP#1|))) + (SETQ |name2| (CADDR . #3#)) (SETQ |body2| (CADDDR . #3#)) + (LIST (OR |b| |b1|) (CONS |norq| |norq1|) + (CONS |name1| |name2|) |body2|)))))) + +(DEFUN |bfInsertLet1| (|y| |body|) + (PROG (|g| |b| |r| |ISTMP#2| |l| |ISTMP#1|) + (RETURN + (COND + ((AND (CONSP |y|) (EQ (CAR |y|) 'L%T) + (PROGN + (SETQ |ISTMP#1| (CDR |y|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |l| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |r| (CAR |ISTMP#2|)) #0='T)))))) + (LIST NIL NIL |l| + (|bfMKPROGN| (LIST (|bfLET| |r| |l|) |body|)))) + ((IDENTP |y|) (LIST NIL NIL |y| |body|)) + ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE) + (PROGN + (SETQ |ISTMP#1| (CDR |y|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |b| (CAR |ISTMP#1|)) #0#)))) + (LIST T 'QUOTE |b| |body|)) + ('T (SETQ |g| (|bfGenSymbol|)) + (COND + ((ATOM |y|) (LIST NIL NIL |g| |body|)) + ('T + (LIST NIL NIL |g| + (|bfMKPROGN| + (LIST (|bfLET| (|compFluidize| |y|) |g|) |body|)))))))))) + +(DEFUN |shoeCompTran| (|x|) + (PROG (|$dollarVars| |$locVars| |$fluidVars| |fvs| |fl| |fvars| + |lvars| |body| |args| |lamtype|) + (DECLARE (SPECIAL |$typings| |$dollarVars| |$fluidVars| |$locVars|)) + (RETURN + (PROGN + (SETQ |lamtype| (CAR |x|)) + (SETQ |args| (CADR |x|)) + (SETQ |body| (CDDR |x|)) + (SETQ |$fluidVars| NIL) + (SETQ |$locVars| NIL) + (SETQ |$dollarVars| NIL) + (|shoeCompTran1| |body|) + (SETQ |$locVars| + (SETDIFFERENCE (SETDIFFERENCE |$locVars| |$fluidVars|) + (|shoeATOMs| |args|))) + (SETQ |body| + (COND + ((OR |$fluidVars| |$locVars| |$dollarVars| |$typings|) + (SETQ |lvars| (APPEND |$fluidVars| |$locVars|)) + (SETQ |$fluidVars| (UNION |$fluidVars| |$dollarVars|)) + (COND + ((NULL |$fluidVars|) + (COND + ((NULL |$typings|) (|shoePROG| |lvars| |body|)) + (#0='T + (|shoePROG| |lvars| + (CONS (CONS 'DECLARE |$typings|) |body|))))) + (#1='T + (SETQ |fvars| + (LIST 'DECLARE (CONS 'SPECIAL |$fluidVars|))) + (COND + ((NULL |$typings|) + (|shoePROG| |lvars| (CONS |fvars| |body|))) + (#0# + (|shoePROG| |lvars| + (CONS |fvars| + (CONS (CONS 'DECLARE |$typings|) + |body|)))))))) + (#1# (|shoePROG| NIL |body|)))) + (SETQ |fl| (|shoeFluids| |args|)) + (SETQ |body| + (COND + (|fl| (SETQ |fvs| (LIST 'DECLARE (CONS 'SPECIAL |fl|))) + (CONS |fvs| |body|)) + (#1# |body|))) + (CONS |lamtype| (CONS |args| |body|)))))) + +(DEFUN |shoePROG| (|v| |b|) + (PROG (|blist| |blast| |LETTMP#1|) + (RETURN + (COND + ((NULL |b|) (LIST (LIST 'PROG |v|))) + ('T + (PROGN + (SETQ |LETTMP#1| (REVERSE |b|)) + (SETQ |blast| (CAR |LETTMP#1|)) + (SETQ |blist| (NREVERSE (CDR |LETTMP#1|))) + (LIST (CONS 'PROG + (CONS |v| + (APPEND |blist| + (CONS (LIST 'RETURN |blast|) NIL))))))))))) + +(DEFUN |shoeFluids| (|x|) + (PROG () + (RETURN + (COND + ((NULL |x|) NIL) + ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) (LIST |x|)) + ((EQCAR |x| 'QUOTE) NIL) + ((ATOM |x|) NIL) + ('T (APPEND (|shoeFluids| (CAR |x|)) (|shoeFluids| (CDR |x|)))))))) + +(DEFUN |shoeATOMs| (|x|) + (PROG () + (RETURN + (COND + ((NULL |x|) NIL) + ((ATOM |x|) (LIST |x|)) + ('T (APPEND (|shoeATOMs| (CAR |x|)) (|shoeATOMs| (CDR |x|)))))))) + +(DEFUN |shoeCompTran1| (|x|) + (PROG (|res| |newbindings| |r| |ISTMP#2| |l| |ISTMP#1| U) + (DECLARE (SPECIAL |$fluidVars| |$locVars| |$dollarVars|)) + (RETURN + (COND + ((ATOM |x|) + (COND + ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) + (SETQ |$dollarVars| + (COND + ((MEMQ |x| |$dollarVars|) |$dollarVars|) + (#0='T (CONS |x| |$dollarVars|))))) + (#0# NIL))) + (#0# + (PROGN + (SETQ U (CAR |x|)) + (COND + ((EQ U 'QUOTE) NIL) + ((AND (CONSP |x|) (EQ (CAR |x|) 'L%T) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |l| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |r| (CAR |ISTMP#2|)) 'T)))))) + (PROGN + (RPLACA |x| 'SETQ) + (|shoeCompTran1| |r|) + (COND + ((IDENTP |l|) + (COND + ((NULL (|bfBeginsDollar| |l|)) + (SETQ |$locVars| + (COND + ((MEMQ |l| |$locVars|) |$locVars|) + (#0# (CONS |l| |$locVars|))))) + (#0# + (SETQ |$dollarVars| + (COND + ((MEMQ |l| |$dollarVars|) |$dollarVars|) + (#0# (CONS |l| |$dollarVars|))))))) + ((EQCAR |l| 'FLUID) + (PROGN + (SETQ |$fluidVars| + (COND + ((MEMQ (CADR |l|) |$fluidVars|) + |$fluidVars|) + (#0# (CONS (CADR |l|) |$fluidVars|)))) + (RPLACA (CDR |x|) (CADR |l|))))))) + ((MEMQ U '(PROG LAMBDA)) + (PROGN + (SETQ |newbindings| NIL) + (LET ((|bfVar#99| (CADR |x|)) (|y| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#99|) + (PROGN (SETQ |y| (CAR |bfVar#99|)) NIL)) + (RETURN NIL)) + (#1='T + (COND + ((NULL (MEMQ |y| |$locVars|)) + (IDENTITY + (PROGN + (SETQ |$locVars| (CONS |y| |$locVars|)) + (SETQ |newbindings| + (CONS |y| |newbindings|)))))))) + (SETQ |bfVar#99| (CDR |bfVar#99|)))) + (SETQ |res| (|shoeCompTran1| (CDDR |x|))) + (SETQ |$locVars| + (LET ((|bfVar#101| NIL) (|bfVar#100| |$locVars|) + (|y| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#100|) + (PROGN + (SETQ |y| (CAR |bfVar#100|)) + NIL)) + (RETURN (NREVERSE |bfVar#101|))) + (#1# + (AND (NULL (MEMQ |y| |newbindings|)) + (SETQ |bfVar#101| + (CONS |y| |bfVar#101|))))) + (SETQ |bfVar#100| (CDR |bfVar#100|))))))) + (#0# + (PROGN + (|shoeCompTran1| (CAR |x|)) + (|shoeCompTran1| (CDR |x|))))))))))) + +(DEFUN |bfTagged| (|a| |b|) + (PROG () + (DECLARE (SPECIAL |$typings|)) + (RETURN + (COND + ((IDENTP |a|) + (COND + ((EQ |b| 'FLUID) (|bfLET| (|compFluid| |a|) NIL)) + ((EQ |b| '|fluid|) (|bfLET| (|compFluid| |a|) NIL)) + ((EQ |b| '|local|) (|bfLET| (|compFluid| |a|) NIL)) + (#0='T + (PROGN + (SETQ |$typings| (CONS (LIST 'TYPE |b| |a|) |$typings|)) + |a|)))) + (#0# (LIST 'THE |b| |a|)))))) + +(DEFUN |bfAssign| (|l| |r|) + (PROG () + (RETURN + (COND + ((|bfTupleP| |l|) (|bfSetelt| (CADR |l|) (CDDR |l|) |r|)) + ('T (|bfLET| |l| |r|)))))) + +(DEFUN |bfSetelt| (|e| |l| |r|) + (PROG () + (RETURN + (COND + ((NULL (CDR |l|)) (|defSETELT| |e| (CAR |l|) |r|)) + ('T (|bfSetelt| (|bfElt| |e| (CAR |l|)) (CDR |l|) |r|)))))) + +(DEFUN |bfElt| (|expr| |sel|) + (PROG (|y|) + (RETURN + (PROGN + (SETQ |y| (AND (SYMBOLP |sel|) (GET |sel| 'SHOESELFUNCTION))) + (COND + (|y| (COND + ((INTEGERP |y|) (LIST 'ELT |expr| |y|)) + (#0='T (LIST |y| |expr|)))) + (#0# (LIST 'ELT |expr| |sel|))))))) + +(DEFUN |defSETELT| (|var| |sel| |expr|) + (PROG (|y|) + (RETURN + (PROGN + (SETQ |y| (AND (SYMBOLP |sel|) (GET |sel| 'SHOESELFUNCTION))) + (COND + (|y| (COND + ((INTEGERP |y|) + (LIST 'SETF (LIST 'ELT |var| |y|) |expr|)) + (#0='T (LIST 'SETF (LIST |y| |var|) |expr|)))) + (#0# (LIST 'SETF (LIST 'ELT |var| |sel|) |expr|))))))) + +(DEFUN |bfIfThenOnly| (|a| |b|) + (PROG (|b1|) + (RETURN + (PROGN + (SETQ |b1| + (COND ((EQCAR |b| 'PROGN) (CDR |b|)) ('T (LIST |b|)))) + (LIST 'COND (CONS |a| |b1|)))))) + +(DEFUN |bfIf| (|a| |b| |c|) + (PROG (|c1| |b1|) + (RETURN + (PROGN + (SETQ |b1| + (COND ((EQCAR |b| 'PROGN) (CDR |b|)) (#0='T (LIST |b|)))) + (COND + ((EQCAR |c| 'COND) + (CONS 'COND (CONS (CONS |a| |b1|) (CDR |c|)))) + ('T + (PROGN + (SETQ |c1| + (COND + ((EQCAR |c| 'PROGN) (CDR |c|)) + (#0# (LIST |c|)))) + (LIST 'COND (CONS |a| |b1|) (CONS ''T |c1|))))))))) + +(DEFUN |bfExit| (|a| |b|) + (PROG () (RETURN (LIST 'COND (LIST |a| (LIST 'IDENTITY |b|)))))) + +(DEFUN |bfMKPROGN| (|l|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| + (LET ((|bfVar#102| NIL) (|c| |l|)) + (LOOP + (COND + ((ATOM |c|) (RETURN (NREVERSE |bfVar#102|))) + ('T + (SETQ |bfVar#102| + (APPEND (REVERSE (|bfFlattenSeq| |c|)) + |bfVar#102|)))) + (SETQ |c| (CDR |c|))))) + (COND + ((NULL |a|) NIL) + ((NULL (CDR |a|)) (CAR |a|)) + ('T (CONS 'PROGN |a|))))))) + +(DEFUN |bfFlattenSeq| (|x|) + (PROG (|f|) + (RETURN + (COND + ((NULL |x|) NIL) + (#0='T + (PROGN + (SETQ |f| (CAR |x|)) + (COND + ((ATOM |f|) (COND ((CDR |x|) NIL) ('T (LIST |f|)))) + ((EQCAR |f| 'PROGN) + (COND + ((CDR |x|) + (LET ((|bfVar#104| NIL) (|bfVar#103| (CDR |f|)) + (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#103|) + (PROGN (SETQ |i| (CAR |bfVar#103|)) NIL)) + (RETURN (NREVERSE |bfVar#104|))) + ('T + (AND (NULL (ATOM |i|)) + (SETQ |bfVar#104| (CONS |i| |bfVar#104|))))) + (SETQ |bfVar#103| (CDR |bfVar#103|))))) + (#0# (CDR |f|)))) + (#0# (LIST |f|))))))))) + +(DEFUN |bfSequence| (|l|) + (PROG (|f| |aft| |before| |no| |transform| |b| |ISTMP#5| |ISTMP#4| + |ISTMP#3| |a| |ISTMP#2| |ISTMP#1|) + (RETURN + (COND + ((NULL |l|) NIL) + (#0='T + (PROGN + (SETQ |transform| + (LET ((|bfVar#106| NIL) (|bfVar#105| |l|) (|x| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#105|) + (PROGN (SETQ |x| (CAR |bfVar#105|)) NIL) + (NOT (AND (CONSP |x|) (EQ (CAR |x|) 'COND) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (EQ (CDR |ISTMP#1|) NIL) + (PROGN + (SETQ |ISTMP#2| + (CAR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |a| + (CAR |ISTMP#2|)) + (SETQ |ISTMP#3| + (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CDR |ISTMP#3|) NIL) + (PROGN + (SETQ |ISTMP#4| + (CAR |ISTMP#3|)) + (AND (CONSP |ISTMP#4|) + (EQ (CAR |ISTMP#4|) + 'IDENTITY) + (PROGN + (SETQ |ISTMP#5| + (CDR |ISTMP#4|)) + (AND + (CONSP |ISTMP#5|) + (EQ + (CDR |ISTMP#5|) + NIL) + (PROGN + (SETQ |b| + (CAR |ISTMP#5|)) + 'T)))))))))))))) + (RETURN (NREVERSE |bfVar#106|))) + ('T + (SETQ |bfVar#106| + (CONS (LIST |a| |b|) |bfVar#106|)))) + (SETQ |bfVar#105| (CDR |bfVar#105|))))) + (SETQ |no| (LENGTH |transform|)) + (SETQ |before| (|bfTake| |no| |l|)) + (SETQ |aft| (|bfDrop| |no| |l|)) + (COND + ((NULL |before|) + (COND + ((NULL (CDR |l|)) + (PROGN + (SETQ |f| (CAR |l|)) + (COND + ((EQCAR |f| 'PROGN) (|bfSequence| (CDR |f|))) + ('T |f|)))) + (#0# + (|bfMKPROGN| + (LIST (CAR |l|) (|bfSequence| (CDR |l|))))))) + ((NULL |aft|) (CONS 'COND |transform|)) + (#0# + (CONS 'COND + (APPEND |transform| + (CONS (LIST ''T (|bfSequence| |aft|)) NIL))))))))))) + +(DEFUN |bfWhere| (|context| |expr|) + (PROG (|a| |body| |ISTMP#3| |args| |ISTMP#2| |op| |ISTMP#1| |def| + |nondefs| |defs| |opassoc| |LETTMP#1|) + (DECLARE (SPECIAL |$wheredefs|)) + (RETURN + (PROGN + (SETQ |LETTMP#1| (|defSheepAndGoats| |context|)) + (SETQ |opassoc| (CAR |LETTMP#1|)) + (SETQ |defs| (CADR . #0=(|LETTMP#1|))) + (SETQ |nondefs| (CADDR . #0#)) + (SETQ |a| + (LET ((|bfVar#108| NIL) (|bfVar#107| |defs|) (|d| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#107|) + (PROGN (SETQ |d| (CAR |bfVar#107|)) NIL)) + (RETURN (NREVERSE |bfVar#108|))) + ('T + (AND (CONSP |d|) + (PROGN + (SETQ |def| (CAR |d|)) + (SETQ |ISTMP#1| (CDR |d|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |op| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |args| (CAR |ISTMP#2|)) + (SETQ |ISTMP#3| (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CDR |ISTMP#3|) NIL) + (PROGN + (SETQ |body| (CAR |ISTMP#3|)) + 'T))))))) + (SETQ |bfVar#108| + (CONS (LIST |def| |op| |args| + (|bfSUBLIS| |opassoc| |body|)) + |bfVar#108|))))) + (SETQ |bfVar#107| (CDR |bfVar#107|))))) + (SETQ |$wheredefs| (APPEND |a| |$wheredefs|)) + (|bfMKPROGN| + (|bfSUBLIS| |opassoc| (NCONC |nondefs| (LIST |expr|)))))))) + +(DEFUN |bfReadLisp| (|string|) + (PROG () (RETURN (|bfTuple| (|shoeReadLispString| |string| 0))))) + +(DEFUN |bfCompHash| (|op| |argl| |body|) + (PROG (|computeFunction| |auxfn|) + (RETURN + (PROGN + (SETQ |auxfn| (INTERN (CONCAT (PNAME |op|) ";"))) + (SETQ |computeFunction| + (CONS 'DEFUN (CONS |auxfn| (CONS |argl| |body|)))) + (|bfTuple| (CONS |computeFunction| (|bfMain| |auxfn| |op|))))))) + +(DEFUN |shoeCompileTimeEvaluation| (|x|) + (PROG () (RETURN (LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL) |x|)))) + +(DEFUN |shoeEVALANDFILEACTQ| (|x|) + (PROG () + (RETURN (LIST 'EVAL-WHEN (LIST :EXECUTE :LOAD-TOPLEVEL) |x|)))) + +(DEFUN |bfMain| (|auxfn| |op|) + (PROG (|cacheVector| |cacheCountCode| |cacheResetCode| |cacheType| + |mainFunction| |codeBody| |thirdPredPair| |putCode| + |secondPredPair| |getCode| |g2| |cacheName| |computeValue| + |arg| |g1|) + (RETURN + (PROGN + (SETQ |g1| (|bfGenSymbol|)) + (SETQ |arg| (LIST '&REST |g1|)) + (SETQ |computeValue| + (LIST 'APPLY (LIST 'FUNCTION |auxfn|) |g1|)) + (SETQ |cacheName| (INTERN (CONCAT (PNAME |op|) ";AL"))) + (SETQ |g2| (|bfGenSymbol|)) + (SETQ |getCode| (LIST 'GETHASH |g1| |cacheName|)) + (SETQ |secondPredPair| (LIST (LIST 'SETQ |g2| |getCode|) |g2|)) + (SETQ |putCode| (LIST 'SETF |getCode| |computeValue|)) + (SETQ |thirdPredPair| (LIST ''T |putCode|)) + (SETQ |codeBody| + (LIST 'PROG (LIST |g2|) + (LIST 'RETURN + (LIST 'COND |secondPredPair| |thirdPredPair|)))) + (SETQ |mainFunction| (LIST 'DEFUN |op| |arg| |codeBody|)) + (SETQ |cacheType| '|hash-table|) + (SETQ |cacheResetCode| + (LIST 'SETQ |cacheName| + (LIST 'MAKE-HASHTABLE (LIST 'QUOTE 'UEQUAL)))) + (SETQ |cacheCountCode| (LIST '|hashCount| |cacheName|)) + (SETQ |cacheVector| + (LIST |op| |cacheName| |cacheType| |cacheResetCode| + |cacheCountCode|)) + (LIST |mainFunction| + (|shoeEVALANDFILEACTQ| + (LIST 'SETF + (LIST 'GET (LIST 'QUOTE |op|) + (LIST 'QUOTE '|cacheInfo|)) + (LIST 'QUOTE |cacheVector|))) + (|shoeEVALANDFILEACTQ| |cacheResetCode|)))))) + +(DEFUN |bfNameOnly| (|x|) + (PROG () (RETURN (COND ((EQ |x| '|t|) (LIST 'T)) ('T (LIST |x|)))))) + +(DEFUN |bfNameArgs| (|x| |y|) + (PROG () + (RETURN + (PROGN + (SETQ |y| + (COND ((EQCAR |y| 'TUPLE) (CDR |y|)) ('T (LIST |y|)))) + (CONS |x| |y|))))) + +(DEFUN |bfStruct| (|name| |arglist|) + (PROG () + (RETURN + (|bfTuple| + (LET ((|bfVar#110| NIL) (|bfVar#109| |arglist|) (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#109|) + (PROGN (SETQ |i| (CAR |bfVar#109|)) NIL)) + (RETURN (NREVERSE |bfVar#110|))) + ('T + (SETQ |bfVar#110| + (CONS (|bfCreateDef| |i|) |bfVar#110|)))) + (SETQ |bfVar#109| (CDR |bfVar#109|)))))))) + +(DEFUN |bfCreateDef| (|x|) + (PROG (|a| |f|) + (RETURN + (COND + ((NULL (CDR |x|)) (SETQ |f| (CAR |x|)) + (LIST 'SETQ |f| (LIST 'LIST (LIST 'QUOTE |f|)))) + ('T + (SETQ |a| + (LET ((|bfVar#112| NIL) (|bfVar#111| (CDR |x|)) + (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#111|) + (PROGN (SETQ |i| (CAR |bfVar#111|)) NIL)) + (RETURN (NREVERSE |bfVar#112|))) + ('T + (SETQ |bfVar#112| + (CONS (|bfGenSymbol|) |bfVar#112|)))) + (SETQ |bfVar#111| (CDR |bfVar#111|))))) + (LIST 'DEFUN (CAR |x|) |a| + (LIST 'CONS (LIST 'QUOTE (CAR |x|)) (CONS 'LIST |a|)))))))) + +(DEFUN |bfCaseItem| (|x| |y|) (PROG () (RETURN (LIST |x| |y|)))) + +(DEFUN |bfCase| (|x| |y|) + (PROG (|c| |b| |a| |g1| |g|) + (RETURN + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (SETQ |g1| (|bfGenSymbol|)) + (SETQ |a| (|bfLET| |g| |x|)) + (SETQ |b| (|bfLET| |g1| (LIST 'CDR |g|))) + (SETQ |c| (|bfCaseItems| |g1| |y|)) + (|bfMKPROGN| + (LIST |a| |b| (CONS 'CASE (CONS (LIST 'CAR |g|) |c|)))))))) + +(DEFUN |bfCaseItems| (|g| |x|) + (PROG (|j| |ISTMP#1| |i|) + (RETURN + (LET ((|bfVar#115| NIL) (|bfVar#114| |x|) (|bfVar#113| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#114|) + (PROGN (SETQ |bfVar#113| (CAR |bfVar#114|)) NIL)) + (RETURN (NREVERSE |bfVar#115|))) + ('T + (AND (CONSP |bfVar#113|) + (PROGN + (SETQ |i| (CAR |bfVar#113|)) + (SETQ |ISTMP#1| (CDR |bfVar#113|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |j| (CAR |ISTMP#1|)) 'T))) + (SETQ |bfVar#115| + (CONS (|bfCI| |g| |i| |j|) |bfVar#115|))))) + (SETQ |bfVar#114| (CDR |bfVar#114|))))))) + +(DEFUN |bfCI| (|g| |x| |y|) + (PROG (|b| |a|) + (RETURN + (PROGN + (SETQ |a| (CDR |x|)) + (COND + ((NULL |a|) (LIST (CAR |x|) |y|)) + ('T + (SETQ |b| + (LET ((|bfVar#117| NIL) (|bfVar#116| |a|) (|i| NIL) + (|j| 0)) + (LOOP + (COND + ((OR (ATOM |bfVar#116|) + (PROGN (SETQ |i| (CAR |bfVar#116|)) NIL)) + (RETURN (NREVERSE |bfVar#117|))) + ('T + (SETQ |bfVar#117| + (CONS (LIST |i| (|bfCARCDR| |j| |g|)) + |bfVar#117|)))) + (SETQ |bfVar#116| (CDR |bfVar#116|)) + (SETQ |j| (+ |j| 1))))) + (LIST (CAR |x|) (LIST 'LET |b| |y|)))))))) + +(DEFUN |bfCARCDR| (|n| |g|) + (PROG () + (RETURN (LIST (INTERN (CONCAT "CA" (|bfDs| |n|) "R")) |g|)))) + +(DEFUN |bfDs| (|n|) + (PROG () + (RETURN + (COND ((EQL |n| 0) "") ('T (CONCAT "D" (|bfDs| (- |n| 1)))))))) + 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))))) + diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp new file mode 100644 index 00000000..cfc9b0fa --- /dev/null +++ b/src/boot/strap/parser.clisp @@ -0,0 +1,1331 @@ +(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-parser")) + +(IMPORT-MODULE "includer") + +(IMPORT-MODULE "scanner") + +(IMPORT-MODULE "ast") + +(IN-PACKAGE "BOOTTRAN") + +(DEFPARAMETER |$sawParenthesizedHead| NIL) + +(DEFPARAMETER |$bodyHasReturn| NIL) + +(DEFUN |bpFirstToken| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok| |$inputStream|)) + (RETURN + (PROGN + (SETQ |$stok| + (COND + ((NULL |$inputStream|) + (|shoeTokConstruct| 'ERROR 'NOMORE + (|shoeTokPosn| |$stok|))) + ('T (CAR |$inputStream|)))) + (SETQ |$ttok| (|shoeTokPart| |$stok|)) + T)))) + +(DEFUN |bpFirstTok| () + (PROG () + (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$ttok| |$stok| + |$inputStream|)) + (RETURN + (PROGN + (SETQ |$stok| + (COND + ((NULL |$inputStream|) + (|shoeTokConstruct| 'ERROR 'NOMORE + (|shoeTokPosn| |$stok|))) + ('T (CAR |$inputStream|)))) + (SETQ |$ttok| (|shoeTokPart| |$stok|)) + (COND + ((AND (< 0 |$bpParenCount|) (EQCAR |$stok| 'KEY)) + (COND + ((EQ |$ttok| 'SETTAB) + (PROGN (SETQ |$bpCount| (+ |$bpCount| 1)) (|bpNext|))) + ((EQ |$ttok| 'BACKTAB) + (PROGN (SETQ |$bpCount| (- |$bpCount| 1)) (|bpNext|))) + ((EQ |$ttok| 'BACKSET) (|bpNext|)) + (#0='T T))) + (#0# T)))))) + +(DEFUN |bpNext| () + (PROG () + (DECLARE (SPECIAL |$inputStream|)) + (RETURN + (PROGN + (SETQ |$inputStream| (CDR |$inputStream|)) + (|bpFirstTok|))))) + +(DEFUN |bpNextToken| () + (PROG () + (DECLARE (SPECIAL |$inputStream|)) + (RETURN + (PROGN + (SETQ |$inputStream| (CDR |$inputStream|)) + (|bpFirstToken|))))) + +(DEFUN |bpState| () + (PROG () + (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$stack| + |$inputStream|)) + (RETURN (LIST |$inputStream| |$stack| |$bpParenCount| |$bpCount|)))) + +(DEFUN |bpRestore| (|x|) + (PROG () + (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$stack| + |$inputStream|)) + (RETURN + (PROGN + (SETQ |$inputStream| (CAR |x|)) + (|bpFirstToken|) + (SETQ |$stack| (CADR |x|)) + (SETQ |$bpParenCount| (CADDR |x|)) + (SETQ |$bpCount| (CADDDR |x|)) + T)))) + +(DEFUN |bpPush| (|x|) + (PROG () + (DECLARE (SPECIAL |$stack|)) + (RETURN (SETQ |$stack| (CONS |x| |$stack|))))) + +(DEFUN |bpPushId| () + (PROG () + (DECLARE (SPECIAL |$stack| |$ttok|)) + (RETURN (SETQ |$stack| (CONS (|bfReName| |$ttok|) |$stack|))))) + +(DEFUN |bpPop1| () + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (PROGN + (SETQ |a| (CAR |$stack|)) + (SETQ |$stack| (CDR |$stack|)) + |a|)))) + +(DEFUN |bpPop2| () + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (PROGN + (SETQ |a| (CADR |$stack|)) + (RPLACD |$stack| (CDDR |$stack|)) + |a|)))) + +(DEFUN |bpPop3| () + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (PROGN + (SETQ |a| (CADDR |$stack|)) + (RPLACD (CDR |$stack|) (CDDDR |$stack|)) + |a|)))) + +(DEFUN |bpIndentParenthesized| (|f|) + (PROG (|$bpCount| |a|) + (DECLARE (SPECIAL |$inputStream| |$bpCount| |$bpParenCount| + |$stok|)) + (RETURN + (PROGN + (SETQ |$bpCount| 0) + (SETQ |a| |$stok|) + (COND + ((|bpEqPeek| 'OPAREN) + (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) (|bpNext|) + (COND + ((AND (APPLY |f| NIL) (|bpFirstTok|) + (OR (|bpEqPeek| 'CPAREN) (|bpParenTrap| |a|))) + (SETQ |$bpParenCount| (- |$bpParenCount| 1)) + (|bpNextToken|) + (COND + ((EQL |$bpCount| 0) T) + (#0='T + (PROGN + (SETQ |$inputStream| + (APPEND (|bpAddTokens| |$bpCount|) + |$inputStream|)) + (|bpFirstToken|) + (COND + ((EQL |$bpParenCount| 0) (PROGN (|bpCancel|) T)) + (#0# T)))))) + ((|bpEqPeek| 'CPAREN) (|bpPush| (|bfTuple| NIL)) + (SETQ |$bpParenCount| (- |$bpParenCount| 1)) + (|bpNextToken|) T) + (#1='T (|bpParenTrap| |a|)))) + (#1# NIL)))))) + +(DEFUN |bpParenthesized| (|f|) + (PROG (|a|) + (DECLARE (SPECIAL |$stok|)) + (RETURN + (PROGN + (SETQ |a| |$stok|) + (COND + ((|bpEqKey| 'OPAREN) + (COND + ((AND (APPLY |f| NIL) + (OR (|bpEqKey| 'CPAREN) (|bpParenTrap| |a|))) + T) + ((|bpEqKey| 'CPAREN) (|bpPush| (|bfTuple| NIL)) T) + (#0='T (|bpParenTrap| |a|)))) + (#0# NIL)))))) + +(DEFUN |bpBracket| (|f|) + (PROG (|a|) + (DECLARE (SPECIAL |$stok|)) + (RETURN + (PROGN + (SETQ |a| |$stok|) + (COND + ((|bpEqKey| 'OBRACK) + (COND + ((AND (APPLY |f| NIL) + (OR (|bpEqKey| 'CBRACK) (|bpBrackTrap| |a|))) + (|bpPush| (|bfBracket| (|bpPop1|)))) + ((|bpEqKey| 'CBRACK) (|bpPush| NIL)) + (#0='T (|bpBrackTrap| |a|)))) + (#0# NIL)))))) + +(DEFUN |bpPileBracketed| (|f|) + (PROG () + (RETURN + (COND + ((|bpEqKey| 'SETTAB) + (COND + ((|bpEqKey| 'BACKTAB) T) + ((AND (APPLY |f| NIL) + (OR (|bpEqKey| 'BACKTAB) (|bpPileTrap|))) + (|bpPush| (|bfPile| (|bpPop1|)))) + (#0='T NIL))) + (#0# NIL))))) + +(DEFUN |bpListof| (|f| |str1| |g|) + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (COND + ((APPLY |f| NIL) + (COND + ((AND (|bpEqKey| |str1|) (OR (APPLY |f| NIL) (|bpTrap|))) + (SETQ |a| |$stack|) (SETQ |$stack| NIL) + (LOOP + (COND + ((NOT (AND (|bpEqKey| |str1|) + (OR (APPLY |f| NIL) (|bpTrap|)))) + (RETURN NIL)) + ('T 0))) + (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) + (|bpPush| + (FUNCALL |g| + (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) + (#0='T T))) + (#0# NIL))))) + +(DEFUN |bpListofFun| (|f| |h| |g|) + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (COND + ((APPLY |f| NIL) + (COND + ((AND (APPLY |h| NIL) (OR (APPLY |f| NIL) (|bpTrap|))) + (SETQ |a| |$stack|) (SETQ |$stack| NIL) + (LOOP + (COND + ((NOT (AND (APPLY |h| NIL) + (OR (APPLY |f| NIL) (|bpTrap|)))) + (RETURN NIL)) + ('T 0))) + (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) + (|bpPush| + (FUNCALL |g| + (|bfListOf| + (CONS (|bpPop3|) + (CONS (|bpPop2|) (|bpPop1|))))))) + (#0='T T))) + (#0# NIL))))) + +(DEFUN |bpList| (|f| |str1| |g|) + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (COND + ((APPLY |f| NIL) + (COND + ((AND (|bpEqKey| |str1|) (OR (APPLY |f| NIL) (|bpTrap|))) + (SETQ |a| |$stack|) (SETQ |$stack| NIL) + (LOOP + (COND + ((NOT (AND (|bpEqKey| |str1|) + (OR (APPLY |f| NIL) (|bpTrap|)))) + (RETURN NIL)) + ('T 0))) + (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) + (|bpPush| + (FUNCALL |g| + (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) + (#0='T (|bpPush| (FUNCALL |g| (LIST (|bpPop1|))))))) + (#0# (|bpPush| (FUNCALL |g| NIL))))))) + +(DEFUN |bpOneOrMore| (|f|) + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (COND + ((APPLY |f| NIL) + (PROGN + (SETQ |a| |$stack|) + (SETQ |$stack| NIL) + (LOOP (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) ('T 0))) + (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) + (|bpPush| (CONS (|bpPop2|) (|bpPop1|))))) + ('T NIL))))) + +(DEFUN |bpAnyNo| (|s|) + (PROG () + (RETURN + (PROGN + (LOOP (COND ((NOT (APPLY |s| NIL)) (RETURN NIL)) ('T 0))) + T)))) + +(DEFUN |bpAndOr| (|keyword| |p| |f|) + (PROG () + (RETURN + (AND (|bpEqKey| |keyword|) (OR (APPLY |p| NIL) (|bpTrap|)) + (|bpPush| (FUNCALL |f| (|bpPop1|))))))) + +(DEFUN |bpConditional| (|f|) + (PROG () + (RETURN + (COND + ((AND (|bpEqKey| 'IF) (OR (|bpWhere|) (|bpTrap|)) + (OR (|bpEqKey| 'BACKSET) T)) + (COND + ((|bpEqKey| 'SETTAB) + (COND + ((|bpEqKey| 'THEN) + (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|) + (|bpEqKey| 'BACKTAB))) + (#0='T (|bpMissing| 'THEN)))) + ((|bpEqKey| 'THEN) + (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|))) + (#0# (|bpMissing| '|then|)))) + (#0# NIL))))) + +(DEFUN |bpElse| (|f|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpBacksetElse|) + (AND (OR (APPLY |f| NIL) (|bpTrap|)) + (|bpPush| (|bfIf| (|bpPop3|) (|bpPop2|) (|bpPop1|))))) + ('T (|bpRestore| |a|) + (|bpPush| (|bfIfThenOnly| (|bpPop2|) (|bpPop1|))))))))) + +(DEFUN |bpBacksetElse| () + (PROG () + (RETURN + (COND + ((|bpEqKey| 'BACKSET) (|bpEqKey| 'ELSE)) + ('T (|bpEqKey| 'ELSE)))))) + +(DEFUN |bpEqPeek| (|s|) + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|))))) + +(DEFUN |bpEqKey| (|s|) + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|) (|bpNext|))))) + +(DEFUN |bpEqKeyNextTok| (|s|) + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|) (|bpNextToken|))))) + +(DEFUN |bpPileTrap| () (PROG () (RETURN (|bpMissing| 'BACKTAB)))) + +(DEFUN |bpBrackTrap| (|x|) + (PROG () (RETURN (|bpMissingMate| '] |x|)))) + +(DEFUN |bpParenTrap| (|x|) + (PROG () (RETURN (|bpMissingMate| '|)| |x|)))) + +(DEFUN |bpMissingMate| (|close| |open|) + (PROG () + (RETURN + (PROGN + (|bpSpecificErrorAtToken| |open| "possibly missing mate") + (|bpMissing| |close|))))) + +(DEFUN |bpMissing| (|s|) + (PROG () + (RETURN + (PROGN + (|bpSpecificErrorHere| + (CONCAT (PNAME |s|) " possibly missing")) + (THROW 'TRAPPOINT 'TRAPPED))))) + +(DEFUN |bpCompMissing| (|s|) + (PROG () (RETURN (OR (|bpEqKey| |s|) (|bpMissing| |s|))))) + +(DEFUN |bpTrap| () + (PROG () + (RETURN + (PROGN (|bpGeneralErrorHere|) (THROW 'TRAPPOINT 'TRAPPED))))) + +(DEFUN |bpRecoverTrap| () + (PROG (|pos2| |pos1|) + (DECLARE (SPECIAL |$stok|)) + (RETURN + (PROGN + (|bpFirstToken|) + (SETQ |pos1| (|shoeTokPosn| |$stok|)) + (|bpMoveTo| 0) + (SETQ |pos2| (|shoeTokPosn| |$stok|)) + (|bpIgnoredFromTo| |pos1| |pos2|) + (|bpPush| (LIST (LIST "pile syntax error"))))))) + +(DEFUN |bpListAndRecover| (|f|) + (PROG (|found| |c| |done| |b| |a|) + (DECLARE (SPECIAL |$inputStream| |$stack|)) + (RETURN + (PROGN + (SETQ |a| |$stack|) + (SETQ |b| NIL) + (SETQ |$stack| NIL) + (SETQ |done| NIL) + (SETQ |c| |$inputStream|) + (LOOP + (COND + (|done| (RETURN NIL)) + ('T + (PROGN + (SETQ |found| (CATCH 'TRAPPOINT (APPLY |f| NIL))) + (COND + ((EQ |found| 'TRAPPED) (SETQ |$inputStream| |c|) + (|bpRecoverTrap|)) + ((NULL |found|) (SETQ |$inputStream| |c|) + (|bpGeneralErrorHere|) (|bpRecoverTrap|))) + (COND + ((|bpEqKey| 'BACKSET) (SETQ |c| |$inputStream|)) + ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|)) + (SETQ |done| T)) + (#0='T (SETQ |$inputStream| |c|) + (|bpGeneralErrorHere|) (|bpRecoverTrap|) + (COND + ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|)) + (SETQ |done| T)) + (#0# (|bpNext|) (SETQ |c| |$inputStream|))))) + (SETQ |b| (CONS (|bpPop1|) |b|)))))) + (SETQ |$stack| |a|) + (|bpPush| (NREVERSE |b|)))))) + +(DEFUN |bpMoveTo| (|n|) + (PROG () + (DECLARE (SPECIAL |$bpParenCount| |$bpCount| |$inputStream|)) + (RETURN + (COND + ((NULL |$inputStream|) T) + ((|bpEqPeek| 'BACKTAB) + (COND + ((EQL |n| 0) T) + (#0='T + (PROGN + (|bpNextToken|) + (SETQ |$bpCount| (- |$bpCount| 1)) + (|bpMoveTo| (- |n| 1)))))) + ((|bpEqPeek| 'BACKSET) + (COND + ((EQL |n| 0) T) + (#0# (PROGN (|bpNextToken|) (|bpMoveTo| |n|))))) + ((|bpEqPeek| 'SETTAB) + (PROGN (|bpNextToken|) (|bpMoveTo| (+ |n| 1)))) + ((|bpEqPeek| 'OPAREN) + (PROGN + (|bpNextToken|) + (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) + (|bpMoveTo| |n|))) + ((|bpEqPeek| 'CPAREN) + (PROGN + (|bpNextToken|) + (SETQ |$bpParenCount| (- |$bpParenCount| 1)) + (|bpMoveTo| |n|))) + (#0# (PROGN (|bpNextToken|) (|bpMoveTo| |n|))))))) + +(DEFUN |bpQualifiedName| () + (PROG () + (DECLARE (SPECIAL |$stok|)) + (RETURN + (COND + ((|bpEqPeek| 'COLON-COLON) + (PROGN + (|bpNext|) + (AND (EQCAR |$stok| 'ID) (|bpPushId|) (|bpNext|) + (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|)))))) + ('T NIL))))) + +(DEFUN |bpName| () + (PROG () + (DECLARE (SPECIAL |$stok|)) + (RETURN + (COND + ((EQCAR |$stok| 'ID) + (PROGN + (|bpPushId|) + (|bpNext|) + (|bpAnyNo| #'|bpQualifiedName|))) + ('T NIL))))) + +(DEFUN |bpConstTok| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (COND + ((MEMQ (|shoeTokType| |$stok|) '(INTEGER FLOAT)) + (PROGN (|bpPush| |$ttok|) (|bpNext|))) + ((EQCAR |$stok| 'LISP) + (AND (|bpPush| (|bfReadLisp| |$ttok|)) (|bpNext|))) + ((EQCAR |$stok| 'LISPEXP) (AND (|bpPush| |$ttok|) (|bpNext|))) + ((EQCAR |$stok| 'LINE) + (AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|))) + ((|bpEqPeek| 'QUOTE) + (PROGN + (|bpNext|) + (AND (OR (|bpSexp|) (|bpTrap|)) + (|bpPush| (|bfSymbol| (|bpPop1|)))))) + ('T (|bpString|)))))) + +(DEFUN |bpModule| () + (PROG () + (RETURN + (COND + ((|bpEqKey| 'MODULE) + (AND (|bpConstTok|) (|bpPush| (|Module| (|bpPop1|))))) + ('T NIL))))) + +(DEFUN |bpImport| () + (PROG () + (RETURN + (COND + ((|bpEqKey| 'IMPORT) + (OR (AND (|bpName|) (OR (|bpEqKey| 'FOR) (|bpTrap|)) + (|bpSignature|) + (|bpPush| (|ImportSignature| (|bpPop2|) (|bpPop1|)))) + (AND (|bpConstTok|) (|bpPush| (|Import| (|bpPop1|)))))) + ('T NIL))))) + +(DEFUN |bpTypeAliasDefition| () + (PROG () + (RETURN + (AND (OR (|bpName|) (|bpTrap|)) (|bpEqKey| 'TDEF) (|bpLogical|) + (|bpPush| (|TypeAlias| (|bpPop2|) NIL (|bpPop1|))))))) + +(DEFUN |bpSignature| () + (PROG () + (RETURN + (AND (|bpName|) (|bpEqKey| 'COLON) (|bpMapping|) + (|bpPush| (|Signature| (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpMapping| () + (PROG () + (RETURN + (AND (OR (|bpName|) (|bpIdList|)) (|bpEqKey| 'ARROW) (|bpName|) + (|bpPush| (|Mapping| (|bpPop1|) (|bpPop1|))))))) + +(DEFUN |bpCancel| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpEqKeyNextTok| 'SETTAB) + (COND + ((|bpCancel|) + (COND + ((|bpEqKeyNextTok| 'BACKTAB) T) + (#0='T (|bpRestore| |a|) NIL))) + ((|bpEqKeyNextTok| 'BACKTAB) T) + (#0# (|bpRestore| |a|) NIL))) + (#0# NIL)))))) + +(DEFUN |bpAddTokens| (|n|) + (PROG () + (DECLARE (SPECIAL |$stok|)) + (RETURN + (COND + ((EQL |n| 0) NIL) + ((< 0 |n|) + (CONS (|shoeTokConstruct| 'KEY 'SETTAB + (|shoeTokPosn| |$stok|)) + (|bpAddTokens| (- |n| 1)))) + ('T + (CONS (|shoeTokConstruct| 'KEY 'BACKTAB + (|shoeTokPosn| |$stok|)) + (|bpAddTokens| (+ |n| 1)))))))) + +(DEFUN |bpExceptions| () + (PROG () + (RETURN + (OR (|bpEqPeek| 'DOT) (|bpEqPeek| 'QUOTE) (|bpEqPeek| 'OPAREN) + (|bpEqPeek| 'CPAREN) (|bpEqPeek| 'SETTAB) + (|bpEqPeek| 'BACKTAB) (|bpEqPeek| 'BACKSET))))) + +(DEFUN |bpSexpKey| () + (PROG (|a|) + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (COND + ((AND (EQCAR |$stok| 'KEY) (NULL (|bpExceptions|))) + (PROGN + (SETQ |a| (GET |$ttok| 'SHOEINF)) + (COND + ((NULL |a|) (AND (|bpPush| |$ttok|) (|bpNext|))) + (#0='T (AND (|bpPush| |a|) (|bpNext|)))))) + (#0# NIL))))) + +(DEFUN |bpAnyId| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (OR (AND (|bpEqKey| 'MINUS) + (OR (EQCAR |$stok| 'INTEGER) (|bpTrap|)) + (|bpPush| (- |$ttok|)) (|bpNext|)) + (|bpSexpKey|) + (AND (MEMQ (|shoeTokType| |$stok|) + '(ID INTEGER STRING FLOAT)) + (|bpPush| |$ttok|) (|bpNext|)))))) + +(DEFUN |bpSexp| () + (PROG () + (RETURN + (OR (|bpAnyId|) + (AND (|bpEqKey| 'QUOTE) (OR (|bpSexp|) (|bpTrap|)) + (|bpPush| (|bfSymbol| (|bpPop1|)))) + (|bpIndentParenthesized| #'|bpSexp1|))))) + +(DEFUN |bpSexp1| () + (PROG () + (RETURN + (OR (AND (|bpFirstTok|) (|bpSexp|) + (OR (AND (|bpEqKey| 'DOT) (|bpSexp|) + (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))) + (AND (|bpSexp1|) + (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))))) + (|bpPush| NIL))))) + +(DEFUN |bpPrimary1| () + (PROG () + (RETURN + (OR (|bpName|) (|bpDot|) (|bpConstTok|) (|bpConstruct|) + (|bpCase|) (|bpStruct|) (|bpPDefinition|) + (|bpBPileDefinition|))))) + +(DEFUN |bpPrimary| () + (PROG () + (RETURN + (AND (|bpFirstTok|) (OR (|bpPrimary1|) (|bpPrefixOperator|)))))) + +(DEFUN |bpDot| () + (PROG () (RETURN (AND (|bpEqKey| 'DOT) (|bpPush| (|bfDot|)))))) + +(DEFUN |bpPrefixOperator| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQCAR |$stok| 'KEY) (GET |$ttok| 'SHOEPRE) (|bpPushId|) + (|bpNext|))))) + +(DEFUN |bpInfixOperator| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQCAR |$stok| 'KEY) (GET |$ttok| 'SHOEINF) (|bpPushId|) + (|bpNext|))))) + +(DEFUN |bpSelector| () + (PROG () + (RETURN + (AND (|bpEqKey| 'DOT) + (OR (AND (|bpPrimary|) + (|bpPush| (|bfElt| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfSuffixDot| (|bpPop1|)))))))) + +(DEFUN |bpOperator| () + (PROG () (RETURN (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|))))) + +(DEFUN |bpApplication| () + (PROG () + (RETURN + (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|) + (OR (AND (|bpApplication|) + (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) + T))))) + +(DEFUN |bpTagged| () + (PROG () + (RETURN + (AND (|bpApplication|) + (OR (AND (|bpEqKey| 'COLON) + (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|)))) + T))))) + +(DEFUN |bpExpt| () + (PROG () (RETURN (|bpRightAssoc| '(POWER) #'|bpTagged|)))) + +(DEFUN |bpInfKey| (|s|) + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQCAR |$stok| 'KEY) (MEMBER |$ttok| |s|) (|bpPushId|) + (|bpNext|))))) + +(DEFUN |bpInfGeneric| (|s|) + (PROG () + (RETURN (AND (|bpInfKey| |s|) (OR (|bpEqKey| 'BACKSET) T))))) + +(DEFUN |bpRightAssoc| (|o| |p|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((APPLY |p| NIL) + (LOOP + (COND + ((NOT (AND (|bpInfGeneric| |o|) + (OR (|bpRightAssoc| |o| |p|) (|bpTrap|)))) + (RETURN NIL)) + ('T + (|bpPush| + (|bfInfApplication| (|bpPop2|) (|bpPop2|) + (|bpPop1|)))))) + T) + ('T (|bpRestore| |a|) NIL)))))) + +(DEFUN |bpLeftAssoc| (|operations| |parser|) + (PROG () + (RETURN + (COND + ((APPLY |parser| NIL) + (LOOP + (COND + ((NOT (AND (|bpInfGeneric| |operations|) + (OR (APPLY |parser| NIL) (|bpTrap|)))) + (RETURN NIL)) + ('T + (|bpPush| + (|bfInfApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|)))))) + T) + ('T NIL))))) + +(DEFUN |bpString| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQ (|shoeTokType| |$stok|) 'STRING) + (|bpPush| (LIST 'QUOTE (INTERN |$ttok|))) (|bpNext|))))) + +(DEFUN |bpThetaName| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (COND + ((AND (EQCAR |$stok| 'ID) (GET |$ttok| 'SHOETHETA)) + (|bpPushId|) (|bpNext|)) + ('T NIL))))) + +(DEFUN |bpReduceOperator| () + (PROG () + (RETURN (OR (|bpInfixOperator|) (|bpString|) (|bpThetaName|))))) + +(DEFUN |bpReduce| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((AND (|bpReduceOperator|) (|bpEqKey| 'SLASH)) + (COND + ((|bpEqPeek| 'OBRACK) + (AND (OR (|bpDConstruct|) (|bpTrap|)) + (|bpPush| (|bfReduceCollect| (|bpPop2|) (|bpPop1|))))) + ('T + (AND (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|bfReduce| (|bpPop2|) (|bpPop1|))))))) + ('T (|bpRestore| |a|) NIL)))))) + +(DEFUN |bpTimes| () + (PROG () + (RETURN + (OR (|bpReduce|) (|bpLeftAssoc| '(TIMES SLASH) #'|bpExpt|))))) + +(DEFUN |bpMinus| () + (PROG () + (RETURN + (OR (AND (|bpInfGeneric| '(MINUS)) (OR (|bpTimes|) (|bpTrap|)) + (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) + (|bpTimes|))))) + +(DEFUN |bpArith| () + (PROG () (RETURN (|bpLeftAssoc| '(PLUS MINUS) #'|bpMinus|)))) + +(DEFUN |bpIs| () + (PROG () + (RETURN + (AND (|bpArith|) + (OR (AND (|bpInfKey| '(IS ISNT)) + (OR (|bpPattern|) (|bpTrap|)) + (|bpPush| + (|bfISApplication| (|bpPop2|) (|bpPop2|) + (|bpPop1|)))) + T))))) + +(DEFUN |bpBracketConstruct| (|f|) + (PROG () + (RETURN + (AND (|bpBracket| |f|) (|bpPush| (|bfConstruct| (|bpPop1|))))))) + +(DEFUN |bpCompare| () + (PROG () + (RETURN + (AND (|bpIs|) + (OR (AND (|bpInfKey| '(SHOEEQ SHOENE LT LE GT GE IN)) + (OR (|bpIs|) (|bpTrap|)) + (|bpPush| + (|bfInfApplication| (|bpPop2|) (|bpPop2|) + (|bpPop1|)))) + T))))) + +(DEFUN |bpAnd| () + (PROG () (RETURN (|bpLeftAssoc| '(AND) #'|bpCompare|)))) + +(DEFUN |bpNoteReturnStmt| () + (PROG () + (DECLARE (SPECIAL |$bodyHasReturn|)) + (RETURN (PROGN (SETQ |$bodyHasReturn| T) T)))) + +(DEFUN |bpReturn| () + (PROG () + (RETURN + (OR (AND (|bpEqKey| 'RETURN) (|bpNoteReturnStmt|) + (OR (|bpAnd|) (|bpTrap|)) + (|bpPush| (|bfReturnNoName| (|bpPop1|)))) + (|bpAnd|))))) + +(DEFUN |bpLogical| () + (PROG () (RETURN (|bpLeftAssoc| '(OR) #'|bpReturn|)))) + +(DEFUN |bpExpression| () + (PROG () + (RETURN + (OR (AND (|bpEqKey| 'COLON) + (OR (AND (|bpLogical|) + (|bpPush| (|bfApplication| 'COLON (|bpPop1|)))) + (|bpTrap|))) + (|bpLogical|))))) + +(DEFUN |bpStatement| () + (PROG () + (RETURN + (OR (|bpConditional| #'|bpWhere|) (|bpLoop|) (|bpExpression|))))) + +(DEFUN |bpLoop| () + (PROG () + (RETURN + (OR (AND (|bpIterators|) (|bpCompMissing| 'REPEAT) + (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|bfLp| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'REPEAT) (OR (|bpLogical|) (|bpTrap|)) + (|bpPush| (|bfLoop1| (|bpPop1|)))))))) + +(DEFUN |bpSuchThat| () + (PROG () (RETURN (|bpAndOr| 'BAR #'|bpWhere| #'|bfSuchthat|)))) + +(DEFUN |bpWhile| () + (PROG () (RETURN (|bpAndOr| 'WHILE #'|bpLogical| #'|bfWhile|)))) + +(DEFUN |bpUntil| () + (PROG () (RETURN (|bpAndOr| 'UNTIL #'|bpLogical| #'|bfUntil|)))) + +(DEFUN |bpForIn| () + (PROG () + (RETURN + (AND (|bpEqKey| 'FOR) (OR (|bpVariable|) (|bpTrap|)) + (|bpCompMissing| 'IN) + (OR (AND (OR (|bpSeg|) (|bpTrap|)) (|bpEqKey| 'BY) + (OR (|bpArith|) (|bpTrap|)) + (|bpPush| + (|bfForInBy| (|bpPop3|) (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfForin| (|bpPop2|) (|bpPop1|)))))))) + +(DEFUN |bpSeg| () + (PROG () + (RETURN + (AND (|bpArith|) + (OR (AND (|bpEqKey| 'SEG) + (OR (AND (|bpArith|) + (|bpPush| + (|bfSegment2| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfSegment1| (|bpPop1|))))) + T))))) + +(DEFUN |bpIterator| () + (PROG () + (RETURN (OR (|bpForIn|) (|bpSuchThat|) (|bpWhile|) (|bpUntil|))))) + +(DEFUN |bpIteratorList| () + (PROG () + (RETURN + (AND (|bpOneOrMore| #'|bpIterator|) + (|bpPush| (|bfIterators| (|bpPop1|))))))) + +(DEFUN |bpCrossBackSet| () + (PROG () + (RETURN (AND (|bpEqKey| 'CROSS) (OR (|bpEqKey| 'BACKSET) T))))) + +(DEFUN |bpIterators| () + (PROG () + (RETURN + (|bpListofFun| #'|bpIteratorList| #'|bpCrossBackSet| #'|bfCross|)))) + +(DEFUN |bpAssign| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpStatement|) + (COND + ((|bpEqPeek| 'BEC) (|bpRestore| |a|) + (OR (|bpAssignment|) (|bpTrap|))) + (#0='T T))) + (#0# (|bpRestore| |a|) NIL)))))) + +(DEFUN |bpAssignment| () + (PROG () + (RETURN + (AND (|bpAssignVariable|) (|bpEqKey| 'BEC) + (OR (|bpAssign|) (|bpTrap|)) + (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpExit| () + (PROG () + (RETURN + (AND (|bpAssign|) + (OR (AND (|bpEqKey| 'EXIT) (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|bfExit| (|bpPop2|) (|bpPop1|)))) + T))))) + +(DEFUN |bpBeginDefinition| () + (PROG () + (DECLARE (SPECIAL |$sawParenthesizedHead|)) + (RETURN + (OR (|bpEqPeek| 'DEF) + (AND |$sawParenthesizedHead| (|bpEqPeek| 'COLON)))))) + +(DEFUN |bpDefinition| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpExit|) + (COND + ((|bpBeginDefinition|) + (PROGN (|bpRestore| |a|) (|bpDef|))) + ((|bpEqPeek| 'TDEF) + (PROGN (|bpRestore| |a|) (|bpTypeAliasDefition|))) + ((|bpEqPeek| 'MDEF) (PROGN (|bpRestore| |a|) (|bpMdef|))) + (#0='T T))) + (#0# (PROGN (|bpRestore| |a|) NIL))))))) + +(DEFUN |bpStoreName| () + (PROG () + (DECLARE (SPECIAL |$bodyHasReturn| |$returnType| |$typings| + |$wheredefs| |$op| |$stack|)) + (RETURN + (PROGN + (SETQ |$op| (CAR |$stack|)) + (SETQ |$wheredefs| NIL) + (SETQ |$typings| NIL) + (SETQ |$returnType| T) + (SETQ |$bodyHasReturn| NIL) + T)))) + +(DEFUN |bpReturnType| () + (PROG () + (DECLARE (SPECIAL |$returnType| |$sawParenthesizedHead|)) + (RETURN + (COND + ((AND |$sawParenthesizedHead| (|bpEqKey| 'COLON)) + (PROGN + (OR (|bpApplication|) (|bpTrap|)) + (SETQ |$returnType| (|bpPop1|)) + T)) + ('T T))))) + +(DEFUN |bpDef| () + (PROG () + (RETURN + (AND (|bpName|) (|bpStoreName|) (|bpDefTail|) + (|bpPush| (|bfCompDef| (|bpPop1|))))))) + +(DEFUN |bpDDef| () (PROG () (RETURN (AND (|bpName|) (|bpDefTail|))))) + +(DEFUN |bpSimpleDefinitionTail| () + (PROG () + (RETURN + (AND (|bpEqKey| 'DEF) (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|ConstantDefinition| (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpCompoundDefinitionTail| () + (PROG () + (RETURN + (AND (|bpVariable|) (|bpReturnType|) (|bpEqKey| 'DEF) + (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|bfDefinition| (|bpPop3|) (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpDefTail| () + (PROG () + (RETURN + (OR (|bpSimpleDefinitionTail|) (|bpCompoundDefinitionTail|))))) + +(DEFUN |bpMDefTail| () + (PROG () + (RETURN + (AND (OR (|bpVariable|) (|bpTrap|)) (|bpEqKey| 'MDEF) + (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| + (|bfMDefinition| (|bpPop3|) (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpMdef| () + (PROG () (RETURN (AND (|bpName|) (|bpStoreName|) (|bpMDefTail|))))) + +(DEFUN |bpWhere| () + (PROG () + (RETURN + (AND (|bpDefinition|) + (OR (AND (|bpEqKey| 'WHERE) + (OR (|bpDefinitionItem|) (|bpTrap|)) + (|bpPush| (|bfWhere| (|bpPop1|) (|bpPop1|)))) + T))))) + +(DEFUN |bpDefinitionItem| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpDDef|) T) + (#0='T (|bpRestore| |a|) + (COND + ((|bpBDefinitionPileItems|) T) + (#0# (|bpRestore| |a|) + (COND + ((|bpPDefinitionItems|) T) + (#0# (|bpRestore| |a|) (|bpWhere|))))))))))) + +(DEFUN |bpDefinitionPileItems| () + (PROG () + (RETURN + (AND (|bpListAndRecover| #'|bpDefinitionItem|) + (|bpPush| (|bfDefSequence| (|bpPop1|))))))) + +(DEFUN |bpBDefinitionPileItems| () + (PROG () (RETURN (|bpPileBracketed| #'|bpDefinitionPileItems|)))) + +(DEFUN |bpSemiColonDefinition| () + (PROG () + (RETURN (|bpSemiListing| #'|bpDefinitionItem| #'|bfDefSequence|)))) + +(DEFUN |bpPDefinitionItems| () + (PROG () (RETURN (|bpParenthesized| #'|bpSemiColonDefinition|)))) + +(DEFUN |bpComma| () + (PROG () + (RETURN (OR (|bpModule|) (|bpImport|) (|bpTuple| #'|bpWhere|))))) + +(DEFUN |bpTuple| (|p|) + (PROG () + (RETURN (|bpListofFun| |p| #'|bpCommaBackSet| #'|bfTuple|)))) + +(DEFUN |bpCommaBackSet| () + (PROG () + (RETURN (AND (|bpEqKey| 'COMMA) (OR (|bpEqKey| 'BACKSET) T))))) + +(DEFUN |bpSemiColon| () + (PROG () (RETURN (|bpSemiListing| #'|bpComma| #'|bfSequence|)))) + +(DEFUN |bpSemiListing| (|p| |f|) + (PROG () (RETURN (|bpListofFun| |p| #'|bpSemiBackSet| |f|)))) + +(DEFUN |bpSemiBackSet| () + (PROG () + (RETURN (AND (|bpEqKey| 'SEMICOLON) (OR (|bpEqKey| 'BACKSET) T))))) + +(DEFUN |bpPDefinition| () + (PROG () (RETURN (|bpIndentParenthesized| #'|bpSemiColon|)))) + +(DEFUN |bpPileItems| () + (PROG () + (RETURN + (AND (|bpListAndRecover| #'|bpSemiColon|) + (|bpPush| (|bfSequence| (|bpPop1|))))))) + +(DEFUN |bpBPileDefinition| () + (PROG () (RETURN (|bpPileBracketed| #'|bpPileItems|)))) + +(DEFUN |bpIteratorTail| () + (PROG () (RETURN (AND (OR (|bpEqKey| 'REPEAT) T) (|bpIterators|))))) + +(DEFUN |bpConstruct| () + (PROG () (RETURN (|bpBracket| #'|bpConstruction|)))) + +(DEFUN |bpConstruction| () + (PROG () + (RETURN + (AND (|bpComma|) + (OR (AND (|bpIteratorTail|) + (|bpPush| (|bfCollect| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfTupleConstruct| (|bpPop1|)))))))) + +(DEFUN |bpDConstruct| () + (PROG () (RETURN (|bpBracket| #'|bpDConstruction|)))) + +(DEFUN |bpDConstruction| () + (PROG () + (RETURN + (AND (|bpComma|) + (OR (AND (|bpIteratorTail|) + (|bpPush| (|bfDCollect| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfDTuple| (|bpPop1|)))))))) + +(DEFUN |bpPattern| () + (PROG () + (RETURN + (OR (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) + (|bpConstTok|))))) + +(DEFUN |bpEqual| () + (PROG () + (RETURN + (AND (|bpEqKey| 'SHOEEQ) + (OR (|bpApplication|) (|bpConstTok|) (|bpTrap|)) + (|bpPush| (|bfEqual| (|bpPop1|))))))) + +(DEFUN |bpRegularPatternItem| () + (PROG () + (RETURN + (OR (|bpEqual|) (|bpConstTok|) (|bpDot|) + (AND (|bpName|) + (OR (AND (|bpEqKey| 'BEC) (OR (|bpPattern|) (|bpTrap|)) + (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) + T)) + (|bpBracketConstruct| #'|bpPatternL|))))) + +(DEFUN |bpRegularPatternItemL| () + (PROG () + (RETURN + (AND (|bpRegularPatternItem|) (|bpPush| (LIST (|bpPop1|))))))) + +(DEFUN |bpRegularList| () + (PROG () + (RETURN + (|bpListof| #'|bpRegularPatternItemL| 'COMMA #'|bfAppend|)))) + +(DEFUN |bpPatternColon| () + (PROG () + (RETURN + (AND (|bpEqKey| 'COLON) (OR (|bpRegularPatternItem|) (|bpTrap|)) + (|bpPush| (LIST (|bfColon| (|bpPop1|)))))))) + +(DEFUN |bpPatternL| () + (PROG () + (RETURN (AND (|bpPatternList|) (|bpPush| (|bfTuple| (|bpPop1|))))))) + +(DEFUN |bpPatternList| () + (PROG () + (RETURN + (COND + ((|bpRegularPatternItemL|) + (LOOP + (COND + ((NOT (AND (|bpEqKey| 'COMMA) + (OR (|bpRegularPatternItemL|) + (PROGN + (OR (AND (|bpPatternTail|) + (|bpPush| + (APPEND (|bpPop2|) (|bpPop1|)))) + (|bpTrap|)) + NIL)))) + (RETURN NIL)) + ('T (|bpPush| (APPEND (|bpPop2|) (|bpPop1|)))))) + T) + ('T (|bpPatternTail|)))))) + +(DEFUN |bpPatternTail| () + (PROG () + (RETURN + (AND (|bpPatternColon|) + (OR (AND (|bpEqKey| 'COMMA) + (OR (|bpRegularList|) (|bpTrap|)) + (|bpPush| (APPEND (|bpPop2|) (|bpPop1|)))) + T))))) + +(DEFUN |bpRegularBVItem| () + (PROG () + (RETURN + (OR (|bpBVString|) (|bpConstTok|) + (AND (|bpName|) + (OR (AND (|bpEqKey| 'COLON) + (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'BEC) (OR (|bpPattern|) (|bpTrap|)) + (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'IS) (OR (|bpPattern|) (|bpTrap|)) + (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) + T)) + (|bpBracketConstruct| #'|bpPatternL|))))) + +(DEFUN |bpBVString| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQ (|shoeTokType| |$stok|) 'STRING) + (|bpPush| (LIST 'BVQUOTE (INTERN |$ttok|))) (|bpNext|))))) + +(DEFUN |bpRegularBVItemL| () + (PROG () + (RETURN (AND (|bpRegularBVItem|) (|bpPush| (LIST (|bpPop1|))))))) + +(DEFUN |bpColonName| () + (PROG () + (RETURN + (AND (|bpEqKey| 'COLON) + (OR (|bpName|) (|bpBVString|) (|bpTrap|)))))) + +(DEFUN |bpBoundVariablelist| () + (PROG () + (RETURN + (COND + ((|bpRegularBVItemL|) + (LOOP + (COND + ((NOT (AND (|bpEqKey| 'COMMA) + (OR (|bpRegularBVItemL|) + (PROGN + (OR (AND (|bpColonName|) + (|bpPush| + (|bfColonAppend| (|bpPop2|) + (|bpPop1|)))) + (|bpTrap|)) + NIL)))) + (RETURN NIL)) + ('T (|bpPush| (APPEND (|bpPop2|) (|bpPop1|)))))) + T) + ('T + (AND (|bpColonName|) + (|bpPush| (|bfColonAppend| NIL (|bpPop1|))))))))) + +(DEFUN |bpBeginParameterList| () + (PROG () + (DECLARE (SPECIAL |$sawParenthesizedHead|)) + (RETURN (PROGN (SETQ |$sawParenthesizedHead| NIL) T)))) + +(DEFUN |bpEndParameterList| () + (PROG () + (DECLARE (SPECIAL |$sawParenthesizedHead|)) + (RETURN (SETQ |$sawParenthesizedHead| T)))) + +(DEFUN |bpVariable| () + (PROG () + (RETURN + (OR (AND (|bpBeginParameterList|) + (|bpParenthesized| #'|bpBoundVariablelist|) + (|bpPush| (|bfTupleIf| (|bpPop1|))) + (|bpEndParameterList|)) + (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) + (|bpConstTok|))))) + +(DEFUN |bpAssignVariable| () + (PROG () + (RETURN + (OR (|bpBracketConstruct| #'|bpPatternL|) (|bpAssignLHS|))))) + +(DEFUN |bpAssignLHS| () + (PROG () + (RETURN + (AND (|bpName|) + (OR (AND (|bpEqKey| 'COLON) + (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|bfLocal| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'DOT) + (|bpList| #'|bpPrimary| 'DOT #'|bfListOf|) + (|bpChecknull|) + (|bpPush| (|bfTuple| (CONS (|bpPop2|) (|bpPop1|))))) + T))))) + +(DEFUN |bpChecknull| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpPop1|)) + (COND ((NULL |a|) (|bpTrap|)) ('T (|bpPush| |a|))))))) + +(DEFUN |bpStruct| () + (PROG () + (RETURN + (AND (|bpEqKey| 'STRUCTURE) (OR (|bpName|) (|bpTrap|)) + (OR (|bpEqKey| 'DEF) (|bpTrap|)) (|bpTypeList|) + (|bpPush| (|bfStruct| (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpTypeList| () + (PROG () + (RETURN + (OR (|bpPileBracketed| #'|bpTypeItemList|) + (AND (|bpTerm|) (|bpPush| (LIST (|bpPop1|)))))))) + +(DEFUN |bpTypeItemList| () + (PROG () (RETURN (|bpListAndRecover| #'|bpTerm|)))) + +(DEFUN |bpTerm| () + (PROG () + (RETURN + (OR (AND (OR (|bpName|) (|bpTrap|)) + (OR (AND (|bpParenthesized| #'|bpIdList|) + (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))) + (AND (|bpName|) + (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))))) + (|bpPush| (|bfNameOnly| (|bpPop1|))))))) + +(DEFUN |bpIdList| () (PROG () (RETURN (|bpTuple| #'|bpName|)))) + +(DEFUN |bpCase| () + (PROG () + (RETURN + (AND (|bpEqKey| 'CASE) (OR (|bpWhere|) (|bpTrap|)) + (OR (|bpEqKey| 'OF) (|bpMissing| 'OF)) (|bpPiledCaseItems|))))) + +(DEFUN |bpPiledCaseItems| () + (PROG () + (RETURN + (AND (|bpPileBracketed| #'|bpCaseItemList|) + (|bpPush| (|bfCase| (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpCaseItemList| () + (PROG () (RETURN (|bpListAndRecover| #'|bpCaseItem|)))) + +(DEFUN |bpCaseItem| () + (PROG () + (RETURN + (AND (OR (|bpTerm|) (|bpTrap|)) (OR (|bpEqKey| 'EXIT) (|bpTrap|)) + (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|bfCaseItem| (|bpPop2|) (|bpPop1|))))))) + 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|)))))))) + diff --git a/src/boot/strap/scanner.clisp b/src/boot/strap/scanner.clisp new file mode 100644 index 00000000..50078c3d --- /dev/null +++ b/src/boot/strap/scanner.clisp @@ -0,0 +1,626 @@ +(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-lexer")) + +(IMPORT-MODULE "tokens") + +(IMPORT-MODULE "includer") + +(IN-PACKAGE "BOOTTRAN") + +(DEFUN |double| (|x|) (PROG () (RETURN (FLOAT |x| 1.0)))) + +(DEFUN |dqUnit| (|s|) + (PROG (|a|) (RETURN (PROGN (SETQ |a| (LIST |s|)) (CONS |a| |a|))))) + +(DEFUN |dqAppend| (|x| |y|) + (PROG () + (RETURN + (COND + ((NULL |x|) |y|) + ((NULL |y|) |x|) + ('T (RPLACD (CDR |x|) (CAR |y|)) (RPLACD |x| (CDR |y|)) |x|))))) + +(DEFUN |dqConcat| (|ld|) + (PROG () + (RETURN + (COND + ((NULL |ld|) NIL) + ((NULL (CDR |ld|)) (CAR |ld|)) + ('T (|dqAppend| (CAR |ld|) (|dqConcat| (CDR |ld|)))))))) + +(DEFUN |dqToList| (|s|) + (PROG () (RETURN (COND ((NULL |s|) NIL) ('T (CAR |s|)))))) + +(DEFUN |shoeConstructToken| (|ln| |lp| |b| |n|) + (PROG () + (RETURN (CONS (ELT |b| 0) (CONS (ELT |b| 1) (CONS |lp| |n|)))))) + +(DEFUN |shoeTokType| (|x|) (PROG () (RETURN (CAR |x|)))) + +(DEFUN |shoeTokPart| (|x|) (PROG () (RETURN (CADR |x|)))) + +(DEFUN |shoeTokPosn| (|x|) (PROG () (RETURN (CDDR |x|)))) + +(DEFUN |shoeTokConstruct| (|x| |y| |z|) + (PROG () (RETURN (CONS |x| (CONS |y| |z|))))) + +(DEFUN |shoeNextLine| (|s|) + (PROG (|s1| |a|) + (DECLARE (SPECIAL |$sz| |$n| |$ln| |$r| |$f| |$linepos|)) + (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 |$sz| (LENGTH |$ln|)) + (COND + ((NULL |$n|) T) + ((EQUAL (QENUM |$ln| |$n|) |shoeTAB|) + (PROGN + (SETQ |a| (MAKE-FULL-CVEC (- 7 (REM |$n| 8)) " ")) + (SETF (ELT |$ln| |$n|) (ELT " " 0)) + (SETQ |$ln| (CONCAT |a| |$ln|)) + (SETQ |s1| (CONS (CONS |$ln| (CDR |$f|)) |$r|)) + (|shoeNextLine| |s1|))) + ('T T))))))) + +(DEFUN |shoeLineToks| (|s|) + (PROG (|$linepos| |$floatok| |$sz| |$n| |$ln| |$r| |$f| |toks| |a| + |dq| |command| |fst|) + (DECLARE (SPECIAL |$floatok| |$f| |$sz| |$linepos| |$ln| |$r| |$n|)) + (RETURN + (PROGN + (SETQ |$f| NIL) + (SETQ |$r| NIL) + (SETQ |$ln| NIL) + (SETQ |$n| NIL) + (SETQ |$sz| NIL) + (SETQ |$floatok| T) + (SETQ |$linepos| |s|) + (COND + ((NULL (|shoeNextLine| |s|)) (CONS NIL NIL)) + ((NULL |$n|) (|shoeLineToks| |$r|)) + (#0='T + (PROGN + (SETQ |fst| (QENUM |$ln| 0)) + (COND + ((EQL |fst| |shoeCLOSEPAREN|) + (COND + ((SETQ |command| (|shoeLine?| |$ln|)) + (PROGN + (SETQ |dq| + (|dqUnit| + (|shoeConstructToken| |$ln| |$linepos| + (|shoeLeafLine| |command|) 0))) + (CONS (LIST |dq|) |$r|))) + ((SETQ |command| (|shoeLisp?| |$ln|)) + (|shoeLispToken| |$r| |command|)) + ((SETQ |command| (|shoePackage?| |$ln|)) + (PROGN + (SETQ |a| (CONCAT "(IN-PACKAGE " |command| ")")) + (SETQ |dq| + (|dqUnit| + (|shoeConstructToken| |$ln| |$linepos| + (|shoeLeafLisp| |a|) 0))) + (CONS (LIST |dq|) |$r|))) + (#0# (|shoeLineToks| |$r|)))) + (#0# + (PROGN + (SETQ |toks| NIL) + (LOOP + (COND + ((NOT (< |$n| |$sz|)) (RETURN NIL)) + ('T + (SETQ |toks| (|dqAppend| |toks| (|shoeToken|)))))) + (COND + ((NULL |toks|) (|shoeLineToks| |$r|)) + (#0# (CONS (LIST |toks|) |$r|))))))))))))) + +(DEFUN |shoeLispToken| (|s| |string|) + (PROG (|dq| |st| |r| |LETTMP#1| |linepos| |ln|) + (DECLARE (SPECIAL |$linepos| |$ln|)) + (RETURN + (PROGN + (SETQ |string| + (COND + ((OR (EQL (LENGTH |string|) 0) + (EQL (QENUM |string| 0) (QENUM ";" 0))) + "") + ('T |string|))) + (SETQ |ln| |$ln|) + (SETQ |linepos| |$linepos|) + (SETQ |LETTMP#1| (|shoeAccumulateLines| |s| |string|)) + (SETQ |r| (CAR |LETTMP#1|)) + (SETQ |st| (CDR |LETTMP#1|)) + (SETQ |dq| + (|dqUnit| + (|shoeConstructToken| |ln| |linepos| + (|shoeLeafLisp| |st|) 0))) + (CONS (LIST |dq|) |r|))))) + +(DEFUN |shoeAccumulateLines| (|s| |string|) + (PROG (|a| |command| |fst|) + (DECLARE (SPECIAL |$ln| |$r| |$n|)) + (RETURN + (COND + ((NULL (|shoeNextLine| |s|)) (CONS |s| |string|)) + ((NULL |$n|) (|shoeAccumulateLines| |$r| |string|)) + ((EQL (LENGTH |$ln|) 0) (|shoeAccumulateLines| |$r| |string|)) + (#0='T + (PROGN + (SETQ |fst| (QENUM |$ln| 0)) + (COND + ((EQL |fst| |shoeCLOSEPAREN|) + (PROGN + (SETQ |command| (|shoeLisp?| |$ln|)) + (COND + ((AND |command| (< 0 (LENGTH |command|))) + (COND + ((EQL (QENUM |command| 0) (QENUM ";" 0)) + (|shoeAccumulateLines| |$r| |string|)) + (#0# + (PROGN + (SETQ |a| (STRPOS ";" |command| 0 NIL)) + (COND + (|a| (|shoeAccumulateLines| |$r| + (CONCAT |string| + (SUBSTRING |command| 0 (- |a| 1))))) + (#0# + (|shoeAccumulateLines| |$r| + (CONCAT |string| |command|)))))))) + (#0# (|shoeAccumulateLines| |$r| |string|))))) + (#0# (CONS |s| |string|))))))))) + +(DEFUN |shoeCloser| (|t|) + (PROG () (RETURN (MEMQ (|shoeKeyWord| |t|) '(CPAREN CBRACK))))) + +(DEFUN |shoeToken| () + (PROG (|b| |ch| |n| |linepos| |c| |ln|) + (DECLARE (SPECIAL |$linepos| |$n| |$ln|)) + (RETURN + (PROGN + (SETQ |ln| |$ln|) + (SETQ |c| (QENUM |$ln| |$n|)) + (SETQ |linepos| |$linepos|) + (SETQ |n| |$n|) + (SETQ |ch| (ELT |$ln| |$n|)) + (SETQ |b| + (COND + ((|shoeStartsComment|) (PROGN (|shoeComment|) NIL)) + ((|shoeStartsNegComment|) + (PROGN (|shoeNegComment|) NIL)) + ((EQUAL |c| |shoeLispESCAPE|) (|shoeLispEscape|)) + ((|shoePunctuation| |c|) (|shoePunct|)) + ((|shoeStartsId| |ch|) (|shoeWord| NIL)) + ((EQUAL |c| |shoeSPACE|) (PROGN (|shoeSpace|) NIL)) + ((EQUAL |c| |shoeSTRINGCHAR|) (|shoeString|)) + ((|shoeDigit| |ch|) (|shoeNumber|)) + ((EQUAL |c| |shoeESCAPE|) (|shoeEscape|)) + ((EQUAL |c| |shoeTAB|) + (PROGN (SETQ |$n| (+ |$n| 1)) NIL)) + (#0='T (|shoeError|)))) + (COND + ((NULL |b|) NIL) + (#0# + (|dqUnit| (|shoeConstructToken| |ln| |linepos| |b| |n|)))))))) + +(DEFUN |shoeLeafId| (|x|) (PROG () (RETURN (LIST 'ID (INTERN |x|))))) + +(DEFUN |shoeLeafKey| (|x|) + (PROG () (RETURN (LIST 'KEY (|shoeKeyWord| |x|))))) + +(DEFUN |shoeLeafInteger| (|x|) + (PROG () (RETURN (LIST 'INTEGER (|shoeIntValue| |x|))))) + +(DEFUN |shoeLeafFloat| (|a| |w| |e|) + (PROG (|c| |b|) + (RETURN + (PROGN + (SETQ |b| (|shoeIntValue| (CONCAT |a| |w|))) + (SETQ |c| + (* (|double| |b|) + (EXPT (|double| 10) (- |e| (LENGTH |w|))))) + (LIST 'FLOAT |c|))))) + +(DEFUN |shoeLeafString| (|x|) (PROG () (RETURN (LIST 'STRING |x|)))) + +(DEFUN |shoeLeafLisp| (|x|) (PROG () (RETURN (LIST 'LISP |x|)))) + +(DEFUN |shoeLeafLispExp| (|x|) (PROG () (RETURN (LIST 'LISPEXP |x|)))) + +(DEFUN |shoeLeafLine| (|x|) (PROG () (RETURN (LIST 'LINE |x|)))) + +(DEFUN |shoeLeafComment| (|x|) (PROG () (RETURN (LIST 'COMMENT |x|)))) + +(DEFUN |shoeLeafNegComment| (|x|) + (PROG () (RETURN (LIST 'NEGCOMMENT |x|)))) + +(DEFUN |shoeLeafError| (|x|) (PROG () (RETURN (LIST 'ERROR |x|)))) + +(DEFUN |shoeLeafSpaces| (|x|) (PROG () (RETURN (LIST 'SPACES |x|)))) + +(DEFUN |shoeLispEscape| () + (PROG (|n| |exp| |a|) + (DECLARE (SPECIAL |$ln| |$linepos| |$sz| |$n|)) + (RETURN + (PROGN + (SETQ |$n| (+ |$n| 1)) + (COND + ((NOT (< |$n| |$sz|)) + (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error") + (|shoeLeafError| (ELT |$ln| |$n|))) + ('T (SETQ |a| (|shoeReadLispString| |$ln| |$n|)) + (COND + ((NULL |a|) + (PROGN + (|SoftShoeError| (CONS |$linepos| |$n|) + "lisp escape error") + (|shoeLeafError| (ELT |$ln| |$n|)))) + (#0='T + (PROGN + (SETQ |exp| (CAR |a|)) + (SETQ |n| (CADR |a|)) + (COND + ((NULL |n|) + (PROGN (SETQ |$n| |$sz|) (|shoeLeafLispExp| |exp|))) + (#0# + (PROGN (SETQ |$n| |n|) (|shoeLeafLispExp| |exp|))))))))))))) + +(DEFUN |shoeEscape| () + (PROG (|a|) + (DECLARE (SPECIAL |$n|)) + (RETURN + (PROGN + (SETQ |$n| (+ |$n| 1)) + (SETQ |a| (|shoeEsc|)) + (COND (|a| (|shoeWord| T)) ('T NIL)))))) + +(DEFUN |shoeEsc| () + (PROG (|n1|) + (DECLARE (SPECIAL |$ln| |$r| |$sz| |$n|)) + (RETURN + (COND + ((NOT (< |$n| |$sz|)) + (COND + ((|shoeNextLine| |$r|) + (LOOP + (COND (|$n| (RETURN NIL)) (#0='T (|shoeNextLine| |$r|)))) + (|shoeEsc|) NIL) + (#1='T NIL))) + (#1# (SETQ |n1| (STRPOSL " " |$ln| |$n| T)) + (COND + ((NULL |n1|) (|shoeNextLine| |$r|) + (LOOP + (COND (|$n| (RETURN NIL)) (#0# (|shoeNextLine| |$r|)))) + (|shoeEsc|) NIL) + (#1# T))))))) + +(DEFUN |shoeStartsComment| () + (PROG (|www|) + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (COND + ((< |$n| |$sz|) + (COND + ((EQUAL (QENUM |$ln| |$n|) |shoePLUSCOMMENT|) + (SETQ |www| (+ |$n| 1)) + (COND + ((NOT (< |www| |$sz|)) NIL) + (#0='T (EQUAL (QENUM |$ln| |www|) |shoePLUSCOMMENT|)))) + (#0# NIL))) + (#0# NIL))))) + +(DEFUN |shoeStartsNegComment| () + (PROG (|www|) + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (COND + ((< |$n| |$sz|) + (COND + ((EQUAL (QENUM |$ln| |$n|) |shoeMINUSCOMMENT|) + (SETQ |www| (+ |$n| 1)) + (COND + ((NOT (< |www| |$sz|)) NIL) + (#0='T (EQUAL (QENUM |$ln| |www|) |shoeMINUSCOMMENT|)))) + (#0# NIL))) + (#0# NIL))))) + +(DEFUN |shoeNegComment| () + (PROG (|n|) + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (PROGN + (SETQ |n| |$n|) + (SETQ |$n| |$sz|) + (|shoeLeafNegComment| (SUBSTRING |$ln| |n| NIL)))))) + +(DEFUN |shoeComment| () + (PROG (|n|) + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (PROGN + (SETQ |n| |$n|) + (SETQ |$n| |$sz|) + (|shoeLeafComment| (SUBSTRING |$ln| |n| NIL)))))) + +(DEFUN |shoePunct| () + (PROG (|sss|) + (DECLARE (SPECIAL |$n| |$ln|)) + (RETURN + (PROGN + (SETQ |sss| (|shoeMatch| |$ln| |$n|)) + (SETQ |$n| (+ |$n| (LENGTH |sss|))) + (|shoeKeyTr| |sss|))))) + +(DEFUN |shoeKeyTr| (|w|) + (PROG () + (DECLARE (SPECIAL |$floatok|)) + (RETURN + (COND + ((EQ (|shoeKeyWord| |w|) 'DOT) + (COND + (|$floatok| (|shoePossFloat| |w|)) + (#0='T (|shoeLeafKey| |w|)))) + (#0# (SETQ |$floatok| (NULL (|shoeCloser| |w|))) + (|shoeLeafKey| |w|)))))) + +(DEFUN |shoePossFloat| (|w|) + (PROG () + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (COND + ((OR (NOT (< |$n| |$sz|)) + (NULL (|shoeDigit| (ELT |$ln| |$n|)))) + (|shoeLeafKey| |w|)) + ('T (SETQ |w| (|shoeInteger|)) (|shoeExponent| "0" |w|)))))) + +(DEFUN |shoeSpace| () + (PROG (|n|) + (DECLARE (SPECIAL |$floatok| |$ln| |$n|)) + (RETURN + (PROGN + (SETQ |n| |$n|) + (SETQ |$n| (STRPOSL " " |$ln| |$n| T)) + (SETQ |$floatok| T) + (COND + ((NULL |$n|) (|shoeLeafSpaces| 0) (SETQ |$n| (LENGTH |$ln|))) + ('T (|shoeLeafSpaces| (- |$n| |n|)))))))) + +(DEFUN |shoeString| () + (PROG () + (DECLARE (SPECIAL |$floatok| |$n|)) + (RETURN + (PROGN + (SETQ |$n| (+ |$n| 1)) + (SETQ |$floatok| NIL) + (|shoeLeafString| (|shoeS|)))))) + +(DEFUN |shoeS| () + (PROG (|b| |a| |str| |mn| |escsym| |strsym| |n|) + (DECLARE (SPECIAL |$ln| |$linepos| |$sz| |$n|)) + (RETURN + (COND + ((NOT (< |$n| |$sz|)) + (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") "") + (#0='T (SETQ |n| |$n|) + (SETQ |strsym| (OR (STRPOS "\"" |$ln| |$n| NIL) |$sz|)) + (SETQ |escsym| (OR (STRPOS "_" |$ln| |$n| NIL) |$sz|)) + (SETQ |mn| (MIN |strsym| |escsym|)) + (COND + ((EQUAL |mn| |$sz|) (SETQ |$n| |$sz|) + (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") + (SUBSTRING |$ln| |n| NIL)) + ((EQUAL |mn| |strsym|) (SETQ |$n| (+ |mn| 1)) + (SUBSTRING |$ln| |n| (- |mn| |n|))) + (#0# (SETQ |str| (SUBSTRING |$ln| |n| (- |mn| |n|))) + (SETQ |$n| (+ |mn| 1)) (SETQ |a| (|shoeEsc|)) + (SETQ |b| + (COND + (|a| (SETQ |str| (CONCAT |str| (ELT |$ln| |$n|))) + (SETQ |$n| (+ |$n| 1)) (|shoeS|)) + (#0# (|shoeS|)))) + (CONCAT |str| |b|)))))))) + +(DEFUN |shoeIdEnd| (|line| |n|) + (PROG () + (RETURN + (PROGN + (LOOP + (COND + ((NOT (AND (< |n| (LENGTH |line|)) + (|shoeIdChar| (ELT |line| |n|)))) + (RETURN NIL)) + ('T (SETQ |n| (+ |n| 1))))) + |n|)))) + +(DEFUN |shoeDigit| (|x|) (PROG () (RETURN (DIGIT-CHAR-P |x|)))) + +(DEFUN |shoeW| (|b|) + (PROG (|bb| |a| |str| |endid| |l| |n1|) + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (PROGN + (SETQ |n1| |$n|) + (SETQ |$n| (+ |$n| 1)) + (SETQ |l| |$sz|) + (SETQ |endid| (|shoeIdEnd| |$ln| |$n|)) + (COND + ((OR (EQUAL |endid| |l|) + (NOT (EQUAL (QENUM |$ln| |endid|) |shoeESCAPE|))) + (SETQ |$n| |endid|) + (LIST |b| (SUBSTRING |$ln| |n1| (- |endid| |n1|)))) + (#0='T (SETQ |str| (SUBSTRING |$ln| |n1| (- |endid| |n1|))) + (SETQ |$n| (+ |endid| 1)) (SETQ |a| (|shoeEsc|)) + (SETQ |bb| (COND (|a| (|shoeW| T)) (#0# (LIST |b| "")))) + (LIST (OR (ELT |bb| 0) |b|) (CONCAT |str| (ELT |bb| 1))))))))) + +(DEFUN |shoeWord| (|esp|) + (PROG (|w| |aaa|) + (DECLARE (SPECIAL |$floatok|)) + (RETURN + (PROGN + (SETQ |aaa| (|shoeW| NIL)) + (SETQ |w| (ELT |aaa| 1)) + (SETQ |$floatok| NIL) + (COND + ((OR |esp| (ELT |aaa| 0)) (|shoeLeafId| |w|)) + ((|shoeKeyWordP| |w|) (SETQ |$floatok| T) + (|shoeLeafKey| |w|)) + ('T (|shoeLeafId| |w|))))))) + +(DEFUN |shoeInteger| () (PROG () (RETURN (|shoeInteger1| NIL)))) + +(DEFUN |shoeInteger1| (|zro|) + (PROG (|bb| |a| |str| |l| |n|) + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (PROGN + (SETQ |n| |$n|) + (SETQ |l| |$sz|) + (LOOP + (COND + ((NOT (AND (< |$n| |l|) (|shoeDigit| (ELT |$ln| |$n|)))) + (RETURN NIL)) + ('T (SETQ |$n| (+ |$n| 1))))) + (COND + ((OR (EQUAL |$n| |l|) + (NOT (EQUAL (QENUM |$ln| |$n|) |shoeESCAPE|))) + (COND + ((AND (EQUAL |n| |$n|) |zro|) "0") + (#0='T (SUBSTRING |$ln| |n| (- |$n| |n|))))) + (#0# (SETQ |str| (SUBSTRING |$ln| |n| (- |$n| |n|))) + (SETQ |$n| (+ |$n| 1)) (SETQ |a| (|shoeEsc|)) + (SETQ |bb| (|shoeInteger1| |zro|)) (CONCAT |str| |bb|))))))) + +(DEFUN |shoeIntValue| (|s|) + (PROG (|d| |ival| |ns|) + (RETURN + (PROGN + (SETQ |ns| (LENGTH |s|)) + (SETQ |ival| 0) + (LET ((|bfVar#1| (- |ns| 1)) (|i| 0)) + (LOOP + (COND + ((> |i| |bfVar#1|) (RETURN NIL)) + ('T + (PROGN + (SETQ |d| (|shoeOrdToNum| (ELT |s| |i|))) + (SETQ |ival| (+ (* 10 |ival|) |d|))))) + (SETQ |i| (+ |i| 1)))) + |ival|)))) + +(DEFUN |shoeNumber| () + (PROG (|w| |n| |a|) + (DECLARE (SPECIAL |$ln| |$floatok| |$sz| |$n|)) + (RETURN + (PROGN + (SETQ |a| (|shoeInteger|)) + (COND + ((NOT (< |$n| |$sz|)) (|shoeLeafInteger| |a|)) + ((AND |$floatok| (EQUAL (QENUM |$ln| |$n|) |shoeDOT|)) + (SETQ |n| |$n|) (SETQ |$n| (+ |$n| 1)) + (COND + ((AND (< |$n| |$sz|) (EQUAL (QENUM |$ln| |$n|) |shoeDOT|)) + (SETQ |$n| |n|) (|shoeLeafInteger| |a|)) + (#0='T (SETQ |w| (|shoeInteger1| T)) + (|shoeExponent| |a| |w|)))) + (#0# (|shoeLeafInteger| |a|))))))) + +(DEFUN |shoeExponent| (|a| |w|) + (PROG (|c1| |e| |c| |n|) + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (COND + ((NOT (< |$n| |$sz|)) (|shoeLeafFloat| |a| |w| 0)) + (#0='T (SETQ |n| |$n|) (SETQ |c| (QENUM |$ln| |$n|)) + (COND + ((OR (EQUAL |c| |shoeEXPONENT1|) + (EQUAL |c| |shoeEXPONENT2|)) + (SETQ |$n| (+ |$n| 1)) + (COND + ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|) + (|shoeLeafFloat| |a| |w| 0)) + ((|shoeDigit| (ELT |$ln| |$n|)) + (SETQ |e| (|shoeInteger|)) + (SETQ |e| (|shoeIntValue| |e|)) + (|shoeLeafFloat| |a| |w| |e|)) + (#0# (SETQ |c1| (QENUM |$ln| |$n|)) + (COND + ((OR (EQUAL |c1| |shoePLUSCOMMENT|) + (EQUAL |c1| |shoeMINUSCOMMENT|)) + (SETQ |$n| (+ |$n| 1)) + (COND + ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|) + (|shoeLeafFloat| |a| |w| 0)) + ((|shoeDigit| (ELT |$ln| |$n|)) + (SETQ |e| (|shoeInteger|)) + (SETQ |e| (|shoeIntValue| |e|)) + (|shoeLeafFloat| |a| |w| + (COND + ((EQUAL |c1| |shoeMINUSCOMMENT|) (- |e|)) + (#0# |e|)))) + (#0# (SETQ |$n| |n|) (|shoeLeafFloat| |a| |w| 0)))))))) + (#0# (|shoeLeafFloat| |a| |w| 0)))))))) + +(DEFUN |shoeError| () + (PROG (|n|) + (DECLARE (SPECIAL |$ln| |$linepos| |$n|)) + (RETURN + (PROGN + (SETQ |n| |$n|) + (SETQ |$n| (+ |$n| 1)) + (|SoftShoeError| (CONS |$linepos| |n|) + (CONCAT "The character whose number is " + (STRINGIMAGE (QENUM |$ln| |n|)) + " is not a Boot character")) + (|shoeLeafError| (ELT |$ln| |n|)))))) + +(DEFUN |shoeOrdToNum| (|x|) (PROG () (RETURN (DIGIT-CHAR-P |x|)))) + +(DEFUN |shoeKeyWord| (|st|) + (PROG () (RETURN (GETHASH |st| |shoeKeyTable|)))) + +(DEFUN |shoeKeyWordP| (|st|) + (PROG () (RETURN (NULL (NULL (GETHASH |st| |shoeKeyTable|)))))) + +(DEFUN |shoeMatch| (|l| |i|) + (PROG () (RETURN (|shoeSubStringMatch| |l| |shoeDict| |i|)))) + +(DEFUN |shoeSubStringMatch| (|l| |d| |i|) + (PROG (|eql| |ls| |s| |s1| |done| |ll| |u| |h|) + (RETURN + (PROGN + (SETQ |h| (QENUM |l| |i|)) + (SETQ |u| (ELT |d| |h|)) + (SETQ |ll| (SIZE |l|)) + (SETQ |done| NIL) + (SETQ |s1| "") + (LET ((|bfVar#2| (- (SIZE |u|) 1)) (|j| 0)) + (LOOP + (COND + ((OR (> |j| |bfVar#2|) |done|) (RETURN NIL)) + (#0='T + (PROGN + (SETQ |s| (ELT |u| |j|)) + (SETQ |ls| (SIZE |s|)) + (SETQ |done| + (COND + ((< |ll| (+ |ls| |i|)) NIL) + (#1='T (SETQ |eql| T) + (LET ((|bfVar#3| (- |ls| 1)) (|k| 1)) + (LOOP + (COND + ((OR (> |k| |bfVar#3|) (NOT |eql|)) + (RETURN NIL)) + (#0# + (SETQ |eql| + (EQL (QENUM |s| |k|) + (QENUM |l| (+ |k| |i|)))))) + (SETQ |k| (+ |k| 1)))) + (COND (|eql| (SETQ |s1| |s|) T) (#1# NIL)))))))) + (SETQ |j| (+ |j| 1)))) + |s1|)))) + +(DEFUN |shoePunctuation| (|c|) + (PROG () (RETURN (EQL (ELT |shoePun| |c|) 1)))) + diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp new file mode 100644 index 00000000..3ce6a7c8 --- /dev/null +++ b/src/boot/strap/tokens.clisp @@ -0,0 +1,352 @@ +(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-tokens")) + +(IMPORT-MODULE "initial-env") + +(IN-PACKAGE "BOOTTRAN") + +(DEFPARAMETER |shoeKeyWords| + (LIST (LIST "and" 'AND) (LIST "by" 'BY) (LIST "case" 'CASE) + (LIST "cross" 'CROSS) (LIST "else" 'ELSE) (LIST "for" 'FOR) + (LIST "if" 'IF) (LIST "import" 'IMPORT) (LIST "in" 'IN) + (LIST "is" 'IS) (LIST "isnt" 'ISNT) (LIST "module" 'MODULE) + (LIST "of" 'OF) (LIST "or" 'OR) (LIST "repeat" 'REPEAT) + (LIST "return" 'RETURN) (LIST "structure" 'STRUCTURE) + (LIST "then" 'THEN) (LIST "until" 'UNTIL) + (LIST "where" 'WHERE) (LIST "while" 'WHILE) (LIST "." 'DOT) + (LIST ":" 'COLON) (LIST "::" 'COLON-COLON) (LIST "," 'COMMA) + (LIST ";" 'SEMICOLON) (LIST "*" 'TIMES) (LIST "**" 'POWER) + (LIST "/" 'SLASH) (LIST "+" 'PLUS) (LIST "-" 'MINUS) + (LIST "<" 'LT) (LIST ">" 'GT) (LIST "<=" 'LE) (LIST ">=" 'GE) + (LIST "=" 'SHOEEQ) (LIST "^" 'NOT) (LIST "^=" 'SHOENE) + (LIST ".." 'SEG) (LIST "#" 'LENGTH) (LIST "=>" 'EXIT) + (LIST "->" 'ARROW) (LIST ":=" 'BEC) (LIST "==" 'DEF) + (LIST "==>" 'MDEF) (LIST "<=>" 'TDEF) (LIST "(" 'OPAREN) + (LIST ")" 'CPAREN) (LIST "(|" 'OBRACK) (LIST "|)" 'CBRACK) + (LIST "[" 'OBRACK) (LIST "]" 'CBRACK) (LIST "suchthat" 'BAR) + (LIST "'" 'QUOTE) (LIST "|" 'BAR))) + +(DEFUN |shoeKeyTableCons| () + (PROG (|KeyTable|) + (RETURN + (PROGN + (SETQ |KeyTable| (MAKE-HASHTABLE 'CVEC)) + (LET ((|bfVar#1| |shoeKeyWords|) (|st| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#1|) + (PROGN (SETQ |st| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + ('T (HPUT |KeyTable| (CAR |st|) (CADR |st|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + |KeyTable|)))) + +(DEFPARAMETER |shoeKeyTable| (|shoeKeyTableCons|)) + +(DEFPARAMETER |shoeSPACE| (QENUM " " 0)) + +(DEFPARAMETER |shoeESCAPE| (QENUM "_ " 0)) + +(DEFPARAMETER |shoeLispESCAPE| (QENUM "! " 0)) + +(DEFPARAMETER |shoeSTRINGCHAR| (QENUM "\" " 0)) + +(DEFPARAMETER |shoePLUSCOMMENT| (QENUM "+ " 0)) + +(DEFPARAMETER |shoeMINUSCOMMENT| (QENUM "- " 0)) + +(DEFPARAMETER |shoeDOT| (QENUM ". " 0)) + +(DEFPARAMETER |shoeEXPONENT1| (QENUM "E " 0)) + +(DEFPARAMETER |shoeEXPONENT2| (QENUM "e " 0)) + +(DEFPARAMETER |shoeCLOSEPAREN| (QENUM ") " 0)) + +(DEFPARAMETER |shoeTAB| 9) + +(DEFUN |shoeInsert| (|s| |d|) + (PROG (|v| |k| |n| |u| |h| |l|) + (RETURN + (PROGN + (SETQ |l| (LENGTH |s|)) + (SETQ |h| (QENUM |s| 0)) + (SETQ |u| (ELT |d| |h|)) + (SETQ |n| (LENGTH |u|)) + (SETQ |k| 0) + (LOOP + (COND + ((< (LENGTH (ELT |u| |k|)) |l|) (RETURN NIL)) + (#0='T (SETQ |k| (+ |k| 1))))) + (SETQ |v| (MAKE-VEC (+ |n| 1))) + (LET ((|bfVar#2| (- |k| 1)) (|i| 0)) + (LOOP + (COND + ((> |i| |bfVar#2|) (RETURN NIL)) + (#0# (VEC-SETELT |v| |i| (ELT |u| |i|)))) + (SETQ |i| (+ |i| 1)))) + (VEC-SETELT |v| |k| |s|) + (LET ((|bfVar#3| (- |n| 1)) (|i| |k|)) + (LOOP + (COND + ((> |i| |bfVar#3|) (RETURN NIL)) + (#0# (VEC-SETELT |v| (+ |i| 1) (ELT |u| |i|)))) + (SETQ |i| (+ |i| 1)))) + (VEC-SETELT |d| |h| |v|) + |s|)))) + +(DEFUN |shoeDictCons| () + (PROG (|d| |b| |a| |l|) + (RETURN + (PROGN + (SETQ |l| (HKEYS |shoeKeyTable|)) + (SETQ |d| + (PROGN + (SETQ |a| (MAKE-VEC 256)) + (SETQ |b| (MAKE-VEC 1)) + (VEC-SETELT |b| 0 (MAKE-CVEC 0)) + (LET ((|i| 0)) + (LOOP + (COND + ((> |i| 255) (RETURN NIL)) + (#0='T (VEC-SETELT |a| |i| |b|))) + (SETQ |i| (+ |i| 1)))) + |a|)) + (LET ((|bfVar#4| |l|) (|s| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#4|) + (PROGN (SETQ |s| (CAR |bfVar#4|)) NIL)) + (RETURN NIL)) + (#0# (|shoeInsert| |s| |d|))) + (SETQ |bfVar#4| (CDR |bfVar#4|)))) + |d|)))) + +(DEFPARAMETER |shoeDict| (|shoeDictCons|)) + +(DEFUN |shoePunCons| () + (PROG (|a| |listing|) + (RETURN + (PROGN + (SETQ |listing| (HKEYS |shoeKeyTable|)) + (SETQ |a| (MAKE-BVEC 256)) + (LET ((|i| 0)) + (LOOP + (COND + ((> |i| 255) (RETURN NIL)) + (#0='T (BVEC-SETELT |a| |i| 0))) + (SETQ |i| (+ |i| 1)))) + (LET ((|bfVar#5| |listing|) (|k| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#5|) + (PROGN (SETQ |k| (CAR |bfVar#5|)) NIL)) + (RETURN NIL)) + (#0# + (COND + ((NULL (|shoeStartsId| (ELT |k| 0))) + (BVEC-SETELT |a| (QENUM |k| 0) 1))))) + (SETQ |bfVar#5| (CDR |bfVar#5|)))) + |a|)))) + +(DEFPARAMETER |shoePun| (|shoePunCons|)) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + (LET ((|bfVar#6| (LIST 'NOT 'LENGTH)) (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#6|) + (PROGN (SETQ |i| (CAR |bfVar#6|)) NIL)) + (RETURN NIL)) + ('T (SETF (GET |i| 'SHOEPRE) 'T))) + (SETQ |bfVar#6| (CDR |bfVar#6|))))))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + (LET ((|bfVar#7| + (LIST (LIST 'SHOEEQ '=) (LIST 'TIMES '*) + (LIST 'PLUS '+) (LIST 'IS '|is|) + (LIST 'ISNT '|isnt|) (LIST 'AND '|and|) + (LIST 'OR '|or|) (LIST 'SLASH '/) + (LIST 'POWER '**) (LIST 'MINUS '-) (LIST 'LT '<) + (LIST 'GT '>) (LIST 'LE '<=) (LIST 'GE '>=) + (LIST 'SHOENE '^=))) + (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#7|) + (PROGN (SETQ |i| (CAR |bfVar#7|)) NIL)) + (RETURN NIL)) + ('T (SETF (GET (CAR |i|) 'SHOEINF) (CADR |i|)))) + (SETQ |bfVar#7| (CDR |bfVar#7|))))))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + (LET ((|bfVar#8| + (LIST (LIST '+ 0) (LIST '|gcd| 0) (LIST '|lcm| 1) + (LIST 'STRCONC "") (LIST '|strconc| "") + (LIST 'MAX (- 999999)) (LIST 'MIN 999999) + (LIST '* 1) (LIST '|times| 1) (LIST 'CONS NIL) + (LIST 'APPEND NIL) (LIST '|append| NIL) + (LIST 'UNION NIL) (LIST 'UNIONQ NIL) + (LIST '|union| NIL) (LIST 'NCONC NIL) + (LIST '|and| 'T) (LIST '|or| NIL) (LIST 'AND 'T) + (LIST 'OR NIL))) + (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#8|) + (PROGN (SETQ |i| (CAR |bfVar#8|)) NIL)) + (RETURN NIL)) + ('T (SETF (GET (CAR |i|) 'SHOETHETA) (CDR |i|)))) + (SETQ |bfVar#8| (CDR |bfVar#8|))))))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + (LET ((|bfVar#9| + (LIST (LIST '|and| 'AND) (LIST '|append| 'APPEND) + (LIST '|apply| 'APPLY) (LIST '|atom| 'ATOM) + (LIST '|car| 'CAR) (LIST '|cdr| 'CDR) + (LIST '|cons| 'CONS) (LIST '|copy| 'COPY) + (LIST '|croak| 'CROAK) (LIST '|drop| 'DROP) + (LIST '|exit| 'EXIT) (LIST '|false| 'NIL) + (LIST '|first| 'CAR) (LIST '|function| 'FUNCTION) + (LIST '|genvar| 'GENVAR) (LIST 'IN 'MEMBER) + (LIST '|is| 'IS) (LIST '|isnt| 'ISNT) + (LIST '|lastNode| 'LAST) (LIST 'LAST '|last|) + (LIST '|list| 'LIST) (LIST '|mkpf| 'MKPF) + (LIST '|nconc| 'NCONC) (LIST '|nil| NIL) + (LIST '|not| 'NULL) (LIST 'NOT 'NULL) + (LIST '|nreverse| 'NREVERSE) (LIST '|null| 'NULL) + (LIST '|or| 'OR) (LIST '|otherwise| 'T) + (LIST 'PAIRP 'CONSP) + (LIST '|removeDuplicates| 'REMDUP) + (LIST '|rest| 'CDR) (LIST '|reverse| 'REVERSE) + (LIST '|setDifference| 'SETDIFFERENCE) + (LIST '|setIntersection| 'INTERSECTION) + (LIST '|setPart| 'SETELT) + (LIST '|setUnion| 'UNION) (LIST '|size| 'SIZE) + (LIST '|strconc| 'CONCAT) + (LIST '|substitute| 'SUBST) (LIST '|take| 'TAKE) + (LIST '|true| 'T) (LIST 'PLUS '+) + (LIST 'MINUS '-) (LIST 'TIMES '*) + (LIST 'POWER 'EXPT) (LIST 'SLASH '/) + (LIST 'LT '<) (LIST 'GT '>) (LIST 'LE '<=) + (LIST 'GE '>=) (LIST 'SHOEEQ 'EQUAL) + (LIST 'SHOENE '/=) (LIST 'T 'T$))) + (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#9|) + (PROGN (SETQ |i| (CAR |bfVar#9|)) NIL)) + (RETURN NIL)) + ('T (SETF (GET (CAR |i|) 'SHOERENAME) (CDR |i|)))) + (SETQ |bfVar#9| (CDR |bfVar#9|))))))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + (LET ((|bfVar#10| + (LIST (LIST 'PLUS 'PLUS) (LIST '|and| 'AND) + (LIST '|append| 'APPEND) (LIST '|apply| 'APPLY) + (LIST '|atom| 'ATOM) (LIST '|brace| 'REMDUP) + (LIST '|car| 'CAR) (LIST '|cdr| 'CDR) + (LIST '|cons| 'CONS) (LIST '|copy| 'COPY) + (LIST '|croak| 'CROAK) (LIST '|drop| 'DROP) + (LIST '|exit| 'EXIT) (LIST '|false| 'NIL) + (LIST '|first| 'CAR) (LIST '|genvar| 'GENVAR) + (LIST '|in| '|member|) (LIST '|is| 'IS) + (LIST '|lastNode| 'LASTNODE) (LIST '|list| 'LIST) + (LIST '|mkpf| 'MKPF) (LIST '|nconc| 'NCONC) + (LIST '|nil| 'NIL) (LIST '|not| 'NULL) + (LIST 'NOT 'NULL) (LIST '|nreverse| 'NREVERSE) + (LIST '|null| 'NULL) (LIST '|or| 'OR) + (LIST '|otherwise| 'T) + (LIST '|removeDuplicates| 'REMDUP) + (LIST '|rest| 'CDR) (LIST '|return| 'RETURN) + (LIST '|reverse| 'REVERSE) + (LIST '|setDifference| 'SETDIFFERENCE) + (LIST '|setIntersection| '|intersection|) + (LIST '|setPart| 'SETELT) + (LIST '|setUnion| '|union|) (LIST '|size| 'SIZE) + (LIST '|strconc| 'STRCONC) + (LIST '|substitute| 'MSUBST) + (LIST 'SUBST 'MSUBST) (LIST '|take| 'TAKE) + (LIST '|true| 'T) (LIST '|where| 'WHERE) + (LIST 'TIMES 'TIMES) (LIST 'POWER 'EXPT) + (LIST 'NOT 'NULL) (LIST 'SHOENE 'NEQUAL) + (LIST 'MINUS 'SPADDIFFERENCE) + (LIST 'SLASH 'QUOTIENT) (LIST '= 'EQUAL) + (LIST 'SHOEEQ 'EQUAL) (LIST 'ASSOC '|assoc|) + (LIST 'DELETE '|delete|) (LIST 'GET 'GETL) + (LIST 'INTERSECTION '|intersection|) + (LIST 'LAST '|last|) (LIST 'MEMBER '|member|) + (LIST 'RASSOC '|rassoc|) (LIST 'READ 'VMREAD) + (LIST 'READ-LINE '|read-line|) + (LIST 'REDUCE 'SPADREDUCE) + (LIST 'REMOVE '|remove|) (LIST 'BAR 'SUCHTHAT) + (LIST 'T 'T$) (LIST 'IN '|member|) + (LIST 'UNION '|union|))) + (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#10|) + (PROGN (SETQ |i| (CAR |bfVar#10|)) NIL)) + (RETURN NIL)) + ('T (SETF (GET (CAR |i|) 'OLD-BOOT) (CDR |i|)))) + (SETQ |bfVar#10| (CDR |bfVar#10|))))))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + (LET ((|bfVar#11| + (LIST 'LT 'LE 'GT 'GE 'SHOENE 'TIMES 'PLUS 'MINUS + '|function| 'PAIRP)) + (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#11|) + (PROGN (SETQ |i| (CAR |bfVar#11|)) NIL)) + (RETURN NIL)) + ('T (SETF (GET |i| 'RENAME-OK) T))) + (SETQ |bfVar#11| (CDR |bfVar#11|))))))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + (LET ((|bfVar#12| + (LIST (LIST '|setName| 0) (LIST '|setLabel| 1) + (LIST '|setLevel| 2) (LIST '|setType| 3) + (LIST '|setVar| 4) (LIST '|setLeaf| 5) + (LIST '|setDef| 6) (LIST '|aGeneral| 4) + (LIST '|aMode| 1) (LIST '|aModeSet| 3) + (LIST '|aTree| 0) (LIST '|aValue| 2) + (LIST '|attributes| 'CADDR) + (LIST '|cacheCount| 'CADDDDR) + (LIST '|cacheName| 'CADR) + (LIST '|cacheReset| 'CADDDR) + (LIST '|cacheType| 'CADDR) (LIST '|env| 'CADDR) + (LIST '|expr| 'CAR) (LIST 'CAR 'CAR) + (LIST '|mmCondition| 'CAADR) (LIST '|mmDC| 'CAAR) + (LIST '|mmImplementation| 'CADADR) + (LIST '|mmSignature| 'CDAR) + (LIST '|mmTarget| 'CADAR) (LIST '|mode| 'CADR) + (LIST '|op| 'CAR) (LIST '|opcode| 'CADR) + (LIST '|opSig| 'CADR) (LIST 'CDR 'CDR) + (LIST '|sig| 'CDDR) (LIST '|source| 'CDR) + (LIST '|streamCode| 'CADDDR) + (LIST '|streamDef| 'CADDR) + (LIST '|streamName| 'CADR) (LIST '|target| 'CAR))) + (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#12|) + (PROGN (SETQ |i| (CAR |bfVar#12|)) NIL)) + (RETURN NIL)) + ('T (SETF (GET (CAR |i|) 'SHOESELFUNCTION) (CADR |i|)))) + (SETQ |bfVar#12| (CDR |bfVar#12|))))))) + diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp new file mode 100644 index 00000000..0b849cfc --- /dev/null +++ b/src/boot/strap/translator.clisp @@ -0,0 +1,1156 @@ +(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-translator")) + +(IMPORT-MODULE "includer") + +(IMPORT-MODULE "scanner") + +(IMPORT-MODULE "pile") + +(IMPORT-MODULE "parser") + +(IMPORT-MODULE "ast") + +(IN-PACKAGE "BOOTTRAN") + +(DEFPARAMETER |$translatingOldBoot| NIL) + +(DEFUN |AxiomCore|::|%sysInit| () + (PROG () + (DECLARE (SPECIAL |$translatingOldBoot|)) + (RETURN + (COND + ((EQUAL (CDR (ASSOC (|Option| "boot") (|%systemOptions|))) + "old") + (SETQ |$translatingOldBoot| T)))))) + +(DEFUN |setCurrentPackage| (|x|) + (PROG () (RETURN (SETQ *PACKAGE* |x|)))) + +(DEFUN |shoeCOMPILE-FILE| (|lspFileName|) + (PROG () (RETURN (COMPILE-FILE |lspFileName|)))) + +(DEFUN BOOTTOCL (|fn| |out|) + (PROG () (RETURN (BOOTTOCLLINES NIL |fn| |out|)))) + +(DEFUN BOOTCLAM (|fn| |out|) + (PROG () + (DECLARE (SPECIAL |$bfClamming|)) + (RETURN + (PROGN (SETQ |$bfClamming| T) (BOOTCLAMLINES NIL |fn| |out|))))) + +(DEFUN BOOTCLAMLINES (|lines| |fn| |out|) + (PROG () (RETURN (BOOTTOCLLINES |lines| |fn| |out|)))) + +(DEFUN BOOTTOCLLINES (|lines| |fn| |outfn|) + (PROG (|result| |infn| |callingPackage|) + (RETURN + (PROGN + (SETQ *READ-DEFAULT-FLOAT-FORMAT* 'DOUBLE-FLOAT) + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (SETQ |result| + (|shoeOpenInputFile| |a| |infn| + (|shoeClLines| |a| |fn| |lines| |outfn|))) + (|setCurrentPackage| |callingPackage|) + |result|)))) + +(DEFUN |shoeClLines| (|a| |fn| |lines| |outfn|) + (PROG (|$GenVarCounter|) + (DECLARE (SPECIAL |$GenVarCounter|)) + (RETURN + (COND + ((NULL |a|) (|shoeNotFound| |fn|)) + ('T (SETQ |$GenVarCounter| 0) + (|shoeOpenOutputFile| |stream| |outfn| + (PROGN + (LET ((|bfVar#1| |lines|) (|line| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#1|) + (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + ('T (|shoeFileLine| |line| |stream|))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (|shoeFileTrees| (|shoeTransformStream| |a|) |stream|))) + |outfn|))))) + +(DEFUN BOOTTOCLC (|fn| |out|) + (PROG () (RETURN (BOOTTOCLCLINES NIL |fn| |out|)))) + +(DEFUN BOOTTOCLCLINES (|lines| |fn| |outfn|) + (PROG (|result| |infn| |callingPackage|) + (RETURN + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (SETQ |result| + (|shoeOpenInputFile| |a| |infn| + (|shoeClCLines| |a| |fn| |lines| |outfn|))) + (|setCurrentPackage| |callingPackage|) + |result|)))) + +(DEFUN |shoeClCLines| (|a| |fn| |lines| |outfn|) + (PROG (|$GenVarCounter|) + (DECLARE (SPECIAL |$GenVarCounter|)) + (RETURN + (COND + ((NULL |a|) (|shoeNotFound| |fn|)) + ('T (SETQ |$GenVarCounter| 0) + (|shoeOpenOutputFile| |stream| |outfn| + (PROGN + (LET ((|bfVar#2| |lines|) (|line| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#2|) + (PROGN (SETQ |line| (CAR |bfVar#2|)) NIL)) + (RETURN NIL)) + ('T (|shoeFileLine| |line| |stream|))) + (SETQ |bfVar#2| (CDR |bfVar#2|)))) + (|shoeFileTrees| + (|shoeTransformToFile| |stream| + (|shoeInclude| + (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0)))) + |stream|))) + |outfn|))))) + +(DEFUN BOOTTOMC (|fn|) + (PROG (|$GenVarCounter| |result| |infn| |callingPackage|) + (DECLARE (SPECIAL |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$GenVarCounter| 0) + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (SETQ |result| + (|shoeOpenInputFile| |a| |infn| (|shoeMc| |a| |fn|))) + (|setCurrentPackage| |callingPackage|) + |result|)))) + +(DEFUN |shoeMc| (|a| |fn|) + (PROG () + (RETURN + (COND + ((NULL |a|) (|shoeNotFound| |fn|)) + ('T (|shoePCompileTrees| (|shoeTransformStream| |a|)) + (|shoeConsole| (CONCAT |fn| " COMPILED AND LOADED"))))))) + +(DEFUN EVAL-BOOT-FILE (|fn|) + (PROG (|outfn| |infn| |b|) + (RETURN + (PROGN + (SETQ |b| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (SETQ |outfn| + (CONCAT (|shoeRemovebootIfNec| |fn|) "." + *LISP-SOURCE-FILETYPE*)) + (|shoeOpenInputFile| |a| |infn| + (|shoeClLines| |a| |infn| NIL |outfn|)) + (|setCurrentPackage| |b|) + (LOAD |outfn|))))) + +(DEFUN BO (|fn|) + (PROG (|$GenVarCounter| |infn| |b|) + (DECLARE (SPECIAL |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |b| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$GenVarCounter| 0) + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (|shoeOpenInputFile| |a| |infn| (|shoeToConsole| |a| |fn|)) + (|setCurrentPackage| |b|))))) + +(DEFUN BOCLAM (|fn|) + (PROG (|$bfClamming| |$GenVarCounter| |result| |infn| + |callingPackage|) + (DECLARE (SPECIAL |$bfClamming| |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$GenVarCounter| 0) + (SETQ |$bfClamming| T) + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (SETQ |result| + (|shoeOpenInputFile| |a| |infn| + (|shoeToConsole| |a| |fn|))) + (|setCurrentPackage| |callingPackage|) + |result|)))) + +(DEFUN |shoeToConsole| (|a| |fn|) + (PROG () + (RETURN + (COND + ((NULL |a|) (|shoeNotFound| |fn|)) + ('T + (|shoeConsoleTrees| + (|shoeTransformToConsole| + (|shoeInclude| + (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0)))))))))) + +(DEFUN STOUT (|string|) (PROG () (RETURN (PSTOUT (LIST |string|))))) + +(DEFUN STEVAL (|string|) + (PROG (|$GenVarCounter| |result| |fn| |a| |callingPackage|) + (DECLARE (SPECIAL |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$GenVarCounter| 0) + (SETQ |a| (|shoeTransformString| (LIST |string|))) + (SETQ |result| + (COND + ((|bStreamPackageNull| |a|) NIL) + ('T + (PROGN + (SETQ |fn| + (|stripm| (CAR |a|) *PACKAGE* + (FIND-PACKAGE "BOOTTRAN"))) + (EVAL |fn|))))) + (|setCurrentPackage| |callingPackage|) + |result|)))) + +(DEFUN STTOMC (|string|) + (PROG (|$GenVarCounter| |result| |a| |callingPackage|) + (DECLARE (SPECIAL |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$GenVarCounter| 0) + (SETQ |a| (|shoeTransformString| (LIST |string|))) + (SETQ |result| + (COND + ((|bStreamPackageNull| |a|) NIL) + ('T (|shoePCompile| (CAR |a|))))) + (|setCurrentPackage| |callingPackage|) + |result|)))) + +(DEFUN |shoeCompileTrees| (|s|) + (PROG () + (RETURN + (LOOP + (COND + ((|bStreamNull| |s|) (RETURN NIL)) + ('T (PROGN (|shoeCompile| (CAR |s|)) (SETQ |s| (CDR |s|))))))))) + +(DEFUN |shoeCompile| (|fn|) + (PROG (|body| |bv| |ISTMP#2| |name| |ISTMP#1|) + (RETURN + (COND + ((AND (CONSP |fn|) (EQ (CAR |fn|) 'DEFUN) + (PROGN + (SETQ |ISTMP#1| (CDR |fn|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |name| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |bv| (CAR |ISTMP#2|)) + (SETQ |body| (CDR |ISTMP#2|)) + 'T)))))) + (COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|)))) + ('T (EVAL |fn|)))))) + +(DEFUN |shoeTransform| (|str|) + (PROG () + (RETURN + (|bNext| #'|shoeTreeConstruct| + (|bNext| #'|shoePileInsert| + (|bNext| #'|shoeLineToks| |str|)))))) + +(DEFUN |shoeTransformString| (|s|) + (PROG () + (RETURN + (|shoeTransform| + (|shoeInclude| (|bAddLineNumber| |s| (|bIgen| 0))))))) + +(DEFUN |shoeTransformStream| (|s|) + (PROG () (RETURN (|shoeTransformString| (|bRgen| |s|))))) + +(DEFUN |shoeTransformToConsole| (|str|) + (PROG () + (RETURN + (|bNext| #'|shoeConsoleItem| + (|bNext| #'|shoePileInsert| + (|bNext| #'|shoeLineToks| |str|)))))) + +(DEFUN |shoeTransformToFile| (|fn| |str|) + (PROG () + (RETURN + (|bFileNext| |fn| + (|bNext| #'|shoePileInsert| (|bNext| #'|shoeLineToks| |str|)))))) + +(DEFUN |shoeConsoleItem| (|str|) + (PROG (|dq|) + (RETURN + (PROGN + (SETQ |dq| (CAR |str|)) + (|shoeConsoleLines| (|shoeDQlines| |dq|)) + (CONS (|shoeParseTrees| |dq|) (CDR |str|)))))) + +(DEFUN |bFileNext| (|fn| |s|) + (PROG () (RETURN (|bDelay| #'|bFileNext1| (LIST |fn| |s|))))) + +(DEFUN |bFileNext1| (|fn| |s|) + (PROG (|dq|) + (RETURN + (COND + ((|bStreamNull| |s|) (LIST '|nullstream|)) + ('T + (PROGN + (SETQ |dq| (CAR |s|)) + (|shoeFileLines| (|shoeDQlines| |dq|) |fn|) + (|bAppend| (|shoeParseTrees| |dq|) + (|bFileNext| |fn| (CDR |s|))))))))) + +(DEFUN |shoeParseTrees| (|dq|) + (PROG (|toklist|) + (RETURN + (PROGN + (SETQ |toklist| (|dqToList| |dq|)) + (COND ((NULL |toklist|) NIL) ('T (|shoeOutParse| |toklist|))))))) + +(DEFUN |shoeTreeConstruct| (|str|) + (PROG () (RETURN (CONS (|shoeParseTrees| (CAR |str|)) (CDR |str|))))) + +(DEFUN |shoeDQlines| (|dq|) + (PROG (|b| |a|) + (RETURN + (PROGN + (SETQ |a| (CDAAR (|shoeLastTokPosn| |dq|))) + (SETQ |b| (CDAAR (|shoeFirstTokPosn| |dq|))) + (|streamTake| (+ (- |a| |b|) 1) + (CAR (|shoeFirstTokPosn| |dq|))))))) + +(DEFUN |streamTake| (|n| |s|) + (PROG () + (RETURN + (COND + ((|bStreamNull| |s|) NIL) + ((EQL |n| 0) NIL) + ('T (CONS (CAR |s|) (|streamTake| (- |n| 1) (CDR |s|)))))))) + +(DEFUN |shoeFileLines| (|lines| |fn|) + (PROG () + (RETURN + (PROGN + (|shoeFileLine| " " |fn|) + (LET ((|bfVar#3| |lines|) (|line| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#3|) + (PROGN (SETQ |line| (CAR |bfVar#3|)) NIL)) + (RETURN NIL)) + ('T (|shoeFileLine| (|shoeAddComment| |line|) |fn|))) + (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (|shoeFileLine| " " |fn|))))) + +(DEFUN |shoeConsoleLines| (|lines|) + (PROG () + (RETURN + (PROGN + (|shoeConsole| " ") + (LET ((|bfVar#4| |lines|) (|line| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#4|) + (PROGN (SETQ |line| (CAR |bfVar#4|)) NIL)) + (RETURN NIL)) + ('T (|shoeConsole| (|shoeAddComment| |line|)))) + (SETQ |bfVar#4| (CDR |bfVar#4|)))) + (|shoeConsole| " "))))) + +(DEFUN |shoeFileLine| (|x| |stream|) + (PROG () (RETURN (PROGN (WRITE-LINE |x| |stream|) |x|)))) + +(DEFUN |shoeFileTrees| (|s| |st|) + (PROG (|a|) + (RETURN + (LOOP + (COND + ((|bStreamNull| |s|) (RETURN NIL)) + ('T + (PROGN + (SETQ |a| (CAR |s|)) + (COND + ((EQCAR |a| '+LINE) (|shoeFileLine| (CADR |a|) |st|)) + ('T (REALLYPRETTYPRINT |a| |st|) (TERPRI |st|))) + (SETQ |s| (CDR |s|))))))))) + +(DEFUN |shoePPtoFile| (|x| |stream|) + (PROG () (RETURN (PROGN (SHOENOTPRETTYPRINT |x| |stream|) |x|)))) + +(DEFUN |shoeConsoleTrees| (|s|) + (PROG (|fn|) + (RETURN + (LOOP + (COND + ((|bStreamPackageNull| |s|) (RETURN NIL)) + ('T + (PROGN + (SETQ |fn| + (|stripm| (CAR |s|) *PACKAGE* + (FIND-PACKAGE "BOOTTRAN"))) + (REALLYPRETTYPRINT |fn|) + (SETQ |s| (CDR |s|))))))))) + +(DEFUN |shoeAddComment| (|l|) + (PROG () (RETURN (CONCAT "; " (CAR |l|))))) + +(DEFUN |genImportDeclaration| (|op| |sig|) + (PROG (|s| |t| |m| |ISTMP#2| |op'| |ISTMP#1|) + (RETURN + (COND + ((NOT (AND (CONSP |sig|) (EQ (CAR |sig|) '|Signature|) + (PROGN + (SETQ |ISTMP#1| (CDR |sig|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |op'| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN + (SETQ |m| (CAR |ISTMP#2|)) + #0='T))))))) + (|coreError| "invalid signature")) + ((NOT (AND (CONSP |m|) (EQ (CAR |m|) '|Mapping|) + (PROGN + (SETQ |ISTMP#1| (CDR |m|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |t| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN + (SETQ |s| (CAR |ISTMP#2|)) + #0#))))))) + (|coreError| "invalid function type")) + ((|%hasFeature| :GCL) + (PROGN + (COND ((SYMBOLP |s|) (SETQ |s| (LIST |s|)))) + (LIST 'DEFENTRY |op| |s| (LIST |t| (SYMBOL-NAME |op'|))))) + ('T + (|fatalError| + "import declaration not implemented for this Lisp")))))) + +(DEFUN |shoeOutParse| (|stream|) + (PROG (|$bpParenCount| |$bpCount| |$returns| |$typings| |$wheredefs| + |$op| |$ttok| |$stok| |$stack| |$inputStream| |found|) + (DECLARE (SPECIAL |$bpParenCount| |$bpCount| |$returns| |$typings| + |$wheredefs| |$op| |$ttok| |$stok| |$stack| + |$inputStream|)) + (RETURN + (PROGN + (SETQ |$inputStream| |stream|) + (SETQ |$stack| NIL) + (SETQ |$stok| NIL) + (SETQ |$ttok| NIL) + (SETQ |$op| NIL) + (SETQ |$wheredefs| NIL) + (SETQ |$typings| NIL) + (SETQ |$returns| NIL) + (SETQ |$bpCount| 0) + (SETQ |$bpParenCount| 0) + (|bpFirstTok|) + (SETQ |found| (CATCH 'TRAPPOINT (|bpOutItem|))) + (COND + ((EQ |found| 'TRAPPED) NIL) + ((NULL (|bStreamNull| |$inputStream|)) (|bpGeneralErrorHere|) + NIL) + ((NULL |$stack|) (|bpGeneralErrorHere|) NIL) + ('T (CAR |$stack|))))))) + +(DEFUN |bpOutItem| () + (PROG (|bfVar#6| |bfVar#5| |r| |ISTMP#2| |l| |ISTMP#1| |b|) + (RETURN + (PROGN + (OR (|bpComma|) (|bpTrap|)) + (SETQ |b| (|bpPop1|)) + (COND + ((EQCAR |b| 'TUPLE) (|bpPush| (CDR |b|))) + ((EQCAR |b| '+LINE) (|bpPush| (LIST |b|))) + ((AND (CONSP |b|) (EQ (CAR |b|) 'L%T) + (PROGN + (SETQ |ISTMP#1| (CDR |b|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |l| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |r| (CAR |ISTMP#2|)) 'T))))) + (IDENTP |l|)) + (|bpPush| (LIST (LIST 'DEFPARAMETER |l| |r|)))) + ('T + (PROGN + (SETQ |bfVar#5| |b|) + (SETQ |bfVar#6| (CDR |bfVar#5|)) + (CASE (CAR |bfVar#5|) + (|Module| + (LET ((|m| (CAR |bfVar#6|))) + (|bpPush| + (LIST (|shoeCompileTimeEvaluation| + (LIST 'PROVIDE |m|)))))) + (|Import| + (LET ((|m| (CAR |bfVar#6|))) + (|bpPush| (LIST (LIST 'IMPORT-MODULE |m|))))) + (|ImportSignature| + (LET ((|x| (CAR |bfVar#6|)) + (|sig| (CADR |bfVar#6|))) + (|bpPush| + (LIST (|genImportDeclaration| |x| |sig|))))) + (|TypeAlias| + (LET ((|t| (CAR |bfVar#6|)) + (|args| (CADR |bfVar#6|)) + (|rhs| (CADDR |bfVar#6|))) + (|bpPush| + (LIST (LIST 'DEFTYPE |t| |args| + (LIST 'QUOTE |rhs|)))))) + (|ConstantDefinition| + (LET ((|n| (CAR |bfVar#6|)) (|e| (CADR |bfVar#6|))) + (|bpPush| (LIST (LIST 'DEFCONSTANT |n| |e|))))) + (T (PROGN + (SETQ |b| + (|shoeCompTran| + (LIST 'LAMBDA (LIST '|x|) |b|))) + (|bpPush| + (LIST (|shoeEVALANDFILEACTQ| (CADDR |b|)))))))))))))) + +(DEFUN |shoeAddbootIfNec| (|s|) + (PROG () (RETURN (|shoeAddStringIfNec| ".boot" |s|)))) + +(DEFUN |shoeRemovebootIfNec| (|s|) + (PROG () (RETURN (|shoeRemoveStringIfNec| ".boot" |s|)))) + +(DEFUN |shoeAddStringIfNec| (|str| |s|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (STRPOS |str| |s| 0 NIL)) + (COND ((NULL |a|) (CONCAT |s| |str|)) ('T |s|)))))) + +(DEFUN |shoeRemoveStringIfNec| (|str| |s|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (STRPOS |str| |s| 0 NIL)) + (COND ((NULL |a|) |s|) ('T (SUBSTRING |s| 0 |a|))))))) + +(DEFUN DEFUSE (|fn|) + (PROG (|infn|) + (RETURN + (PROGN + (SETQ |infn| (CONCAT |fn| ".boot")) + (|shoeOpenInputFile| |a| |infn| (|shoeDfu| |a| |fn|)))))) + +(DEFUN |shoeDfu| (|a| |fn|) + (PROG (|$bfClamming| |$GenVarCounter| |$bootDefinedTwice| |$bootUsed| + |$bootDefined| |$lispWordTable| |out|) + (DECLARE (SPECIAL |$bfClamming| |$GenVarCounter| + |$bootDefinedTwice| |$bootUsed| |$bootDefined| + |$lispWordTable|)) + (RETURN + (COND + ((NULL |a|) (|shoeNotFound| |fn|)) + ('T (SETQ |$lispWordTable| (MAKE-HASHTABLE 'EQ)) + (DO-SYMBOLS (|i| (FIND-PACKAGE 'LISP)) + (HPUT |$lispWordTable| |i| T)) + (SETQ |$bootDefined| (MAKE-HASHTABLE 'EQ)) + (SETQ |$bootUsed| (MAKE-HASHTABLE 'EQ)) + (SETQ |$bootDefinedTwice| NIL) (SETQ |$GenVarCounter| 0) + (SETQ |$bfClamming| NIL) + (|shoeDefUse| (|shoeTransformStream| |a|)) + (SETQ |out| (CONCAT |fn| ".defuse")) + (|shoeOpenOutputFile| |stream| |out| (|shoeReport| |stream|)) + |out|))))) + +(DEFUN |shoeReport| (|stream|) + (PROG (|b| |a|) + (DECLARE (SPECIAL |$bootDefinedTwice| |$bootUsed| |$bootDefined|)) + (RETURN + (PROGN + (|shoeFileLine| "DEFINED and not USED" |stream|) + (SETQ |a| + (LET ((|bfVar#8| NIL) (|bfVar#7| (HKEYS |$bootDefined|)) + (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#7|) + (PROGN (SETQ |i| (CAR |bfVar#7|)) NIL)) + (RETURN (NREVERSE |bfVar#8|))) + (#0='T + (AND (NULL (GETHASH |i| |$bootUsed|)) + (SETQ |bfVar#8| (CONS |i| |bfVar#8|))))) + (SETQ |bfVar#7| (CDR |bfVar#7|))))) + (|bootOut| (SSORT |a|) |stream|) + (|shoeFileLine| " " |stream|) + (|shoeFileLine| "DEFINED TWICE" |stream|) + (|bootOut| (SSORT |$bootDefinedTwice|) |stream|) + (|shoeFileLine| " " |stream|) + (|shoeFileLine| "USED and not DEFINED" |stream|) + (SETQ |a| + (LET ((|bfVar#10| NIL) (|bfVar#9| (HKEYS |$bootUsed|)) + (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#9|) + (PROGN (SETQ |i| (CAR |bfVar#9|)) NIL)) + (RETURN (NREVERSE |bfVar#10|))) + (#0# + (AND (NULL (GETHASH |i| |$bootDefined|)) + (SETQ |bfVar#10| (CONS |i| |bfVar#10|))))) + (SETQ |bfVar#9| (CDR |bfVar#9|))))) + (LET ((|bfVar#11| (SSORT |a|)) (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#11|) + (PROGN (SETQ |i| (CAR |bfVar#11|)) NIL)) + (RETURN NIL)) + (#0# + (PROGN + (SETQ |b| (CONCAT (PNAME |i|) " is used in ")) + (|bootOutLines| (SSORT (GETHASH |i| |$bootUsed|)) + |stream| |b|)))) + (SETQ |bfVar#11| (CDR |bfVar#11|)))))))) + +(DEFUN |shoeDefUse| (|s|) + (PROG () + (RETURN + (LOOP + (COND + ((|bStreamPackageNull| |s|) (RETURN NIL)) + ('T (PROGN (|defuse| NIL (CAR |s|)) (SETQ |s| (CDR |s|))))))))) + +(DEFUN |defuse| (|e| |x|) + (PROG (|$used| |niens| |nee| |LETTMP#1| |exp| |ISTMP#5| |id| + |ISTMP#4| |ISTMP#3| |body| |bv| |ISTMP#2| |name| + |ISTMP#1|) + (DECLARE (SPECIAL |$bootUsed| |$used| |$bootDefinedTwice| + |$bootDefined|)) + (RETURN + (PROGN + (SETQ |x| (|stripm| |x| *PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) + (SETQ |$used| NIL) + (SETQ |LETTMP#1| + (COND + ((AND (CONSP |x|) (EQ (CAR |x|) 'DEFUN) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |name| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |bv| (CAR |ISTMP#2|)) + (SETQ |body| (CDR |ISTMP#2|)) + #0='T)))))) + (LIST |name| (CONS 'LAMBDA (CONS |bv| |body|)))) + ((AND (CONSP |x|) (EQ (CAR |x|) 'DEFMACRO) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |name| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |bv| (CAR |ISTMP#2|)) + (SETQ |body| (CDR |ISTMP#2|)) + #0#)))))) + (LIST |name| (CONS 'LAMBDA (CONS |bv| |body|)))) + ((AND (CONSP |x|) (EQ (CAR |x|) 'EVAL-WHEN) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN + (SETQ |ISTMP#3| (CAR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CAR |ISTMP#3|) 'SETQ) + (PROGN + (SETQ |ISTMP#4| + (CDR |ISTMP#3|)) + (AND (CONSP |ISTMP#4|) + (PROGN + (SETQ |id| (CAR |ISTMP#4|)) + (SETQ |ISTMP#5| + (CDR |ISTMP#4|)) + (AND (CONSP |ISTMP#5|) + (EQ (CDR |ISTMP#5|) NIL) + (PROGN + (SETQ |exp| + (CAR |ISTMP#5|)) + #0#)))))))))))) + (LIST |id| |exp|)) + ((AND (CONSP |x|) (EQ (CAR |x|) 'SETQ) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |id| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN + (SETQ |exp| (CAR |ISTMP#2|)) + #0#)))))) + (LIST |id| |exp|)) + (#1='T (LIST 'TOP-LEVEL |x|)))) + (SETQ |nee| (CAR |LETTMP#1|)) + (SETQ |niens| (CADR |LETTMP#1|)) + (COND + ((GETHASH |nee| |$bootDefined|) + (SETQ |$bootDefinedTwice| + (COND + ((EQ |nee| 'TOP-LEVEL) |$bootDefinedTwice|) + (#1# (CONS |nee| |$bootDefinedTwice|))))) + ('T (HPUT |$bootDefined| |nee| T))) + (|defuse1| |e| |niens|) + (LET ((|bfVar#12| |$used|) (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#12|) + (PROGN (SETQ |i| (CAR |bfVar#12|)) NIL)) + (RETURN NIL)) + ('T + (HPUT |$bootUsed| |i| + (CONS |nee| (GETHASH |i| |$bootUsed|))))) + (SETQ |bfVar#12| (CDR |bfVar#12|)))))))) + +(DEFUN |defuse1| (|e| |y|) + (PROG (|ndol| |dol| |LETTMP#1| |b| |a| |ISTMP#1|) + (DECLARE (SPECIAL |$bootDefined| |$used|)) + (RETURN + (COND + ((ATOM |y|) + (COND + ((IDENTP |y|) + (SETQ |$used| + (COND + ((MEMQ |y| |e|) |$used|) + ((MEMQ |y| |$used|) |$used|) + ((|defusebuiltin| |y|) |$used|) + (#0='T (UNION (LIST |y|) |$used|))))) + (#0# NIL))) + ((AND (CONSP |y|) (EQ (CAR |y|) 'LAMBDA) + (PROGN + (SETQ |ISTMP#1| (CDR |y|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |a| (CAR |ISTMP#1|)) + (SETQ |b| (CDR |ISTMP#1|)) + #1='T)))) + (|defuse1| (APPEND (|unfluidlist| |a|) |e|) |b|)) + ((AND (CONSP |y|) (EQ (CAR |y|) 'PROG) + (PROGN + (SETQ |ISTMP#1| (CDR |y|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |a| (CAR |ISTMP#1|)) + (SETQ |b| (CDR |ISTMP#1|)) + #1#)))) + (PROGN + (SETQ |LETTMP#1| (|defSeparate| |a|)) + (SETQ |dol| (CAR |LETTMP#1|)) + (SETQ |ndol| (CADR |LETTMP#1|)) + (LET ((|bfVar#13| |dol|) (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#13|) + (PROGN (SETQ |i| (CAR |bfVar#13|)) NIL)) + (RETURN NIL)) + (#2='T (HPUT |$bootDefined| |i| T))) + (SETQ |bfVar#13| (CDR |bfVar#13|)))) + (|defuse1| (APPEND |ndol| |e|) |b|))) + ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE) + (PROGN (SETQ |a| (CDR |y|)) #1#)) + NIL) + ((AND (CONSP |y|) (EQ (CAR |y|) '+LINE) + (PROGN (SETQ |a| (CDR |y|)) #1#)) + NIL) + (#0# + (LET ((|bfVar#14| |y|) (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#14|) + (PROGN (SETQ |i| (CAR |bfVar#14|)) NIL)) + (RETURN NIL)) + (#2# (|defuse1| |e| |i|))) + (SETQ |bfVar#14| (CDR |bfVar#14|))))))))) + +(DEFUN |defSeparate| (|x|) + (PROG (|x2| |x1| |LETTMP#1| |f|) + (RETURN + (COND + ((NULL |x|) (LIST NIL NIL)) + (#0='T (SETQ |f| (CAR |x|)) + (SETQ |LETTMP#1| (|defSeparate| (CDR |x|))) + (SETQ |x1| (CAR |LETTMP#1|)) (SETQ |x2| (CADR |LETTMP#1|)) + (COND + ((|bfBeginsDollar| |f|) (LIST (CONS |f| |x1|) |x2|)) + (#0# (LIST |x1| (CONS |f| |x2|))))))))) + +(DEFUN |unfluidlist| (|x|) + (PROG (|y| |ISTMP#1|) + (RETURN + (COND + ((NULL |x|) NIL) + ((ATOM |x|) (LIST |x|)) + ((AND (CONSP |x|) (EQ (CAR |x|) '&REST) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |y| (CAR |ISTMP#1|)) 'T)))) + (LIST |y|)) + ('T (CONS (CAR |x|) (|unfluidlist| (CDR |x|)))))))) + +(DEFUN |defusebuiltin| (|x|) + (PROG () + (DECLARE (SPECIAL |$lispWordTable|)) + (RETURN (GETHASH |x| |$lispWordTable|)))) + +(DEFUN |bootOut| (|l| |outfn|) + (PROG () + (RETURN + (LET ((|bfVar#15| |l|) (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#15|) + (PROGN (SETQ |i| (CAR |bfVar#15|)) NIL)) + (RETURN NIL)) + ('T (|shoeFileLine| (CONCAT " " (PNAME |i|)) |outfn|))) + (SETQ |bfVar#15| (CDR |bfVar#15|))))))) + +(DEFUN CLESSP (|s1| |s2|) + (PROG () (RETURN (NULL (SHOEGREATERP |s1| |s2|))))) + +(DEFUN SSORT (|l|) (PROG () (RETURN (SORT |l| #'CLESSP)))) + +(DEFUN |bootOutLines| (|l| |outfn| |s|) + (PROG (|a|) + (RETURN + (COND + ((NULL |l|) (|shoeFileLine| |s| |outfn|)) + (#0='T (SETQ |a| (PNAME (CAR |l|))) + (COND + ((< 70 (+ (LENGTH |s|) (LENGTH |a|))) + (|shoeFileLine| |s| |outfn|) + (|bootOutLines| |l| |outfn| " ")) + (#0# + (|bootOutLines| (CDR |l|) |outfn| (CONCAT |s| " " |a|))))))))) + +(DEFUN XREF (|fn|) + (PROG (|infn|) + (RETURN + (PROGN + (SETQ |infn| (CONCAT |fn| ".boot")) + (|shoeOpenInputFile| |a| |infn| (|shoeXref| |a| |fn|)))))) + +(DEFUN |shoeXref| (|a| |fn|) + (PROG (|$bfClamming| |$GenVarCounter| |$bootUsed| |$bootDefined| + |$lispWordTable| |out|) + (DECLARE (SPECIAL |$bfClamming| |$GenVarCounter| |$bootUsed| + |$bootDefined| |$lispWordTable|)) + (RETURN + (COND + ((NULL |a|) (|shoeNotFound| |fn|)) + ('T (SETQ |$lispWordTable| (MAKE-HASHTABLE 'EQ)) + (DO-SYMBOLS (|i| (FIND-PACKAGE 'LISP)) + (HPUT |$lispWordTable| |i| T)) + (SETQ |$bootDefined| (MAKE-HASHTABLE 'EQ)) + (SETQ |$bootUsed| (MAKE-HASHTABLE 'EQ)) + (SETQ |$GenVarCounter| 0) (SETQ |$bfClamming| NIL) + (|shoeDefUse| (|shoeTransformStream| |a|)) + (SETQ |out| (CONCAT |fn| ".xref")) + (|shoeOpenOutputFile| |stream| |out| (|shoeXReport| |stream|)) + |out|))))) + +(DEFUN |shoeXReport| (|stream|) + (PROG (|a| |c|) + (DECLARE (SPECIAL |$bootUsed|)) + (RETURN + (PROGN + (|shoeFileLine| "USED and where DEFINED" |stream|) + (SETQ |c| (SSORT (HKEYS |$bootUsed|))) + (LET ((|bfVar#16| |c|) (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#16|) + (PROGN (SETQ |i| (CAR |bfVar#16|)) NIL)) + (RETURN NIL)) + ('T + (PROGN + (SETQ |a| (CONCAT (PNAME |i|) " is used in ")) + (|bootOutLines| (SSORT (GETHASH |i| |$bootUsed|)) + |stream| |a|)))) + (SETQ |bfVar#16| (CDR |bfVar#16|)))))))) + +(DEFUN FBO (|name| |fn|) + (PROG () (RETURN (|shoeGeneralFC| #'BO |name| |fn|)))) + +(DEFUN FEV (|name| |fn|) + (PROG () (RETURN (|shoeGeneralFC| #'EVAL-BOOT-FILE |name| |fn|)))) + +(DEFUN |shoeGeneralFC| (|f| |name| |fn|) + (PROG (|$GenVarCounter| |$bfClamming| |filename| |a| |infn|) + (DECLARE (SPECIAL |$GenVarCounter| |$bfClamming|)) + (RETURN + (PROGN + (SETQ |$bfClamming| NIL) + (SETQ |$GenVarCounter| 0) + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (SETQ |a| + (|shoeOpenInputFile| |a| |infn| + (|shoeFindName2| |fn| |name| |a|))) + (SETQ |filename| + (COND + ((< 8 (LENGTH |name|)) (SUBSTRING |name| 0 8)) + ('T |name|))) + (COND + (|a| (FUNCALL |f| (CONCAT "/tmp/" |filename|))) + ('T NIL)))))) + +(DEFUN |shoeFindName2| (|fn| |name| |a|) + (PROG (|filename| |lines|) + (RETURN + (PROGN + (SETQ |lines| (|shoeFindLines| |fn| |name| |a|)) + (COND + (|lines| (PROGN + (SETQ |filename| + (COND + ((< 8 (LENGTH |name|)) + (SUBSTRING |name| 0 8)) + ('T |name|))) + (SETQ |filename| + (CONCAT "/tmp/" |filename| ".boot")) + (|shoeOpenOutputFile| |stream| |filename| + (LET ((|bfVar#17| |lines|) (|line| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#17|) + (PROGN + (SETQ |line| (CAR |bfVar#17|)) + NIL)) + (RETURN NIL)) + ('T (|shoeFileLine| |line| |stream|))) + (SETQ |bfVar#17| (CDR |bfVar#17|))))) + T)) + ('T NIL)))))) + +(DEFUN |shoeTransform2| (|str|) + (PROG () + (RETURN + (|bNext| #'|shoeItem| + (|streamTake| 1 + (|bNext| #'|shoePileInsert| + (|bNext| #'|shoeLineToks| |str|))))))) + +(DEFUN |shoeItem| (|str|) + (PROG (|dq|) + (RETURN + (PROGN + (SETQ |dq| (CAR |str|)) + (CONS (LIST (LET ((|bfVar#19| NIL) + (|bfVar#18| (|shoeDQlines| |dq|)) + (|line| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#18|) + (PROGN + (SETQ |line| (CAR |bfVar#18|)) + NIL)) + (RETURN (NREVERSE |bfVar#19|))) + ('T + (SETQ |bfVar#19| + (CONS (CAR |line|) |bfVar#19|)))) + (SETQ |bfVar#18| (CDR |bfVar#18|))))) + (CDR |str|)))))) + +(DEFUN |stripm| (|x| |pk| |bt|) + (PROG () + (RETURN + (COND + ((ATOM |x|) + (COND + ((IDENTP |x|) + (COND + ((EQUAL (SYMBOL-PACKAGE |x|) |bt|) + (INTERN (PNAME |x|) |pk|)) + (#0='T |x|))) + (#0# |x|))) + (#0# + (CONS (|stripm| (CAR |x|) |pk| |bt|) + (|stripm| (CDR |x|) |pk| |bt|))))))) + +(DEFUN |shoePCompile| (|fn|) + (PROG (|body| |bv| |ISTMP#2| |name| |ISTMP#1|) + (RETURN + (PROGN + (SETQ |fn| (|stripm| |fn| *PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) + (COND + ((AND (CONSP |fn|) (EQ (CAR |fn|) 'DEFUN) + (PROGN + (SETQ |ISTMP#1| (CDR |fn|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |name| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |bv| (CAR |ISTMP#2|)) + (SETQ |body| (CDR |ISTMP#2|)) + 'T)))))) + (COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|)))) + ('T (EVAL |fn|))))))) + +(DEFUN FC (|name| |fn|) + (PROG (|$GenVarCounter| |infn|) + (DECLARE (SPECIAL |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |$GenVarCounter| 0) + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (|shoeOpenInputFile| |a| |infn| + (|shoeFindName| |fn| |name| |a|)))))) + +(DEFUN |shoeFindName| (|fn| |name| |a|) + (PROG (|lines|) + (RETURN + (PROGN + (SETQ |lines| (|shoeFindLines| |fn| |name| |a|)) + (|shoePCompileTrees| (|shoeTransformString| |lines|)))))) + +(DEFUN |shoePCompileTrees| (|s|) + (PROG () + (RETURN + (LOOP + (COND + ((|bStreamPackageNull| |s|) (RETURN NIL)) + ('T + (PROGN + (REALLYPRETTYPRINT (|shoePCompile| (CAR |s|))) + (SETQ |s| (CDR |s|))))))))) + +(DEFUN |bStreamPackageNull| (|s|) + (PROG (|b| |a|) + (RETURN + (PROGN + (SETQ |a| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |b| (|bStreamNull| |s|)) + (|setCurrentPackage| |a|) + |b|)))) + +(DEFUN PSTTOMC (|string|) + (PROG (|$GenVarCounter|) + (DECLARE (SPECIAL |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |$GenVarCounter| 0) + (|shoePCompileTrees| (|shoeTransformString| |string|)))))) + +(DEFUN BOOTLOOP () + (PROG (|stream| |b| |a|) + (RETURN + (PROGN + (SETQ |a| (READ-LINE)) + (COND + ((EQL (LENGTH |a|) 0) + (PROGN + (WRITE-LINE "Boot Loop; to exit type ] ") + (BOOTLOOP))) + (#0='T + (PROGN + (SETQ |b| (|shoePrefix?| ")console" |a|)) + (COND + (|b| (PROGN + (SETQ |stream| *TERMINAL-IO*) + (PSTTOMC (|bRgen| |stream|)) + (BOOTLOOP))) + ((EQUAL (ELT |a| 0) (ELT "]" 0)) NIL) + (#0# (PROGN (PSTTOMC (LIST |a|)) (BOOTLOOP))))))))))) + +(DEFUN BOOTPO () + (PROG (|stream| |b| |a|) + (RETURN + (PROGN + (SETQ |a| (READ-LINE)) + (COND + ((EQL (LENGTH |a|) 0) + (PROGN (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTPO))) + (#0='T + (PROGN + (SETQ |b| (|shoePrefix?| ")console" |a|)) + (COND + (|b| (PROGN + (SETQ |stream| *TERMINAL-IO*) + (PSTOUT (|bRgen| |stream|)) + (BOOTPO))) + ((EQUAL (ELT |a| 0) (ELT "]" 0)) NIL) + (#0# (PROGN (PSTOUT (LIST |a|)) (BOOTPO))))))))))) + +(DEFUN PSTOUT (|string|) + (PROG (|$GenVarCounter| |result| |callingPackage|) + (DECLARE (SPECIAL |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$GenVarCounter| 0) + (SETQ |result| + (|shoeConsoleTrees| (|shoeTransformString| |string|))) + (|setCurrentPackage| |callingPackage|) + |result|)))) + +(DEFUN |defaultBootToLispFile| (|file|) + (PROG () (RETURN (CONCAT (|shoeRemovebootIfNec| |file|) ".clisp")))) + +(DEFUN |translateBootFile| (|progname| |options| |file|) + (PROG (|outFile|) + (RETURN + (PROGN + (SETQ |outFile| (|getOutputPathname| |options|)) + (BOOTTOCL |file| (ENOUGH-NAMESTRING |outFile|)))))) + +(DEFUN |compileBootHandler| (|progname| |options| |file|) + (PROG (|objFile| |intFile|) + (RETURN + (PROGN + (SETQ |intFile| + (BOOTTOCL |file| (|defaultBootToLispFile| |file|))) + (COND + (|intFile| + (PROGN + (SETQ |objFile| + (|compileLispHandler| |progname| |options| + |intFile|)) + (DELETE-FILE |intFile|) + |objFile|)) + ('T NIL)))))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + (|associateRequestWithFileType| (|Option| "translate") "boot" + #'|translateBootFile|)))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + (|associateRequestWithFileType| (|Option| "compile") "boot" + #'|compileBootHandler|)))) + -- cgit v1.2.3