diff options
Diffstat (limited to 'src/boot/strap')
| -rw-r--r-- | src/boot/strap/ast.clisp | 5303 | ||||
| -rw-r--r-- | src/boot/strap/includer.clisp | 376 | ||||
| -rw-r--r-- | src/boot/strap/parser.clisp | 1294 | ||||
| -rw-r--r-- | src/boot/strap/pile.clisp | 158 | ||||
| -rw-r--r-- | src/boot/strap/scanner.clisp | 694 | ||||
| -rw-r--r-- | src/boot/strap/tokens.clisp | 435 | ||||
| -rw-r--r-- | src/boot/strap/translator.clisp | 1807 | ||||
| -rw-r--r-- | src/boot/strap/utility.clisp | 387 |
8 files changed, 4971 insertions, 5483 deletions
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index a5faf9a0..71922a32 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -11,139 +11,125 @@ (DEFPARAMETER |$activeNamespace| NIL) -(DEFUN |%Command| #0=(|bfVar#1|) (CONS '|%Command| (LIST . #0#))) +(DEFUN |%Command| #1=(|bfVar#1|) (CONS '|%Command| (LIST . #1#))) -(DEFUN |%Lisp| #0=(|bfVar#2|) (CONS '|%Lisp| (LIST . #0#))) +(DEFUN |%Lisp| #1=(|bfVar#2|) (CONS '|%Lisp| (LIST . #1#))) -(DEFUN |%Module| #0=(|bfVar#3| |bfVar#4| |bfVar#5|) - (CONS '|%Module| (LIST . #0#))) +(DEFUN |%Module| #1=(|bfVar#3| |bfVar#4| |bfVar#5|) + (CONS '|%Module| (LIST . #1#))) -(DEFUN |%Namespace| #0=(|bfVar#6|) (CONS '|%Namespace| (LIST . #0#))) +(DEFUN |%Namespace| #1=(|bfVar#6|) (CONS '|%Namespace| (LIST . #1#))) -(DEFUN |%Import| #0=(|bfVar#7|) (CONS '|%Import| (LIST . #0#))) +(DEFUN |%Import| #1=(|bfVar#7|) (CONS '|%Import| (LIST . #1#))) -(DEFUN |%ImportSignature| #0=(|bfVar#8| |bfVar#9|) - (CONS '|%ImportSignature| (LIST . #0#))) +(DEFUN |%ImportSignature| #1=(|bfVar#8| |bfVar#9|) + (CONS '|%ImportSignature| (LIST . #1#))) -(DEFUN |%TypeAlias| #0=(|bfVar#10| |bfVar#11|) - (CONS '|%TypeAlias| (LIST . #0#))) +(DEFUN |%TypeAlias| #1=(|bfVar#10| |bfVar#11|) + (CONS '|%TypeAlias| (LIST . #1#))) -(DEFUN |%Signature| #0=(|bfVar#12| |bfVar#13|) - (CONS '|%Signature| (LIST . #0#))) +(DEFUN |%Signature| #1=(|bfVar#12| |bfVar#13|) + (CONS '|%Signature| (LIST . #1#))) -(DEFUN |%Mapping| #0=(|bfVar#14| |bfVar#15|) - (CONS '|%Mapping| (LIST . #0#))) +(DEFUN |%Mapping| #1=(|bfVar#14| |bfVar#15|) (CONS '|%Mapping| (LIST . #1#))) -(DEFUN |%Forall| #0=(|bfVar#16| |bfVar#17|) - (CONS '|%Forall| (LIST . #0#))) +(DEFUN |%Forall| #1=(|bfVar#16| |bfVar#17|) (CONS '|%Forall| (LIST . #1#))) -(DEFUN |%SuffixDot| #0=(|bfVar#18|) (CONS '|%SuffixDot| (LIST . #0#))) +(DEFUN |%SuffixDot| #1=(|bfVar#18|) (CONS '|%SuffixDot| (LIST . #1#))) -(DEFUN |%Quote| #0=(|bfVar#19|) (CONS '|%Quote| (LIST . #0#))) +(DEFUN |%Quote| #1=(|bfVar#19|) (CONS '|%Quote| (LIST . #1#))) -(DEFUN |%EqualPattern| #0=(|bfVar#20|) - (CONS '|%EqualPattern| (LIST . #0#))) +(DEFUN |%EqualPattern| #1=(|bfVar#20|) (CONS '|%EqualPattern| (LIST . #1#))) -(DEFUN |%Colon| #0=(|bfVar#21|) (CONS '|%Colon| (LIST . #0#))) +(DEFUN |%Colon| #1=(|bfVar#21|) (CONS '|%Colon| (LIST . #1#))) -(DEFUN |%QualifiedName| #0=(|bfVar#22| |bfVar#23|) - (CONS '|%QualifiedName| (LIST . #0#))) +(DEFUN |%QualifiedName| #1=(|bfVar#22| |bfVar#23|) + (CONS '|%QualifiedName| (LIST . #1#))) -(DEFUN |%DefaultValue| #0=(|bfVar#24| |bfVar#25|) - (CONS '|%DefaultValue| (LIST . #0#))) +(DEFUN |%DefaultValue| #1=(|bfVar#24| |bfVar#25|) + (CONS '|%DefaultValue| (LIST . #1#))) -(DEFUN |%Bracket| #0=(|bfVar#26|) (CONS '|%Bracket| (LIST . #0#))) +(DEFUN |%Bracket| #1=(|bfVar#26|) (CONS '|%Bracket| (LIST . #1#))) -(DEFUN |%UnboundedSegment| #0=(|bfVar#27|) - (CONS '|%UnboundedSegment| (LIST . #0#))) +(DEFUN |%UnboundedSegment| #1=(|bfVar#27|) + (CONS '|%UnboundedSegment| (LIST . #1#))) -(DEFUN |%BoundedSgement| #0=(|bfVar#28| |bfVar#29|) - (CONS '|%BoundedSgement| (LIST . #0#))) +(DEFUN |%BoundedSgement| #1=(|bfVar#28| |bfVar#29|) + (CONS '|%BoundedSgement| (LIST . #1#))) -(DEFUN |%Tuple| #0=(|bfVar#30|) (CONS '|%Tuple| (LIST . #0#))) +(DEFUN |%Tuple| #1=(|bfVar#30|) (CONS '|%Tuple| (LIST . #1#))) -(DEFUN |%ColonAppend| #0=(|bfVar#31| |bfVar#32|) - (CONS '|%ColonAppend| (LIST . #0#))) +(DEFUN |%ColonAppend| #1=(|bfVar#31| |bfVar#32|) + (CONS '|%ColonAppend| (LIST . #1#))) -(DEFUN |%Pretend| #0=(|bfVar#33| |bfVar#34|) - (CONS '|%Pretend| (LIST . #0#))) +(DEFUN |%Pretend| #1=(|bfVar#33| |bfVar#34|) (CONS '|%Pretend| (LIST . #1#))) -(DEFUN |%Is| #0=(|bfVar#35| |bfVar#36|) (CONS '|%Is| (LIST . #0#))) +(DEFUN |%Is| #1=(|bfVar#35| |bfVar#36|) (CONS '|%Is| (LIST . #1#))) -(DEFUN |%Isnt| #0=(|bfVar#37| |bfVar#38|) - (CONS '|%Isnt| (LIST . #0#))) +(DEFUN |%Isnt| #1=(|bfVar#37| |bfVar#38|) (CONS '|%Isnt| (LIST . #1#))) -(DEFUN |%Reduce| #0=(|bfVar#39| |bfVar#40|) - (CONS '|%Reduce| (LIST . #0#))) +(DEFUN |%Reduce| #1=(|bfVar#39| |bfVar#40|) (CONS '|%Reduce| (LIST . #1#))) -(DEFUN |%PrefixExpr| #0=(|bfVar#41| |bfVar#42|) - (CONS '|%PrefixExpr| (LIST . #0#))) +(DEFUN |%PrefixExpr| #1=(|bfVar#41| |bfVar#42|) + (CONS '|%PrefixExpr| (LIST . #1#))) -(DEFUN |%Call| #0=(|bfVar#43| |bfVar#44|) - (CONS '|%Call| (LIST . #0#))) +(DEFUN |%Call| #1=(|bfVar#43| |bfVar#44|) (CONS '|%Call| (LIST . #1#))) -(DEFUN |%InfixExpr| #0=(|bfVar#45| |bfVar#46| |bfVar#47|) - (CONS '|%InfixExpr| (LIST . #0#))) +(DEFUN |%InfixExpr| #1=(|bfVar#45| |bfVar#46| |bfVar#47|) + (CONS '|%InfixExpr| (LIST . #1#))) -(DEFUN |%ConstantDefinition| #0=(|bfVar#48| |bfVar#49|) - (CONS '|%ConstantDefinition| (LIST . #0#))) +(DEFUN |%ConstantDefinition| #1=(|bfVar#48| |bfVar#49|) + (CONS '|%ConstantDefinition| (LIST . #1#))) -(DEFUN |%Definition| #0=(|bfVar#50| |bfVar#51| |bfVar#52|) - (CONS '|%Definition| (LIST . #0#))) +(DEFUN |%Definition| #1=(|bfVar#50| |bfVar#51| |bfVar#52|) + (CONS '|%Definition| (LIST . #1#))) -(DEFUN |%Macro| #0=(|bfVar#53| |bfVar#54| |bfVar#55|) - (CONS '|%Macro| (LIST . #0#))) +(DEFUN |%Macro| #1=(|bfVar#53| |bfVar#54| |bfVar#55|) + (CONS '|%Macro| (LIST . #1#))) -(DEFUN |%Lambda| #0=(|bfVar#56| |bfVar#57|) - (CONS '|%Lambda| (LIST . #0#))) +(DEFUN |%Lambda| #1=(|bfVar#56| |bfVar#57|) (CONS '|%Lambda| (LIST . #1#))) -(DEFUN |%SuchThat| #0=(|bfVar#58|) (CONS '|%SuchThat| (LIST . #0#))) +(DEFUN |%SuchThat| #1=(|bfVar#58|) (CONS '|%SuchThat| (LIST . #1#))) -(DEFUN |%Assignment| #0=(|bfVar#59| |bfVar#60|) - (CONS '|%Assignment| (LIST . #0#))) +(DEFUN |%Assignment| #1=(|bfVar#59| |bfVar#60|) + (CONS '|%Assignment| (LIST . #1#))) -(DEFUN |%While| #0=(|bfVar#61|) (CONS '|%While| (LIST . #0#))) +(DEFUN |%While| #1=(|bfVar#61|) (CONS '|%While| (LIST . #1#))) -(DEFUN |%Until| #0=(|bfVar#62|) (CONS '|%Until| (LIST . #0#))) +(DEFUN |%Until| #1=(|bfVar#62|) (CONS '|%Until| (LIST . #1#))) -(DEFUN |%For| #0=(|bfVar#63| |bfVar#64| |bfVar#65|) - (CONS '|%For| (LIST . #0#))) +(DEFUN |%For| #1=(|bfVar#63| |bfVar#64| |bfVar#65|) (CONS '|%For| (LIST . #1#))) -(DEFUN |%Implies| #0=(|bfVar#66| |bfVar#67|) - (CONS '|%Implies| (LIST . #0#))) +(DEFUN |%Implies| #1=(|bfVar#66| |bfVar#67|) (CONS '|%Implies| (LIST . #1#))) -(DEFUN |%Iterators| #0=(|bfVar#68|) (CONS '|%Iterators| (LIST . #0#))) +(DEFUN |%Iterators| #1=(|bfVar#68|) (CONS '|%Iterators| (LIST . #1#))) -(DEFUN |%Cross| #0=(|bfVar#69|) (CONS '|%Cross| (LIST . #0#))) +(DEFUN |%Cross| #1=(|bfVar#69|) (CONS '|%Cross| (LIST . #1#))) -(DEFUN |%Repeat| #0=(|bfVar#70| |bfVar#71|) - (CONS '|%Repeat| (LIST . #0#))) +(DEFUN |%Repeat| #1=(|bfVar#70| |bfVar#71|) (CONS '|%Repeat| (LIST . #1#))) -(DEFUN |%Pile| #0=(|bfVar#72|) (CONS '|%Pile| (LIST . #0#))) +(DEFUN |%Pile| #1=(|bfVar#72|) (CONS '|%Pile| (LIST . #1#))) -(DEFUN |%Append| #0=(|bfVar#73|) (CONS '|%Append| (LIST . #0#))) +(DEFUN |%Append| #1=(|bfVar#73|) (CONS '|%Append| (LIST . #1#))) -(DEFUN |%Case| #0=(|bfVar#74| |bfVar#75|) - (CONS '|%Case| (LIST . #0#))) +(DEFUN |%Case| #1=(|bfVar#74| |bfVar#75|) (CONS '|%Case| (LIST . #1#))) -(DEFUN |%Return| #0=(|bfVar#76|) (CONS '|%Return| (LIST . #0#))) +(DEFUN |%Return| #1=(|bfVar#76|) (CONS '|%Return| (LIST . #1#))) -(DEFUN |%Leave| #0=(|bfVar#77|) (CONS '|%Leave| (LIST . #0#))) +(DEFUN |%Leave| #1=(|bfVar#77|) (CONS '|%Leave| (LIST . #1#))) -(DEFUN |%Throw| #0=(|bfVar#78|) (CONS '|%Throw| (LIST . #0#))) +(DEFUN |%Throw| #1=(|bfVar#78|) (CONS '|%Throw| (LIST . #1#))) -(DEFUN |%Catch| #0=(|bfVar#79| |bfVar#80|) - (CONS '|%Catch| (LIST . #0#))) +(DEFUN |%Catch| #1=(|bfVar#79| |bfVar#80|) (CONS '|%Catch| (LIST . #1#))) -(DEFUN |%Finally| #0=(|bfVar#81|) (CONS '|%Finally| (LIST . #0#))) +(DEFUN |%Finally| #1=(|bfVar#81|) (CONS '|%Finally| (LIST . #1#))) -(DEFUN |%Try| #0=(|bfVar#82| |bfVar#83|) (CONS '|%Try| (LIST . #0#))) +(DEFUN |%Try| #1=(|bfVar#82| |bfVar#83|) (CONS '|%Try| (LIST . #1#))) -(DEFUN |%Where| #0=(|bfVar#84| |bfVar#85|) - (CONS '|%Where| (LIST . #0#))) +(DEFUN |%Where| #1=(|bfVar#84| |bfVar#85|) (CONS '|%Where| (LIST . #1#))) -(DEFUN |%Structure| #0=(|bfVar#86| |bfVar#87|) - (CONS '|%Structure| (LIST . #0#))) +(DEFUN |%Structure| #1=(|bfVar#86| |bfVar#87|) + (CONS '|%Structure| (LIST . #1#))) (DEFPARAMETER |$inDefIS| NIL) @@ -154,38 +140,36 @@ (DEFUN |bfGenSymbol| () (DECLARE (SPECIAL |$GenVarCounter|)) (PROGN - (SETQ |$GenVarCounter| (+ |$GenVarCounter| 1)) - (INTERN (CONCAT "bfVar#" (WRITE-TO-STRING |$GenVarCounter|))))) + (SETQ |$GenVarCounter| (+ |$GenVarCounter| 1)) + (INTERN (CONCAT "bfVar#" (WRITE-TO-STRING |$GenVarCounter|))))) (DECLAIM (FTYPE (FUNCTION NIL |%Symbol|) |bfLetVar|)) (DEFUN |bfLetVar| () (DECLARE (SPECIAL |$letGenVarCounter|)) (PROGN - (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1)) - (INTERN (CONCAT "LETTMP#" (WRITE-TO-STRING |$letGenVarCounter|))))) + (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1)) + (INTERN (CONCAT "LETTMP#" (WRITE-TO-STRING |$letGenVarCounter|))))) (DECLAIM (FTYPE (FUNCTION NIL |%Symbol|) |bfIsVar|)) (DEFUN |bfIsVar| () (DECLARE (SPECIAL |$isGenVarCounter|)) (PROGN - (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1)) - (INTERN (CONCAT "ISTMP#" (WRITE-TO-STRING |$isGenVarCounter|))))) + (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1)) + (INTERN (CONCAT "ISTMP#" (WRITE-TO-STRING |$isGenVarCounter|))))) (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Form|) |bfColon|)) (DEFUN |bfColon| (|x|) (LIST 'COLON |x|)) -(DECLAIM (FTYPE (FUNCTION (|%Symbol| |%Symbol|) |%Symbol|) - |bfColonColon|)) +(DECLAIM (FTYPE (FUNCTION (|%Symbol| |%Symbol|) |%Symbol|) |bfColonColon|)) (DEFUN |bfColonColon| (|package| |name|) (COND - ((AND (|%hasFeature| :CLISP) - (|symbolMember?| |package| '(EXT FFI))) - (FIND-SYMBOL (SYMBOL-NAME |name|) |package|)) - (T (INTERN (SYMBOL-NAME |name|) |package|)))) + ((AND (|%hasFeature| :CLISP) (|symbolMember?| |package| '(EXT FFI))) + (FIND-SYMBOL (SYMBOL-NAME |name|) |package|)) + (T (INTERN (SYMBOL-NAME |name|) |package|)))) (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Thing|) |bfSymbol|)) @@ -207,70 +191,60 @@ (DEFUN |bfBracket| (|part|) |part|) -(DECLAIM (FTYPE (FUNCTION ((|%List| |%Form|)) (|%List| |%Form|)) - |bfPile|)) +(DECLAIM (FTYPE (FUNCTION ((|%List| |%Form|)) (|%List| |%Form|)) |bfPile|)) (DEFUN |bfPile| (|part|) |part|) (DEFUN |bfDo| (|x|) |x|) -(DEFUN |bfAtScope| (|s| |x|) - (LIST 'LET (LIST (LIST '*PACKAGE* |s|)) |x|)) +(DEFUN |bfAtScope| (|s| |x|) (LIST 'LET (LIST (LIST '*PACKAGE* |s|)) |x|)) -(DECLAIM (FTYPE (FUNCTION ((|%List| (|%List| |%Form|))) - (|%List| |%Form|)) - |bfAppend|)) +(DECLAIM + (FTYPE (FUNCTION ((|%List| (|%List| |%Form|))) (|%List| |%Form|)) |bfAppend|)) (DEFUN |bfAppend| (|ls|) (PROG (|p| |r| |l|) (RETURN - (COND - ((NOT (AND (CONSP |ls|) - (PROGN - (SETQ |l| (CAR |ls|)) - (SETQ |ls| (CDR |ls|)) - T))) - NIL) - (T (SETQ |r| (|copyList| |l|)) (SETQ |p| |r|) - (LOOP - (COND - ((NOT (AND (CONSP |ls|) - (PROGN - (SETQ |l| (CAR |ls|)) - (SETQ |ls| (CDR |ls|)) - T))) - (RETURN |r|)) - ((NULL |l|) NIL) - (T (RPLACD (|lastNode| |p|) (|copyList| |l|)) - (SETQ |p| (CDR |p|)))))))))) + (COND + ((NOT + (AND (CONSP |ls|) + (PROGN (SETQ |l| (CAR |ls|)) (SETQ |ls| (CDR |ls|)) T))) + NIL) + (T (SETQ |r| (|copyList| |l|)) (SETQ |p| |r|) + (LOOP + (COND + ((NOT + (AND (CONSP |ls|) + (PROGN (SETQ |l| (CAR |ls|)) (SETQ |ls| (CDR |ls|)) T))) + (RETURN |r|)) + ((NULL |l|) NIL) + (T (RPLACD (|lastNode| |p|) (|copyList| |l|)) + (SETQ |p| (CDR |p|)))))))))) -(DECLAIM (FTYPE (FUNCTION ((|%List| |%Form|) |%Form|) |%Form|) - |bfColonAppend|)) +(DECLAIM (FTYPE (FUNCTION ((|%List| |%Form|) |%Form|) |%Form|) |bfColonAppend|)) (DEFUN |bfColonAppend| (|x| |y|) (PROG (|a|) (RETURN - (COND - ((NULL |x|) - (COND - ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE)) - (SETQ |a| (CDR |y|)) (LIST '&REST (CONS 'QUOTE |a|))) - (T (LIST '&REST |y|)))) - (T (CONS (CAR |x|) (|bfColonAppend| (CDR |x|) |y|))))))) + (COND + ((NULL |x|) + (COND + ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE)) (SETQ |a| (CDR |y|)) + (LIST '&REST (CONS 'QUOTE |a|))) + (T (LIST '&REST |y|)))) + (T (CONS (CAR |x|) (|bfColonAppend| (CDR |x|) |y|))))))) (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Boolean|) |bfBeginsDollar|)) -(DEFUN |bfBeginsDollar| (|x|) - (CHAR= (SCHAR (SYMBOL-NAME |x|) 0) (|char| '$))) +(DEFUN |bfBeginsDollar| (|x|) (CHAR= (SCHAR (SYMBOL-NAME |x|) 0) (|char| '$))) (DEFUN |compFluid| (|id|) (LIST 'FLUID |id|)) (DEFUN |compFluidize| (|x|) - (COND - ((NULL |x|) NIL) - ((AND (SYMBOLP |x|) (|bfBeginsDollar| |x|)) (|compFluid| |x|)) - ((|atomic?| |x|) |x|) - (T (CONS (|compFluidize| (CAR |x|)) (|compFluidize| (CDR |x|)))))) + (COND ((NULL |x|) NIL) + ((AND (SYMBOLP |x|) (|bfBeginsDollar| |x|)) (|compFluid| |x|)) + ((|atomic?| |x|) |x|) + (T (CONS (|compFluidize| (CAR |x|)) (|compFluidize| (CDR |x|)))))) (DEFUN |bfPlace| (|x|) (CONS '|%Place| |x|)) @@ -278,179 +252,167 @@ (DEFUN |bfTupleP| (|x|) (AND (CONSP |x|) (EQ (CAR |x|) 'TUPLE))) -(DEFUN |bfUntuple| (|bf|) - (COND ((|bfTupleP| |bf|) (CDR |bf|)) (T |bf|))) +(DEFUN |bfUntuple| (|bf|) (COND ((|bfTupleP| |bf|) (CDR |bf|)) (T |bf|))) -(DEFUN |bfTupleIf| (|x|) - (COND ((|bfTupleP| |x|) |x|) (T (|bfTuple| |x|)))) +(DEFUN |bfTupleIf| (|x|) (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#2| NIL) (|bfVar#1| |a|) (|x| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - (T (SETQ |bfVar#2| - (AND (CONSP |x|) (EQ (CAR |x|) 'COLON) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (NULL (CDR |ISTMP#1|)))))) - (COND (|bfVar#2| (RETURN |bfVar#2|))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - (|bfMakeCons| |a|)) - (T (CONS 'LIST |a|))))))) + (PROGN + (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) (T (LIST |b|)))) + (COND + ((LET ((|bfVar#2| NIL) (|bfVar#1| |a|) (|x| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + (T + (SETQ |bfVar#2| + (AND (CONSP |x|) (EQ (CAR |x|) 'COLON) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))))) + (COND (|bfVar#2| (RETURN |bfVar#2|))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (|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|))))) + (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|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |a| (CAR |ISTMP#2|)) T)))))) - (SETQ |l1| (CDR |l|)) - (COND - (|l1| (LIST '|append| |a| (|bfMakeCons| |l1|))) - (T |a|))) - (T (LIST 'CONS (CAR |l|) (|bfMakeCons| (CDR |l|)))))))) - -(DEFUN |bfFor| (|bflhs| U |step|) + (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|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |a| (CAR |ISTMP#2|)) T)))))) + (SETQ |l1| (CDR |l|)) + (COND (|l1| (LIST '|append| |a| (|bfMakeCons| |l1|))) (T |a|))) + (T (LIST 'CONS (CAR |l|) (|bfMakeCons| (CDR |l|)))))))) + +(DEFUN |bfFor| (|lhs| |u| |step|) (COND - ((AND (CONSP U) (EQ (CAR U) '|tails|)) - (|bfForTree| 'ON |bflhs| (CADR U))) - ((AND (CONSP U) (EQ (CAR U) 'SEGMENT)) - (|bfSTEP| |bflhs| (CADR U) |step| (CADDR U))) - (T (|bfForTree| 'IN |bflhs| U)))) + ((AND (CONSP |u|) (EQ (CAR |u|) '|tails|)) + (|bfForTree| 'ON |lhs| (CADR |u|))) + ((AND (CONSP |u|) (EQ (CAR |u|) 'SEGMENT)) + (|bfSTEP| |lhs| (CADR |u|) |step| (CADDR |u|))) + ((AND (CONSP |u|) (EQ (CAR |u|) '|entries|)) + (|bfIterateTable| |lhs| (CADR |u|))) + (T (|bfForTree| 'IN |lhs| |u|)))) (DEFUN |bfForTree| (OP |lhs| |whole|) (PROG (G) (RETURN - (PROGN - (SETQ |whole| - (COND - ((|bfTupleP| |whole|) (|bfMakeCons| (CDR |whole|))) - (T |whole|))) - (COND - ((NOT (CONSP |lhs|)) (|bfINON| (LIST OP |lhs| |whole|))) - (T (SETQ |lhs| - (COND ((|bfTupleP| |lhs|) (CADR |lhs|)) (T |lhs|))) + (PROGN + (SETQ |whole| + (COND ((|bfTupleP| |whole|) (|bfMakeCons| (CDR |whole|))) + (T |whole|))) + (COND ((NOT (CONSP |lhs|)) (|bfINON| (LIST OP |lhs| |whole|))) + (T (SETQ |lhs| (COND ((|bfTupleP| |lhs|) (CADR |lhs|)) (T |lhs|))) (COND - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'L%T)) - (SETQ G (CADR |lhs|)) - (|append| (|bfINON| (LIST OP G |whole|)) - (|bfSuchthat| (|bfIS| G (CADDR |lhs|))))) - (T (SETQ G (|bfGenSymbol|)) - (|append| (|bfINON| (LIST OP G |whole|)) - (|bfSuchthat| (|bfIS| G |lhs|))))))))))) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'L%T)) (SETQ G (CADR |lhs|)) + (|append| (|bfINON| (LIST OP G |whole|)) + (|bfSuchthat| (|bfIS| G (CADDR |lhs|))))) + (T (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 - (COND ((EQ |id| 'DOT) (SETQ |id| (|bfGenSymbol|)))) - (SETQ |initvar| (LIST |id|)) - (SETQ |initval| (LIST |fst|)) - (SETQ |inc| - (COND - ((NOT (CONSP |step|)) |step|) - (T (SETQ |g1| (|bfGenSymbol|)) - (SETQ |initvar| (CONS |g1| |initvar|)) - (SETQ |initval| (CONS |step| |initval|)) |g1|))) - (SETQ |final| - (COND - ((NOT (CONSP |lst|)) |lst|) - (T (SETQ |g2| (|bfGenSymbol|)) - (SETQ |initvar| (CONS |g2| |initvar|)) - (SETQ |initval| (CONS |lst| |initval|)) |g2|))) - (SETQ |ex| - (COND - ((NULL |lst|) NIL) - ((INTEGERP |inc|) - (SETQ |pred| (COND ((MINUSP |inc|) '<) (T '>))) - (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)))))) + (PROGN + (COND ((EQ |id| 'DOT) (SETQ |id| (|bfGenSymbol|)))) + (SETQ |initvar| (LIST |id|)) + (SETQ |initval| (LIST |fst|)) + (SETQ |inc| + (COND ((NOT (CONSP |step|)) |step|) + (T (SETQ |g1| (|bfGenSymbol|)) + (SETQ |initvar| (CONS |g1| |initvar|)) + (SETQ |initval| (CONS |step| |initval|)) |g1|))) + (SETQ |final| + (COND ((NOT (CONSP |lst|)) |lst|) + (T (SETQ |g2| (|bfGenSymbol|)) + (SETQ |initvar| (CONS |g2| |initvar|)) + (SETQ |initval| (CONS |lst| |initval|)) |g2|))) + (SETQ |ex| + (COND ((NULL |lst|) NIL) + ((INTEGERP |inc|) + (SETQ |pred| (COND ((MINUSP |inc|) '<) (T '>))) + (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 |bfIterateTable| (|e| |t|) (LIST '|%tbliter| |e| |t| (GENSYM))) (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|))))))) + (PROGN + (SETQ |op| (CAR |x|)) + (SETQ |id| (CADR . #1=(|x|))) + (SETQ |whole| (CADDR . #1#)) + (COND ((EQ |op| 'ON) (|bfON| |id| |whole|)) (T (|bfIN| |id| |whole|))))))) (DEFUN |bfIN| (|x| E) (PROG (|exitCond| |inits| |vars| |g|) (RETURN - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (SETQ |vars| (LIST |g|)) - (SETQ |inits| (LIST E)) - (SETQ |exitCond| (LIST 'NOT (LIST 'CONSP |g|))) - (COND - ((NOT (EQ |x| 'DOT)) - (SETQ |vars| (|append| |vars| (CONS |x| NIL))) - (SETQ |inits| (|append| |inits| (CONS NIL NIL))) - (SETQ |exitCond| - (LIST 'OR |exitCond| - (LIST 'PROGN (LIST 'SETQ |x| (LIST 'CAR |g|)) - 'NIL))))) - (LIST (LIST |vars| |inits| - (LIST (LIST 'SETQ |g| (LIST 'CDR |g|))) NIL - (LIST |exitCond|) NIL)))))) + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (SETQ |vars| (LIST |g|)) + (SETQ |inits| (LIST E)) + (SETQ |exitCond| (LIST 'NOT (LIST 'CONSP |g|))) + (COND + ((NOT (EQ |x| 'DOT)) (SETQ |vars| (|append| |vars| (CONS |x| NIL))) + (SETQ |inits| (|append| |inits| (CONS NIL NIL))) + (SETQ |exitCond| + (LIST 'OR |exitCond| + (LIST 'PROGN (LIST 'SETQ |x| (LIST 'CAR |g|)) 'NIL))))) + (LIST + (LIST |vars| |inits| (LIST (LIST 'SETQ |g| (LIST 'CDR |g|))) NIL + (LIST |exitCond|) NIL)))))) (DEFUN |bfON| (|x| E) (PROG (|var| |init|) (RETURN - (PROGN - (COND ((EQ |x| 'DOT) (SETQ |x| (|bfGenSymbol|)))) - (SETQ |var| (SETQ |init| NIL)) - (COND - ((OR (NOT (SYMBOLP E)) (NOT (EQ |x| E))) - (SETQ |var| (LIST |x|)) (SETQ |init| (LIST E)))) - (LIST (LIST |var| |init| - (LIST (LIST 'SETQ |x| (LIST 'CDR |x|))) NIL - (LIST (LIST 'NOT (LIST 'CONSP |x|))) NIL)))))) + (PROGN + (COND ((EQ |x| 'DOT) (SETQ |x| (|bfGenSymbol|)))) + (SETQ |var| (SETQ |init| NIL)) + (COND + ((OR (NOT (SYMBOLP E)) (NOT (EQ |x| E))) (SETQ |var| (LIST |x|)) + (SETQ |init| (LIST E)))) + (LIST + (LIST |var| |init| (LIST (LIST 'SETQ |x| (LIST 'CDR |x|))) NIL + (LIST (LIST 'NOT (LIST 'CONSP |x|))) NIL)))))) -(DEFUN |bfSuchthat| (|p|) - (LIST (LIST NIL NIL NIL (LIST |p|) NIL NIL))) +(DEFUN |bfSuchthat| (|p|) (LIST (LIST NIL NIL NIL (LIST |p|) NIL NIL))) -(DEFUN |bfWhile| (|p|) - (LIST (LIST NIL NIL NIL NIL (LIST (|bfNOT| |p|)) NIL))) +(DEFUN |bfWhile| (|p|) (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)))))) + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (LIST + (LIST (LIST |g|) (LIST NIL) (LIST (LIST 'SETQ |g| |p|)) NIL (LIST |g|) + NIL)))))) (DEFUN |bfIterators| (|x|) (CONS 'ITERATORS |x|)) @@ -458,93 +420,90 @@ (DEFUN |bfLp| (|iters| |body|) (COND - ((AND (CONSP |iters|) (EQ (CAR |iters|) 'ITERATORS)) - (|bfLp1| (CDR |iters|) |body|)) - (T (|bfLpCross| (CDR |iters|) |body|)))) + ((AND (CONSP |iters|) (EQ (CAR |iters|) 'ITERATORS)) + (|bfLp1| (CDR |iters|) |body|)) + (T (|bfLpCross| (CDR |iters|) |body|)))) (DEFUN |bfLpCross| (|iters| |body|) - (COND - ((NULL (CDR |iters|)) (|bfLp| (CAR |iters|) |body|)) - (T (|bfLp| (CAR |iters|) (|bfLpCross| (CDR |iters|) |body|))))) + (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#3| NIL) (|bfVar#4| NIL) (|bfVar#1| |f|) - (|i| NIL) (|bfVar#2| |r|) (|j| NIL)) - (LOOP + (COND ((NULL |iters|) (LIST NIL NIL NIL NIL NIL NIL)) + (T (SETQ |f| (CAR |iters|)) (SETQ |r| (|bfSep| (CDR |iters|))) + (LET ((|bfVar#3| NIL) + (|bfVar#4| NIL) + (|bfVar#1| |f|) + (|i| NIL) + (|bfVar#2| |r|) + (|j| NIL)) + (LOOP (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL) - (NOT (CONSP |bfVar#2|)) - (PROGN (SETQ |j| (CAR |bfVar#2|)) NIL)) - (RETURN |bfVar#3|)) - ((NULL |bfVar#3|) - (SETQ |bfVar#3| #0=(CONS (|append| |i| |j|) NIL)) - (SETQ |bfVar#4| |bfVar#3|)) - (T (RPLACD |bfVar#4| #0#) - (SETQ |bfVar#4| (CDR |bfVar#4|)))) + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL) + (NOT (CONSP |bfVar#2|)) + (PROGN (SETQ |j| (CAR |bfVar#2|)) NIL)) + (RETURN |bfVar#3|)) + ((NULL |bfVar#3|) + (SETQ |bfVar#3| #1=(CONS (|append| |i| |j|) NIL)) + (SETQ |bfVar#4| |bfVar#3|)) + (T (RPLACD |bfVar#4| #1#) (SETQ |bfVar#4| (CDR |bfVar#4|)))) (SETQ |bfVar#1| (CDR |bfVar#1|)) (SETQ |bfVar#2| (CDR |bfVar#2|))))))))) (DEFUN |bfReduce| (|op| |y|) (PROG (|it| |ny| |g2| |body| |g1| |g| |init| |a|) (RETURN - (PROGN - (SETQ |a| - (COND - ((AND (CONSP |op|) (EQ (CAR |op|) 'QUOTE)) (CADR |op|)) - (T |op|))) - (SETQ |op| (|bfReName| |a|)) - (SETQ |init| (OR (GET |a| 'SHOETHETA) (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|)))) - (T (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|))))))) + (PROGN + (SETQ |a| + (COND ((AND (CONSP |op|) (EQ (CAR |op|) 'QUOTE)) (CADR |op|)) + (T |op|))) + (SETQ |op| (|bfReName| |a|)) + (SETQ |init| (OR (GET |a| 'SHOETHETA) (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|)))) + (T (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 (|seq| |init| |a| |itl| |body|) (RETURN - (COND - ((AND (CONSP |y|) (EQ (CAR |y|) 'COLLECT)) - (SETQ |body| (CADR |y|)) (SETQ |itl| (CADDR |y|)) - (SETQ |a| - (COND - ((AND (CONSP |op|) (EQ (CAR |op|) 'QUOTE)) - (CADR |op|)) - (T |op|))) - (COND - ((EQ |a| '|append!|) - (|bfDoCollect| |body| |itl| '|lastNode| '|skipNil|)) - ((EQ |a| '|append|) - (|bfDoCollect| (LIST '|copyList| |body|) |itl| '|lastNode| - '|skipNil|)) - (T (SETQ |op| (|bfReName| |a|)) - (SETQ |init| - (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA))) - (|bfOpReduce| |op| |init| |body| |itl|)))) - (T (SETQ |seq| - (COND ((NULL |y|) (|bfTuple| NIL)) (T (CADR |y|)))) - (|bfReduce| |op| (|bfTupleConstruct| |seq|))))))) + (COND + ((AND (CONSP |y|) (EQ (CAR |y|) 'COLLECT)) (SETQ |body| (CADR |y|)) + (SETQ |itl| (CADDR |y|)) + (SETQ |a| + (COND ((AND (CONSP |op|) (EQ (CAR |op|) 'QUOTE)) (CADR |op|)) + (T |op|))) + (COND + ((EQ |a| '|append!|) + (|bfDoCollect| |body| |itl| '|lastNode| '|skipNil|)) + ((EQ |a| '|append|) + (|bfDoCollect| (LIST '|copyList| |body|) |itl| '|lastNode| + '|skipNil|)) + (T (SETQ |op| (|bfReName| |a|)) + (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA))) + (|bfOpReduce| |op| |init| |body| |itl|)))) + (T (SETQ |seq| (COND ((NULL |y|) (|bfTuple| NIL)) (T (CADR |y|)))) + (|bfReduce| |op| (|bfTupleConstruct| |seq|))))))) (DEFUN |bfDCollect| (|y| |itl|) (LIST 'COLLECT |y| |itl|)) @@ -553,154 +512,255 @@ (DEFUN |bfCollect| (|y| |itl|) (PROG (|a| |ISTMP#1|) (RETURN - (COND - ((AND (CONSP |y|) (EQ (CAR |y|) 'COLON) - (PROGN - (SETQ |ISTMP#1| (CDR |y|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) - (COND - ((OR (AND (CONSP |a|) (EQ (CAR |a|) 'CONS)) - (AND (CONSP |a|) (EQ (CAR |a|) 'LIST))) - (|bfDoCollect| |a| |itl| '|lastNode| '|skipNil|)) - (T (|bfDoCollect| (LIST '|copyList| |a|) |itl| '|lastNode| - '|skipNil|)))) - ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) - (|bfDoCollect| (|bfConstruct| |y|) |itl| '|lastNode| - '|skipNil|)) - (T (|bfDoCollect| (LIST 'CONS |y| 'NIL) |itl| 'CDR NIL)))))) + (COND + ((AND (CONSP |y|) (EQ (CAR |y|) 'COLON) + (PROGN + (SETQ |ISTMP#1| (CDR |y|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) + (COND + ((OR (AND (CONSP |a|) (EQ (CAR |a|) 'CONS)) + (AND (CONSP |a|) (EQ (CAR |a|) 'LIST))) + (|bfDoCollect| |a| |itl| '|lastNode| '|skipNil|)) + (T + (|bfDoCollect| (LIST '|copyList| |a|) |itl| '|lastNode| '|skipNil|)))) + ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) + (|bfDoCollect| (|bfConstruct| |y|) |itl| '|lastNode| '|skipNil|)) + (T (|bfDoCollect| (LIST 'CONS |y| 'NIL) |itl| 'CDR NIL)))))) (DEFUN |bfMakeCollectInsn| (|expr| |prev| |head| |adv|) (PROG (|otherTime| |firstTime|) (RETURN - (PROGN - (SETQ |firstTime| + (PROGN + (SETQ |firstTime| (|bfMKPROGN| - (LIST (LIST 'SETQ |head| |expr|) - (LIST 'SETQ |prev| - (COND - ((EQ |adv| 'CDR) |head|) - (T (LIST |adv| |head|))))))) - (SETQ |otherTime| + (LIST (LIST 'SETQ |head| |expr|) + (LIST 'SETQ |prev| + (COND ((EQ |adv| 'CDR) |head|) + (T (LIST |adv| |head|))))))) + (SETQ |otherTime| (|bfMKPROGN| - (LIST (LIST 'RPLACD |prev| |expr|) - (LIST 'SETQ |prev| (LIST |adv| |prev|))))) - (|bfIf| (LIST 'NULL |head|) |firstTime| |otherTime|))))) + (LIST (LIST 'RPLACD |prev| |expr|) + (LIST 'SETQ |prev| (LIST |adv| |prev|))))) + (|bfIf| (LIST 'NULL |head|) |firstTime| |otherTime|))))) (DEFUN |bfDoCollect| (|expr| |itl| |adv| |k|) (PROG (|extrait| |body| |x| |prev| |head|) (RETURN - (PROGN - (SETQ |head| (|bfGenSymbol|)) - (SETQ |prev| (|bfGenSymbol|)) - (SETQ |body| + (PROGN + (SETQ |head| (|bfGenSymbol|)) + (SETQ |prev| (|bfGenSymbol|)) + (SETQ |body| (COND - ((EQ |k| '|skipNil|) (SETQ |x| (|bfGenSymbol|)) - (LIST 'LET (LIST (LIST |x| |expr|)) - (|bfIf| (LIST 'NULL |x|) 'NIL - (|bfMakeCollectInsn| |x| |prev| |head| - |adv|)))) - (T (|bfMakeCollectInsn| |expr| |prev| |head| |adv|)))) - (SETQ |extrait| - (LIST (LIST (LIST |head| |prev|) (LIST 'NIL 'NIL) NIL NIL - NIL (LIST |head|)))) - (|bfLp2| |extrait| |itl| |body|))))) + ((EQ |k| '|skipNil|) (SETQ |x| (|bfGenSymbol|)) + (LIST 'LET (LIST (LIST |x| |expr|)) + (|bfIf| (LIST 'NULL |x|) 'NIL + (|bfMakeCollectInsn| |x| |prev| |head| |adv|)))) + (T (|bfMakeCollectInsn| |expr| |prev| |head| |adv|)))) + (SETQ |extrait| + (LIST + (LIST (LIST |head| |prev|) (LIST 'NIL 'NIL) NIL NIL NIL + (LIST |head|)))) + (|bfLp2| |extrait| |itl| |body|))))) + +(DEFUN |separateIterators| (|iters|) + (PROG (|y| |x|) + (RETURN + (PROGN + (SETQ |x| NIL) + (SETQ |y| NIL) + (LET ((|bfVar#1| |iters|) (|iter| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |iter| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + ((AND (CONSP |iter|) (EQ (CAR |iter|) '|%tbliter|)) + (SETQ |y| (CONS (CDR |iter|) |y|))) + (T (SETQ |x| (CONS |iter| |x|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (LIST (|reverse!| |x|) (|reverse!| |y|)))))) + +(DEFUN |bfExpandTableIters| (|iters|) + (PROG (|ISTMP#5| |v| |ISTMP#4| CONS |ISTMP#3| |k| |x| |g| |ISTMP#2| |t| + |ISTMP#1| |e| |exits| |localBindings| |inits|) + (RETURN + (PROGN + (SETQ |inits| NIL) + (SETQ |localBindings| NIL) + (SETQ |exits| NIL) + (LET ((|bfVar#2| |iters|) (|bfVar#1| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#2|)) + (PROGN (SETQ |bfVar#1| (CAR |bfVar#2|)) NIL)) + (RETURN NIL)) + (T + (AND (CONSP |bfVar#1|) + (PROGN + (SETQ |e| (CAR |bfVar#1|)) + (SETQ |ISTMP#1| (CDR |bfVar#1|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |t| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |g| (CAR |ISTMP#2|)) T))))) + (PROGN + (SETQ |inits| (CONS (LIST |g| |t|) |inits|)) + (SETQ |x| (GENSYM)) + (SETQ |exits| (CONS (LIST 'NOT |x|) |exits|)) + (COND + ((AND (CONSP |e|) (EQ (CAR |e|) 'CONS) + (PROGN + (SETQ |ISTMP#1| (CDR |e|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |k| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN + (SETQ |ISTMP#3| (CAR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (PROGN + (SETQ CONS (CAR |ISTMP#3|)) + (SETQ |ISTMP#4| (CDR |ISTMP#3|)) + (AND (CONSP |ISTMP#4|) + (PROGN + (SETQ |v| (CAR |ISTMP#4|)) + (SETQ |ISTMP#5| + (CDR |ISTMP#4|)) + (AND (CONSP |ISTMP#5|) + (NULL (CDR |ISTMP#5|)) + (EQ (CAR |ISTMP#5|) + 'NIL))))))))))) + (|ident?| |k|) (|ident?| |v|)) + (SETQ |localBindings| + (CONS + (LIST 'MULTIPLE-VALUE-BIND (LIST |x| |k| |v|) + (LIST |g|)) + |localBindings|))) + (T (SETQ |k| (GENSYM)) (SETQ |v| (GENSYM)) + (SETQ |localBindings| + (CONS + (LIST 'MULTIPLE-VALUE-BIND (LIST |x| |k| |v|) + (LIST |g|) + (|bfLET1| + (LIST 'CONS |k| (LIST 'CONS |v| 'NIL)) |e|)) + |localBindings|)))))))) + (SETQ |bfVar#2| (CDR |bfVar#2|)))) + (LIST |inits| |localBindings| |exits|))))) (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|) - (T (|bfAND| (|append| |filters| (CONS |body| NIL)))))) - (SETQ |value| (COND ((NULL |value|) 'NIL) (T (CAR |value|)))) - (SETQ |exits| - (COND - ((NULL |exits|) |nbody|) - (T (|bfIf| (|bfOR| |exits|) (LIST 'RETURN |value|) - |nbody|)))) - (SETQ |loop| (CONS 'LOOP (CONS |exits| |sucs|))) - (COND - (|vars| (SETQ |loop| - (LIST 'LET - (LET ((|bfVar#3| NIL) (|bfVar#4| NIL) - (|bfVar#1| |vars|) (|v| NIL) - (|bfVar#2| |inits|) (|i| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN - (SETQ |v| (CAR |bfVar#1|)) - NIL) - (NOT (CONSP |bfVar#2|)) - (PROGN - (SETQ |i| (CAR |bfVar#2|)) - NIL)) - (RETURN |bfVar#3|)) - ((NULL |bfVar#3|) - (SETQ |bfVar#3| - #2=(CONS (LIST |v| |i|) NIL)) - (SETQ |bfVar#4| |bfVar#3|)) - (T (RPLACD |bfVar#4| #2#) - (SETQ |bfVar#4| (CDR |bfVar#4|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)) - (SETQ |bfVar#2| (CDR |bfVar#2|)))) - |loop|)))) - |loop|)))) + (PROG (|loop| |nbody| |tblExits| |tblLocs| |tblInits| |value| |exits| + |filters| |sucs| |inits| |vars| |tbls| |LETTMP#1|) + (RETURN + (PROGN + (SETQ |LETTMP#1| (|separateIterators| |iters|)) + (SETQ |iters| (CAR |LETTMP#1|)) + (SETQ |tbls| (CADR |LETTMP#1|)) + (SETQ |LETTMP#1| (|bfSep| (|bfAppend| |iters|))) + (SETQ |vars| (CAR |LETTMP#1|)) + (SETQ |inits| (CADR . #1=(|LETTMP#1|))) + (SETQ |sucs| (CADDR . #1#)) + (SETQ |filters| (CADDDR . #1#)) + (SETQ |exits| (CAR #2=(CDDDDR . #1#))) + (SETQ |value| (CADR #2#)) + (SETQ |LETTMP#1| (|bfExpandTableIters| |tbls|)) + (SETQ |tblInits| (CAR |LETTMP#1|)) + (SETQ |tblLocs| (CADR . #3=(|LETTMP#1|))) + (SETQ |tblExits| (CADDR . #3#)) + (SETQ |nbody| + (COND ((NULL |filters|) |body|) + (T (|bfAND| (|append| |filters| (CONS |body| NIL)))))) + (SETQ |value| (COND ((NULL |value|) 'NIL) (T (CAR |value|)))) + (SETQ |exits| + (COND ((AND (NULL |exits|) (NULL |tblExits|)) |nbody|) + (T + (|bfIf| (|bfOR| (|append| |exits| |tblExits|)) + (LIST 'RETURN |value|) |nbody|)))) + (LET ((|bfVar#1| |tblLocs|) (|locBinding| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |locBinding| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (SETQ |exits| (|append| |locBinding| (CONS |exits| NIL))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (SETQ |loop| (CONS 'LOOP (CONS |exits| |sucs|))) + (COND + (|vars| + (SETQ |loop| + (LIST 'LET + (LET ((|bfVar#4| NIL) + (|bfVar#5| NIL) + (|bfVar#2| |vars|) + (|v| NIL) + (|bfVar#3| |inits|) + (|i| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#2|)) + (PROGN (SETQ |v| (CAR |bfVar#2|)) NIL) + (NOT (CONSP |bfVar#3|)) + (PROGN (SETQ |i| (CAR |bfVar#3|)) NIL)) + (RETURN |bfVar#4|)) + ((NULL |bfVar#4|) + (SETQ |bfVar#4| #4=(CONS (LIST |v| |i|) NIL)) + (SETQ |bfVar#5| |bfVar#4|)) + (T (RPLACD |bfVar#5| #4#) + (SETQ |bfVar#5| (CDR |bfVar#5|)))) + (SETQ |bfVar#2| (CDR |bfVar#2|)) + (SETQ |bfVar#3| (CDR |bfVar#3|)))) + |loop|)))) + (LET ((|bfVar#6| |tblInits|) (|x| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#6|)) (PROGN (SETQ |x| (CAR |bfVar#6|)) NIL)) + (RETURN NIL)) + (T (SETQ |loop| (LIST 'WITH-HASH-TABLE-ITERATOR |x| |loop|)))) + (SETQ |bfVar#6| (CDR |bfVar#6|)))) + |loop|)))) (DEFUN |bfLp2| (|extrait| |itl| |body|) (PROG (|iters|) (RETURN - (COND - ((AND (CONSP |itl|) (EQ (CAR |itl|) 'ITERATORS)) - (|bfLp1| (CONS |extrait| (CDR |itl|)) |body|)) - (T (SETQ |iters| (CDR |itl|)) - (|bfLpCross| - (CONS (CONS 'ITERATORS (CONS |extrait| (CDAR |iters|))) - (CDR |iters|)) - |body|)))))) + (COND + ((AND (CONSP |itl|) (EQ (CAR |itl|) 'ITERATORS)) + (|bfLp1| (CONS |extrait| (CDR |itl|)) |body|)) + (T (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| + (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|))))))) + ((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|) (|bfLp| (|bfIterators| NIL) |body|)) @@ -714,1546 +774,1442 @@ (DEFUN |bfForin| (|lhs| U) (|bfFor| |lhs| U 1)) (DEFUN |bfLocal| (|a| |b|) - (COND - ((EQ |b| 'FLUID) (|compFluid| |a|)) - ((EQ |b| '|local|) (|compFluid| |a|)) - (T |a|))) + (COND ((EQ |b| 'FLUID) (|compFluid| |a|)) + ((EQ |b| '|local|) (|compFluid| |a|)) (T |a|))) (DEFUN |bfTake| (|n| |x|) - (COND - ((NULL |x|) |x|) - ((EQL |n| 0) NIL) - (T (CONS (CAR |x|) (|bfTake| (- |n| 1) (CDR |x|)))))) + (COND ((NULL |x|) |x|) ((EQL |n| 0) NIL) + (T (CONS (CAR |x|) (|bfTake| (- |n| 1) (CDR |x|)))))) (DEFUN |bfDrop| (|n| |x|) - (COND - ((OR (NULL |x|) (EQL |n| 0)) |x|) - (T (|bfDrop| (- |n| 1) (CDR |x|))))) + (COND ((OR (NULL |x|) (EQL |n| 0)) |x|) (T (|bfDrop| (- |n| 1) (CDR |x|))))) (DEFUN |bfReturnNoName| (|a|) (LIST 'RETURN |a|)) (DEFUN |bfLeave| (|x|) (LIST '|%Leave| |x|)) (DEFUN |bfSUBLIS| (|p| |e|) - (COND - ((NOT (CONSP |e|)) (|bfSUBLIS1| |p| |e|)) - ((EQ (CAR |e|) 'QUOTE) |e|) - (T (CONS (|bfSUBLIS| |p| (CAR |e|)) (|bfSUBLIS| |p| (CDR |e|)))))) + (COND ((NOT (CONSP |e|)) (|bfSUBLIS1| |p| |e|)) ((EQ (CAR |e|) 'QUOTE) |e|) + (T (CONS (|bfSUBLIS| |p| (CAR |e|)) (|bfSUBLIS| |p| (CDR |e|)))))) (DEFUN |bfSUBLIS1| (|p| |e|) (PROG (|f|) (RETURN - (COND - ((NULL |p|) |e|) - (T (SETQ |f| (CAR |p|)) - (COND - ((EQ (CAR |f|) |e|) (|bfSUBLIS| |p| (CDR |f|))) - (T (|bfSUBLIS1| (CDR |p|) |e|)))))))) + (COND ((NULL |p|) |e|) + (T (SETQ |f| (CAR |p|)) + (COND ((EQ (CAR |f|) |e|) (|bfSUBLIS| |p| (CDR |f|))) + (T (|bfSUBLIS1| (CDR |p|) |e|)))))))) (DEFUN |defSheepAndGoats| (|x|) (PROG (|defstack| |op1| |opassoc| |argl|) (DECLARE (SPECIAL |$op|)) (RETURN - (CASE (CAR |x|) - (|%Definition| - (LET ((|op| (CADR |x|)) (|args| (CADDR |x|)) - (|body| (CADDDR |x|))) - (PROGN - (SETQ |argl| - (COND - ((|bfTupleP| |args|) (CDR |args|)) - (T (LIST |args|)))) - (COND - ((NULL |argl|) - (SETQ |opassoc| (LIST (CONS |op| |body|))) - (LIST |opassoc| NIL NIL)) - (T (SETQ |op1| - (INTERN (CONCAT (SYMBOL-NAME |$op|) "," - (SYMBOL-NAME |op|)))) - (SETQ |opassoc| (LIST (CONS |op| |op1|))) - (SETQ |defstack| - (LIST (LIST |op1| |args| |body|))) - (LIST |opassoc| |defstack| NIL)))))) - (|%Pile| (LET ((|defs| (CADR |x|))) - (|defSheepAndGoatsList| |defs|))) - (T (LIST NIL NIL (LIST |x|))))))) + (CASE (CAR |x|) + (|%Definition| + (LET ((|op| (CADR |x|)) (|args| (CADDR |x|)) (|body| (CADDDR |x|))) + (PROGN + (SETQ |argl| + (COND ((|bfTupleP| |args|) (CDR |args|)) (T (LIST |args|)))) + (COND + ((NULL |argl|) (SETQ |opassoc| (LIST (CONS |op| |body|))) + (LIST |opassoc| NIL NIL)) + (T + (SETQ |op1| + (INTERN + (CONCAT (SYMBOL-NAME |$op|) "," (SYMBOL-NAME |op|)))) + (SETQ |opassoc| (LIST (CONS |op| |op1|))) + (SETQ |defstack| (LIST (LIST |op1| |args| |body|))) + (LIST |opassoc| |defstack| NIL)))))) + (|%Pile| + (LET ((|defs| (CADR |x|))) + (|defSheepAndGoatsList| |defs|))) + (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|))))))) + (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 . #1=(|LETTMP#1|))) + (SETQ |nondefs| (CADDR . #1#)) + (SETQ |LETTMP#1| (|defSheepAndGoatsList| (CDR |x|))) + (SETQ |opassoc1| (CAR |LETTMP#1|)) + (SETQ |defs1| (CADR . #2=(|LETTMP#1|))) + (SETQ |nondefs1| (CADDR . #2#)) + (LIST (|append| |opassoc| |opassoc1|) (|append| |defs| |defs1|) + (|append| |nondefs| |nondefs1|))))))) (DEFUN |bfLetForm| (|lhs| |rhs|) (LIST 'L%T |lhs| |rhs|)) (DEFUN |bfLET1| (|lhs| |rhs|) (PROG (|let1| |g| |l2| |l1| |name| |rhs1| |ISTMP#1|) (RETURN - (COND - ((SYMBOLP |lhs|) (|bfLetForm| |lhs| |rhs|)) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))) - (|bfLetForm| |lhs| |rhs|)) - ((AND (SYMBOLP |rhs|) (NOT (|bfCONTAINED| |rhs| |lhs|))) - (SETQ |rhs1| (|bfLET2| |lhs| |rhs|)) - (COND - ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'L%T)) - (|bfMKPROGN| (LIST |rhs1| |rhs|))) - ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'PROGN)) - (|append| |rhs1| (LIST |rhs|))) - (T (COND - ((SYMBOLP (CAR |rhs1|)) - (SETQ |rhs1| (CONS |rhs1| NIL)))) + (COND ((SYMBOLP |lhs|) (|bfLetForm| |lhs| |rhs|)) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))) + (|bfLetForm| |lhs| |rhs|)) + ((AND (SYMBOLP |rhs|) (NOT (|bfCONTAINED| |rhs| |lhs|))) + (SETQ |rhs1| (|bfLET2| |lhs| |rhs|)) + (COND + ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'L%T)) + (|bfMKPROGN| (LIST |rhs1| |rhs|))) + ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'PROGN)) + (|append| |rhs1| (LIST |rhs|))) + (T (COND ((SYMBOLP (CAR |rhs1|)) (SETQ |rhs1| (CONS |rhs1| NIL)))) (|bfMKPROGN| (|append| |rhs1| (CONS |rhs| NIL)))))) - ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'L%T) - (SYMBOLP (SETQ |name| (CADR |rhs|)))) - (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|))) - (SETQ |l2| (|bfLET1| |lhs| |name|)) - (COND - ((AND (CONSP |l2|) (EQ (CAR |l2|) 'PROGN)) - (|bfMKPROGN| (CONS |l1| (CDR |l2|)))) - (T (COND - ((SYMBOLP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL)))) - (|bfMKPROGN| - (CONS |l1| (|append| |l2| (CONS |name| NIL))))))) - (T (SETQ |g| (|bfLetVar|)) (SETQ |rhs1| (LIST 'L%T |g| |rhs|)) - (SETQ |let1| (|bfLET1| |lhs| |g|)) - (COND + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'L%T) + (SYMBOLP (SETQ |name| (CADR |rhs|)))) + (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|))) + (SETQ |l2| (|bfLET1| |lhs| |name|)) + (COND + ((AND (CONSP |l2|) (EQ (CAR |l2|) 'PROGN)) + (|bfMKPROGN| (CONS |l1| (CDR |l2|)))) + (T (COND ((SYMBOLP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL)))) + (|bfMKPROGN| (CONS |l1| (|append| |l2| (CONS |name| NIL))))))) + (T (SETQ |g| (|bfLetVar|)) (SETQ |rhs1| (LIST 'L%T |g| |rhs|)) + (SETQ |let1| (|bfLET1| |lhs| |g|)) + (COND ((AND (CONSP |let1|) (EQ (CAR |let1|) 'PROGN)) (|bfMKPROGN| (CONS |rhs1| (CDR |let1|)))) - (T (COND - ((SYMBOLP (CAR |let1|)) - (SETQ |let1| (CONS |let1| NIL)))) - (|bfMKPROGN| - (CONS |rhs1| (|append| |let1| (CONS |g| NIL))))))))))) + (T (COND ((SYMBOLP (CAR |let1|)) (SETQ |let1| (CONS |let1| NIL)))) + (|bfMKPROGN| + (CONS |rhs1| (|append| |let1| (CONS |g| NIL))))))))))) (DEFUN |bfCONTAINED| (|x| |y|) - (COND - ((EQ |x| |y|) T) - ((NOT (CONSP |y|)) NIL) - (T (OR (|bfCONTAINED| |x| (CAR |y|)) (|bfCONTAINED| |x| (CDR |y|)))))) + (COND ((EQ |x| |y|) T) ((NOT (CONSP |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|) + (PROG (|isPred| |val1| |ISTMP#3| |g| |rev| |patrev| |l2| |l1| |var2| |var1| + |b| |ISTMP#2| |a| |ISTMP#1|) (DECLARE (SPECIAL |$inDefIS|)) (RETURN - (COND - ((NULL |lhs|) NIL) - ((SYMBOLP |lhs|) (|bfLetForm| |lhs| |rhs|)) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))) - (|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|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |b| (CAR |ISTMP#2|)) T)))))) - (SETQ |a| (|bfLET2| |a| |rhs|)) - (COND - ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|) - ((NOT (CONSP |b|)) (LIST |a| |b|)) - ((CONSP (CAR |b|)) (CONS |a| |b|)) - (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|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |var2| (CAR |ISTMP#2|)) T)))))) - (COND - ((OR (EQ |var1| 'DOT) - (AND (CONSP |var1|) (EQ (CAR |var1|) 'QUOTE))) - (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) - (T (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|))) - (COND - ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|) - (T (COND - ((AND (CONSP |l1|) (NOT (CONSP (CAR |l1|)))) - (SETQ |l1| (CONS |l1| NIL)))) - (COND - ((SYMBOLP |var2|) - (|append| |l1| - (CONS (|bfLetForm| |var2| - (|addCARorCDR| 'CDR |rhs|)) - NIL))) - (T (SETQ |l2| - (|bfLET2| |var2| - (|addCARorCDR| 'CDR |rhs|))) - (COND - ((AND (CONSP |l2|) (NOT (CONSP (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|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |var2| (CAR |ISTMP#2|)) T)))))) - (SETQ |patrev| (|bfISReverse| |var2| |var1|)) - (SETQ |rev| (LIST '|reverse| |rhs|)) (SETQ |g| (|bfLetVar|)) - (SETQ |l2| (|bfLET2| |patrev| |g|)) - (COND - ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|)))) - (SETQ |l2| (CONS |l2| NIL)))) - (COND - ((EQ |var1| 'DOT) (CONS (LIST 'L%T |g| |rev|) |l2|)) - ((PROGN - (SETQ |ISTMP#1| (CAR (|lastNode| |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|) - (NULL (CDR |ISTMP#3|)) - (PROGN - (SETQ |val1| (CAR |ISTMP#3|)) - T))))))) - (CONS (LIST 'L%T |g| |rev|) - (|append| (|reverse| (CDR (|reverse| |l2|))) - (CONS (|bfLetForm| |var1| - (LIST '|reverse!| |val1|)) - NIL)))) - (T (CONS (LIST 'L%T |g| |rev|) - (|append| |l2| - (CONS (|bfLetForm| |var1| - (LIST '|reverse!| |var1|)) - NIL)))))) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'EQUAL) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |var1| (CAR |ISTMP#1|)) T)))) - (LIST 'COND (LIST (|bfQ| |var1| |rhs|) |var1|))) - (T (SETQ |isPred| - (COND - (|$inDefIS| (|bfIS1| |rhs| |lhs|)) - (T (|bfIS| |rhs| |lhs|)))) - (LIST 'COND (LIST |isPred| |rhs|))))))) + (COND ((NULL |lhs|) NIL) ((SYMBOLP |lhs|) (|bfLetForm| |lhs| |rhs|)) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))) + (|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|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |b| (CAR |ISTMP#2|)) T)))))) + (SETQ |a| (|bfLET2| |a| |rhs|)) + (COND ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|) + ((NOT (CONSP |b|)) (LIST |a| |b|)) + ((CONSP (CAR |b|)) (CONS |a| |b|)) (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|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |var2| (CAR |ISTMP#2|)) T)))))) + (COND + ((OR (EQ |var1| 'DOT) + (AND (CONSP |var1|) (EQ (CAR |var1|) 'QUOTE))) + (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) + (T (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|))) + (COND ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|) + (T + (COND + ((AND (CONSP |l1|) (NOT (CONSP (CAR |l1|)))) + (SETQ |l1| (CONS |l1| NIL)))) + (COND + ((SYMBOLP |var2|) + (|append| |l1| + (CONS + (|bfLetForm| |var2| + (|addCARorCDR| 'CDR |rhs|)) + NIL))) + (T + (SETQ |l2| (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) + (COND + ((AND (CONSP |l2|) (NOT (CONSP (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|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |var2| (CAR |ISTMP#2|)) T)))))) + (SETQ |patrev| (|bfISReverse| |var2| |var1|)) + (SETQ |rev| (LIST '|reverse| |rhs|)) (SETQ |g| (|bfLetVar|)) + (SETQ |l2| (|bfLET2| |patrev| |g|)) + (COND + ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|)))) + (SETQ |l2| (CONS |l2| NIL)))) + (COND ((EQ |var1| 'DOT) (CONS (LIST 'L%T |g| |rev|) |l2|)) + ((PROGN + (SETQ |ISTMP#1| (CAR (|lastNode| |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|) (NULL (CDR |ISTMP#3|)) + (PROGN + (SETQ |val1| (CAR |ISTMP#3|)) + T))))))) + (CONS (LIST 'L%T |g| |rev|) + (|append| (|reverse| (CDR (|reverse| |l2|))) + (CONS + (|bfLetForm| |var1| + (LIST '|reverse!| |val1|)) + NIL)))) + (T + (CONS (LIST 'L%T |g| |rev|) + (|append| |l2| + (CONS + (|bfLetForm| |var1| + (LIST '|reverse!| |var1|)) + NIL)))))) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'EQUAL) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |var1| (CAR |ISTMP#1|)) T)))) + (LIST 'COND (LIST (|bfQ| |var1| |rhs|) |var1|))) + (T + (SETQ |isPred| + (COND (|$inDefIS| (|bfIS1| |rhs| |lhs|)) + (T (|bfIS| |rhs| |lhs|)))) + (LIST 'COND (LIST |isPred| |rhs|))))))) (DEFUN |bfLET| (|lhs| |rhs|) (PROG (|$letGenVarCounter|) (DECLARE (SPECIAL |$letGenVarCounter|)) - (RETURN - (PROGN (SETQ |$letGenVarCounter| 0) (|bfLET1| |lhs| |rhs|))))) + (RETURN (PROGN (SETQ |$letGenVarCounter| 0) (|bfLET1| |lhs| |rhs|))))) (DEFUN |addCARorCDR| (|acc| |expr|) (PROG (|funsR| |funsA| |p| |funs|) (RETURN - (COND - ((NOT (CONSP |expr|)) (LIST |acc| |expr|)) - ((AND (EQ |acc| 'CAR) (CONSP |expr|) - (EQ (CAR |expr|) '|reverse|)) - (LIST 'CAR (CONS '|lastNode| (CDR |expr|)))) - (T (SETQ |funs| - '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR - CDAAR CDDAR CDADR CDDDR)) - (SETQ |p| (|bfPosition| (CAR |expr|) |funs|)) - (COND - ((EQL |p| (- 1)) (LIST |acc| |expr|)) - (T (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|))))))))))) + (COND ((NOT (CONSP |expr|)) (LIST |acc| |expr|)) + ((AND (EQ |acc| 'CAR) (CONSP |expr|) (EQ (CAR |expr|) '|reverse|)) + (LIST 'CAR (CONS '|lastNode| (CDR |expr|)))) + (T + (SETQ |funs| + '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR CDAAR + CDDAR CDADR CDDDR)) + (SETQ |p| (|bfPosition| (CAR |expr|) |funs|)) + (COND ((EQL |p| (- 1)) (LIST |acc| |expr|)) + (T + (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|) (|bfPosn| |x| |l| 0)) (DEFUN |bfPosn| (|x| |l| |n|) - (COND - ((NULL |l|) (- 1)) - ((EQUAL |x| (CAR |l|)) |n|) - (T (|bfPosn| |x| (CDR |l|) (+ |n| 1))))) + (COND ((NULL |l|) (- 1)) ((EQUAL |x| (CAR |l|)) |n|) + (T (|bfPosn| |x| (CDR |l|) (+ |n| 1))))) (DEFUN |bfISApplication| (|op| |left| |right|) - (COND - ((EQ |op| 'IS) (|bfIS| |left| |right|)) - ((EQ |op| 'ISNT) (|bfNOT| (|bfIS| |left| |right|))) - (T (LIST |op| |left| |right|)))) + (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|)) + (DECLARE (SPECIAL |$isGenVarCounter| |$inDefIS|)) (RETURN - (PROGN - (SETQ |$isGenVarCounter| 0) - (SETQ |$inDefIS| T) - (|bfIS1| |left| |right|))))) + (PROGN + (SETQ |$isGenVarCounter| 0) + (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|)) - (T (SETQ |y| (|bfISReverse| (CADDR |x|) NIL)) + (COND + ((AND (CONSP |x|) (EQ (CAR |x|) 'CONS)) + (COND ((NULL (CADDR |x|)) (LIST 'CONS (CADR |x|) |a|)) + (T (SETQ |y| (|bfISReverse| (CADDR |x|) NIL)) (RPLACA (CDR (CDR |y|)) (LIST 'CONS (CADR |x|) |a|)) |y|))) - (T (|bpSpecificErrorHere| "Error in bfISReverse") (|bpTrap|)))))) + (T (|bpSpecificErrorHere| "Error in bfISReverse") (|bpTrap|)))))) (DEFUN |bfIS1| (|lhs| |rhs|) - (PROG (|l2| |rev| |patrev| |cls| |b1| |a1| |g| |b| |ISTMP#2| - |ISTMP#1| |l| |d| |c| |a|) - (RETURN - (COND - ((NULL |rhs|) (LIST 'NULL |lhs|)) - ((|bfString?| |rhs|) - (|bfAND| (LIST (LIST 'STRINGP |lhs|) - (LIST 'STRING= |lhs| |rhs|)))) - ((OR (|bfChar?| |rhs|) (INTEGERP |rhs|)) - (LIST 'EQL |lhs| |rhs|)) - ((NOT (CONSP |rhs|)) - (LIST 'PROGN (|bfLetForm| |rhs| |lhs|) 'T)) - ((EQ (CAR |rhs|) 'QUOTE) (SETQ |a| (CADR |rhs|)) - (COND - ((SYMBOLP |a|) (LIST 'EQ |lhs| |rhs|)) - ((STRINGP |a|) - (|bfAND| (LIST (LIST 'STRINGP |lhs|) - (LIST 'STRING= |lhs| |a|)))) - (T (LIST 'EQUAL |lhs| |rhs|)))) - ((EQ (CAR |rhs|) 'L%T) (SETQ |c| (CADR . #0=(|rhs|))) - (SETQ |d| (CADDR . #0#)) (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|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) - (|bfQ| |lhs| |a|)) - ((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|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |b| (CAR |ISTMP#2|)) T))))) - (EQ |a| 'DOT) (EQ |b| 'DOT)) - (LIST 'CONSP |lhs|)) - ((CONSP |lhs|) (SETQ |g| (|bfIsVar|)) - (|bfMKPROGN| (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|)))) - ((EQ (CAR |rhs|) 'CONS) (SETQ |a| (CADR . #1=(|rhs|))) - (SETQ |b| (CADDR . #1#)) - (COND - ((EQ |a| 'DOT) + (PROG (|l2| |rev| |patrev| |cls| |b1| |a1| |g| |b| |ISTMP#2| |ISTMP#1| |l| + |d| |c| |a|) + (RETURN + (COND ((NULL |rhs|) (LIST 'NULL |lhs|)) + ((|bfString?| |rhs|) + (|bfAND| (LIST (LIST 'STRINGP |lhs|) (LIST 'STRING= |lhs| |rhs|)))) + ((OR (|bfChar?| |rhs|) (INTEGERP |rhs|)) (LIST 'EQL |lhs| |rhs|)) + ((NOT (CONSP |rhs|)) (LIST 'PROGN (|bfLetForm| |rhs| |lhs|) 'T)) + ((EQ (CAR |rhs|) 'QUOTE) (SETQ |a| (CADR |rhs|)) + (COND ((SYMBOLP |a|) (LIST 'EQ |lhs| |rhs|)) + ((STRINGP |a|) + (|bfAND| + (LIST (LIST 'STRINGP |lhs|) (LIST 'STRING= |lhs| |a|)))) + (T (LIST 'EQUAL |lhs| |rhs|)))) + ((EQ (CAR |rhs|) 'L%T) (SETQ |c| (CADR . #1=(|rhs|))) + (SETQ |d| (CADDR . #1#)) (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|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) + (|bfQ| |lhs| |a|)) + ((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|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |b| (CAR |ISTMP#2|)) T))))) + (EQ |a| 'DOT) (EQ |b| 'DOT)) + (LIST 'CONSP |lhs|)) + ((CONSP |lhs|) (SETQ |g| (|bfIsVar|)) + (|bfMKPROGN| (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|)))) + ((EQ (CAR |rhs|) 'CONS) (SETQ |a| (CADR . #2=(|rhs|))) + (SETQ |b| (CADDR . #2#)) (COND - ((NULL |b|) - (|bfAND| (LIST (LIST 'CONSP |lhs|) - (LIST 'NULL (LIST 'CDR |lhs|))))) - ((EQ |b| 'DOT) (LIST 'CONSP |lhs|)) - (T (|bfAND| (LIST (LIST 'CONSP |lhs|) - (|bfIS1| (LIST 'CDR |lhs|) |b|)))))) - ((NULL |b|) - (|bfAND| (LIST (LIST 'CONSP |lhs|) - (LIST 'NULL (LIST 'CDR |lhs|)) - (|bfIS1| (LIST 'CAR |lhs|) |a|)))) - ((EQ |b| 'DOT) - (|bfAND| (LIST (LIST 'CONSP |lhs|) - (|bfIS1| (LIST 'CAR |lhs|) |a|)))) - (T (SETQ |a1| (|bfIS1| (LIST 'CAR |lhs|) |a|)) + ((EQ |a| 'DOT) + (COND + ((NULL |b|) + (|bfAND| + (LIST (LIST 'CONSP |lhs|) (LIST 'NULL (LIST 'CDR |lhs|))))) + ((EQ |b| 'DOT) (LIST 'CONSP |lhs|)) + (T + (|bfAND| + (LIST (LIST 'CONSP |lhs|) (|bfIS1| (LIST 'CDR |lhs|) |b|)))))) + ((NULL |b|) + (|bfAND| + (LIST (LIST 'CONSP |lhs|) (LIST 'NULL (LIST 'CDR |lhs|)) + (|bfIS1| (LIST 'CAR |lhs|) |a|)))) + ((EQ |b| 'DOT) + (|bfAND| + (LIST (LIST 'CONSP |lhs|) (|bfIS1| (LIST 'CAR |lhs|) |a|)))) + (T (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|) - (NULL (CDR |ISTMP#2|)) - (EQ (CAR |ISTMP#2|) 'T))))) - (CONSP |b1|) (EQ (CAR |b1|) 'PROGN)) - (SETQ |cls| (CDR |b1|)) - (|bfAND| (LIST (LIST 'CONSP |lhs|) - (|bfMKPROGN| (CONS |c| |cls|))))) - (T (|bfAND| (LIST (LIST 'CONSP |lhs|) |a1| |b1|))))))) - ((EQ (CAR |rhs|) '|append|) (SETQ |a| (CADR . #2=(|rhs|))) - (SETQ |b| (CADDR . #2#)) - (SETQ |patrev| (|bfISReverse| |b| |a|)) (SETQ |g| (|bfIsVar|)) - (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|) (NOT (CONSP (CAR |l2|)))) - (SETQ |l2| (CONS |l2| NIL)))) - (COND - ((EQ |a| 'DOT) (|bfAND| (CONS |rev| |l2|))) - (T (|bfAND| (CONS |rev| - (|append| |l2| - (CONS (LIST 'PROGN - (|bfLetForm| |a| - (LIST '|reverse!| |a|)) - 'T) - NIL))))))) - (T (|bpSpecificErrorHere| "bad IS code is generated") - (|bpTrap|)))))) + ((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|) (NULL (CDR |ISTMP#2|)) + (EQ (CAR |ISTMP#2|) 'T))))) + (CONSP |b1|) (EQ (CAR |b1|) 'PROGN)) + (SETQ |cls| (CDR |b1|)) + (|bfAND| + (LIST (LIST 'CONSP |lhs|) (|bfMKPROGN| (CONS |c| |cls|))))) + (T (|bfAND| (LIST (LIST 'CONSP |lhs|) |a1| |b1|))))))) + ((EQ (CAR |rhs|) '|append|) (SETQ |a| (CADR . #3=(|rhs|))) + (SETQ |b| (CADDR . #3#)) (SETQ |patrev| (|bfISReverse| |b| |a|)) + (SETQ |g| (|bfIsVar|)) + (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|) (NOT (CONSP (CAR |l2|)))) + (SETQ |l2| (CONS |l2| NIL)))) + (COND ((EQ |a| 'DOT) (|bfAND| (CONS |rev| |l2|))) + (T + (|bfAND| + (CONS |rev| + (|append| |l2| + (CONS + (LIST 'PROGN + (|bfLetForm| |a| + (LIST '|reverse!| |a|)) + 'T) + NIL))))))) + (T (|bpSpecificErrorHere| "bad IS code is generated") (|bpTrap|)))))) (DEFUN |bfHas| (|expr| |prop|) - (COND - ((SYMBOLP |prop|) (LIST 'GET |expr| (|quote| |prop|))) - (T (|bpSpecificErrorHere| "expected identifier as property name")))) + (COND ((SYMBOLP |prop|) (LIST 'GET |expr| (|quote| |prop|))) + (T (|bpSpecificErrorHere| "expected identifier as property name")))) (DEFUN |bfApplication| (|bfop| |bfarg|) - (COND - ((|bfTupleP| |bfarg|) (CONS |bfop| (CDR |bfarg|))) - (T (LIST |bfop| |bfarg|)))) + (COND ((|bfTupleP| |bfarg|) (CONS |bfop| (CDR |bfarg|))) + (T (LIST |bfop| |bfarg|)))) (DEFUN |bfReName| (|x|) (PROG (|a|) - (RETURN - (COND ((SETQ |a| (GET |x| 'SHOERENAME)) (CAR |a|)) (T |x|))))) + (RETURN (COND ((SETQ |a| (GET |x| 'SHOERENAME)) (CAR |a|)) (T |x|))))) (DEFUN |sequence?| (|x| |pred|) (PROG (|seq| |ISTMP#1|) (RETURN - (AND (CONSP |x|) (EQ (CAR |x|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |seq| (CAR |ISTMP#1|)) T))) - (CONSP |seq|) - (LET ((|bfVar#2| T) (|bfVar#1| |seq|) (|y| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |y| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - (T (SETQ |bfVar#2| (APPLY |pred| |y| NIL)) - (COND ((NOT |bfVar#2|) (RETURN NIL))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) + (AND (CONSP |x|) (EQ (CAR |x|) 'QUOTE) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |seq| (CAR |ISTMP#1|)) T))) + (CONSP |seq|) + (LET ((|bfVar#2| T) (|bfVar#1| |seq|) (|y| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |y| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + (T (SETQ |bfVar#2| (APPLY |pred| |y| NIL)) + (COND ((NOT |bfVar#2|) (RETURN NIL))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) (DEFUN |idList?| (|x|) (AND (CONSP |x|) (EQ (CAR |x|) 'LIST) (LET ((|bfVar#2| T) (|bfVar#1| (CDR |x|)) (|arg| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |arg| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - (T (SETQ |bfVar#2| (|defQuoteId| |arg|)) - (COND ((NOT |bfVar#2|) (RETURN NIL))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))))) + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |arg| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + (T (SETQ |bfVar#2| (|defQuoteId| |arg|)) + (COND ((NOT |bfVar#2|) (RETURN NIL))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))))) (DEFUN |charList?| (|x|) (AND (CONSP |x|) (EQ (CAR |x|) 'LIST) (LET ((|bfVar#2| T) (|bfVar#1| (CDR |x|)) (|arg| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |arg| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - (T (SETQ |bfVar#2| (|bfChar?| |arg|)) - (COND ((NOT |bfVar#2|) (RETURN NIL))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))))) + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |arg| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + (T (SETQ |bfVar#2| (|bfChar?| |arg|)) + (COND ((NOT |bfVar#2|) (RETURN NIL))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))))) (DEFUN |stringList?| (|x|) (AND (CONSP |x|) (EQ (CAR |x|) 'LIST) (LET ((|bfVar#2| T) (|bfVar#1| (CDR |x|)) (|arg| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |arg| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - (T (SETQ |bfVar#2| (|bfString?| |arg|)) - (COND ((NOT |bfVar#2|) (RETURN NIL))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))))) + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |arg| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + (T (SETQ |bfVar#2| (|bfString?| |arg|)) + (COND ((NOT |bfVar#2|) (RETURN NIL))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))))) (DEFUN |bfMember| (|var| |seq|) (PROG (|y| |x| |ISTMP#2| |ISTMP#1|) (RETURN - (COND - ((OR (INTEGERP |var|) (|sequence?| |seq| #'INTEGERP)) - (COND - ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN - (SETQ |ISTMP#2| (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |x| (CAR |ISTMP#2|)) T)))))) - (LIST 'EQL |var| |x|)) - (T (LIST '|scalarMember?| |var| |seq|)))) - ((OR (|defQuoteId| |var|) (|sequence?| |seq| #'SYMBOLP)) - (COND - ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN - (SETQ |ISTMP#2| (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |x| (CAR |ISTMP#2|)) T)))))) - (LIST 'EQ |var| (|quote| |x|))) - (T (LIST '|symbolMember?| |var| |seq|)))) - ((|idList?| |seq|) - (COND - ((PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))) - (CONS 'EQ (CONS |var| (CDR |seq|)))) - ((AND (SYMBOLP |var|) - (PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |x| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |y| (CAR |ISTMP#2|)) T)))))) - (|bfOR| (LIST (LIST 'EQ |var| |x|) (LIST 'EQ |var| |y|)))) - (T (LIST '|symbolMember?| |var| |seq|)))) - ((OR (|bfChar?| |var|) (|sequence?| |seq| #'CHARACTERP)) - (COND - ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN - (SETQ |ISTMP#2| (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |x| (CAR |ISTMP#2|)) T)))))) - (LIST 'CHAR= |var| |x|)) - (T (LIST '|charMember?| |var| |seq|)))) - ((|charList?| |seq|) - (COND - ((PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))) - (CONS 'CHAR= (CONS |var| (CDR |seq|)))) - ((AND (SYMBOLP |var|) - (PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |x| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |y| (CAR |ISTMP#2|)) T)))))) - (|bfOR| (LIST (LIST 'CHAR= |var| |x|) - (LIST 'CHAR= |var| |y|)))) - (T (LIST '|charMember?| |var| |seq|)))) - ((OR (|bfString?| |var|) (|sequence?| |seq| #'STRINGP)) - (COND - ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN - (SETQ |ISTMP#2| (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |x| (CAR |ISTMP#2|)) T)))))) - (LIST 'STRING= |var| |x|)) - (T (LIST '|stringMember?| |var| |seq|)))) - ((|stringList?| |seq|) - (COND - ((PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))) - (CONS 'STRING= (CONS |var| (CDR |seq|)))) - ((AND (SYMBOLP |var|) - (PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |x| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |y| (CAR |ISTMP#2|)) T)))))) - (|bfOR| (LIST (LIST 'STRING= |var| |x|) - (LIST 'STRING= |var| |y|)))) - (T (LIST '|stringMember?| |var| |seq|)))) - (T (LIST 'MEMBER |var| |seq|)))))) + (COND + ((OR (INTEGERP |var|) (|sequence?| |seq| #'INTEGERP)) + (COND + ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE) + (PROGN + (SETQ |ISTMP#1| (CDR |seq|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN + (SETQ |ISTMP#2| (CAR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |x| (CAR |ISTMP#2|)) T)))))) + (LIST 'EQL |var| |x|)) + (T (LIST '|scalarMember?| |var| |seq|)))) + ((OR (|defQuoteId| |var|) (|sequence?| |seq| #'SYMBOLP)) + (COND + ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE) + (PROGN + (SETQ |ISTMP#1| (CDR |seq|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN + (SETQ |ISTMP#2| (CAR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |x| (CAR |ISTMP#2|)) T)))))) + (LIST 'EQ |var| (|quote| |x|))) + (T (LIST '|symbolMember?| |var| |seq|)))) + ((|idList?| |seq|) + (COND + ((PROGN + (SETQ |ISTMP#1| (CDR |seq|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))) + (CONS 'EQ (CONS |var| (CDR |seq|)))) + ((AND (SYMBOLP |var|) + (PROGN + (SETQ |ISTMP#1| (CDR |seq|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |x| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |y| (CAR |ISTMP#2|)) T)))))) + (|bfOR| (LIST (LIST 'EQ |var| |x|) (LIST 'EQ |var| |y|)))) + (T (LIST '|symbolMember?| |var| |seq|)))) + ((OR (|bfChar?| |var|) (|sequence?| |seq| #'CHARACTERP)) + (COND + ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE) + (PROGN + (SETQ |ISTMP#1| (CDR |seq|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN + (SETQ |ISTMP#2| (CAR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |x| (CAR |ISTMP#2|)) T)))))) + (LIST 'CHAR= |var| |x|)) + (T (LIST '|charMember?| |var| |seq|)))) + ((|charList?| |seq|) + (COND + ((PROGN + (SETQ |ISTMP#1| (CDR |seq|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))) + (CONS 'CHAR= (CONS |var| (CDR |seq|)))) + ((AND (SYMBOLP |var|) + (PROGN + (SETQ |ISTMP#1| (CDR |seq|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |x| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |y| (CAR |ISTMP#2|)) T)))))) + (|bfOR| (LIST (LIST 'CHAR= |var| |x|) (LIST 'CHAR= |var| |y|)))) + (T (LIST '|charMember?| |var| |seq|)))) + ((OR (|bfString?| |var|) (|sequence?| |seq| #'STRINGP)) + (COND + ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE) + (PROGN + (SETQ |ISTMP#1| (CDR |seq|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN + (SETQ |ISTMP#2| (CAR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |x| (CAR |ISTMP#2|)) T)))))) + (LIST 'STRING= |var| |x|)) + (T (LIST '|stringMember?| |var| |seq|)))) + ((|stringList?| |seq|) + (COND + ((PROGN + (SETQ |ISTMP#1| (CDR |seq|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))) + (CONS 'STRING= (CONS |var| (CDR |seq|)))) + ((AND (SYMBOLP |var|) + (PROGN + (SETQ |ISTMP#1| (CDR |seq|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |x| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |y| (CAR |ISTMP#2|)) T)))))) + (|bfOR| (LIST (LIST 'STRING= |var| |x|) (LIST 'STRING= |var| |y|)))) + (T (LIST '|stringMember?| |var| |seq|)))) + (T (LIST 'MEMBER |var| |seq|)))))) (DEFUN |bfInfApplication| (|op| |left| |right|) - (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|))) - ((EQ |op| 'IN) (|bfMember| |left| |right|)) - (T (LIST |op| |left| |right|)))) + (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|))) + ((EQ |op| 'IN) (|bfMember| |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|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) - |a|) - ((AND (CONSP |x|) (EQ (CAR |x|) 'NULL) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) - |a|) - (T (LIST 'NOT |x|)))))) + (COND + ((AND (CONSP |x|) (EQ (CAR |x|) 'NOT) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) + |a|) + ((AND (CONSP |x|) (EQ (CAR |x|) 'NULL) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) + |a|) + (T (LIST 'NOT |x|)))))) (DEFUN |bfFlatten| (|op| |x|) - (COND - ((AND (CONSP |x|) (EQUAL (CAR |x|) |op|)) (CDR |x|)) - (T (LIST |x|)))) + (COND ((AND (CONSP |x|) (EQUAL (CAR |x|) |op|)) (CDR |x|)) (T (LIST |x|)))) (DEFUN |bfOR| (|l|) - (COND - ((NULL |l|) NIL) - ((NULL (CDR |l|)) (CAR |l|)) - (T (CONS 'OR - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |l|) - (|c| NIL)) - (LOOP - (COND + (COND ((NULL |l|) NIL) ((NULL (CDR |l|)) (CAR |l|)) + (T + (CONS 'OR + (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |l|) (|c| NIL)) + (LOOP + (COND ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |c| (CAR |bfVar#1|)) NIL)) (RETURN |bfVar#2|)) - (T (LET ((|bfVar#4| - (|copyList| (|bfFlatten| 'OR |c|)))) - (COND - ((NULL |bfVar#4|) NIL) - ((NULL |bfVar#2|) (SETQ |bfVar#2| |bfVar#4|) - (SETQ |bfVar#3| (|lastNode| |bfVar#2|))) - (T (RPLACD |bfVar#3| |bfVar#4|) + (T + (LET ((|bfVar#4| (|copyList| (|bfFlatten| 'OR |c|)))) + (COND ((NULL |bfVar#4|) NIL) + ((NULL |bfVar#2|) (SETQ |bfVar#2| |bfVar#4|) + (SETQ |bfVar#3| (|lastNode| |bfVar#2|))) + (T (RPLACD |bfVar#3| |bfVar#4|) (SETQ |bfVar#3| (|lastNode| |bfVar#3|))))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) (DEFUN |bfAND| (|l|) - (COND - ((NULL |l|) T) - ((NULL (CDR |l|)) (CAR |l|)) - (T (CONS 'AND - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |l|) - (|c| NIL)) - (LOOP - (COND + (COND ((NULL |l|) T) ((NULL (CDR |l|)) (CAR |l|)) + (T + (CONS 'AND + (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |l|) (|c| NIL)) + (LOOP + (COND ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |c| (CAR |bfVar#1|)) NIL)) (RETURN |bfVar#2|)) - (T (LET ((|bfVar#4| - (|copyList| (|bfFlatten| 'AND |c|)))) - (COND - ((NULL |bfVar#4|) NIL) - ((NULL |bfVar#2|) (SETQ |bfVar#2| |bfVar#4|) - (SETQ |bfVar#3| (|lastNode| |bfVar#2|))) - (T (RPLACD |bfVar#3| |bfVar#4|) + (T + (LET ((|bfVar#4| (|copyList| (|bfFlatten| 'AND |c|)))) + (COND ((NULL |bfVar#4|) NIL) + ((NULL |bfVar#2|) (SETQ |bfVar#2| |bfVar#4|) + (SETQ |bfVar#3| (|lastNode| |bfVar#2|))) + (T (RPLACD |bfVar#3| |bfVar#4|) (SETQ |bfVar#3| (|lastNode| |bfVar#3|))))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) (DEFUN |defQuoteId| (|x|) (AND (CONSP |x|) (EQ (CAR |x|) 'QUOTE) (SYMBOLP (CADR |x|)))) (DEFUN |bfChar?| (|x|) (OR (CHARACTERP |x|) - (AND (CONSP |x|) - (|symbolMember?| (CAR |x|) '(|char| CODE-CHAR SCHAR))))) + (AND (CONSP |x|) (|symbolMember?| (CAR |x|) '(|char| CODE-CHAR SCHAR))))) (DEFUN |bfSmintable| (|x|) (OR (INTEGERP |x|) (AND (CONSP |x|) - (|symbolMember?| (CAR |x|) - '(SIZE LENGTH CHAR-CODE MAXINDEX + -))))) + (|symbolMember?| (CAR |x|) '(SIZE LENGTH CHAR-CODE MAXINDEX + -))))) (DEFUN |bfString?| (|x|) (OR (STRINGP |x|) (AND (CONSP |x|) - (|symbolMember?| (CAR |x|) - '(STRING SYMBOL-NAME |subString|))))) + (|symbolMember?| (CAR |x|) '(STRING SYMBOL-NAME |subString|))))) (DEFUN |bfQ| (|l| |r|) - (COND - ((OR (|bfChar?| |l|) (|bfChar?| |r|)) (LIST 'CHAR= |l| |r|)) - ((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|)) - ((OR (EQ |l| T) (EQ |r| T)) (LIST 'EQ |l| |r|)) - ((OR (|bfString?| |l|) (|bfString?| |r|)) (LIST 'STRING= |l| |r|)) - ((OR (EQ |l| '|%nothing|) (EQ |r| '|%nothing|)) (LIST 'EQ |l| |r|)) - (T (LIST 'EQUAL |l| |r|)))) + (COND ((OR (|bfChar?| |l|) (|bfChar?| |r|)) (LIST 'CHAR= |l| |r|)) + ((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|)) + ((OR (EQ |l| T) (EQ |r| T)) (LIST 'EQ |l| |r|)) + ((OR (|bfString?| |l|) (|bfString?| |r|)) (LIST 'STRING= |l| |r|)) + ((OR (EQ |l| '|%nothing|) (EQ |r| '|%nothing|)) (LIST 'EQ |l| |r|)) + (T (LIST 'EQUAL |l| |r|)))) (DEFUN |bfLessp| (|l| |r|) - (COND - ((EQL |l| 0) (LIST 'PLUSP |r|)) - ((EQL |r| 0) (LIST 'MINUSP |l|)) - ((OR (|bfChar?| |l|) (|bfChar?| |r|)) (LIST 'CHAR< |l| |r|)) - ((OR (|bfString?| |l|) (|bfString?| |r|)) (LIST 'STRING< |l| |r|)) - (T (LIST '< |l| |r|)))) + (COND ((EQL |l| 0) (LIST 'PLUSP |r|)) ((EQL |r| 0) (LIST 'MINUSP |l|)) + ((OR (|bfChar?| |l|) (|bfChar?| |r|)) (LIST 'CHAR< |l| |r|)) + ((OR (|bfString?| |l|) (|bfString?| |r|)) (LIST 'STRING< |l| |r|)) + (T (LIST '< |l| |r|)))) (DEFUN |bfLambda| (|vars| |body|) (PROGN - (SETQ |vars| - (COND ((|bfTupleP| |vars|) (CDR |vars|)) (T (LIST |vars|)))) - (LIST 'LAMBDA |vars| |body|))) + (SETQ |vars| (COND ((|bfTupleP| |vars|) (CDR |vars|)) (T (LIST |vars|)))) + (LIST 'LAMBDA |vars| |body|))) (DEFUN |bfMDef| (|op| |args| |body|) - (PROG (|def| |lamex| |sb2| |sb| |largl| |nargl| |sgargl| |gargl| - |LETTMP#1| |argl|) + (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#3| NIL) (|bfVar#4| NIL) (|bfVar#1| |nargl|) - (|i| NIL) (|bfVar#2| |sgargl|) (|j| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL) - (NOT (CONSP |bfVar#2|)) - (PROGN (SETQ |j| (CAR |bfVar#2|)) NIL)) - (RETURN |bfVar#3|)) - ((NULL |bfVar#3|) - (SETQ |bfVar#3| #1=(CONS (CONS |i| |j|) NIL)) - (SETQ |bfVar#4| |bfVar#3|)) - (T (RPLACD |bfVar#4| #1#) - (SETQ |bfVar#4| (CDR |bfVar#4|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)) - (SETQ |bfVar#2| (CDR |bfVar#2|))))) - (SETQ |body| (|applySubst| |sb| |body|)) - (SETQ |sb2| - (LET ((|bfVar#7| NIL) (|bfVar#8| NIL) - (|bfVar#5| |sgargl|) (|i| NIL) (|bfVar#6| |largl|) + (PROGN + (SETQ |argl| (COND ((|bfTupleP| |args|) (CDR |args|)) (T (LIST |args|)))) + (SETQ |LETTMP#1| (|bfGargl| |argl|)) + (SETQ |gargl| (CAR |LETTMP#1|)) + (SETQ |sgargl| (CADR . #1=(|LETTMP#1|))) + (SETQ |nargl| (CADDR . #1#)) + (SETQ |largl| (CADDDR . #1#)) + (SETQ |sb| + (LET ((|bfVar#3| NIL) + (|bfVar#4| NIL) + (|bfVar#1| |nargl|) + (|i| NIL) + (|bfVar#2| |sgargl|) (|j| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#5|)) - (PROGN (SETQ |i| (CAR |bfVar#5|)) NIL) - (NOT (CONSP |bfVar#6|)) - (PROGN (SETQ |j| (CAR |bfVar#6|)) NIL)) - (RETURN |bfVar#7|)) - ((NULL |bfVar#7|) - (SETQ |bfVar#7| - #2=(CONS (LIST 'CONS (|quote| |i|) |j|) NIL)) - (SETQ |bfVar#8| |bfVar#7|)) - (T (RPLACD |bfVar#8| #2#) - (SETQ |bfVar#8| (CDR |bfVar#8|)))) - (SETQ |bfVar#5| (CDR |bfVar#5|)) - (SETQ |bfVar#6| (CDR |bfVar#6|))))) - (SETQ |body| - (LIST '|applySubst| (CONS 'LIST |sb2|) (|quote| |body|))) - (SETQ |lamex| (LIST 'MLAMBDA |gargl| |body|)) - (SETQ |def| (LIST |op| |lamex|)) - (CONS (|shoeComp| |def|) - (LET ((|bfVar#10| NIL) (|bfVar#11| NIL) - (|bfVar#9| |$wheredefs|) (|d| NIL)) + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL) + (NOT (CONSP |bfVar#2|)) + (PROGN (SETQ |j| (CAR |bfVar#2|)) NIL)) + (RETURN |bfVar#3|)) + ((NULL |bfVar#3|) + (SETQ |bfVar#3| #2=(CONS (CONS |i| |j|) NIL)) + (SETQ |bfVar#4| |bfVar#3|)) + (T (RPLACD |bfVar#4| #2#) (SETQ |bfVar#4| (CDR |bfVar#4|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)) + (SETQ |bfVar#2| (CDR |bfVar#2|))))) + (SETQ |body| (|applySubst| |sb| |body|)) + (SETQ |sb2| + (LET ((|bfVar#7| NIL) + (|bfVar#8| NIL) + (|bfVar#5| |sgargl|) + (|i| NIL) + (|bfVar#6| |largl|) + (|j| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#9|)) - (PROGN (SETQ |d| (CAR |bfVar#9|)) NIL)) - (RETURN |bfVar#10|)) - (T (LET ((|bfVar#12| - (|copyList| - (|shoeComps| (|bfDef1| |d|))))) - (COND - ((NULL |bfVar#12|) NIL) - ((NULL |bfVar#10|) - (SETQ |bfVar#10| |bfVar#12|) - (SETQ |bfVar#11| (|lastNode| |bfVar#10|))) - (T (RPLACD |bfVar#11| |bfVar#12|) - (SETQ |bfVar#11| (|lastNode| |bfVar#11|))))))) - (SETQ |bfVar#9| (CDR |bfVar#9|))))))))) + (COND + ((OR (NOT (CONSP |bfVar#5|)) + (PROGN (SETQ |i| (CAR |bfVar#5|)) NIL) + (NOT (CONSP |bfVar#6|)) + (PROGN (SETQ |j| (CAR |bfVar#6|)) NIL)) + (RETURN |bfVar#7|)) + ((NULL |bfVar#7|) + (SETQ |bfVar#7| + #3=(CONS (LIST 'CONS (|quote| |i|) |j|) NIL)) + (SETQ |bfVar#8| |bfVar#7|)) + (T (RPLACD |bfVar#8| #3#) (SETQ |bfVar#8| (CDR |bfVar#8|)))) + (SETQ |bfVar#5| (CDR |bfVar#5|)) + (SETQ |bfVar#6| (CDR |bfVar#6|))))) + (SETQ |body| (LIST '|applySubst| (CONS 'LIST |sb2|) (|quote| |body|))) + (SETQ |lamex| (LIST 'MLAMBDA |gargl| |body|)) + (SETQ |def| (LIST |op| |lamex|)) + (CONS (|shoeComp| |def|) + (LET ((|bfVar#10| NIL) + (|bfVar#11| NIL) + (|bfVar#9| |$wheredefs|) + (|d| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#9|)) + (PROGN (SETQ |d| (CAR |bfVar#9|)) NIL)) + (RETURN |bfVar#10|)) + (T + (LET ((|bfVar#12| (|copyList| (|shoeComps| (|bfDef1| |d|))))) + (COND ((NULL |bfVar#12|) NIL) + ((NULL |bfVar#10|) (SETQ |bfVar#10| |bfVar#12|) + (SETQ |bfVar#11| (|lastNode| |bfVar#10|))) + (T (RPLACD |bfVar#11| |bfVar#12|) + (SETQ |bfVar#11| (|lastNode| |bfVar#11|))))))) + (SETQ |bfVar#9| (CDR |bfVar#9|))))))))) (DEFUN |bfGargl| (|argl|) (PROG (|f| |d| |c| |b| |a| |LETTMP#1|) (RETURN - (COND - ((NULL |argl|) (LIST NIL NIL NIL NIL)) - (T (SETQ |LETTMP#1| (|bfGargl| (CDR |argl|))) - (SETQ |a| (CAR |LETTMP#1|)) - (SETQ |b| (CADR . #0=(|LETTMP#1|))) (SETQ |c| (CADDR . #0#)) - (SETQ |d| (CADDDR . #0#)) - (COND + (COND ((NULL |argl|) (LIST NIL NIL NIL NIL)) + (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 (|quote| 'LIST) (CAR |d|)) - (CDR |d|)))) + (CONS (LIST 'CONS (|quote| 'LIST) (CAR |d|)) (CDR |d|)))) (T (SETQ |f| (|bfGenSymbol|)) - (LIST (CONS |f| |a|) (CONS |f| |b|) - (CONS (CAR |argl|) |c|) (CONS |f| |d|))))))))) + (LIST (CONS |f| |a|) (CONS |f| |b|) (CONS (CAR |argl|) |c|) + (CONS |f| |d|))))))))) (DEFUN |bfDef1| (|bfVar#1|) - (PROG (|arglp| |control| |quotes| |LETTMP#1| |argl| |body| |args| - |op|) - (RETURN - (PROGN - (SETQ |op| (CAR |bfVar#1|)) - (SETQ |args| (CADR . #0=(|bfVar#1|))) - (SETQ |body| (CADDR . #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|))))))))) + (PROG (|arglp| |control| |quotes| |LETTMP#1| |argl| |body| |args| |op|) + (RETURN + (PROGN + (SETQ |op| (CAR |bfVar#1|)) + (SETQ |args| (CADR . #1=(|bfVar#1|))) + (SETQ |body| (CADDR . #1#)) + (SETQ |argl| (COND ((|bfTupleP| |args|) (CDR |args|)) (T (LIST |args|)))) + (SETQ |LETTMP#1| (|bfInsertLet| |argl| |body|)) + (SETQ |quotes| (CAR |LETTMP#1|)) + (SETQ |control| (CADR . #2=(|LETTMP#1|))) + (SETQ |arglp| (CADDR . #2#)) + (SETQ |body| (CADDDR . #2#)) + (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 (SYMBOL-NAME |op|) ",LAM"))) - (LIST (LIST |innerfunc| (LIST 'LAMBDA |args| |body|)) - (LIST |op| - (LIST 'MLAMBDA (LIST '&REST |margs|) - (LIST 'CONS (|quote| |innerfunc|) - (LIST 'WRAP |margs| - (|quote| |control|)))))))))) + (PROGN + (SETQ |margs| (|bfGenSymbol|)) + (SETQ |innerfunc| (INTERN (CONCAT (SYMBOL-NAME |op|) ",LAM"))) + (LIST (LIST |innerfunc| (LIST 'LAMBDA |args| |body|)) + (LIST |op| + (LIST 'MLAMBDA (LIST '&REST |margs|) + (LIST 'CONS (|quote| |innerfunc|) + (LIST 'WRAP |margs| (|quote| |control|)))))))))) (DEFUN |bfDef| (|op| |args| |body|) (PROG (|body1| |arg1| |op1| |LETTMP#1|) - (DECLARE (SPECIAL |$wheredefs| |$bfClamming|)) + (DECLARE (SPECIAL |$bfClamming| |$wheredefs|)) (RETURN - (COND - (|$bfClamming| - (SETQ |LETTMP#1| - (|shoeComp| - (CAR (|bfDef1| (LIST |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#2| NIL) (|bfVar#3| NIL) - (|bfVar#1| - (CONS (LIST |op| |args| |body|) |$wheredefs|)) - (|d| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |d| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - (T (LET ((|bfVar#4| - (|copyList| - (|shoeComps| (|bfDef1| |d|))))) - (COND - ((NULL |bfVar#4|) NIL) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| |bfVar#4|) - (SETQ |bfVar#3| (|lastNode| |bfVar#2|))) - (T (RPLACD |bfVar#3| |bfVar#4|) - (SETQ |bfVar#3| (|lastNode| |bfVar#3|))))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))))))))) + (COND + (|$bfClamming| + (SETQ |LETTMP#1| + (|shoeComp| (CAR (|bfDef1| (LIST |op| |args| |body|))))) + (SETQ |op1| (CADR . #1=(|LETTMP#1|))) (SETQ |arg1| (CADDR . #1#)) + (SETQ |body1| (CDDDR . #1#)) (|bfCompHash| |op1| |arg1| |body1|)) + (T + (|bfTuple| + (LET ((|bfVar#2| NIL) + (|bfVar#3| NIL) + (|bfVar#1| (CONS (LIST |op| |args| |body|) |$wheredefs|)) + (|d| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |d| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + (T + (LET ((|bfVar#4| (|copyList| (|shoeComps| (|bfDef1| |d|))))) + (COND ((NULL |bfVar#4|) NIL) + ((NULL |bfVar#2|) (SETQ |bfVar#2| |bfVar#4|) + (SETQ |bfVar#3| (|lastNode| |bfVar#2|))) + (T (RPLACD |bfVar#3| |bfVar#4|) + (SETQ |bfVar#3| (|lastNode| |bfVar#3|))))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))))))))) (DEFUN |shoeComps| (|x|) (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |x|) (|def| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |def| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| #0=(CONS (|shoeComp| |def|) NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #0#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))) + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |def| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS (|shoeComp| |def|) NIL)) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))) (DEFUN |shoeComp| (|x|) (PROG (|a|) (RETURN - (PROGN - (SETQ |a| (|shoeCompTran| (CADR |x|))) - (COND - ((AND (CONSP |a|) (EQ (CAR |a|) 'LAMBDA)) - (CONS 'DEFUN (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|))))) - (T (CONS 'DEFMACRO - (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|)))))))))) + (PROGN + (SETQ |a| (|shoeCompTran| (CADR |x|))) + (COND + ((AND (CONSP |a|) (EQ (CAR |a|) 'LAMBDA)) + (CONS 'DEFUN (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|))))) + (T (CONS 'DEFMACRO (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|)))))))))) (DEFUN |bfParameterList| (|p1| |p2|) - (COND - ((AND (NULL |p2|) (CONSP |p1|)) |p1|) - ((AND (CONSP |p1|) (EQ (CAR |p1|) '&OPTIONAL)) - (COND - ((NOT (AND (CONSP |p2|) (EQ (CAR |p2|) '&OPTIONAL))) - (|bpSpecificErrorHere| "default value required")) - (T (CONS (CAR |p1|) (|append| (CDR |p1|) (CDR |p2|)))))) - ((AND (CONSP |p2|) (EQ (CAR |p2|) '&OPTIONAL)) - (CONS |p1| (CONS (CAR |p2|) (CDR |p2|)))) - (T (CONS |p1| |p2|)))) + (COND ((AND (NULL |p2|) (CONSP |p1|)) |p1|) + ((AND (CONSP |p1|) (EQ (CAR |p1|) '&OPTIONAL)) + (COND + ((NOT (AND (CONSP |p2|) (EQ (CAR |p2|) '&OPTIONAL))) + (|bpSpecificErrorHere| "default value required")) + (T (CONS (CAR |p1|) (|append| (CDR |p1|) (CDR |p2|)))))) + ((AND (CONSP |p2|) (EQ (CAR |p2|) '&OPTIONAL)) + (CONS |p1| (CONS (CAR |p2|) (CDR |p2|)))) + (T (CONS |p1| |p2|)))) (DEFUN |bfInsertLet| (|x| |body|) - (PROG (|body2| |name2| |norq1| |b1| |body1| |name1| |norq| |LETTMP#1| - |b| |a| |ISTMP#1|) + (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|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) - (COND - ((AND (CONSP |a|) (EQ (CAR |a|) 'QUOTE) + (COND ((NULL |x|) (LIST NIL NIL |x| |body|)) + ((AND (CONSP |x|) (EQ (CAR |x|) '&REST) (PROGN - (SETQ |ISTMP#1| (CDR |a|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |b| (CAR |ISTMP#1|)) T)))) - (LIST T 'QUOTE (LIST '&REST |b|) |body|)) - (T (LIST NIL NIL |x| |body|)))) - (T (SETQ |LETTMP#1| (|bfInsertLet1| (CAR |x|) |body|)) - (SETQ |b| (CAR |LETTMP#1|)) - (SETQ |norq| (CADR . #0=(|LETTMP#1|))) - (SETQ |name1| (CADDR . #0#)) (SETQ |body1| (CADDDR . #0#)) - (SETQ |LETTMP#1| (|bfInsertLet| (CDR |x|) |body1|)) - (SETQ |b1| (CAR |LETTMP#1|)) - (SETQ |norq1| (CADR . #1=(|LETTMP#1|))) - (SETQ |name2| (CADDR . #1#)) (SETQ |body2| (CADDDR . #1#)) - (LIST (OR |b| |b1|) (CONS |norq| |norq1|) - (|bfParameterList| |name1| |name2|) |body2|)))))) + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) + (COND + ((AND (CONSP |a|) (EQ (CAR |a|) 'QUOTE) + (PROGN + (SETQ |ISTMP#1| (CDR |a|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |b| (CAR |ISTMP#1|)) T)))) + (LIST T 'QUOTE (LIST '&REST |b|) |body|)) + (T (LIST NIL NIL |x| |body|)))) + (T (SETQ |LETTMP#1| (|bfInsertLet1| (CAR |x|) |body|)) + (SETQ |b| (CAR |LETTMP#1|)) (SETQ |norq| (CADR . #1=(|LETTMP#1|))) + (SETQ |name1| (CADDR . #1#)) (SETQ |body1| (CADDDR . #1#)) + (SETQ |LETTMP#1| (|bfInsertLet| (CDR |x|) |body1|)) + (SETQ |b1| (CAR |LETTMP#1|)) + (SETQ |norq1| (CADR . #2=(|LETTMP#1|))) + (SETQ |name2| (CADDR . #2#)) (SETQ |body2| (CADDDR . #2#)) + (LIST (OR |b| |b1|) (CONS |norq| |norq1|) + (|bfParameterList| |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|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |r| (CAR |ISTMP#2|)) T)))))) - (LIST NIL NIL |l| - (|bfMKPROGN| (LIST (|bfLET| |r| |l|) |body|)))) - ((SYMBOLP |y|) (LIST NIL NIL |y| |body|)) - ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |y|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |b| (CAR |ISTMP#1|)) T)))) - (LIST T 'QUOTE |b| |body|)) - (T (SETQ |g| (|bfGenSymbol|)) - (COND - ((NOT (CONSP |y|)) (LIST NIL NIL |g| |body|)) - (T (CASE (CAR |y|) - (|%DefaultValue| - (LET ((|p| (CADR |y|)) (|v| (CADDR |y|))) - (LIST NIL NIL (LIST '&OPTIONAL (LIST |p| |v|)) - |body|))) - (T (LIST NIL NIL |g| - (|bfMKPROGN| - (LIST (|bfLET| (|compFluidize| |y|) |g|) - |body|)))))))))))) + (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|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |r| (CAR |ISTMP#2|)) T)))))) + (LIST NIL NIL |l| (|bfMKPROGN| (LIST (|bfLET| |r| |l|) |body|)))) + ((SYMBOLP |y|) (LIST NIL NIL |y| |body|)) + ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE) + (PROGN + (SETQ |ISTMP#1| (CDR |y|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |b| (CAR |ISTMP#1|)) T)))) + (LIST T 'QUOTE |b| |body|)) + (T (SETQ |g| (|bfGenSymbol|)) + (COND ((NOT (CONSP |y|)) (LIST NIL NIL |g| |body|)) + (T + (CASE (CAR |y|) + (|%DefaultValue| + (LET ((|p| (CADR |y|)) (|v| (CADDR |y|))) + (LIST NIL NIL (LIST '&OPTIONAL (LIST |p| |v|)) |body|))) + (T + (LIST NIL NIL |g| + (|bfMKPROGN| + (LIST (|bfLET| (|compFluidize| |y|) |g|) + |body|)))))))))))) (DEFUN |shoeCompTran| (|x|) - (PROG (|$dollarVars| |$locVars| |$fluidVars| |fvs| |fl| |fvars| - |body'| |lvars| |body| |args| |lamtype|) - (DECLARE (SPECIAL |$typings| |$dollarVars| |$fluidVars| |$locVars|)) - (RETURN - (PROGN - (SETQ |lamtype| (CAR |x|)) - (SETQ |args| (CADR . #0=(|x|))) - (SETQ |body| (CDDR . #0#)) - (SETQ |$fluidVars| NIL) - (SETQ |$locVars| NIL) - (SETQ |$dollarVars| NIL) - (|shoeCompTran1| |body|) - (SETQ |$locVars| - (|setDifference| - (|setDifference| |$locVars| |$fluidVars|) - (|shoeATOMs| |args|))) - (SETQ |body| + (PROG (|$dollarVars| |$locVars| |$fluidVars| |fvs| |fl| |fvars| |body'| + |lvars| |body| |args| |lamtype|) + (DECLARE (SPECIAL |$typings| |$dollarVars| |$locVars| |$fluidVars|)) + (RETURN + (PROGN + (SETQ |lamtype| (CAR |x|)) + (SETQ |args| (CADR . #1=(|x|))) + (SETQ |body| (CDDR . #1#)) + (SETQ |$fluidVars| NIL) + (SETQ |$locVars| NIL) + (SETQ |$dollarVars| NIL) + (|shoeCompTran1| |body|) + (SETQ |$locVars| + (|setDifference| (|setDifference| |$locVars| |$fluidVars|) + (|shoeATOMs| |args|))) + (SETQ |body| (PROGN - (SETQ |lvars| (|append| |$fluidVars| |$locVars|)) - (SETQ |$fluidVars| (UNION |$fluidVars| |$dollarVars|)) - (SETQ |body'| |body|) - (COND - (|$typings| - (SETQ |body'| - (CONS (CONS 'DECLARE |$typings|) |body'|)))) - (COND - (|$fluidVars| - (SETQ |fvars| - (LIST 'DECLARE - (CONS 'SPECIAL |$fluidVars|))) - (SETQ |body'| (CONS |fvars| |body'|)))) - (COND - ((OR |lvars| (|needsPROG| |body|)) - (|shoePROG| |lvars| |body'|)) - (T |body'|)))) - (SETQ |fl| (|shoeFluids| |args|)) - (SETQ |body| + (SETQ |lvars| (|append| |$fluidVars| |$locVars|)) + (SETQ |$fluidVars| (UNION |$fluidVars| |$dollarVars|)) + (SETQ |body'| |body|) + (COND + (|$typings| + (SETQ |body'| (CONS (CONS 'DECLARE |$typings|) |body'|)))) + (COND + (|$fluidVars| + (SETQ |fvars| (LIST 'DECLARE (CONS 'SPECIAL |$fluidVars|))) + (SETQ |body'| (CONS |fvars| |body'|)))) + (COND + ((OR |lvars| (|needsPROG| |body|)) + (|shoePROG| |lvars| |body'|)) + (T |body'|)))) + (SETQ |fl| (|shoeFluids| |args|)) + (SETQ |body| (COND - (|fl| (SETQ |fvs| (LIST 'DECLARE (CONS 'SPECIAL |fl|))) - (CONS |fvs| |body|)) - (T |body|))) - (CONS |lamtype| (CONS |args| |body|)))))) + (|fl| (SETQ |fvs| (LIST 'DECLARE (CONS 'SPECIAL |fl|))) + (CONS |fvs| |body|)) + (T |body|))) + (CONS |lamtype| (CONS |args| |body|)))))) (DEFUN |needsPROG| (|body|) (PROG (|args| |op|) (RETURN - (COND - ((NOT (CONSP |body|)) NIL) - (T (SETQ |op| (CAR |body|)) (SETQ |args| (CDR |body|)) - (COND - ((|symbolMember?| |op| '(RETURN RETURN-FROM)) T) - ((|symbolMember?| |op| - '(LET PROG LOOP BLOCK DECLARE LAMBDA)) - NIL) - (T (LET ((|bfVar#2| NIL) (|bfVar#1| |body|) (|t| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |t| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - (T (SETQ |bfVar#2| (|needsPROG| |t|)) - (COND (|bfVar#2| (RETURN |bfVar#2|))))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))))))))) + (COND ((NOT (CONSP |body|)) NIL) + (T (SETQ |op| (CAR |body|)) (SETQ |args| (CDR |body|)) + (COND ((|symbolMember?| |op| '(RETURN RETURN-FROM)) T) + ((|symbolMember?| |op| + '(LET PROG + LOOP + BLOCK + DECLARE + LAMBDA)) + NIL) + (T + (LET ((|bfVar#2| NIL) (|bfVar#1| |body|) (|t| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |t| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + (T (SETQ |bfVar#2| (|needsPROG| |t|)) + (COND (|bfVar#2| (RETURN |bfVar#2|))))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))))))))) (DEFUN |shoePROG| (|v| |b|) (PROG (|blist| |blast| |LETTMP#1|) (RETURN - (COND - ((NULL |b|) (LIST (LIST 'PROG |v|))) - (T (SETQ |LETTMP#1| (|reverse| |b|)) - (SETQ |blast| (CAR |LETTMP#1|)) - (SETQ |blist| (|reverse!| (CDR |LETTMP#1|))) - (LIST (CONS 'PROG - (CONS |v| - (|append| |blist| - (CONS (LIST 'RETURN |blast|) NIL)))))))))) + (COND ((NULL |b|) (LIST (LIST 'PROG |v|))) + (T (SETQ |LETTMP#1| (|reverse| |b|)) (SETQ |blast| (CAR |LETTMP#1|)) + (SETQ |blist| (|reverse!| (CDR |LETTMP#1|))) + (LIST + (CONS 'PROG + (CONS |v| + (|append| |blist| + (CONS (LIST 'RETURN |blast|) NIL)))))))))) (DEFUN |shoeFluids| (|x|) - (COND - ((AND (|ident?| |x|) (|bfBeginsDollar| |x|)) (LIST |x|)) - ((|atomic?| |x|) NIL) - (T (|append| (|shoeFluids| (CAR |x|)) (|shoeFluids| (CDR |x|)))))) + (COND ((AND (|ident?| |x|) (|bfBeginsDollar| |x|)) (LIST |x|)) + ((|atomic?| |x|) NIL) + (T (|append| (|shoeFluids| (CAR |x|)) (|shoeFluids| (CDR |x|)))))) (DEFUN |shoeATOMs| (|x|) - (COND - ((|ident?| |x|) (LIST |x|)) - ((|atomic?| |x|) NIL) - (T (|append| (|shoeATOMs| (CAR |x|)) (|shoeATOMs| (CDR |x|)))))) + (COND ((|ident?| |x|) (LIST |x|)) ((|atomic?| |x|) NIL) + (T (|append| (|shoeATOMs| (CAR |x|)) (|shoeATOMs| (CDR |x|)))))) (DEFUN |isDynamicVariable| (|x|) (PROG (|y|) - (DECLARE (SPECIAL |$activeNamespace| |$constantIdentifiers|)) + (DECLARE (SPECIAL |$constantIdentifiers| |$activeNamespace|)) (RETURN - (COND - ((AND (SYMBOLP |x|) (|bfBeginsDollar| |x|)) - (COND - ((|symbolMember?| |x| |$constantIdentifiers|) NIL) - ((CONSTANTP |x|) NIL) - ((OR (BOUNDP |x|) (NULL |$activeNamespace|)) T) - ((SETQ |y| - (FIND-SYMBOL (SYMBOL-NAME |x|) |$activeNamespace|)) - (NOT (CONSTANTP |y|))) - (T T))) - (T NIL))))) + (COND + ((AND (SYMBOLP |x|) (|bfBeginsDollar| |x|)) + (COND ((|symbolMember?| |x| |$constantIdentifiers|) NIL) + ((CONSTANTP |x|) NIL) + ((OR (BOUNDP |x|) (NULL |$activeNamespace|)) T) + ((SETQ |y| (FIND-SYMBOL (SYMBOL-NAME |x|) |$activeNamespace|)) + (NOT (CONSTANTP |y|))) + (T T))) + (T NIL))))) (DEFUN |shoeCompTran1| (|x|) - (PROG (|n| |elts| |newbindings| |r| |ISTMP#2| |l| |zs| |y| |ISTMP#1| - U) - (DECLARE (SPECIAL |$fluidVars| |$locVars| |$dollarVars|)) + (PROG (|n| |elts| |newbindings| |r| |ISTMP#2| |l| |zs| |y| |ISTMP#1| U) + (DECLARE (SPECIAL |$dollarVars| |$locVars| |$fluidVars|)) (RETURN - (COND - ((NOT (CONSP |x|)) - (COND - ((AND (|isDynamicVariable| |x|) - (NOT (|symbolMember?| |x| |$dollarVars|))) - (SETQ |$dollarVars| (CONS |x| |$dollarVars|)))) - |x|) - (T (SETQ U (CAR |x|)) - (COND - ((EQ U 'QUOTE) |x|) + (COND + ((NOT (CONSP |x|)) + (COND + ((AND (|isDynamicVariable| |x|) + (NOT (|symbolMember?| |x| |$dollarVars|))) + (SETQ |$dollarVars| (CONS |x| |$dollarVars|)))) + |x|) + (T (SETQ U (CAR |x|)) + (COND ((EQ U 'QUOTE) |x|) ((AND (CONSP |x|) (EQ (CAR |x|) 'CASE) (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |y| (CAR |ISTMP#1|)) - (SETQ |zs| (CDR |ISTMP#1|)) - T)))) + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |y| (CAR |ISTMP#1|)) + (SETQ |zs| (CDR |ISTMP#1|)) + T)))) (SETF (CADR |x|) (|shoeCompTran1| |y|)) (LOOP - (COND - ((NOT |zs|) (RETURN NIL)) - (T (SETF (CADR (CAR |zs|)) - (|shoeCompTran1| (CADR (CAR |zs|)))) - (SETQ |zs| (CDR |zs|))))) + (COND ((NOT |zs|) (RETURN NIL)) + (T + (SETF (CADR (CAR |zs|)) + (|shoeCompTran1| (CADR (CAR |zs|)))) + (SETQ |zs| (CDR |zs|))))) |x|) ((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|) - (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |r| (CAR |ISTMP#2|)) T)))))) - (RPLACA |x| 'SETQ) - (SETF (CADDR |x|) (|shoeCompTran1| |r|)) + (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|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |r| (CAR |ISTMP#2|)) T)))))) + (RPLACA |x| 'SETQ) (SETF (CADDR |x|) (|shoeCompTran1| |r|)) (COND - ((SYMBOLP |l|) - (COND - ((|bfBeginsDollar| |l|) - (COND - ((NOT (|symbolMember?| |l| |$dollarVars|)) - (SETQ |$dollarVars| (CONS |l| |$dollarVars|)))) - |x|) - (T (COND - ((NOT (|symbolMember?| |l| |$locVars|)) - (SETQ |$locVars| (CONS |l| |$locVars|)))) - |x|))) - ((AND (CONSP |l|) (EQ (CAR |l|) 'FLUID)) - (COND - ((NOT (|symbolMember?| (CADR |l|) |$fluidVars|)) - (SETQ |$fluidVars| (CONS (CADR |l|) |$fluidVars|)))) - (RPLACA (CDR |x|) (CADR |l|)) |x|))) + ((SYMBOLP |l|) + (COND + ((|bfBeginsDollar| |l|) + (COND + ((NOT (|symbolMember?| |l| |$dollarVars|)) + (SETQ |$dollarVars| (CONS |l| |$dollarVars|)))) + |x|) + (T + (COND + ((NOT (|symbolMember?| |l| |$locVars|)) + (SETQ |$locVars| (CONS |l| |$locVars|)))) + |x|))) + ((AND (CONSP |l|) (EQ (CAR |l|) 'FLUID)) + (COND + ((NOT (|symbolMember?| (CADR |l|) |$fluidVars|)) + (SETQ |$fluidVars| (CONS (CADR |l|) |$fluidVars|)))) + (RPLACA (CDR |x|) (CADR |l|)) |x|))) ((EQ U '|%Leave|) (RPLACA |x| 'RETURN) |x|) - ((|symbolMember?| U '(PROG LAMBDA)) - (SETQ |newbindings| NIL) + ((|symbolMember?| U '(PROG LAMBDA)) (SETQ |newbindings| NIL) (LET ((|bfVar#1| (CADR |x|)) (|y| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |y| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - ((NOT (|symbolMember?| |y| |$locVars|)) - (IDENTITY - (PROGN - (SETQ |$locVars| (CONS |y| |$locVars|)) - (SETQ |newbindings| - (CONS |y| |newbindings|)))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |y| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + ((NOT (|symbolMember?| |y| |$locVars|)) + (IDENTITY + (PROGN + (SETQ |$locVars| (CONS |y| |$locVars|)) + (SETQ |newbindings| (CONS |y| |newbindings|)))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) (RPLACD (CDR |x|) (|shoeCompTran1| (CDDR |x|))) (SETQ |$locVars| - (LET ((|bfVar#3| NIL) (|bfVar#4| NIL) - (|bfVar#2| |$locVars|) (|y| NIL)) - (LOOP - (COND + (LET ((|bfVar#3| NIL) + (|bfVar#4| NIL) + (|bfVar#2| |$locVars|) + (|y| NIL)) + (LOOP + (COND ((OR (NOT (CONSP |bfVar#2|)) (PROGN (SETQ |y| (CAR |bfVar#2|)) NIL)) (RETURN |bfVar#3|)) - (T (AND (NOT (|symbolMember?| |y| - |newbindings|)) - (COND - ((NULL |bfVar#3|) - (SETQ |bfVar#3| #0=(CONS |y| NIL)) - (SETQ |bfVar#4| |bfVar#3|)) - (T (RPLACD |bfVar#4| #0#) - (SETQ |bfVar#4| (CDR |bfVar#4|))))))) - (SETQ |bfVar#2| (CDR |bfVar#2|))))) + (T + (AND (NOT (|symbolMember?| |y| |newbindings|)) + (COND + ((NULL |bfVar#3|) + (SETQ |bfVar#3| #1=(CONS |y| NIL)) + (SETQ |bfVar#4| |bfVar#3|)) + (T (RPLACD |bfVar#4| #1#) + (SETQ |bfVar#4| (CDR |bfVar#4|))))))) + (SETQ |bfVar#2| (CDR |bfVar#2|))))) |x|) ((AND (CONSP |x|) (EQ (CAR |x|) '|vector|) (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |elts| (CAR |ISTMP#1|)) T)))) - (RPLACA |x| 'VECTOR) - (COND - ((EQ |elts| 'NIL) (RPLACD |x| NIL)) - (T (RPLACD |x| (|shoeCompTran1| (CDR |elts|))))) + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |elts| (CAR |ISTMP#1|)) T)))) + (COND ((EQ |elts| 'NIL) (RPLACA |x| 'VECTOR) (RPLACD |x| NIL)) + ((AND (CONSP |elts|) (EQ (CAR |elts|) 'LIST)) + (RPLACA |x| 'VECTOR) + (RPLACD |x| (|shoeCompTran1| (CDR |elts|)))) + ((NOT (CONSP |elts|)) + (SETQ |elts| (|shoeCompTran1| |elts|)) + (RPLACA |x| 'MAKE-ARRAY) + (RPLACD |x| + (LIST (LIST 'LIST-LENGTH |elts|) :INITIAL-CONTENTS + |elts|))) + (T (RPLACA |x| 'COERCE) + (RPLACD |x| + (LIST (|shoeCompTran1| |elts|) + (|quote| 'VECTOR))))) |x|) ((AND (CONSP |x|) (EQ (CAR |x|) '|%Namespace|) (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |n| (CAR |ISTMP#1|)) T)))) - (COND - ((EQ |n| 'DOT) '*PACKAGE*) - (T (LIST 'FIND-PACKAGE (SYMBOL-NAME |n|))))) + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |n| (CAR |ISTMP#1|)) T)))) + (COND ((EQ |n| 'DOT) '*PACKAGE*) + (T (LIST 'FIND-PACKAGE (SYMBOL-NAME |n|))))) (T (RPLACA |x| (|shoeCompTran1| (CAR |x|))) - (RPLACD |x| (|shoeCompTran1| (CDR |x|))) |x|))))))) + (RPLACD |x| (|shoeCompTran1| (CDR |x|))) |x|))))))) (DEFUN |bfTagged| (|a| |b|) - (DECLARE (SPECIAL |$typings| |$op|)) - (COND - ((NULL |$op|) (|%Signature| |a| |b|)) - ((SYMBOLP |a|) - (COND - ((EQ |b| 'FLUID) (|bfLET| (|compFluid| |a|) NIL)) - ((EQ |b| '|local|) (|bfLET| (|compFluid| |a|) NIL)) - (T (SETQ |$typings| (CONS (LIST 'TYPE |b| |a|) |$typings|)) |a|))) - (T (LIST 'THE |b| |a|)))) + (DECLARE (SPECIAL |$op| |$typings|)) + (COND ((NULL |$op|) (|%Signature| |a| |b|)) + ((SYMBOLP |a|) + (COND ((EQ |b| 'FLUID) (|bfLET| (|compFluid| |a|) NIL)) + ((EQ |b| '|local|) (|bfLET| (|compFluid| |a|) NIL)) + (T (SETQ |$typings| (CONS (LIST 'TYPE |b| |a|) |$typings|)) + |a|))) + (T (LIST 'THE |b| |a|)))) (DEFUN |bfAssign| (|l| |r|) (PROG (|l'|) (RETURN - (COND - ((|bfTupleP| |l|) (|bfSetelt| (CADR |l|) (CDDR |l|) |r|)) - ((AND (CONSP |l|) (EQ (CAR |l|) '|%Place|)) - (SETQ |l'| (CDR |l|)) (LIST 'SETF |l'| |r|)) - (T (|bfLET| |l| |r|)))))) + (COND ((|bfTupleP| |l|) (|bfSetelt| (CADR |l|) (CDDR |l|) |r|)) + ((AND (CONSP |l|) (EQ (CAR |l|) '|%Place|)) (SETQ |l'| (CDR |l|)) + (LIST 'SETF |l'| |r|)) + (T (|bfLET| |l| |r|)))))) (DEFUN |bfSetelt| (|e| |l| |r|) - (COND - ((NULL (CDR |l|)) (|defSETELT| |e| (CAR |l|) |r|)) - (T (|bfSetelt| (|bfElt| |e| (CAR |l|)) (CDR |l|) |r|)))) + (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|)) - (T (LIST |y| |expr|)))) - (T (LIST 'ELT |expr| |sel|))))))) + (PROGN + (SETQ |y| (AND (SYMBOLP |sel|) (GET |sel| 'SHOESELFUNCTION))) + (COND + (|y| + (COND ((INTEGERP |y|) (LIST 'ELT |expr| |y|)) (T (LIST |y| |expr|)))) + (T (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|)) - ((EQ |y| 'CAR) (LIST 'RPLACA |var| |expr|)) - ((EQ |y| 'CDR) (LIST 'RPLACD |var| |expr|)) - (T (LIST 'SETF (LIST |y| |var|) |expr|)))) - (T (LIST 'SETF (LIST 'ELT |var| |sel|) |expr|))))))) + (PROGN + (SETQ |y| (AND (SYMBOLP |sel|) (GET |sel| 'SHOESELFUNCTION))) + (COND + (|y| + (COND ((INTEGERP |y|) (LIST 'SETF (LIST 'ELT |var| |y|) |expr|)) + ((EQ |y| 'CAR) (LIST 'RPLACA |var| |expr|)) + ((EQ |y| 'CDR) (LIST 'RPLACD |var| |expr|)) + (T (LIST 'SETF (LIST |y| |var|) |expr|)))) + (T (LIST 'SETF (LIST 'ELT |var| |sel|) |expr|))))))) (DEFUN |bfIfThenOnly| (|a| |b|) (PROG (|b1|) (RETURN - (PROGN - (SETQ |b1| - (COND - ((AND (CONSP |b|) (EQ (CAR |b|) 'PROGN)) (CDR |b|)) - (T (LIST |b|)))) - (LIST 'COND (CONS |a| |b1|)))))) + (PROGN + (SETQ |b1| + (COND ((AND (CONSP |b|) (EQ (CAR |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 - ((AND (CONSP |b|) (EQ (CAR |b|) 'PROGN)) (CDR |b|)) - (T (LIST |b|)))) - (COND - ((AND (CONSP |c|) (EQ (CAR |c|) 'COND)) - (CONS 'COND (CONS (CONS |a| |b1|) (CDR |c|)))) - (T (SETQ |c1| - (COND - ((AND (CONSP |c|) (EQ (CAR |c|) 'PROGN)) - (CDR |c|)) - (T (LIST |c|)))) - (LIST 'COND (CONS |a| |b1|) (CONS 'T |c1|)))))))) + (PROGN + (SETQ |b1| + (COND ((AND (CONSP |b|) (EQ (CAR |b|) 'PROGN)) (CDR |b|)) + (T (LIST |b|)))) + (COND + ((AND (CONSP |c|) (EQ (CAR |c|) 'COND)) + (CONS 'COND (CONS (CONS |a| |b1|) (CDR |c|)))) + (T + (SETQ |c1| + (COND ((AND (CONSP |c|) (EQ (CAR |c|) 'PROGN)) (CDR |c|)) + (T (LIST |c|)))) + (LIST 'COND (CONS |a| |b1|) (CONS 'T |c1|)))))))) -(DEFUN |bfExit| (|a| |b|) - (LIST 'COND (LIST |a| (LIST 'IDENTITY |b|)))) +(DEFUN |bfExit| (|a| |b|) (LIST 'COND (LIST |a| (LIST 'IDENTITY |b|)))) (DEFUN |bfFlattenSeq| (|l|) (PROG (|xs| |x|) (RETURN - (COND - ((NULL |l|) |l|) - (T (SETQ |x| (CAR |l|)) (SETQ |xs| (CDR |l|)) - (COND + (COND ((NULL |l|) |l|) + (T (SETQ |x| (CAR |l|)) (SETQ |xs| (CDR |l|)) + (COND ((NOT (CONSP |x|)) (COND ((NULL |xs|) |l|) (T (|bfFlattenSeq| |xs|)))) - ((EQ (CAR |x|) 'PROGN) - (|bfFlattenSeq| (|append| (CDR |x|) |xs|))) + ((EQ (CAR |x|) 'PROGN) (|bfFlattenSeq| (|append| (CDR |x|) |xs|))) (T (CONS |x| (|bfFlattenSeq| |xs|))))))))) (DEFUN |bfMKPROGN| (|l|) (PROGN - (SETQ |l| (|bfFlattenSeq| |l|)) - (COND - ((NULL |l|) NIL) - ((AND (CONSP |l|) (NULL (CDR |l|))) (CAR |l|)) - (T (CONS 'PROGN |l|))))) + (SETQ |l| (|bfFlattenSeq| |l|)) + (COND ((NULL |l|) NIL) ((AND (CONSP |l|) (NULL (CDR |l|))) (CAR |l|)) + (T (CONS 'PROGN |l|))))) (DEFUN |bfWashCONDBranchBody| (|x|) (PROG (|y|) (RETURN - (COND - ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN)) (SETQ |y| (CDR |x|)) - |y|) - (T (LIST |x|)))))) + (COND ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN)) (SETQ |y| (CDR |x|)) |y|) + (T (LIST |x|)))))) (DEFUN |bfAlternative| (|a| |b|) - (PROG (|conds| |ISTMP#5| |stmt| |ISTMP#4| |ISTMP#3| |ISTMP#2| - |ISTMP#1|) + (PROG (|conds| |ISTMP#5| |stmt| |ISTMP#4| |ISTMP#3| |ISTMP#2| |ISTMP#1|) (RETURN - (COND - ((AND (CONSP |a|) (EQ (CAR |a|) 'AND) - (PROGN - (SETQ |ISTMP#1| (CDR |a|)) - (AND (CONSP |ISTMP#1|) - (PROGN (SETQ |ISTMP#2| (|reverse| |ISTMP#1|)) T) - (CONSP |ISTMP#2|) - (PROGN - (SETQ |ISTMP#3| (CAR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CAR |ISTMP#3|) 'PROGN) - (PROGN - (SETQ |ISTMP#4| (CDR |ISTMP#3|)) - (AND (CONSP |ISTMP#4|) - (PROGN - (SETQ |stmt| (CAR |ISTMP#4|)) - (SETQ |ISTMP#5| (CDR |ISTMP#4|)) - (AND (CONSP |ISTMP#5|) - (NULL (CDR |ISTMP#5|)) - (EQ (CAR |ISTMP#5|) 'T))))))) - (PROGN (SETQ |conds| (CDR |ISTMP#2|)) T) - (PROGN (SETQ |conds| (|reverse!| |conds|)) T)))) - (CONS (CONS 'AND |conds|) - (|bfWashCONDBranchBody| (|bfMKPROGN| (LIST |stmt| |b|))))) - (T (CONS |a| (|bfWashCONDBranchBody| |b|))))))) + (COND + ((AND (CONSP |a|) (EQ (CAR |a|) 'AND) + (PROGN + (SETQ |ISTMP#1| (CDR |a|)) + (AND (CONSP |ISTMP#1|) + (PROGN (SETQ |ISTMP#2| (|reverse| |ISTMP#1|)) T) + (CONSP |ISTMP#2|) + (PROGN + (SETQ |ISTMP#3| (CAR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) (EQ (CAR |ISTMP#3|) 'PROGN) + (PROGN + (SETQ |ISTMP#4| (CDR |ISTMP#3|)) + (AND (CONSP |ISTMP#4|) + (PROGN + (SETQ |stmt| (CAR |ISTMP#4|)) + (SETQ |ISTMP#5| (CDR |ISTMP#4|)) + (AND (CONSP |ISTMP#5|) (NULL (CDR |ISTMP#5|)) + (EQ (CAR |ISTMP#5|) 'T))))))) + (PROGN (SETQ |conds| (CDR |ISTMP#2|)) T) + (PROGN (SETQ |conds| (|reverse!| |conds|)) T)))) + (CONS (CONS 'AND |conds|) + (|bfWashCONDBranchBody| (|bfMKPROGN| (LIST |stmt| |b|))))) + (T (CONS |a| (|bfWashCONDBranchBody| |b|))))))) (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) - (T (SETQ |transform| - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |l|) - (|x| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL) - (NOT (AND (CONSP |x|) (EQ (CAR |x|) 'COND) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) + (PROG (|f| |aft| |before| |no| |transform| |b| |ISTMP#5| |ISTMP#4| |ISTMP#3| + |a| |ISTMP#2| |ISTMP#1|) + (RETURN + (COND ((NULL |l|) NIL) + (T + (SETQ |transform| + (LET ((|bfVar#2| NIL) + (|bfVar#3| NIL) + (|bfVar#1| |l|) + (|x| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL) + (NOT + (AND (CONSP |x|) (EQ (CAR |x|) 'COND) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) (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|) - (NULL (CDR |ISTMP#3|)) + (SETQ |ISTMP#2| (CAR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (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|) - (NULL - (CDR |ISTMP#5|)) + (SETQ |a| (CAR |ISTMP#2|)) + (SETQ |ISTMP#3| + (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (NULL (CDR |ISTMP#3|)) (PROGN - (SETQ |b| - (CAR |ISTMP#5|)) - T)))))))))))))) - (RETURN |bfVar#2|)) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| - #0=(CONS (|bfAlternative| |a| |b|) NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #0#) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))) - (SETQ |no| (LENGTH |transform|)) - (SETQ |before| (|bfTake| |no| |l|)) - (SETQ |aft| (|bfDrop| |no| |l|)) - (COND + (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|) + (NULL + (CDR |ISTMP#5|)) + (PROGN + (SETQ |b| + (CAR + |ISTMP#5|)) + T)))))))))))))) + (RETURN |bfVar#2|)) + ((NULL |bfVar#2|) + (SETQ |bfVar#2| + #1=(CONS (|bfAlternative| |a| |b|) NIL)) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #1#) + (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))) + (SETQ |no| (LENGTH |transform|)) + (SETQ |before| (|bfTake| |no| |l|)) + (SETQ |aft| (|bfDrop| |no| |l|)) + (COND ((NULL |before|) (COND - ((AND (CONSP |l|) (NULL (CDR |l|))) - (SETQ |f| (CAR |l|)) - (COND - ((AND (CONSP |f|) (EQ (CAR |f|) 'PROGN)) - (|bfSequence| (CDR |f|))) - (T |f|))) - (T (|bfMKPROGN| - (LIST (CAR |l|) (|bfSequence| (CDR |l|))))))) + ((AND (CONSP |l|) (NULL (CDR |l|))) (SETQ |f| (CAR |l|)) + (COND + ((AND (CONSP |f|) (EQ (CAR |f|) 'PROGN)) + (|bfSequence| (CDR |f|))) + (T |f|))) + (T (|bfMKPROGN| (LIST (CAR |l|) (|bfSequence| (CDR |l|))))))) ((NULL |aft|) (CONS 'COND |transform|)) - (T (CONS 'COND - (|append| |transform| - (CONS (|bfAlternative| 'T - (|bfSequence| |aft|)) - NIL)))))))))) + (T + (CONS 'COND + (|append| |transform| + (CONS (|bfAlternative| 'T (|bfSequence| |aft|)) + NIL)))))))))) (DEFUN |bfWhere| (|context| |expr|) (PROG (|a| |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#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |defs|) + (PROGN + (SETQ |LETTMP#1| (|defSheepAndGoats| |context|)) + (SETQ |opassoc| (CAR |LETTMP#1|)) + (SETQ |defs| (CADR . #1=(|LETTMP#1|))) + (SETQ |nondefs| (CADDR . #1#)) + (SETQ |a| + (LET ((|bfVar#2| NIL) + (|bfVar#3| NIL) + (|bfVar#1| |defs|) (|d| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |d| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| - #1=(CONS (LIST (CAR |d|) (CADR |d|) + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |d| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + ((NULL |bfVar#2|) + (SETQ |bfVar#2| + #2=(CONS + (LIST (CAR |d|) (CADR |d|) (|bfSUBLIS| |opassoc| (CADDR |d|))) - NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #1#) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))) - (SETQ |$wheredefs| (|append| |a| |$wheredefs|)) - (|bfMKPROGN| - (|bfSUBLIS| |opassoc| (|append!| |nondefs| (LIST |expr|)))))))) + NIL)) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #2#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))) + (SETQ |$wheredefs| (|append| |a| |$wheredefs|)) + (|bfMKPROGN| + (|bfSUBLIS| |opassoc| (|append!| |nondefs| (LIST |expr|)))))))) (DEFUN |bfCompHash| (|op| |argl| |body|) (PROG (|computeFunction| |auxfn|) (RETURN - (PROGN - (SETQ |auxfn| (INTERN (CONCAT (SYMBOL-NAME |op|) ";"))) - (SETQ |computeFunction| + (PROGN + (SETQ |auxfn| (INTERN (CONCAT (SYMBOL-NAME |op|) ";"))) + (SETQ |computeFunction| (CONS 'DEFUN (CONS |auxfn| (CONS |argl| |body|)))) - (|bfTuple| (CONS |computeFunction| (|bfMain| |auxfn| |op|))))))) + (|bfTuple| (CONS |computeFunction| (|bfMain| |auxfn| |op|))))))) (DEFUN |shoeCompileTimeEvaluation| (|x|) (LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL) |x|)) (DEFUN |bfMain| (|auxfn| |op|) - (PROG (|defCode| |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 (SYMBOL-NAME |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| + (PROG (|defCode| |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 (SYMBOL-NAME |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| + (SETQ |mainFunction| (LIST 'DEFUN |op| |arg| |codeBody|)) + (SETQ |cacheType| '|hash-table|) + (SETQ |cacheResetCode| (LIST 'SETQ |cacheName| (LIST 'MAKE-HASHTABLE (|quote| 'UEQUAL)))) - (SETQ |cacheCountCode| (LIST '|hashCount| |cacheName|)) - (SETQ |cacheVector| + (SETQ |cacheCountCode| (LIST '|hashCount| |cacheName|)) + (SETQ |cacheVector| (LIST |op| |cacheName| |cacheType| |cacheResetCode| |cacheCountCode|)) - (SETQ |defCode| + (SETQ |defCode| (LIST 'DEFPARAMETER |cacheName| (LIST 'MAKE-HASHTABLE (|quote| 'UEQUAL)))) - (LIST |defCode| |mainFunction| - (LIST 'SETF - (LIST 'GET (|quote| |op|) (|quote| '|cacheInfo|)) - (|quote| |cacheVector|))))))) + (LIST |defCode| |mainFunction| + (LIST 'SETF (LIST 'GET (|quote| |op|) (|quote| '|cacheInfo|)) + (|quote| |cacheVector|))))))) (DEFUN |bfNamespace| (|x|) (LIST '|%Namespace| |x|)) (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Form|) |bfNameOnly|)) -(DEFUN |bfNameOnly| (|x|) - (COND ((EQ |x| '|t|) (LIST 'T)) (T (LIST |x|)))) +(DEFUN |bfNameOnly| (|x|) (COND ((EQ |x| '|t|) (LIST 'T)) (T (LIST |x|)))) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) (|%List| |%Form|)) - |bfNameArgs|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) (|%List| |%Form|)) |bfNameArgs|)) (DEFUN |bfNameArgs| (|x| |y|) (PROGN - (SETQ |y| - (COND - ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) (CDR |y|)) - (T (LIST |y|)))) - (CONS |x| |y|))) + (SETQ |y| + (COND ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) (CDR |y|)) + (T (LIST |y|)))) + (CONS |x| |y|))) (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Form|) |bfCreateDef|)) (DEFUN |bfCreateDef| (|x|) (PROG (|a| |f|) (RETURN - (COND - ((AND (CONSP |x|) (NULL (CDR |x|))) (SETQ |f| (CAR |x|)) - (LIST 'DEFCONSTANT |f| (LIST 'LIST (|quote| |f|)))) - (T (SETQ |a| - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) - (|bfVar#1| (CDR |x|)) (|i| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| #0=(CONS (|bfGenSymbol|) NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #0#) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))) - (LIST 'DEFUN (CAR |x|) |a| - (LIST 'CONS (|quote| (CAR |x|)) (CONS 'LIST |a|)))))))) + (COND + ((AND (CONSP |x|) (NULL (CDR |x|))) (SETQ |f| (CAR |x|)) + (LIST 'DEFCONSTANT |f| (LIST 'LIST (|quote| |f|)))) + (T + (SETQ |a| + (LET ((|bfVar#2| NIL) + (|bfVar#3| NIL) + (|bfVar#1| (CDR |x|)) + (|i| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + ((NULL |bfVar#2|) + (SETQ |bfVar#2| #1=(CONS (|bfGenSymbol|) NIL)) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))) + (LIST 'DEFUN (CAR |x|) |a| + (LIST 'CONS (|quote| (CAR |x|)) (CONS 'LIST |a|)))))))) (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) |%Form|) |bfCaseItem|)) @@ -2264,245 +2220,216 @@ (DEFUN |bfCase| (|x| |y|) (PROG (|body| |g|) (RETURN - (PROGN - (SETQ |g| (COND ((NOT (CONSP |x|)) |x|) (T (|bfGenSymbol|)))) - (SETQ |body| - (CONS 'CASE - (CONS (LIST 'CAR |g|) (|bfCaseItems| |g| |y|)))) - (COND - ((EQ |g| |x|) |body|) - (T (LIST 'LET (LIST (LIST |g| |x|)) |body|))))))) + (PROGN + (SETQ |g| (COND ((NOT (CONSP |x|)) |x|) (T (|bfGenSymbol|)))) + (SETQ |body| (CONS 'CASE (CONS (LIST 'CAR |g|) (|bfCaseItems| |g| |y|)))) + (COND ((EQ |g| |x|) |body|) + (T (LIST 'LET (LIST (LIST |g| |x|)) |body|))))))) -(DECLAIM (FTYPE (FUNCTION (|%Thing| (|%List| |%Form|)) - (|%List| |%Form|)) - |bfCaseItems|)) +(DECLAIM + (FTYPE (FUNCTION (|%Thing| (|%List| |%Form|)) (|%List| |%Form|)) + |bfCaseItems|)) (DEFUN |bfCaseItems| (|g| |x|) (PROG (|j| |ISTMP#1| |i|) (RETURN - (LET ((|bfVar#3| NIL) (|bfVar#4| NIL) (|bfVar#2| |x|) - (|bfVar#1| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#2|)) - (PROGN (SETQ |bfVar#1| (CAR |bfVar#2|)) NIL)) - (RETURN |bfVar#3|)) - (T (AND (CONSP |bfVar#1|) - (PROGN - (SETQ |i| (CAR |bfVar#1|)) - (SETQ |ISTMP#1| (CDR |bfVar#1|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |j| (CAR |ISTMP#1|)) T))) - (COND - ((NULL |bfVar#3|) - (SETQ |bfVar#3| - #0=(CONS (|bfCI| |g| |i| |j|) NIL)) - (SETQ |bfVar#4| |bfVar#3|)) - (T (RPLACD |bfVar#4| #0#) - (SETQ |bfVar#4| (CDR |bfVar#4|))))))) - (SETQ |bfVar#2| (CDR |bfVar#2|))))))) + (LET ((|bfVar#3| NIL) (|bfVar#4| NIL) (|bfVar#2| |x|) (|bfVar#1| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#2|)) + (PROGN (SETQ |bfVar#1| (CAR |bfVar#2|)) NIL)) + (RETURN |bfVar#3|)) + (T + (AND (CONSP |bfVar#1|) + (PROGN + (SETQ |i| (CAR |bfVar#1|)) + (SETQ |ISTMP#1| (CDR |bfVar#1|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |j| (CAR |ISTMP#1|)) T))) + (COND + ((NULL |bfVar#3|) + (SETQ |bfVar#3| #1=(CONS (|bfCI| |g| |i| |j|) NIL)) + (SETQ |bfVar#4| |bfVar#3|)) + (T (RPLACD |bfVar#4| #1#) (SETQ |bfVar#4| (CDR |bfVar#4|))))))) + (SETQ |bfVar#2| (CDR |bfVar#2|))))))) (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Form|) |bfCI|)) (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#2| NIL) (|bfVar#3| NIL) - (|bfVar#1| |a|) (|i| NIL) (|j| 1)) - (LOOP - (COND + (PROGN + (SETQ |a| (CDR |x|)) + (COND ((NULL |a|) (LIST (CAR |x|) |y|)) + (T + (SETQ |b| + (LET ((|bfVar#2| NIL) + (|bfVar#3| NIL) + (|bfVar#1| |a|) + (|i| NIL) + (|j| 1)) + (LOOP + (COND ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) (RETURN |bfVar#2|)) - (T (AND (NOT (EQ |i| 'DOT)) - (COND - ((NULL |bfVar#2|) - (SETQ |bfVar#2| - #0=(CONS - (LIST |i| - (|bfCARCDR| |j| |g|)) - NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #0#) - (SETQ |bfVar#3| (CDR |bfVar#3|))))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)) - (SETQ |j| (+ |j| 1))))) - (COND - ((NULL |b|) (LIST (CAR |x|) |y|)) - (T (LIST (CAR |x|) (LIST 'LET |b| |y|)))))))))) + (T + (AND (NOT (EQ |i| 'DOT)) + (COND + ((NULL |bfVar#2|) + (SETQ |bfVar#2| + #1=(CONS + (LIST |i| (|bfCARCDR| |j| |g|)) + NIL)) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #1#) + (SETQ |bfVar#3| (CDR |bfVar#3|))))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)) + (SETQ |j| (+ |j| 1))))) + (COND ((NULL |b|) (LIST (CAR |x|) |y|)) + (T (LIST (CAR |x|) (LIST 'LET |b| |y|)))))))))) (DECLAIM (FTYPE (FUNCTION (|%Short| |%Thing|) |%Form|) |bfCARCDR|)) -(DEFUN |bfCARCDR| (|n| |g|) - (LIST (INTERN (CONCAT "CA" (|bfDs| |n|) "R")) |g|)) +(DEFUN |bfCARCDR| (|n| |g|) (LIST (INTERN (CONCAT "CA" (|bfDs| |n|) "R")) |g|)) (DECLAIM (FTYPE (FUNCTION (|%Short|) |%String|) |bfDs|)) -(DEFUN |bfDs| (|n|) - (COND ((EQL |n| 0) "") (T (CONCAT "D" (|bfDs| (- |n| 1)))))) +(DEFUN |bfDs| (|n|) (COND ((EQL |n| 0) "") (T (CONCAT "D" (|bfDs| (- |n| 1)))))) -(DEFUN |bfHandlers| (|n| |e| |hs|) - (|bfHandlers,main| |n| |e| |hs| NIL)) +(DEFUN |bfHandlers| (|n| |e| |hs|) (|bfHandlers,main| |n| |e| |hs| NIL)) (DEFUN |bfHandlers,main| (|n| |e| |hs| |xs|) - (PROG (|hs'| |s| |ISTMP#6| |t| |ISTMP#5| |v| |ISTMP#4| |ISTMP#3| - |ISTMP#2| |ISTMP#1|) + (PROG (|hs'| |s| |ISTMP#6| |t| |ISTMP#5| |v| |ISTMP#4| |ISTMP#3| |ISTMP#2| + |ISTMP#1|) (RETURN - (COND - ((NULL |hs|) - (CONS 'COND - (|reverse!| (CONS (LIST T - (LIST 'THROW - :OPEN-AXIOM-CATCH-POINT |n|)) - |xs|)))) - ((AND (CONSP |hs|) - (PROGN - (SETQ |ISTMP#1| (CAR |hs|)) - (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) '|%Catch|) - (PROGN - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |ISTMP#3| (CAR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CAR |ISTMP#3|) '|%Signature|) - (PROGN - (SETQ |ISTMP#4| (CDR |ISTMP#3|)) - (AND (CONSP |ISTMP#4|) - (PROGN - (SETQ |v| (CAR |ISTMP#4|)) - (SETQ |ISTMP#5| - (CDR |ISTMP#4|)) - (AND (CONSP |ISTMP#5|) - (NULL (CDR |ISTMP#5|)) - (PROGN + (COND + ((NULL |hs|) + (CONS 'COND + (|reverse!| + (CONS (LIST T (LIST 'THROW :OPEN-AXIOM-CATCH-POINT |n|)) |xs|)))) + ((AND (CONSP |hs|) + (PROGN + (SETQ |ISTMP#1| (CAR |hs|)) + (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) '|%Catch|) + (PROGN + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |ISTMP#3| (CAR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CAR |ISTMP#3|) '|%Signature|) + (PROGN + (SETQ |ISTMP#4| (CDR |ISTMP#3|)) + (AND (CONSP |ISTMP#4|) + (PROGN + (SETQ |v| (CAR |ISTMP#4|)) + (SETQ |ISTMP#5| (CDR |ISTMP#4|)) + (AND (CONSP |ISTMP#5|) + (NULL (CDR |ISTMP#5|)) + (PROGN (SETQ |t| (CAR |ISTMP#5|)) T))))))) - (PROGN - (SETQ |ISTMP#6| (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#6|) - (NULL (CDR |ISTMP#6|)) - (PROGN - (SETQ |s| (CAR |ISTMP#6|)) - T)))))))) - (SETQ |hs'| (CDR |hs|)) - (SETQ |t| - (COND - ((SYMBOLP |t|) (|quote| (LIST |t|))) - (T (|quote| |t|)))) - (|bfHandlers,main| |n| |e| |hs'| - (CONS (LIST (|bfQ| (LIST 'CAR |e|) |t|) - (LIST 'LET (LIST (LIST |v| (LIST 'CDR |e|))) - |s|)) - |xs|))) - (T (|bpTrap|)))))) + (PROGN + (SETQ |ISTMP#6| (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#6|) (NULL (CDR |ISTMP#6|)) + (PROGN (SETQ |s| (CAR |ISTMP#6|)) T)))))))) + (SETQ |hs'| (CDR |hs|)) + (SETQ |t| (COND ((SYMBOLP |t|) (|quote| (LIST |t|))) (T (|quote| |t|)))) + (|bfHandlers,main| |n| |e| |hs'| + (CONS + (LIST (|bfQ| (LIST 'CAR |e|) |t|) + (LIST 'LET (LIST (LIST |v| (LIST 'CDR |e|))) + |s|)) + |xs|))) + (T (|bpTrap|)))))) (DEFUN |codeForCatchHandlers| (|g| |e| |cs|) (PROG (|ehTest|) (RETURN - (PROGN - (SETQ |ehTest| + (PROGN + (SETQ |ehTest| (LIST 'AND (LIST 'CONSP |g|) (|bfQ| (LIST 'CAR |g|) :OPEN-AXIOM-CATCH-POINT))) - (LIST 'LET - (LIST (LIST |g| - (LIST 'CATCH :OPEN-AXIOM-CATCH-POINT |e|))) - (LIST 'COND - (LIST |ehTest| - (|bfHandlers| |g| (LIST 'CDR |g|) |cs|)) - (LIST T |g|))))))) + (LIST 'LET (LIST (LIST |g| (LIST 'CATCH :OPEN-AXIOM-CATCH-POINT |e|))) + (LIST 'COND (LIST |ehTest| (|bfHandlers| |g| (LIST 'CDR |g|) |cs|)) + (LIST T |g|))))))) -(DECLAIM (FTYPE (FUNCTION (|%Thing| (|%List| |%Form|)) |%Thing|) - |bfTry|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing| (|%List| |%Form|)) |%Thing|) |bfTry|)) (DEFUN |bfTry| (|e| |cs|) (PROG (|s| |cs'| |f| |ISTMP#1| |g|) (RETURN - (PROGN - (SETQ |g| (GENSYM)) - (COND - ((AND (CONSP |cs|) - (PROGN (SETQ |ISTMP#1| (|reverse| |cs|)) T) - (CONSP |ISTMP#1|) - (PROGN - (SETQ |f| (CAR |ISTMP#1|)) - (SETQ |cs'| (CDR |ISTMP#1|)) - T) - (PROGN (SETQ |cs'| (|reverse!| |cs'|)) T) (CONSP |f|) - (EQ (CAR |f|) '|%Finally|) - (PROGN - (SETQ |ISTMP#1| (CDR |f|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |s| (CAR |ISTMP#1|)) T)))) - (COND - ((NULL |cs'|) (LIST 'UNWIND-PROTECT |e| |s|)) - (T (LIST 'UNWIND-PROTECT - (|codeForCatchHandlers| |g| |e| |cs'|) |s|)))) - (T (|codeForCatchHandlers| |g| |e| |cs|))))))) + (PROGN + (SETQ |g| (GENSYM)) + (COND + ((AND (CONSP |cs|) (PROGN (SETQ |ISTMP#1| (|reverse| |cs|)) T) + (CONSP |ISTMP#1|) + (PROGN (SETQ |f| (CAR |ISTMP#1|)) (SETQ |cs'| (CDR |ISTMP#1|)) T) + (PROGN (SETQ |cs'| (|reverse!| |cs'|)) T) (CONSP |f|) + (EQ (CAR |f|) '|%Finally|) + (PROGN + (SETQ |ISTMP#1| (CDR |f|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |s| (CAR |ISTMP#1|)) T)))) + (COND ((NULL |cs'|) (LIST 'UNWIND-PROTECT |e| |s|)) + (T + (LIST 'UNWIND-PROTECT (|codeForCatchHandlers| |g| |e| |cs'|) + |s|)))) + (T (|codeForCatchHandlers| |g| |e| |cs|))))))) (DEFUN |bfThrow| (|e|) (PROG (|x| |t|) (RETURN - (PROGN - (SETQ |t| NIL) - (SETQ |x| NIL) - (COND - ((AND (CONSP |e|) (EQ (CAR |e|) '|%Pretend|)) - (SETQ |t| (CADDR |e|)) (SETQ |x| (CADR |e|))) - (T (SETQ |t| '|SystemException|) (SETQ |x| |e|))) - (SETQ |t| - (COND - ((SYMBOLP |t|) (|quote| (LIST |t|))) - (T (|quote| |t|)))) - (LIST 'THROW :OPEN-AXIOM-CATCH-POINT - (LIST 'CONS :OPEN-AXIOM-CATCH-POINT (LIST 'CONS |t| |x|))))))) + (PROGN + (SETQ |t| NIL) + (SETQ |x| NIL) + (COND + ((AND (CONSP |e|) (EQ (CAR |e|) '|%Pretend|)) (SETQ |t| (CADDR |e|)) + (SETQ |x| (CADR |e|))) + (T (SETQ |t| '|SystemException|) (SETQ |x| |e|))) + (SETQ |t| (COND ((SYMBOLP |t|) (|quote| (LIST |t|))) (T (|quote| |t|)))) + (LIST 'THROW :OPEN-AXIOM-CATCH-POINT + (LIST 'CONS :OPEN-AXIOM-CATCH-POINT (LIST 'CONS |t| |x|))))))) -(DECLAIM (FTYPE (FUNCTION (|%Form| (|%List| |%Symbol|)) |%Form|) - |backquote|)) +(DECLAIM (FTYPE (FUNCTION (|%Form| (|%List| |%Symbol|)) |%Form|) |backquote|)) (DEFUN |backquote| (|form| |params|) - (COND - ((NULL |params|) (|quote| |form|)) - ((NOT (CONSP |form|)) - (COND - ((|symbolMember?| |form| |params|) |form|) - (T (|quote| |form|)))) - (T (CONS 'LIST - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |form|) - (|t| NIL)) - (LOOP - (COND + (COND ((NULL |params|) (|quote| |form|)) + ((NOT (CONSP |form|)) + (COND ((|symbolMember?| |form| |params|) |form|) + (T (|quote| |form|)))) + (T + (CONS 'LIST + (LET ((|bfVar#2| NIL) + (|bfVar#3| NIL) + (|bfVar#1| |form|) + (|t| NIL)) + (LOOP + (COND ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |t| (CAR |bfVar#1|)) NIL)) (RETURN |bfVar#2|)) ((NULL |bfVar#2|) - (SETQ |bfVar#2| - #0=(CONS (|backquote| |t| |params|) NIL)) + (SETQ |bfVar#2| #1=(CONS (|backquote| |t| |params|) NIL)) (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #0#) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) + (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) (DEFUN |genTypeAlias| (|head| |body|) (PROG (|args| |op|) (RETURN - (PROGN - (SETQ |op| (CAR |head|)) - (SETQ |args| (CDR |head|)) - (LIST 'DEFTYPE |op| |args| (|backquote| |body| |args|)))))) + (PROGN + (SETQ |op| (CAR |head|)) + (SETQ |args| (CDR |head|)) + (LIST 'DEFTYPE |op| |args| (|backquote| |body| |args|)))))) (DEFCONSTANT |$NativeSimpleDataTypes| - '(|char| |byte| |int| |pointer| |int8| |uint8| |int16| |uint16| - |int32| |uint32| |int64| |uint64| |float| |float32| - |double| |float64|)) + '(|char| |byte| |int| |pointer| |int8| |uint8| |int16| |uint16| |int32| + |uint32| |int64| |uint64| |float| |float32| |double| |float64|)) (DEFCONSTANT |$NativeSimpleReturnTypes| - (|append| |$NativeSimpleDataTypes| '(|void| |string|))) + (|append| |$NativeSimpleDataTypes| '(|void| |string|))) (DEFUN |isSimpleNativeType| (|t|) (|objectMember?| |t| |$NativeSimpleReturnTypes|)) @@ -2521,136 +2448,117 @@ (DEFUN |nativeType| (|t|) (PROG (|t'|) (RETURN - (COND - ((NULL |t|) |t|) - ((NOT (CONSP |t|)) - (COND - ((SETQ |t'| - (CDR (ASSOC (|coreSymbol| |t|) |$NativeTypeTable|))) - (SETQ |t'| - (COND - ((|%hasFeature| :SBCL) - (|bfColonColon| 'SB-ALIEN |t'|)) - ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI |t'|)) - (T |t'|))) - (COND - ((AND (EQ |t| '|string|) (|%hasFeature| :SBCL)) - (LIST |t'| :EXTERNAL-FORMAT :ASCII :ELEMENT-TYPE - 'BASE-CHAR)) - (T |t'|))) - ((|symbolMember?| |t| '(|byte| |uint8|)) - (COND - ((|%hasFeature| :SBCL) - (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 8)) - ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT8)) - ((OR (|%hasFeature| :ECL) (|%hasFeature| :CLOZURE)) - :UNSIGNED-BYTE) - (T (|nativeType| '|char|)))) - ((EQ |t| '|int16|) + (COND ((NULL |t|) |t|) + ((NOT (CONSP |t|)) (COND - ((|%hasFeature| :SBCL) - (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 16)) - ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT16)) - ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT16-T)) - :INT16-T) - ((|%hasFeature| :CLOZURE) :SIGNED-HALFWORD) - (T (|unknownNativeTypeError| |t|)))) - ((EQ |t| '|uint16|) - (COND - ((|%hasFeature| :SBCL) - (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 16)) - ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT16)) - ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT16-T)) - :UINT16-T) - ((|%hasFeature| :CLOZURE) :UNSIGNED-HALFWORD) - (T (|unknownNativeTypeError| |t|)))) - ((EQ |t| '|int32|) - (COND - ((|%hasFeature| :SBCL) - (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 32)) - ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT32)) - ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT32-T)) - :INT32-T) - ((|%hasFeature| :CLOZURE) :SIGNED-FULLWORD) - (T (|unknownNativeTypeError| |t|)))) - ((EQ |t| '|uint32|) - (COND - ((|%hasFeature| :SBCL) - (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 32)) - ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT32)) - ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT32-T)) - :UINT32-T) - ((|%hasFeature| :CLOZURE) :UNSIGNED-FULLWORD) - (T (|unknownNativeTypeError| |t|)))) - ((EQ |t| '|int64|) - (COND - ((|%hasFeature| :SBCL) - (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 64)) - ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT64)) - ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT64-T)) - :INT64-T) - ((|%hasFeature| :CLOZURE) :SIGNED-DOUBLEWORD) - (T (|unknownNativeTypeError| |t|)))) - ((EQ |t| '|uint64|) - (COND - ((|%hasFeature| :SBCL) - (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 64)) - ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT64)) - ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT64-T)) - :UINT64-T) - ((|%hasFeature| :CLOZURE) :UNSIGNED-DOUBLEWORD) - (T (|unknownNativeTypeError| |t|)))) - ((EQ |t| '|float32|) (|nativeType| '|float|)) - ((EQ |t| '|float64|) (|nativeType| '|double|)) - ((EQ |t| '|pointer|) - (COND - ((|%hasFeature| :GCL) '|fixnum|) - ((|%hasFeature| :ECL) :POINTER-VOID) - ((|%hasFeature| :SBCL) - (LIST '* (|bfColonColon| 'SB-ALIEN 'VOID))) - ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'C-POINTER)) - ((|%hasFeature| :CLOZURE) :ADDRESS) - (T (|unknownNativeTypeError| |t|)))) - (T (|unknownNativeTypeError| |t|)))) - ((EQ (CAR |t|) '|buffer|) - (COND - ((|%hasFeature| :GCL) 'OBJECT) - ((|%hasFeature| :ECL) :OBJECT) - ((|%hasFeature| :SBCL) (LIST '* (|nativeType| (CADR |t|)))) - ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'C-POINTER)) - ((|%hasFeature| :CLOZURE) - (LIST :* (|nativeType| (CADR |t|)))) - (T (|unknownNativeTypeError| |t|)))) - ((EQ (CAR |t|) '|pointer|) (|nativeType| '|pointer|)) - (T (|unknownNativeTypeError| |t|)))))) + ((SETQ |t'| (CDR (ASSOC (|coreSymbol| |t|) |$NativeTypeTable|))) + (SETQ |t'| + (COND + ((|%hasFeature| :SBCL) (|bfColonColon| 'SB-ALIEN |t'|)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI |t'|)) + (T |t'|))) + (COND + ((AND (EQ |t| '|string|) (|%hasFeature| :SBCL)) + (LIST |t'| :EXTERNAL-FORMAT :ASCII :ELEMENT-TYPE 'BASE-CHAR)) + (T |t'|))) + ((|symbolMember?| |t| '(|byte| |uint8|)) + (COND + ((|%hasFeature| :SBCL) + (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 8)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT8)) + ((OR (|%hasFeature| :ECL) (|%hasFeature| :CLOZURE)) + :UNSIGNED-BYTE) + (T (|nativeType| '|char|)))) + ((EQ |t| '|int16|) + (COND + ((|%hasFeature| :SBCL) + (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 16)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT16)) + ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT16-T)) :INT16-T) + ((|%hasFeature| :CLOZURE) :SIGNED-HALFWORD) + (T (|unknownNativeTypeError| |t|)))) + ((EQ |t| '|uint16|) + (COND + ((|%hasFeature| :SBCL) + (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 16)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT16)) + ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT16-T)) :UINT16-T) + ((|%hasFeature| :CLOZURE) :UNSIGNED-HALFWORD) + (T (|unknownNativeTypeError| |t|)))) + ((EQ |t| '|int32|) + (COND + ((|%hasFeature| :SBCL) + (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 32)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT32)) + ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT32-T)) :INT32-T) + ((|%hasFeature| :CLOZURE) :SIGNED-FULLWORD) + (T (|unknownNativeTypeError| |t|)))) + ((EQ |t| '|uint32|) + (COND + ((|%hasFeature| :SBCL) + (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 32)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT32)) + ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT32-T)) :UINT32-T) + ((|%hasFeature| :CLOZURE) :UNSIGNED-FULLWORD) + (T (|unknownNativeTypeError| |t|)))) + ((EQ |t| '|int64|) + (COND + ((|%hasFeature| :SBCL) + (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 64)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT64)) + ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT64-T)) :INT64-T) + ((|%hasFeature| :CLOZURE) :SIGNED-DOUBLEWORD) + (T (|unknownNativeTypeError| |t|)))) + ((EQ |t| '|uint64|) + (COND + ((|%hasFeature| :SBCL) + (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 64)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT64)) + ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT64-T)) :UINT64-T) + ((|%hasFeature| :CLOZURE) :UNSIGNED-DOUBLEWORD) + (T (|unknownNativeTypeError| |t|)))) + ((EQ |t| '|float32|) (|nativeType| '|float|)) + ((EQ |t| '|float64|) (|nativeType| '|double|)) + ((EQ |t| '|pointer|) + (COND ((|%hasFeature| :GCL) '|fixnum|) + ((|%hasFeature| :ECL) :POINTER-VOID) + ((|%hasFeature| :SBCL) + (LIST '* (|bfColonColon| 'SB-ALIEN 'VOID))) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'C-POINTER)) + ((|%hasFeature| :CLOZURE) :ADDRESS) + (T (|unknownNativeTypeError| |t|)))) + (T (|unknownNativeTypeError| |t|)))) + ((EQ (CAR |t|) '|buffer|) + (COND ((|%hasFeature| :GCL) 'OBJECT) ((|%hasFeature| :ECL) :OBJECT) + ((|%hasFeature| :SBCL) (LIST '* (|nativeType| (CADR |t|)))) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'C-POINTER)) + ((|%hasFeature| :CLOZURE) + (LIST :* (|nativeType| (CADR |t|)))) + (T (|unknownNativeTypeError| |t|)))) + ((EQ (CAR |t|) '|pointer|) (|nativeType| '|pointer|)) + (T (|unknownNativeTypeError| |t|)))))) (DEFUN |nativeReturnType| (|t|) - (COND - ((|objectMember?| |t| |$NativeSimpleReturnTypes|) - (|nativeType| |t|)) - (T (|coreError| - (CONCAT "invalid return type for native function: " - (PNAME |t|)))))) + (COND ((|objectMember?| |t| |$NativeSimpleReturnTypes|) (|nativeType| |t|)) + (T + (|coreError| + (CONCAT "invalid return type for native function: " (PNAME |t|)))))) (DEFUN |nativeArgumentType| (|t|) (PROG (|t'| |c| |m|) (RETURN - (COND - ((|objectMember?| |t| |$NativeSimpleDataTypes|) - (|nativeType| |t|)) - ((EQ |t| '|string|) (|nativeType| |t|)) - ((OR (NOT (CONSP |t|)) (NOT (EQL (LENGTH |t|) 2))) - (|coreError| "invalid argument type for a native function")) - (T (SETQ |m| (CAR |t|)) (SETQ |c| (CAADR . #0=(|t|))) - (SETQ |t'| (CADADR . #0#)) - (COND - ((NOT (|symbolMember?| |m| - '(|readonly| |writeonly| |readwrite|))) + (COND ((|objectMember?| |t| |$NativeSimpleDataTypes|) (|nativeType| |t|)) + ((EQ |t| '|string|) (|nativeType| |t|)) + ((OR (NOT (CONSP |t|)) (NOT (EQL (LENGTH |t|) 2))) + (|coreError| "invalid argument type for a native function")) + (T (SETQ |m| (CAR |t|)) (SETQ |c| (CAADR . #1=(|t|))) + (SETQ |t'| (CADADR . #1#)) + (COND + ((NOT (|symbolMember?| |m| '(|readonly| |writeonly| |readwrite|))) (|coreError| - "missing modifier for argument type for a native function")) + "missing modifier for argument type for a native function")) ((NOT (|symbolMember?| |c| '(|buffer| |pointer|))) - (|coreError| - "expected 'buffer' or 'pointer' type instance")) + (|coreError| "expected 'buffer' or 'pointer' type instance")) ((NOT (|objectMember?| |t'| |$NativeSimpleDataTypes|)) (|coreError| "expected simple native data type")) (T (|nativeType| (CADR |t|))))))))) @@ -2658,218 +2566,222 @@ (DEFUN |needsStableReference?| (|t|) (PROG (|m|) (RETURN - (AND (CONSP |t|) (PROGN (SETQ |m| (CAR |t|)) T) - (|symbolMember?| |m| '(|readonly| |writeonly| |readwrite|)))))) + (AND (CONSP |t|) (PROGN (SETQ |m| (CAR |t|)) T) + (|symbolMember?| |m| '(|readonly| |writeonly| |readwrite|)))))) (DEFUN |coerceToNativeType| (|a| |t|) (PROG (|y| |c|) (RETURN - (COND - ((OR (|%hasFeature| :GCL) (|%hasFeature| :ECL) - (|%hasFeature| :CLISP) (|%hasFeature| :CLOZURE)) - |a|) - ((|%hasFeature| :SBCL) - (COND - ((NOT (|needsStableReference?| |t|)) |a|) - (T (SETQ |c| (CAADR . #0=(|t|))) (SETQ |y| (CADADR . #0#)) + (COND + ((OR (|%hasFeature| :GCL) (|%hasFeature| :ECL) (|%hasFeature| :CLISP) + (|%hasFeature| :CLOZURE)) + |a|) + ((|%hasFeature| :SBCL) + (COND ((NOT (|needsStableReference?| |t|)) |a|) + (T (SETQ |c| (CAADR . #1=(|t|))) (SETQ |y| (CADADR . #1#)) (COND - ((EQ |c| '|buffer|) - (LIST (|bfColonColon| 'SB-SYS 'VECTOR-SAP) |a|)) - ((EQ |c| '|pointer|) - (LIST (|bfColonColon| 'SB-SYS 'ALIEN-SAP) |a|)) - ((|needsStableReference?| |t|) - (|fatalError| - (CONCAT "don't know how to coerce argument for native type" - (PNAME |c|)))))))) - (T (|fatalError| - "don't know how to coerce argument for native type")))))) + ((EQ |c| '|buffer|) + (LIST (|bfColonColon| 'SB-SYS 'VECTOR-SAP) |a|)) + ((EQ |c| '|pointer|) + (LIST (|bfColonColon| 'SB-SYS 'ALIEN-SAP) |a|)) + ((|needsStableReference?| |t|) + (|fatalError| + (CONCAT "don't know how to coerce argument for native type" + (PNAME |c|)))))))) + (T (|fatalError| "don't know how to coerce argument for native type")))))) (DEFUN |genGCLnativeTranslation| (|op| |s| |t| |op'|) (PROG (|ccode| |cargs| |cop| |rettype| |argtypes|) (RETURN - (PROGN - (SETQ |argtypes| - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) - (|x| NIL)) + (PROGN + (SETQ |argtypes| + (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) (|x| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| - #0=(CONS (|nativeArgumentType| |x|) NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #0#) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))) - (SETQ |rettype| (|nativeReturnType| |t|)) - (COND - ((LET ((|bfVar#5| T) (|bfVar#4| (CONS |t| |s|)) (|x| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#4|)) - (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL)) - (RETURN |bfVar#5|)) - (T (SETQ |bfVar#5| (|isSimpleNativeType| |x|)) - (COND ((NOT |bfVar#5|) (RETURN NIL))))) - (SETQ |bfVar#4| (CDR |bfVar#4|)))) - (LIST (LIST 'DEFENTRY |op| |argtypes| - (LIST |rettype| (SYMBOL-NAME |op'|))))) - (T (SETQ |cop| (CONCAT (SYMBOL-NAME |op'|) "_stub")) - (SETQ |cargs| - (LET ((|bfVar#14| NIL) (|bfVar#15| NIL) - (|bfVar#13| (- (LENGTH |s|) 1)) (|i| 0)) - (LOOP - (COND - ((> |i| |bfVar#13|) (RETURN |bfVar#14|)) + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + ((NULL |bfVar#2|) + (SETQ |bfVar#2| #1=(CONS (|nativeArgumentType| |x|) NIL)) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))) + (SETQ |rettype| (|nativeReturnType| |t|)) + (COND + ((LET ((|bfVar#5| T) (|bfVar#4| (CONS |t| |s|)) (|x| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#4|)) + (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL)) + (RETURN |bfVar#5|)) + (T (SETQ |bfVar#5| (|isSimpleNativeType| |x|)) + (COND ((NOT |bfVar#5|) (RETURN NIL))))) + (SETQ |bfVar#4| (CDR |bfVar#4|)))) + (LIST + (LIST 'DEFENTRY |op| |argtypes| + (LIST |rettype| (SYMBOL-NAME |op'|))))) + (T (SETQ |cop| (CONCAT (SYMBOL-NAME |op'|) "_stub")) + (SETQ |cargs| + (LET ((|bfVar#14| NIL) + (|bfVar#15| NIL) + (|bfVar#13| (- (LENGTH |s|) 1)) + (|i| 0)) + (LOOP + (COND ((> |i| |bfVar#13|) (RETURN |bfVar#14|)) ((NULL |bfVar#14|) (SETQ |bfVar#14| - (CONS (|genGCLnativeTranslation,mkCArgName| - |i|) - NIL)) + (CONS + (|genGCLnativeTranslation,mkCArgName| |i|) + NIL)) (SETQ |bfVar#15| |bfVar#14|)) - (T (RPLACD |bfVar#15| - (CONS - (|genGCLnativeTranslation,mkCArgName| - |i|) - NIL)) - (SETQ |bfVar#15| (CDR |bfVar#15|)))) - (SETQ |i| (+ |i| 1))))) - (SETQ |ccode| - (LET ((|bfVar#10| "") - (|bfVar#12| - (CONS (|genGCLnativeTranslation,gclTypeInC| - |t|) - (CONS " " - (CONS |cop| - (CONS "(" - (|append| - (LET - ((|bfVar#6| NIL) - (|bfVar#7| NIL) (|x| |s|) - (|a| |cargs|)) - (LOOP - (COND - ((OR (NOT (CONSP |x|)) - (NOT (CONSP |a|))) - (RETURN |bfVar#6|)) - ((NULL |bfVar#6|) - (SETQ |bfVar#6| - (CONS - (|genGCLnativeTranslation,cparm| - |x| |a|) - NIL)) - (SETQ |bfVar#7| - |bfVar#6|)) - (T - (RPLACD |bfVar#7| - (CONS - (|genGCLnativeTranslation,cparm| - |x| |a|) - NIL)) - (SETQ |bfVar#7| - (CDR |bfVar#7|)))) - (SETQ |x| (CDR |x|)) - (SETQ |a| (CDR |a|)))) - (CONS ") { " - (CONS - (COND - ((NOT (EQ |t| '|void|)) - "return ") - (T '||)) - (CONS (SYMBOL-NAME |op'|) - (CONS "(" - (|append| - (LET - ((|bfVar#8| NIL) - (|bfVar#9| NIL) (|x| |s|) - (|a| |cargs|)) - (LOOP - (COND - ((OR - (NOT (CONSP |x|)) - (NOT (CONSP |a|))) - (RETURN |bfVar#8|)) - ((NULL |bfVar#8|) - (SETQ |bfVar#8| - (CONS - (|genGCLnativeTranslation,gclArgsInC| - |x| |a|) - NIL)) - (SETQ |bfVar#9| - |bfVar#8|)) - (T - (RPLACD |bfVar#9| - (CONS - (|genGCLnativeTranslation,gclArgsInC| - |x| |a|) - NIL)) - (SETQ |bfVar#9| - (CDR |bfVar#9|)))) - (SETQ |x| (CDR |x|)) - (SETQ |a| (CDR |a|)))) - (CONS "); }" NIL)))))))))))) - (|bfVar#11| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#12|)) - (PROGN - (SETQ |bfVar#11| (CAR |bfVar#12|)) - NIL)) - (RETURN |bfVar#10|)) - (T (SETQ |bfVar#10| - (CONCAT |bfVar#10| |bfVar#11|)))) - (SETQ |bfVar#12| (CDR |bfVar#12|))))) - (LIST (LIST 'CLINES |ccode|) - (LIST 'DEFENTRY |op| |argtypes| - (LIST |rettype| |cop|))))))))) + (T + (RPLACD |bfVar#15| + (CONS + (|genGCLnativeTranslation,mkCArgName| |i|) + NIL)) + (SETQ |bfVar#15| (CDR |bfVar#15|)))) + (SETQ |i| (+ |i| 1))))) + (SETQ |ccode| + (LET ((|bfVar#10| "") + (|bfVar#12| + (CONS (|genGCLnativeTranslation,gclTypeInC| |t|) + (CONS " " + (CONS |cop| + (CONS "(" + (|append| + (LET ((|bfVar#6| NIL) + (|bfVar#7| NIL) + (|x| |s|) + (|a| |cargs|)) + (LOOP + (COND + ((OR (NOT (CONSP |x|)) + (NOT (CONSP |a|))) + (RETURN |bfVar#6|)) + ((NULL |bfVar#6|) + (SETQ |bfVar#6| + (CONS + (|genGCLnativeTranslation,cparm| + |x| |a|) + NIL)) + (SETQ |bfVar#7| + |bfVar#6|)) + (T + (RPLACD |bfVar#7| + (CONS + (|genGCLnativeTranslation,cparm| + |x| |a|) + NIL)) + (SETQ |bfVar#7| + (CDR |bfVar#7|)))) + (SETQ |x| (CDR |x|)) + (SETQ |a| (CDR |a|)))) + (CONS ") { " + (CONS + (COND + ((NOT (EQ |t| '|void|)) + "return ") + (T '||)) + (CONS + (SYMBOL-NAME |op'|) + (CONS "(" + (|append| + (LET ((|bfVar#8| + NIL) + (|bfVar#9| + NIL) + (|x| |s|) + (|a| + |cargs|)) + (LOOP + (COND + ((OR + (NOT + (CONSP + |x|)) + (NOT + (CONSP + |a|))) + (RETURN + |bfVar#8|)) + ((NULL + |bfVar#8|) + (SETQ |bfVar#8| + (CONS + (|genGCLnativeTranslation,gclArgsInC| + |x| + |a|) + NIL)) + (SETQ |bfVar#9| + |bfVar#8|)) + (T + (RPLACD + |bfVar#9| + (CONS + (|genGCLnativeTranslation,gclArgsInC| + |x| |a|) + NIL)) + (SETQ |bfVar#9| + (CDR + |bfVar#9|)))) + (SETQ |x| + (CDR + |x|)) + (SETQ |a| + (CDR + |a|)))) + (CONS "); }" + NIL)))))))))))) + (|bfVar#11| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#12|)) + (PROGN (SETQ |bfVar#11| (CAR |bfVar#12|)) NIL)) + (RETURN |bfVar#10|)) + (T (SETQ |bfVar#10| (CONCAT |bfVar#10| |bfVar#11|)))) + (SETQ |bfVar#12| (CDR |bfVar#12|))))) + (LIST (LIST 'CLINES |ccode|) + (LIST 'DEFENTRY |op| |argtypes| (LIST |rettype| |cop|))))))))) (DEFUN |genGCLnativeTranslation,mkCArgName| (|i|) (CONCAT "x" (WRITE-TO-STRING |i|))) (DEFUN |genGCLnativeTranslation,cparm| (|x| |a|) - (CONCAT (|genGCLnativeTranslation,gclTypeInC| (CAR |x|)) " " - (CAR |a|) (COND ((CDR |x|) ", ") (T "")))) + (CONCAT (|genGCLnativeTranslation,gclTypeInC| (CAR |x|)) " " (CAR |a|) + (COND ((CDR |x|) ", ") (T "")))) (DEFUN |genGCLnativeTranslation,gclTypeInC| (|x|) (PROG (|ISTMP#3| |ISTMP#2| |ISTMP#1|) (RETURN - (COND - ((|objectMember?| |x| |$NativeSimpleDataTypes|) - (SYMBOL-NAME |x|)) - ((EQ |x| '|void|) "void") - ((EQ |x| '|string|) "char*") - ((AND (CONSP |x|) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN - (SETQ |ISTMP#2| (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CAR |ISTMP#2|) '|pointer|) - (PROGN + (COND ((|objectMember?| |x| |$NativeSimpleDataTypes|) (SYMBOL-NAME |x|)) + ((EQ |x| '|void|) "void") ((EQ |x| '|string|) "char*") + ((AND (CONSP |x|) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN + (SETQ |ISTMP#2| (CAR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CAR |ISTMP#2|) '|pointer|) + (PROGN (SETQ |ISTMP#3| (CDR |ISTMP#2|)) (AND (CONSP |ISTMP#3|) (NULL (CDR |ISTMP#3|))))))))) - '|fixnum|) - (T "object"))))) + '|fixnum|) + (T "object"))))) (DEFUN |genGCLnativeTranslation,gclArgInC| (|x| |a|) (PROG (|y| |c|) (RETURN - (COND - ((|objectMember?| |x| |$NativeSimpleDataTypes|) |a|) - ((EQ |x| '|string|) |a|) - (T (SETQ |c| (CAADR |x|)) (SETQ |y| (CADADR |x|)) - (COND - ((EQ |c| '|pointer|) |a|) - ((EQ |y| '|char|) (CONCAT |a| "->st.st_self")) - ((EQ |y| '|byte|) (CONCAT |a| "->ust.ust_self")) - ((EQ |y| '|int|) (CONCAT |a| "->fixa.fixa_self")) - ((EQ |y| '|float|) (CONCAT |a| "->sfa.sfa_self")) - ((EQ |y| '|double|) (CONCAT |a| "->lfa.lfa_self")) - (T (|coreError| "unknown argument type")))))))) + (COND ((|objectMember?| |x| |$NativeSimpleDataTypes|) |a|) + ((EQ |x| '|string|) |a|) + (T (SETQ |c| (CAADR |x|)) (SETQ |y| (CADADR |x|)) + (COND ((EQ |c| '|pointer|) |a|) + ((EQ |y| '|char|) (CONCAT |a| "->st.st_self")) + ((EQ |y| '|byte|) (CONCAT |a| "->ust.ust_self")) + ((EQ |y| '|int|) (CONCAT |a| "->fixa.fixa_self")) + ((EQ |y| '|float|) (CONCAT |a| "->sfa.sfa_self")) + ((EQ |y| '|double|) (CONCAT |a| "->lfa.lfa_self")) + (T (|coreError| "unknown argument type")))))))) (DEFUN |genGCLnativeTranslation,gclArgsInC| (|x| |a|) (CONCAT (|genGCLnativeTranslation,gclArgInC| (CAR |x|) (CAR |a|)) @@ -2878,626 +2790,565 @@ (DEFUN |genECLnativeTranslation| (|op| |s| |t| |op'|) (PROG (|rettype| |argtypes| |args|) (RETURN - (PROGN - (SETQ |args| NIL) - (SETQ |argtypes| NIL) - (LET ((|bfVar#1| |s|) (|x| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (SETQ |argtypes| - (CONS (|nativeArgumentType| |x|) |argtypes|)) - (SETQ |args| (CONS (GENSYM) |args|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - (SETQ |args| (|reverse| |args|)) - (SETQ |rettype| (|nativeReturnType| |t|)) - (LIST (LIST 'DEFUN |op| |args| - (LIST (|bfColonColon| 'FFI 'C-INLINE) |args| - (|reverse!| |argtypes|) |rettype| - (|genECLnativeTranslation,callTemplate| |op'| - (LENGTH |args|) |s|) - :ONE-LINER T))))))) + (PROGN + (SETQ |args| NIL) + (SETQ |argtypes| NIL) + (LET ((|bfVar#1| |s|) (|x| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (SETQ |argtypes| (CONS (|nativeArgumentType| |x|) |argtypes|)) + (SETQ |args| (CONS (GENSYM) |args|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (SETQ |args| (|reverse| |args|)) + (SETQ |rettype| (|nativeReturnType| |t|)) + (LIST + (LIST 'DEFUN |op| |args| + (LIST (|bfColonColon| 'FFI 'C-INLINE) |args| + (|reverse!| |argtypes|) |rettype| + (|genECLnativeTranslation,callTemplate| |op'| + (LENGTH |args|) |s|) + :ONE-LINER T))))))) (DEFUN |genECLnativeTranslation,callTemplate| (|op| |n| |s|) (LET ((|bfVar#6| "") (|bfVar#8| - (CONS (SYMBOL-NAME |op|) - (CONS "(" - (|append| - (LET ((|bfVar#4| NIL) (|bfVar#5| NIL) - (|bfVar#2| (- |n| 1)) (|i| 0) - (|bfVar#3| |s|) (|x| NIL)) - (LOOP - (COND - ((OR (> |i| |bfVar#2|) - (NOT (CONSP |bfVar#3|)) - (PROGN - (SETQ |x| (CAR |bfVar#3|)) - NIL)) - (RETURN |bfVar#4|)) - ((NULL |bfVar#4|) - (SETQ |bfVar#4| - (CONS - (|genECLnativeTranslation,sharpArg| - |i| |x|) - NIL)) - (SETQ |bfVar#5| |bfVar#4|)) - (T (RPLACD |bfVar#5| - (CONS - (|genECLnativeTranslation,sharpArg| - |i| |x|) - NIL)) - (SETQ |bfVar#5| (CDR |bfVar#5|)))) - (SETQ |i| (+ |i| 1)) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (CONS ")" NIL))))) + (CONS (SYMBOL-NAME |op|) + (CONS "(" + (|append| + (LET ((|bfVar#4| NIL) + (|bfVar#5| NIL) + (|bfVar#2| (- |n| 1)) + (|i| 0) + (|bfVar#3| |s|) + (|x| NIL)) + (LOOP + (COND + ((OR (> |i| |bfVar#2|) (NOT (CONSP |bfVar#3|)) + (PROGN (SETQ |x| (CAR |bfVar#3|)) NIL)) + (RETURN |bfVar#4|)) + ((NULL |bfVar#4|) + (SETQ |bfVar#4| + (CONS + (|genECLnativeTranslation,sharpArg| |i| + |x|) + NIL)) + (SETQ |bfVar#5| |bfVar#4|)) + (T + (RPLACD |bfVar#5| + (CONS + (|genECLnativeTranslation,sharpArg| |i| + |x|) + NIL)) + (SETQ |bfVar#5| (CDR |bfVar#5|)))) + (SETQ |i| (+ |i| 1)) + (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (CONS ")" NIL))))) (|bfVar#7| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#8|)) - (PROGN (SETQ |bfVar#7| (CAR |bfVar#8|)) NIL)) - (RETURN |bfVar#6|)) - (T (SETQ |bfVar#6| (CONCAT |bfVar#6| |bfVar#7|)))) - (SETQ |bfVar#8| (CDR |bfVar#8|))))) + (COND + ((OR (NOT (CONSP |bfVar#8|)) + (PROGN (SETQ |bfVar#7| (CAR |bfVar#8|)) NIL)) + (RETURN |bfVar#6|)) + (T (SETQ |bfVar#6| (CONCAT |bfVar#6| |bfVar#7|)))) + (SETQ |bfVar#8| (CDR |bfVar#8|))))) (DEFUN |genECLnativeTranslation,sharpArg| (|i| |x|) (COND - ((EQL |i| 0) - (CONCAT "(#0)" (|genECLnativeTranslation,selectDatum| |x|))) - (T (CONCAT "," "(#" (WRITE-TO-STRING |i|) ")" - (|genECLnativeTranslation,selectDatum| |x|))))) + ((EQL |i| 0) (CONCAT "(#0)" (|genECLnativeTranslation,selectDatum| |x|))) + (T + (CONCAT "," "(#" (WRITE-TO-STRING |i|) ")" + (|genECLnativeTranslation,selectDatum| |x|))))) (DEFUN |genECLnativeTranslation,selectDatum| (|x|) (PROG (|y| |c|) (RETURN - (COND - ((|isSimpleNativeType| |x|) "") - (T (SETQ |c| (CAADR |x|)) (SETQ |y| (CADADR |x|)) - (COND + (COND ((|isSimpleNativeType| |x|) "") + (T (SETQ |c| (CAADR |x|)) (SETQ |y| (CADADR |x|)) + (COND ((EQ |c| '|buffer|) (COND - ((OR (EQ |y| '|char|) (EQ |y| '|byte|)) - (COND - ((< |$ECLVersionNumber| 90100) "->vector.self.ch") - ((EQ |y| '|char|) "->vector.self.i8") - (T "->vector.self.b8"))) - ((EQ |y| '|int|) "->vector.self.fix") - ((EQ |y| '|float|) "->vector.self.sf") - ((EQ |y| '|double|) "->vector.self.df") - (T (|coreError| - "unknown argument to buffer type constructor")))) + ((OR (EQ |y| '|char|) (EQ |y| '|byte|)) + (COND ((< |$ECLVersionNumber| 90100) "->vector.self.ch") + ((EQ |y| '|char|) "->vector.self.i8") + (T "->vector.self.b8"))) + ((EQ |y| '|int|) "->vector.self.fix") + ((EQ |y| '|float|) "->vector.self.sf") + ((EQ |y| '|double|) "->vector.self.df") + (T + (|coreError| "unknown argument to buffer type constructor")))) ((EQ |c| '|pointer|) "") (T (|coreError| "unknown type constructor")))))))) (DEFUN |genCLISPnativeTranslation| (|op| |s| |t| |op'|) - (PROG (|forwardingFun| |ISTMP#2| |p| |fixups| |q| |call| |localPairs| - |y| |x| |ISTMP#1| |a| |foreignDecl| |unstableArgs| |parms| - |n| |argtypes| |rettype|) + (PROG (|forwardingFun| |ISTMP#2| |p| |fixups| |q| |call| |localPairs| |y| |x| + |ISTMP#1| |a| |foreignDecl| |unstableArgs| |parms| |n| |argtypes| + |rettype|) (DECLARE (SPECIAL |$foreignsDefsForCLisp|)) (RETURN - (PROGN - (SETQ |rettype| (|nativeReturnType| |t|)) - (SETQ |argtypes| - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) - (|x| NIL)) + (PROGN + (SETQ |rettype| (|nativeReturnType| |t|)) + (SETQ |argtypes| + (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) (|x| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| - #0=(CONS (|nativeArgumentType| |x|) NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #0#) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))) - (SETQ |n| (INTERN (CONCAT (SYMBOL-NAME |op|) "%clisp-hack"))) - (SETQ |parms| - (LET ((|bfVar#5| NIL) (|bfVar#6| NIL) (|bfVar#4| |s|) - (|x| NIL)) + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + ((NULL |bfVar#2|) + (SETQ |bfVar#2| #1=(CONS (|nativeArgumentType| |x|) NIL)) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))) + (SETQ |n| (INTERN (CONCAT (SYMBOL-NAME |op|) "%clisp-hack"))) + (SETQ |parms| + (LET ((|bfVar#5| NIL) (|bfVar#6| NIL) (|bfVar#4| |s|) (|x| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#4|)) - (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL)) - (RETURN |bfVar#5|)) - ((NULL |bfVar#5|) - (SETQ |bfVar#5| #1=(CONS (GENSYM "parm") NIL)) - (SETQ |bfVar#6| |bfVar#5|)) - (T (RPLACD |bfVar#6| #1#) - (SETQ |bfVar#6| (CDR |bfVar#6|)))) - (SETQ |bfVar#4| (CDR |bfVar#4|))))) - (SETQ |unstableArgs| NIL) - (LET ((|bfVar#7| |parms|) (|p| NIL) (|bfVar#8| |s|) (|x| NIL) - (|bfVar#9| |argtypes|) (|y| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#7|)) - (PROGN (SETQ |p| (CAR |bfVar#7|)) NIL) - (NOT (CONSP |bfVar#8|)) - (PROGN (SETQ |x| (CAR |bfVar#8|)) NIL) - (NOT (CONSP |bfVar#9|)) - (PROGN (SETQ |y| (CAR |bfVar#9|)) NIL)) - (RETURN NIL)) - ((|needsStableReference?| |x|) - (IDENTITY - (SETQ |unstableArgs| - (CONS (CONS |p| (CONS |x| |y|)) - |unstableArgs|))))) - (SETQ |bfVar#7| (CDR |bfVar#7|)) - (SETQ |bfVar#8| (CDR |bfVar#8|)) - (SETQ |bfVar#9| (CDR |bfVar#9|)))) - (SETQ |foreignDecl| + (COND + ((OR (NOT (CONSP |bfVar#4|)) + (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL)) + (RETURN |bfVar#5|)) + ((NULL |bfVar#5|) + (SETQ |bfVar#5| #2=(CONS (GENSYM "parm") NIL)) + (SETQ |bfVar#6| |bfVar#5|)) + (T (RPLACD |bfVar#6| #2#) (SETQ |bfVar#6| (CDR |bfVar#6|)))) + (SETQ |bfVar#4| (CDR |bfVar#4|))))) + (SETQ |unstableArgs| NIL) + (LET ((|bfVar#7| |parms|) + (|p| NIL) + (|bfVar#8| |s|) + (|x| NIL) + (|bfVar#9| |argtypes|) + (|y| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#7|)) (PROGN (SETQ |p| (CAR |bfVar#7|)) NIL) + (NOT (CONSP |bfVar#8|)) (PROGN (SETQ |x| (CAR |bfVar#8|)) NIL) + (NOT (CONSP |bfVar#9|)) (PROGN (SETQ |y| (CAR |bfVar#9|)) NIL)) + (RETURN NIL)) + ((|needsStableReference?| |x|) + (IDENTITY + (SETQ |unstableArgs| + (CONS (CONS |p| (CONS |x| |y|)) |unstableArgs|))))) + (SETQ |bfVar#7| (CDR |bfVar#7|)) + (SETQ |bfVar#8| (CDR |bfVar#8|)) + (SETQ |bfVar#9| (CDR |bfVar#9|)))) + (SETQ |foreignDecl| (LIST (|bfColonColon| 'FFI 'DEF-CALL-OUT) |n| (LIST :NAME (SYMBOL-NAME |op'|)) (CONS :ARGUMENTS - (LET ((|bfVar#12| NIL) (|bfVar#13| NIL) - (|bfVar#10| |argtypes|) (|x| NIL) - (|bfVar#11| |parms|) (|a| NIL)) + (LET ((|bfVar#12| NIL) + (|bfVar#13| NIL) + (|bfVar#10| |argtypes|) + (|x| NIL) + (|bfVar#11| |parms|) + (|a| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#10|)) - (PROGN - (SETQ |x| (CAR |bfVar#10|)) - NIL) - (NOT (CONSP |bfVar#11|)) - (PROGN - (SETQ |a| (CAR |bfVar#11|)) - NIL)) - (RETURN |bfVar#12|)) - ((NULL |bfVar#12|) - (SETQ |bfVar#12| - #2=(CONS (LIST |a| |x|) NIL)) - (SETQ |bfVar#13| |bfVar#12|)) - (T (RPLACD |bfVar#13| #2#) - (SETQ |bfVar#13| (CDR |bfVar#13|)))) - (SETQ |bfVar#10| (CDR |bfVar#10|)) - (SETQ |bfVar#11| (CDR |bfVar#11|))))) - (LIST :RETURN-TYPE |rettype|) - (LIST :LANGUAGE :STDC))) - (SETQ |forwardingFun| - (COND - ((NULL |unstableArgs|) - (LIST 'DEFUN |op| |parms| (CONS |n| |parms|))) - (T (SETQ |localPairs| - (LET ((|bfVar#16| NIL) (|bfVar#17| NIL) - (|bfVar#15| |unstableArgs|) - (|bfVar#14| NIL)) - (LOOP (COND - ((OR (NOT (CONSP |bfVar#15|)) - (PROGN - (SETQ |bfVar#14| - (CAR |bfVar#15|)) - NIL)) - (RETURN |bfVar#16|)) - (T (AND (CONSP |bfVar#14|) - (PROGN - (SETQ |a| (CAR |bfVar#14|)) - (SETQ |ISTMP#1| - (CDR |bfVar#14|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |x| (CAR |ISTMP#1|)) - (SETQ |y| (CDR |ISTMP#1|)) - T))) - (COND - ((NULL |bfVar#16|) - (SETQ |bfVar#16| - #3=(CONS - (CONS |a| - (CONS |x| - (CONS |y| - (GENSYM "loc")))) - NIL)) - (SETQ |bfVar#17| |bfVar#16|)) - (T (RPLACD |bfVar#17| #3#) - (SETQ |bfVar#17| - (CDR |bfVar#17|))))))) - (SETQ |bfVar#15| (CDR |bfVar#15|))))) - (SETQ |call| - (CONS |n| - (LET ((|bfVar#19| NIL) (|bfVar#20| NIL) - (|bfVar#18| |parms|) (|p| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#18|)) - (PROGN - (SETQ |p| (CAR |bfVar#18|)) - NIL)) - (RETURN |bfVar#19|)) - ((NULL |bfVar#19|) - (SETQ |bfVar#19| - (CONS - (|genCLISPnativeTranslation,actualArg| - |p| |localPairs|) - NIL)) - (SETQ |bfVar#20| |bfVar#19|)) - (T - (RPLACD |bfVar#20| - (CONS - (|genCLISPnativeTranslation,actualArg| - |p| |localPairs|) - NIL)) - (SETQ |bfVar#20| - (CDR |bfVar#20|)))) - (SETQ |bfVar#18| (CDR |bfVar#18|)))))) - (SETQ |call| - (PROGN - (SETQ |fixups| + ((OR (NOT (CONSP |bfVar#10|)) + (PROGN (SETQ |x| (CAR |bfVar#10|)) NIL) + (NOT (CONSP |bfVar#11|)) + (PROGN (SETQ |a| (CAR |bfVar#11|)) NIL)) + (RETURN |bfVar#12|)) + ((NULL |bfVar#12|) + (SETQ |bfVar#12| #3=(CONS (LIST |a| |x|) NIL)) + (SETQ |bfVar#13| |bfVar#12|)) + (T (RPLACD |bfVar#13| #3#) + (SETQ |bfVar#13| (CDR |bfVar#13|)))) + (SETQ |bfVar#10| (CDR |bfVar#10|)) + (SETQ |bfVar#11| (CDR |bfVar#11|))))) + (LIST :RETURN-TYPE |rettype|) (LIST :LANGUAGE :STDC))) + (SETQ |forwardingFun| + (COND + ((NULL |unstableArgs|) + (LIST 'DEFUN |op| |parms| (CONS |n| |parms|))) + (T + (SETQ |localPairs| + (LET ((|bfVar#16| NIL) + (|bfVar#17| NIL) + (|bfVar#15| |unstableArgs|) + (|bfVar#14| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#15|)) + (PROGN + (SETQ |bfVar#14| (CAR |bfVar#15|)) + NIL)) + (RETURN |bfVar#16|)) + (T + (AND (CONSP |bfVar#14|) + (PROGN + (SETQ |a| (CAR |bfVar#14|)) + (SETQ |ISTMP#1| (CDR |bfVar#14|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |x| (CAR |ISTMP#1|)) + (SETQ |y| (CDR |ISTMP#1|)) + T))) + (COND + ((NULL |bfVar#16|) + (SETQ |bfVar#16| + #4=(CONS + (CONS |a| + (CONS |x| + (CONS |y| + (GENSYM + "loc")))) + NIL)) + (SETQ |bfVar#17| |bfVar#16|)) + (T (RPLACD |bfVar#17| #4#) + (SETQ |bfVar#17| (CDR |bfVar#17|))))))) + (SETQ |bfVar#15| (CDR |bfVar#15|))))) + (SETQ |call| + (CONS |n| + (LET ((|bfVar#19| NIL) + (|bfVar#20| NIL) + (|bfVar#18| |parms|) + (|p| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#18|)) + (PROGN (SETQ |p| (CAR |bfVar#18|)) NIL)) + (RETURN |bfVar#19|)) + ((NULL |bfVar#19|) + (SETQ |bfVar#19| + (CONS + (|genCLISPnativeTranslation,actualArg| + |p| |localPairs|) + NIL)) + (SETQ |bfVar#20| |bfVar#19|)) + (T + (RPLACD |bfVar#20| + (CONS + (|genCLISPnativeTranslation,actualArg| + |p| |localPairs|) + NIL)) + (SETQ |bfVar#20| (CDR |bfVar#20|)))) + (SETQ |bfVar#18| (CDR |bfVar#18|)))))) + (SETQ |call| + (PROGN + (SETQ |fixups| (LET ((|bfVar#22| NIL) (|bfVar#23| NIL) (|bfVar#21| |localPairs|) (|p| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#21|)) - (PROGN + (COND + ((OR (NOT (CONSP |bfVar#21|)) + (PROGN (SETQ |p| (CAR |bfVar#21|)) NIL)) - (RETURN |bfVar#22|)) - (T - (AND - (NOT - (NULL - (SETQ |q| - (|genCLISPnativeTranslation,copyBack| - |p|)))) - (COND - ((NULL |bfVar#22|) - (SETQ |bfVar#22| - (CONS |q| NIL)) - (SETQ |bfVar#23| - |bfVar#22|)) - (T - (RPLACD |bfVar#23| - (CONS |q| NIL)) - (SETQ |bfVar#23| - (CDR |bfVar#23|))))))) - (SETQ |bfVar#21| (CDR |bfVar#21|))))) - (COND - ((NULL |fixups|) (LIST |call|)) - (T (LIST (CONS 'PROG1 - (CONS |call| |fixups|))))))) - (LET ((|bfVar#25| |localPairs|) (|bfVar#24| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#25|)) - (PROGN - (SETQ |bfVar#24| (CAR |bfVar#25|)) - NIL)) - (RETURN NIL)) - (T (AND (CONSP |bfVar#24|) - (PROGN - (SETQ |p| (CAR |bfVar#24|)) - (SETQ |ISTMP#1| (CDR |bfVar#24|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |x| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |y| (CAR |ISTMP#2|)) - (SETQ |a| (CDR |ISTMP#2|)) - T))))) - (SETQ |call| - (LIST - (CONS - (|bfColonColon| 'FFI - 'WITH-FOREIGN-OBJECT) - (CONS - (LIST |a| + (RETURN |bfVar#22|)) + (T + (AND + (NOT + (NULL + (SETQ |q| + (|genCLISPnativeTranslation,copyBack| + |p|)))) + (COND + ((NULL |bfVar#22|) + (SETQ |bfVar#22| (CONS |q| NIL)) + (SETQ |bfVar#23| |bfVar#22|)) + (T (RPLACD |bfVar#23| (CONS |q| NIL)) + (SETQ |bfVar#23| + (CDR |bfVar#23|))))))) + (SETQ |bfVar#21| (CDR |bfVar#21|))))) + (COND ((NULL |fixups|) (LIST |call|)) + (T + (LIST (CONS 'PROG1 (CONS |call| |fixups|))))))) + (LET ((|bfVar#25| |localPairs|) (|bfVar#24| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#25|)) + (PROGN (SETQ |bfVar#24| (CAR |bfVar#25|)) NIL)) + (RETURN NIL)) + (T + (AND (CONSP |bfVar#24|) + (PROGN + (SETQ |p| (CAR |bfVar#24|)) + (SETQ |ISTMP#1| (CDR |bfVar#24|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |x| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |y| (CAR |ISTMP#2|)) + (SETQ |a| (CDR |ISTMP#2|)) + T))))) + (SETQ |call| + (LIST + (CONS + (|bfColonColon| 'FFI 'WITH-FOREIGN-OBJECT) + (CONS + (LIST |a| (LIST 'FUNCALL - (LIST 'INTERN - "getCLISPType" "BOOTTRAN") - |p|) + (LIST 'INTERN "getCLISPType" + "BOOTTRAN") + |p|) |p|) - |call|))))))) - (SETQ |bfVar#25| (CDR |bfVar#25|)))) - (CONS 'DEFUN (CONS |op| (CONS |parms| |call|)))))) - (SETQ |$foreignsDefsForCLisp| + |call|))))))) + (SETQ |bfVar#25| (CDR |bfVar#25|)))) + (CONS 'DEFUN (CONS |op| (CONS |parms| |call|)))))) + (SETQ |$foreignsDefsForCLisp| (CONS |foreignDecl| |$foreignsDefsForCLisp|)) - (LIST |forwardingFun|))))) + (LIST |forwardingFun|))))) (DEFUN |genCLISPnativeTranslation,copyBack| (|bfVar#26|) (PROG (|a| |y| |x| |p|) (RETURN - (PROGN - (SETQ |p| (CAR |bfVar#26|)) - (SETQ |x| (CADR . #0=(|bfVar#26|))) - (SETQ |y| (CADDR . #0#)) - (SETQ |a| (CDDDR . #0#)) - (COND - ((AND (CONSP |x|) (EQ (CAR |x|) '|readonly|)) NIL) - (T (LIST 'SETF |p| + (PROGN + (SETQ |p| (CAR |bfVar#26|)) + (SETQ |x| (CADR . #1=(|bfVar#26|))) + (SETQ |y| (CADDR . #1#)) + (SETQ |a| (CDDDR . #1#)) + (COND ((AND (CONSP |x|) (EQ (CAR |x|) '|readonly|)) NIL) + (T + (LIST 'SETF |p| (LIST (|bfColonColon| 'FFI 'FOREIGN-VALUE) |a|)))))))) (DEFUN |genCLISPnativeTranslation,actualArg| (|p| |pairs|) (PROG (|a'|) (RETURN - (COND - ((SETQ |a'| (CDR (ASSOC |p| |pairs|))) (CDR (CDR |a'|))) - (T |p|))))) + (COND ((SETQ |a'| (CDR (ASSOC |p| |pairs|))) (CDR (CDR |a'|))) (T |p|))))) -(DEFUN |getCLISPType| (|a|) - (LIST (|bfColonColon| 'FFI 'C-ARRAY) (LENGTH |a|))) +(DEFUN |getCLISPType| (|a|) (LIST (|bfColonColon| 'FFI 'C-ARRAY) (LENGTH |a|))) (DEFUN |genSBCLnativeTranslation| (|op| |s| |t| |op'|) (PROG (|newArgs| |unstableArgs| |args| |argtypes| |rettype|) (RETURN - (PROGN - (SETQ |rettype| (|nativeReturnType| |t|)) - (SETQ |argtypes| - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) - (|x| NIL)) + (PROGN + (SETQ |rettype| (|nativeReturnType| |t|)) + (SETQ |argtypes| + (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) (|x| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| - #0=(CONS (|nativeArgumentType| |x|) NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #0#) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))) - (SETQ |args| - (LET ((|bfVar#5| NIL) (|bfVar#6| NIL) (|bfVar#4| |s|) - (|x| NIL)) + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + ((NULL |bfVar#2|) + (SETQ |bfVar#2| #1=(CONS (|nativeArgumentType| |x|) NIL)) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))) + (SETQ |args| + (LET ((|bfVar#5| NIL) (|bfVar#6| NIL) (|bfVar#4| |s|) (|x| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#4|)) - (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL)) - (RETURN |bfVar#5|)) - ((NULL |bfVar#5|) - (SETQ |bfVar#5| #1=(CONS (GENSYM) NIL)) - (SETQ |bfVar#6| |bfVar#5|)) - (T (RPLACD |bfVar#6| #1#) - (SETQ |bfVar#6| (CDR |bfVar#6|)))) - (SETQ |bfVar#4| (CDR |bfVar#4|))))) - (SETQ |unstableArgs| NIL) - (SETQ |newArgs| NIL) - (LET ((|bfVar#7| |args|) (|a| NIL) (|bfVar#8| |s|) (|x| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#7|)) - (PROGN (SETQ |a| (CAR |bfVar#7|)) NIL) - (NOT (CONSP |bfVar#8|)) - (PROGN (SETQ |x| (CAR |bfVar#8|)) NIL)) - (RETURN NIL)) - (T (SETQ |newArgs| - (CONS (|coerceToNativeType| |a| |x|) |newArgs|)) (COND - ((|needsStableReference?| |x|) - (SETQ |unstableArgs| (CONS |a| |unstableArgs|)))))) - (SETQ |bfVar#7| (CDR |bfVar#7|)) - (SETQ |bfVar#8| (CDR |bfVar#8|)))) - (SETQ |op'| - (COND - ((|%hasFeature| :WIN32) - (CONCAT "_" (SYMBOL-NAME |op'|))) - (T (SYMBOL-NAME |op'|)))) - (COND - ((NULL |unstableArgs|) - (LIST (LIST 'DEFUN |op| |args| - (CONS (INTERN "ALIEN-FUNCALL" "SB-ALIEN") - (CONS (LIST - (INTERN "EXTERN-ALIEN" "SB-ALIEN") - |op'| - (CONS 'FUNCTION - (CONS |rettype| |argtypes|))) - |args|))))) - (T (LIST (LIST 'DEFUN |op| |args| - (LIST (|bfColonColon| 'SB-SYS - 'WITH-PINNED-OBJECTS) - (|reverse!| |unstableArgs|) - (CONS (INTERN "ALIEN-FUNCALL" - "SB-ALIEN") - (CONS - (LIST - (INTERN "EXTERN-ALIEN" - "SB-ALIEN") - |op'| - (CONS 'FUNCTION - (CONS |rettype| |argtypes|))) - (|reverse!| |newArgs|)))))))))))) + ((OR (NOT (CONSP |bfVar#4|)) + (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL)) + (RETURN |bfVar#5|)) + ((NULL |bfVar#5|) (SETQ |bfVar#5| #2=(CONS (GENSYM) NIL)) + (SETQ |bfVar#6| |bfVar#5|)) + (T (RPLACD |bfVar#6| #2#) (SETQ |bfVar#6| (CDR |bfVar#6|)))) + (SETQ |bfVar#4| (CDR |bfVar#4|))))) + (SETQ |unstableArgs| NIL) + (SETQ |newArgs| NIL) + (LET ((|bfVar#7| |args|) (|a| NIL) (|bfVar#8| |s|) (|x| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#7|)) (PROGN (SETQ |a| (CAR |bfVar#7|)) NIL) + (NOT (CONSP |bfVar#8|)) (PROGN (SETQ |x| (CAR |bfVar#8|)) NIL)) + (RETURN NIL)) + (T (SETQ |newArgs| (CONS (|coerceToNativeType| |a| |x|) |newArgs|)) + (COND + ((|needsStableReference?| |x|) + (SETQ |unstableArgs| (CONS |a| |unstableArgs|)))))) + (SETQ |bfVar#7| (CDR |bfVar#7|)) + (SETQ |bfVar#8| (CDR |bfVar#8|)))) + (SETQ |op'| + (COND ((|%hasFeature| :WIN32) (CONCAT "_" (SYMBOL-NAME |op'|))) + (T (SYMBOL-NAME |op'|)))) + (COND + ((NULL |unstableArgs|) + (LIST + (LIST 'DEFUN |op| |args| + (CONS (INTERN "ALIEN-FUNCALL" "SB-ALIEN") + (CONS + (LIST (INTERN "EXTERN-ALIEN" "SB-ALIEN") |op'| + (CONS 'FUNCTION (CONS |rettype| |argtypes|))) + |args|))))) + (T + (LIST + (LIST 'DEFUN |op| |args| + (LIST (|bfColonColon| 'SB-SYS 'WITH-PINNED-OBJECTS) + (|reverse!| |unstableArgs|) + (CONS (INTERN "ALIEN-FUNCALL" "SB-ALIEN") + (CONS + (LIST (INTERN "EXTERN-ALIEN" "SB-ALIEN") |op'| + (CONS 'FUNCTION (CONS |rettype| |argtypes|))) + (|reverse!| |newArgs|)))))))))))) (DEFUN |genCLOZUREnativeTranslation| (|op| |s| |t| |op'|) - (PROG (|call| |p'| |ISTMP#3| |ISTMP#2| |ISTMP#1| |aryPairs| - |strPairs| |parms| |argtypes| |rettype|) - (RETURN - (PROGN - (SETQ |rettype| (|nativeReturnType| |t|)) - (SETQ |argtypes| - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) - (|x| NIL)) + (PROG (|call| |p'| |ISTMP#3| |ISTMP#2| |ISTMP#1| |aryPairs| |strPairs| + |parms| |argtypes| |rettype|) + (RETURN + (PROGN + (SETQ |rettype| (|nativeReturnType| |t|)) + (SETQ |argtypes| + (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) (|x| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| - #0=(CONS (|nativeArgumentType| |x|) NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #0#) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))) - (SETQ |parms| - (LET ((|bfVar#5| NIL) (|bfVar#6| NIL) (|bfVar#4| |s|) - (|x| NIL)) + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + ((NULL |bfVar#2|) + (SETQ |bfVar#2| #1=(CONS (|nativeArgumentType| |x|) NIL)) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))) + (SETQ |parms| + (LET ((|bfVar#5| NIL) (|bfVar#6| NIL) (|bfVar#4| |s|) (|x| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#4|)) - (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL)) - (RETURN |bfVar#5|)) - ((NULL |bfVar#5|) - (SETQ |bfVar#5| #1=(CONS (GENSYM "parm") NIL)) - (SETQ |bfVar#6| |bfVar#5|)) - (T (RPLACD |bfVar#6| #1#) - (SETQ |bfVar#6| (CDR |bfVar#6|)))) - (SETQ |bfVar#4| (CDR |bfVar#4|))))) - (SETQ |strPairs| NIL) - (SETQ |aryPairs| NIL) - (LET ((|bfVar#7| |parms|) (|p| NIL) (|bfVar#8| |s|) (|x| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#7|)) - (PROGN (SETQ |p| (CAR |bfVar#7|)) NIL) - (NOT (CONSP |bfVar#8|)) - (PROGN (SETQ |x| (CAR |bfVar#8|)) NIL)) - (RETURN NIL)) - ((EQ |x| '|string|) - (SETQ |strPairs| - (CONS (CONS |p| (GENSYM "loc")) |strPairs|))) - ((AND (CONSP |x|) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN - (SETQ |ISTMP#2| (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CAR |ISTMP#2|) '|buffer|) - (PROGN - (SETQ |ISTMP#3| (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (NULL (CDR |ISTMP#3|))))))))) - (SETQ |aryPairs| - (CONS (CONS |p| (GENSYM "loc")) |aryPairs|)))) - (SETQ |bfVar#7| (CDR |bfVar#7|)) - (SETQ |bfVar#8| (CDR |bfVar#8|)))) - (COND - ((|%hasFeature| :DARWIN) (SETQ |op'| (CONCAT "_" |op'|)))) - (SETQ |call| + (COND + ((OR (NOT (CONSP |bfVar#4|)) + (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL)) + (RETURN |bfVar#5|)) + ((NULL |bfVar#5|) + (SETQ |bfVar#5| #2=(CONS (GENSYM "parm") NIL)) + (SETQ |bfVar#6| |bfVar#5|)) + (T (RPLACD |bfVar#6| #2#) (SETQ |bfVar#6| (CDR |bfVar#6|)))) + (SETQ |bfVar#4| (CDR |bfVar#4|))))) + (SETQ |strPairs| NIL) + (SETQ |aryPairs| NIL) + (LET ((|bfVar#7| |parms|) (|p| NIL) (|bfVar#8| |s|) (|x| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#7|)) (PROGN (SETQ |p| (CAR |bfVar#7|)) NIL) + (NOT (CONSP |bfVar#8|)) (PROGN (SETQ |x| (CAR |bfVar#8|)) NIL)) + (RETURN NIL)) + ((EQ |x| '|string|) + (SETQ |strPairs| (CONS (CONS |p| (GENSYM "loc")) |strPairs|))) + ((AND (CONSP |x|) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN + (SETQ |ISTMP#2| (CAR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CAR |ISTMP#2|) '|buffer|) + (PROGN + (SETQ |ISTMP#3| (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (NULL (CDR |ISTMP#3|))))))))) + (SETQ |aryPairs| (CONS (CONS |p| (GENSYM "loc")) |aryPairs|)))) + (SETQ |bfVar#7| (CDR |bfVar#7|)) + (SETQ |bfVar#8| (CDR |bfVar#8|)))) + (COND ((|%hasFeature| :DARWIN) (SETQ |op'| (CONCAT "_" |op'|)))) + (SETQ |call| (CONS (|bfColonColon| 'CCL 'EXTERNAL-CALL) (CONS (STRING |op'|) (|append| - (LET ((|bfVar#11| NIL) (|bfVar#12| NIL) - (|bfVar#9| |argtypes|) (|x| NIL) - (|bfVar#10| |parms|) (|p| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#9|)) - (PROGN - (SETQ |x| (CAR |bfVar#9|)) - NIL) - (NOT (CONSP |bfVar#10|)) - (PROGN - (SETQ |p| (CAR |bfVar#10|)) - NIL)) - (RETURN |bfVar#11|)) - (T - (LET - ((|bfVar#13| - (LIST |x| - (COND - ((SETQ |p'| - (ASSOC |p| |strPairs|)) - (CDR |p'|)) - ((SETQ |p'| - (ASSOC |p| |aryPairs|)) - (CDR |p'|)) - (T |p|))))) - (COND - ((NULL |bfVar#13|) NIL) - ((NULL |bfVar#11|) - (SETQ |bfVar#11| |bfVar#13|) - (SETQ |bfVar#12| - (|lastNode| |bfVar#11|))) - (T - (RPLACD |bfVar#12| - |bfVar#13|) - (SETQ |bfVar#12| - (|lastNode| |bfVar#12|))))))) - (SETQ |bfVar#9| (CDR |bfVar#9|)) - (SETQ |bfVar#10| (CDR |bfVar#10|)))) - (CONS |rettype| NIL))))) - (COND - ((EQ |t| '|string|) + (LET ((|bfVar#11| NIL) + (|bfVar#12| NIL) + (|bfVar#9| |argtypes|) + (|x| NIL) + (|bfVar#10| |parms|) + (|p| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#9|)) + (PROGN (SETQ |x| (CAR |bfVar#9|)) NIL) + (NOT (CONSP |bfVar#10|)) + (PROGN (SETQ |p| (CAR |bfVar#10|)) NIL)) + (RETURN |bfVar#11|)) + (T + (LET ((|bfVar#13| + (LIST |x| + (COND + ((SETQ |p'| + (ASSOC |p| |strPairs|)) + (CDR |p'|)) + ((SETQ |p'| + (ASSOC |p| |aryPairs|)) + (CDR |p'|)) + (T |p|))))) + (COND ((NULL |bfVar#13|) NIL) + ((NULL |bfVar#11|) + (SETQ |bfVar#11| |bfVar#13|) + (SETQ |bfVar#12| + (|lastNode| |bfVar#11|))) + (T (RPLACD |bfVar#12| |bfVar#13|) + (SETQ |bfVar#12| + (|lastNode| |bfVar#12|))))))) + (SETQ |bfVar#9| (CDR |bfVar#9|)) + (SETQ |bfVar#10| (CDR |bfVar#10|)))) + (CONS |rettype| NIL))))) + (COND + ((EQ |t| '|string|) + (SETQ |call| (LIST (|bfColonColon| 'CCL 'GET-CSTRING) |call|)))) + (LET ((|bfVar#14| |aryPairs|) (|arg| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#14|)) + (PROGN (SETQ |arg| (CAR |bfVar#14|)) NIL)) + (RETURN NIL)) + (T (SETQ |call| - (LIST (|bfColonColon| 'CCL 'GET-CSTRING) |call|)))) - (LET ((|bfVar#14| |aryPairs|) (|arg| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#14|)) - (PROGN (SETQ |arg| (CAR |bfVar#14|)) NIL)) - (RETURN NIL)) - (T (SETQ |call| - (LIST (|bfColonColon| 'CCL - 'WITH-POINTER-TO-IVECTOR) - (LIST (CDR |arg|) (CAR |arg|)) |call|)))) - (SETQ |bfVar#14| (CDR |bfVar#14|)))) - (COND - (|strPairs| (SETQ |call| - (LIST (|bfColonColon| 'CCL 'WITH-CSTRS) - (LET ((|bfVar#16| NIL) - (|bfVar#17| NIL) - (|bfVar#15| |strPairs|) - (|arg| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#15|)) - (PROGN - (SETQ |arg| - (CAR |bfVar#15|)) + (LIST (|bfColonColon| 'CCL 'WITH-POINTER-TO-IVECTOR) + (LIST (CDR |arg|) (CAR |arg|)) |call|)))) + (SETQ |bfVar#14| (CDR |bfVar#14|)))) + (COND + (|strPairs| + (SETQ |call| + (LIST (|bfColonColon| 'CCL 'WITH-CSTRS) + (LET ((|bfVar#16| NIL) + (|bfVar#17| NIL) + (|bfVar#15| |strPairs|) + (|arg| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#15|)) + (PROGN (SETQ |arg| (CAR |bfVar#15|)) NIL)) + (RETURN |bfVar#16|)) + ((NULL |bfVar#16|) + (SETQ |bfVar#16| + #3=(CONS (LIST (CDR |arg|) (CAR |arg|)) NIL)) - (RETURN |bfVar#16|)) - ((NULL |bfVar#16|) - (SETQ |bfVar#16| - #2=(CONS - (LIST (CDR |arg|) - (CAR |arg|)) - NIL)) - (SETQ |bfVar#17| |bfVar#16|)) - (T (RPLACD |bfVar#17| #2#) - (SETQ |bfVar#17| - (CDR |bfVar#17|)))) - (SETQ |bfVar#15| - (CDR |bfVar#15|)))) - |call|)))) - (LIST (LIST 'DEFUN |op| |parms| |call|)))))) + (SETQ |bfVar#17| |bfVar#16|)) + (T (RPLACD |bfVar#17| #3#) + (SETQ |bfVar#17| (CDR |bfVar#17|)))) + (SETQ |bfVar#15| (CDR |bfVar#15|)))) + |call|)))) + (LIST (LIST 'DEFUN |op| |parms| |call|)))))) (DEFUN |genImportDeclaration| (|op| |sig|) (PROG (|s| |t| |m| |ISTMP#2| |op'| |ISTMP#1|) (RETURN - (COND - ((NOT (AND (CONSP |sig|) (EQ (CAR |sig|) '|%Signature|) + (COND + ((NOT + (AND (CONSP |sig|) (EQ (CAR |sig|) '|%Signature|) + (PROGN + (SETQ |ISTMP#1| (CDR |sig|)) + (AND (CONSP |ISTMP#1|) (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|) - (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |m| (CAR |ISTMP#2|)) T))))))) - (|coreError| "invalid signature")) - ((NOT (AND (CONSP |m|) (EQ (CAR |m|) '|%Mapping|) + (SETQ |op'| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |m| (CAR |ISTMP#2|)) T))))))) + (|coreError| "invalid signature")) + ((NOT + (AND (CONSP |m|) (EQ (CAR |m|) '|%Mapping|) + (PROGN + (SETQ |ISTMP#1| (CDR |m|)) + (AND (CONSP |ISTMP#1|) (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|) - (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |s| (CAR |ISTMP#2|)) T))))))) - (|coreError| "invalid function type")) - (T (COND ((AND |s| (SYMBOLP |s|)) (SETQ |s| (LIST |s|)))) - (COND - ((|%hasFeature| :GCL) - (|genGCLnativeTranslation| |op| |s| |t| |op'|)) - ((|%hasFeature| :SBCL) - (|genSBCLnativeTranslation| |op| |s| |t| |op'|)) - ((|%hasFeature| :CLISP) - (|genCLISPnativeTranslation| |op| |s| |t| |op'|)) - ((|%hasFeature| :ECL) - (|genECLnativeTranslation| |op| |s| |t| |op'|)) - ((|%hasFeature| :CLOZURE) - (|genCLOZUREnativeTranslation| |op| |s| |t| |op'|)) - (T (|fatalError| - "import declaration not implemented for this Lisp")))))))) + (SETQ |t| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |s| (CAR |ISTMP#2|)) T))))))) + (|coreError| "invalid function type")) + (T (COND ((AND |s| (SYMBOLP |s|)) (SETQ |s| (LIST |s|)))) + (COND + ((|%hasFeature| :GCL) (|genGCLnativeTranslation| |op| |s| |t| |op'|)) + ((|%hasFeature| :SBCL) (|genSBCLnativeTranslation| |op| |s| |t| |op'|)) + ((|%hasFeature| :CLISP) + (|genCLISPnativeTranslation| |op| |s| |t| |op'|)) + ((|%hasFeature| :ECL) (|genECLnativeTranslation| |op| |s| |t| |op'|)) + ((|%hasFeature| :CLOZURE) + (|genCLOZUREnativeTranslation| |op| |s| |t| |op'|)) + (T + (|fatalError| + "import declaration not implemented for this Lisp")))))))) diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp index 531e84ed..61c7e369 100644 --- a/src/boot/strap/includer.clisp +++ b/src/boot/strap/includer.clisp @@ -6,23 +6,20 @@ (PROVIDE "includer") (DEFUN PNAME (|x|) - (COND - ((SYMBOLP |x|) (SYMBOL-NAME |x|)) - ((CHARACTERP |x|) (STRING |x|)) - (T NIL))) + (COND ((SYMBOLP |x|) (SYMBOL-NAME |x|)) ((CHARACTERP |x|) (STRING |x|)) + (T NIL))) -(DEFUN |shoeNotFound| (|fn|) - (PROGN (|coreError| (LIST |fn| " not found")) NIL)) +(DEFUN |shoeNotFound| (|fn|) (PROGN (|coreError| (LIST |fn| " not found")) NIL)) (DEFUN |shoeReadLispString| (|s| |n|) (PROG (|l|) (RETURN - (PROGN - (SETQ |l| (LENGTH |s|)) - (COND - ((NOT (< |n| |l|)) NIL) - (T (READ-FROM-STRING - (CONCAT "(" (|subString| |s| |n| (- |l| |n|)) ")")))))))) + (PROGN + (SETQ |l| (LENGTH |s|)) + (COND ((NOT (< |n| |l|)) NIL) + (T + (READ-FROM-STRING + (CONCAT "(" (|subString| |s| |n| (- |l| |n|)) ")")))))))) (DEFUN |shoeConsole| (|line|) (WRITE-LINE |line| *TERMINAL-IO*)) @@ -31,25 +28,22 @@ (DEFUN |diagnosticLocation| (|tok|) (PROG (|pos|) (RETURN - (PROGN - (SETQ |pos| (|shoeTokPosn| |tok|)) - (CONCAT "line " (WRITE-TO-STRING (|lineNo| |pos|)) ", column " - (WRITE-TO-STRING (|lineCharacter| |pos|))))))) + (PROGN + (SETQ |pos| (|shoeTokPosn| |tok|)) + (CONCAT "line " (WRITE-TO-STRING (|lineNo| |pos|)) ", column " + (WRITE-TO-STRING (|lineCharacter| |pos|))))))) (DEFUN |SoftShoeError| (|posn| |key|) (PROGN - (|coreError| (LIST "in line " (WRITE-TO-STRING (|lineNo| |posn|)))) - (|shoeConsole| (|lineString| |posn|)) - (|shoeConsole| - (CONCAT (|shoeSpaces| (|lineCharacter| |posn|)) "|")) - (|shoeConsole| |key|))) + (|coreError| (LIST "in line " (WRITE-TO-STRING (|lineNo| |posn|)))) + (|shoeConsole| (|lineString| |posn|)) + (|shoeConsole| (CONCAT (|shoeSpaces| (|lineCharacter| |posn|)) "|")) + (|shoeConsole| |key|))) (DEFUN |bpSpecificErrorAtToken| (|tok| |key|) (PROG (|a|) (RETURN - (PROGN - (SETQ |a| (|shoeTokPosn| |tok|)) - (|SoftShoeError| |a| |key|))))) + (PROGN (SETQ |a| (|shoeTokPosn| |tok|)) (|SoftShoeError| |a| |key|))))) (DEFUN |bpSpecificErrorHere| (|key|) (DECLARE (SPECIAL |$stok|)) @@ -59,18 +53,14 @@ (DEFUN |bpIgnoredFromTo| (|pos1| |pos2|) (PROGN - (|shoeConsole| - (CONCAT "ignored from line " - (WRITE-TO-STRING (|lineNo| |pos1|)))) - (|shoeConsole| (|lineString| |pos1|)) - (|shoeConsole| - (CONCAT (|shoeSpaces| (|lineCharacter| |pos1|)) "|")) - (|shoeConsole| - (CONCAT "ignored through line " - (WRITE-TO-STRING (|lineNo| |pos2|)))) - (|shoeConsole| (|lineString| |pos2|)) - (|shoeConsole| - (CONCAT (|shoeSpaces| (|lineCharacter| |pos2|)) "|")))) + (|shoeConsole| + (CONCAT "ignored from line " (WRITE-TO-STRING (|lineNo| |pos1|)))) + (|shoeConsole| (|lineString| |pos1|)) + (|shoeConsole| (CONCAT (|shoeSpaces| (|lineCharacter| |pos1|)) "|")) + (|shoeConsole| + (CONCAT "ignored through line " (WRITE-TO-STRING (|lineNo| |pos2|)))) + (|shoeConsole| (|lineString| |pos2|)) + (|shoeConsole| (CONCAT (|shoeSpaces| (|lineCharacter| |pos2|)) "|")))) (DEFUN |lineNo| (|p|) (CDAAR |p|)) @@ -83,30 +73,29 @@ (DEFUN |bStreamNull| (|x|) (PROG (|st| |args| |op| |ISTMP#1|) (RETURN - (COND - ((OR (NULL |x|) (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|))) - T) - (T (LOOP + (COND ((OR (NULL |x|) (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|))) T) + (T + (LOOP (COND - ((NOT (AND (CONSP |x|) (EQ (CAR |x|) '|nonnullstream|) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |op| (CAR |ISTMP#1|)) - (SETQ |args| (CDR |ISTMP#1|)) - T))))) - (RETURN NIL)) - (T (SETQ |st| (APPLY |op| |args|)) - (RPLACA |x| (CAR |st|)) (RPLACD |x| (CDR |st|))))) - (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|))))))) + ((NOT + (AND (CONSP |x|) (EQ (CAR |x|) '|nonnullstream|) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |op| (CAR |ISTMP#1|)) + (SETQ |args| (CDR |ISTMP#1|)) + T))))) + (RETURN NIL)) + (T (SETQ |st| (APPLY |op| |args|)) (RPLACA |x| (CAR |st|)) + (RPLACD |x| (CDR |st|))))) + (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|))))))) (DEFUN |bMap| (|f| |x|) (|bDelay| #'|bMap1| (LIST |f| |x|))) (DEFUN |bMap1| (|f| |x|) - (COND - ((|bStreamNull| |x|) |$bStreamNil|) - (T (CONS (APPLY |f| (LIST (CAR |x|))) (|bMap| |f| (CDR |x|)))))) + (COND ((|bStreamNull| |x|) |$bStreamNil|) + (T (CONS (APPLY |f| (LIST (CAR |x|))) (|bMap| |f| (CDR |x|)))))) (DEFUN |bDelay| (|f| |x|) (CONS '|nonnullstream| (CONS |f| |x|))) @@ -114,45 +103,42 @@ (DEFUN |bAppend1| (|x| |y|) (COND - ((|bStreamNull| |x|) - (COND ((|bStreamNull| |y|) (LIST '|nullstream|)) (T |y|))) - (T (CONS (CAR |x|) (|bAppend| (CDR |x|) |y|))))) + ((|bStreamNull| |x|) + (COND ((|bStreamNull| |y|) (LIST '|nullstream|)) (T |y|))) + (T (CONS (CAR |x|) (|bAppend| (CDR |x|) |y|))))) (DEFUN |bNext| (|f| |s|) (|bDelay| #'|bNext1| (LIST |f| |s|))) (DEFUN |bNext1| (|f| |s|) (PROG (|h|) (RETURN - (COND - ((|bStreamNull| |s|) (LIST '|nullstream|)) - (T (SETQ |h| (APPLY |f| (LIST |s|))) - (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|)))))))) + (COND ((|bStreamNull| |s|) (LIST '|nullstream|)) + (T (SETQ |h| (APPLY |f| (LIST |s|))) + (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|)))))))) (DEFUN |bRgen| (|s|) (|bDelay| #'|bRgen1| (LIST |s|))) (DEFUN |bRgen1| (|s|) (PROG (|a|) (RETURN - (PROGN - (SETQ |a| (|readLine| |s|)) - (COND - ((NOT (EQ |a| |%nothing|)) (CONS |a| (|bRgen| |s|))) - (T (LIST '|nullstream|))))))) + (PROGN + (SETQ |a| (|readLine| |s|)) + (COND ((NOT (EQ |a| |%nothing|)) (CONS |a| (|bRgen| |s|))) + (T (LIST '|nullstream|))))))) (DEFUN |bIgen| (|n|) (|bDelay| #'|bIgen1| (LIST |n|))) -(DEFUN |bIgen1| (|n|) - (PROGN (SETQ |n| (+ |n| 1)) (CONS |n| (|bIgen| |n|)))) +(DEFUN |bIgen1| (|n|) (PROGN (SETQ |n| (+ |n| 1)) (CONS |n| (|bIgen| |n|)))) (DEFUN |bAddLineNumber| (|f1| |f2|) (|bDelay| #'|bAddLineNumber1| (LIST |f1| |f2|))) (DEFUN |bAddLineNumber1| (|f1| |f2|) - (COND - ((|bStreamNull| |f1|) (LIST '|nullstream|)) - ((|bStreamNull| |f2|) (LIST '|nullstream|)) - (T (CONS (CONS (CAR |f1|) (CAR |f2|)) - (|bAddLineNumber| (CDR |f1|) (CDR |f2|)))))) + (COND ((|bStreamNull| |f1|) (LIST '|nullstream|)) + ((|bStreamNull| |f2|) (LIST '|nullstream|)) + (T + (CONS (CONS (CAR |f1|) (CAR |f2|)) + (|bAddLineNumber| (CDR |f1|) (CDR |f2|)))))) (DEFUN |shoePrefixLisp| (|x|) (CONCAT ")lisp" |x|)) @@ -161,26 +147,22 @@ (DEFUN |shoePrefix?| (|prefix| |whole|) (PROG (|good|) (RETURN - (COND - ((< (LENGTH |whole|) (LENGTH |prefix|)) NIL) - (T (SETQ |good| T) - (LET ((|bfVar#1| (- (LENGTH |prefix|) 1)) (|i| 0) (|j| 0)) - (LOOP - (COND - ((OR (> |i| |bfVar#1|) (NOT |good|)) (RETURN NIL)) - (T (SETQ |good| - (CHAR= (SCHAR |prefix| |i|) - (SCHAR |whole| |j|))))) + (COND ((< (LENGTH |whole|) (LENGTH |prefix|)) NIL) + (T (SETQ |good| T) + (LET ((|bfVar#1| (- (LENGTH |prefix|) 1)) (|i| 0) (|j| 0)) + (LOOP + (COND ((OR (> |i| |bfVar#1|) (NOT |good|)) (RETURN NIL)) + (T + (SETQ |good| + (CHAR= (SCHAR |prefix| |i|) + (SCHAR |whole| |j|))))) (SETQ |i| (+ |i| 1)) (SETQ |j| (+ |j| 1)))) - (COND - (|good| (|subString| |whole| (LENGTH |prefix|))) - (T |good|))))))) + (COND (|good| (|subString| |whole| (LENGTH |prefix|))) + (T |good|))))))) (DEFUN |shoePlainLine?| (|s|) - (COND - ((EQL (LENGTH |s|) 0) T) - (T (NOT (CHAR= (SCHAR |s| 0) (|char| '|)|)))))) + (COND ((EQL (LENGTH |s|) 0) T) (T (NOT (CHAR= (SCHAR |s| 0) (|char| '|)|)))))) (DEFUN |shoeSay?| (|s|) (|shoePrefix?| ")say" |s|)) @@ -203,69 +185,61 @@ (DEFUN |shoeBiteOff| (|x|) (PROG (|n1| |n|) (RETURN - (PROGN - (SETQ |n| (STRPOSL " " |x| 0 T)) - (COND - ((NULL |n|) NIL) - (T (SETQ |n1| (STRPOSL " " |x| |n| NIL)) - (COND - ((NULL |n1|) (LIST (|subString| |x| |n|) "")) - (T (LIST (|subString| |x| |n| (- |n1| |n|)) - (|subString| |x| |n1|)))))))))) + (PROGN + (SETQ |n| (STRPOSL " " |x| 0 T)) + (COND ((NULL |n|) NIL) + (T (SETQ |n1| (STRPOSL " " |x| |n| NIL)) + (COND ((NULL |n1|) (LIST (|subString| |x| |n|) "")) + (T + (LIST (|subString| |x| |n| (- |n1| |n|)) + (|subString| |x| |n1|)))))))))) (DEFUN |shoeFileName| (|x|) (PROG (|c| |a|) (RETURN - (PROGN - (SETQ |a| (|shoeBiteOff| |x|)) - (COND - ((NULL |a|) "") - (T (SETQ |c| (|shoeBiteOff| (CADR |a|))) - (COND - ((NULL |c|) (CAR |a|)) - (T (CONCAT (CAR |a|) "." (CAR |c|)))))))))) + (PROGN + (SETQ |a| (|shoeBiteOff| |x|)) + (COND ((NULL |a|) "") + (T (SETQ |c| (|shoeBiteOff| (CADR |a|))) + (COND ((NULL |c|) (CAR |a|)) + (T (CONCAT (CAR |a|) "." (CAR |c|)))))))))) (DEFUN |shoeFnFileName| (|x|) (PROG (|c| |a|) (RETURN - (PROGN - (SETQ |a| (|shoeBiteOff| |x|)) - (COND - ((NULL |a|) (LIST "" "")) - (T (SETQ |c| (|shoeFileName| (CADR |a|))) - (COND - ((NULL |c|) (LIST (CAR |a|) "")) - (T (LIST (CAR |a|) |c|))))))))) + (PROGN + (SETQ |a| (|shoeBiteOff| |x|)) + (COND ((NULL |a|) (LIST "" "")) + (T (SETQ |c| (|shoeFileName| (CADR |a|))) + (COND ((NULL |c|) (LIST (CAR |a|) "")) + (T (LIST (CAR |a|) |c|))))))))) (DEFUN |shoeInclude| (|s|) (|bDelay| #'|shoeInclude1| (LIST |s|))) (DEFUN |shoeInclude1| (|s|) (PROG (|command| |string| |t| |h|) (RETURN - (COND - ((|bStreamNull| |s|) |s|) - (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|)) - (SETQ |string| (CAR |h|)) - (COND - ((SETQ |command| (|shoeFin?| |string|)) |$bStreamNil|) - ((SETQ |command| (|shoeIf?| |string|)) - (|shoeThen| (LIST T) (LIST (STTOMC |command|)) |t|)) - (T (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|))))))))) + (COND ((|bStreamNull| |s|) |s|) + (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|)) + (SETQ |string| (CAR |h|)) + (COND ((SETQ |command| (|shoeFin?| |string|)) |$bStreamNil|) + ((SETQ |command| (|shoeIf?| |string|)) + (|shoeThen| (LIST T) (LIST (STTOMC |command|)) |t|)) + (T + (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|))))))))) (DEFUN |shoeSimpleLine| (|h|) (PROG (|command| |string|) (RETURN - (PROGN - (SETQ |string| (CAR |h|)) - (COND - ((|shoePlainLine?| |string|) (LIST |h|)) - ((SETQ |command| (|shoeLisp?| |string|)) (LIST |h|)) - ((SETQ |command| (|shoeLine?| |string|)) (LIST |h|)) - ((SETQ |command| (|shoeSay?| |string|)) - (|shoeConsole| |command|) NIL) - ((SETQ |command| (|shoeEval?| |string|)) (STTOMC |command|) - NIL) - (T (|shoeLineSyntaxError| |h|) NIL)))))) + (PROGN + (SETQ |string| (CAR |h|)) + (COND ((|shoePlainLine?| |string|) (LIST |h|)) + ((SETQ |command| (|shoeLisp?| |string|)) (LIST |h|)) + ((SETQ |command| (|shoeLine?| |string|)) (LIST |h|)) + ((SETQ |command| (|shoeSay?| |string|)) (|shoeConsole| |command|) + NIL) + ((SETQ |command| (|shoeEval?| |string|)) (STTOMC |command|) NIL) + (T (|shoeLineSyntaxError| |h|) NIL)))))) (DEFUN |shoeThen| (|keep| |b| |s|) (|bDelay| #'|shoeThen1| (LIST |keep| |b| |s|))) @@ -273,44 +247,40 @@ (DEFUN |shoeThen1| (|keep| |b| |s|) (PROG (|b1| |keep1| |command| |string| |t| |h|) (RETURN - (COND - ((|bPremStreamNull| |s|) |s|) - (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|)) - (SETQ |string| (CAR |h|)) - (COND - ((SETQ |command| (|shoeFin?| |string|)) - (|bPremStreamNil| |h|)) + (COND ((|bPremStreamNull| |s|) |s|) + (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|)) + (SETQ |string| (CAR |h|)) + (COND + ((SETQ |command| (|shoeFin?| |string|)) (|bPremStreamNil| |h|)) (T (SETQ |keep1| (CAR |keep|)) (SETQ |b1| (CAR |b|)) + (COND + ((SETQ |command| (|shoeIf?| |string|)) (COND - ((SETQ |command| (|shoeIf?| |string|)) - (COND - ((AND |keep1| |b1|) - (|shoeThen| (CONS T |keep|) - (CONS (STTOMC |command|) |b|) |t|)) - (T (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) - |t|)))) - ((SETQ |command| (|shoeElseIf?| |string|)) - (COND - ((AND |keep1| (NOT |b1|)) - (|shoeThen| (CONS T (CDR |keep|)) - (CONS (STTOMC |command|) (CDR |b|)) |t|)) - (T (|shoeThen| (CONS NIL (CDR |keep|)) - (CONS NIL (CDR |b|)) |t|)))) - ((SETQ |command| (|shoeElse?| |string|)) - (COND - ((AND |keep1| (NOT |b1|)) - (|shoeElse| (CONS T (CDR |keep|)) - (CONS T (CDR |b|)) |t|)) - (T (|shoeElse| (CONS NIL (CDR |keep|)) - (CONS NIL (CDR |b|)) |t|)))) - ((SETQ |command| (|shoeEndIf?| |string|)) - (COND - ((NULL (CDR |b|)) (|shoeInclude| |t|)) - (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|)))) - ((AND |keep1| |b1|) - (|bAppend| (|shoeSimpleLine| |h|) - (|shoeThen| |keep| |b| |t|))) - (T (|shoeThen| |keep| |b| |t|)))))))))) + ((AND |keep1| |b1|) + (|shoeThen| (CONS T |keep|) (CONS (STTOMC |command|) |b|) + |t|)) + (T (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|)))) + ((SETQ |command| (|shoeElseIf?| |string|)) + (COND + ((AND |keep1| (NOT |b1|)) + (|shoeThen| (CONS T (CDR |keep|)) + (CONS (STTOMC |command|) (CDR |b|)) |t|)) + (T + (|shoeThen| (CONS NIL (CDR |keep|)) (CONS NIL (CDR |b|)) + |t|)))) + ((SETQ |command| (|shoeElse?| |string|)) + (COND + ((AND |keep1| (NOT |b1|)) + (|shoeElse| (CONS T (CDR |keep|)) (CONS T (CDR |b|)) |t|)) + (T + (|shoeElse| (CONS NIL (CDR |keep|)) (CONS NIL (CDR |b|)) + |t|)))) + ((SETQ |command| (|shoeEndIf?| |string|)) + (COND ((NULL (CDR |b|)) (|shoeInclude| |t|)) + (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|)))) + ((AND |keep1| |b1|) + (|bAppend| (|shoeSimpleLine| |h|) (|shoeThen| |keep| |b| |t|))) + (T (|shoeThen| |keep| |b| |t|)))))))))) (DEFUN |shoeElse| (|keep| |b| |s|) (|bDelay| #'|shoeElse1| (LIST |keep| |b| |s|))) @@ -318,50 +288,42 @@ (DEFUN |shoeElse1| (|keep| |b| |s|) (PROG (|keep1| |b1| |command| |string| |t| |h|) (RETURN - (COND - ((|bPremStreamNull| |s|) |s|) - (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|)) - (SETQ |string| (CAR |h|)) - (COND - ((SETQ |command| (|shoeFin?| |string|)) - (|bPremStreamNil| |h|)) + (COND ((|bPremStreamNull| |s|) |s|) + (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|)) + (SETQ |string| (CAR |h|)) + (COND + ((SETQ |command| (|shoeFin?| |string|)) (|bPremStreamNil| |h|)) (T (SETQ |b1| (CAR |b|)) (SETQ |keep1| (CAR |keep|)) + (COND + ((SETQ |command| (|shoeIf?| |string|)) (COND - ((SETQ |command| (|shoeIf?| |string|)) - (COND - ((AND |keep1| |b1|) - (|shoeThen| (CONS T |keep|) - (CONS (STTOMC |command|) |b|) |t|)) - (T (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) - |t|)))) - ((SETQ |command| (|shoeEndIf?| |string|)) - (COND - ((NULL (CDR |b|)) (|shoeInclude| |t|)) - (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|)))) - ((AND |keep1| |b1|) - (|bAppend| (|shoeSimpleLine| |h|) - (|shoeElse| |keep| |b| |t|))) - (T (|shoeElse| |keep| |b| |t|)))))))))) + ((AND |keep1| |b1|) + (|shoeThen| (CONS T |keep|) (CONS (STTOMC |command|) |b|) + |t|)) + (T (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|)))) + ((SETQ |command| (|shoeEndIf?| |string|)) + (COND ((NULL (CDR |b|)) (|shoeInclude| |t|)) + (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|)))) + ((AND |keep1| |b1|) + (|bAppend| (|shoeSimpleLine| |h|) (|shoeElse| |keep| |b| |t|))) + (T (|shoeElse| |keep| |b| |t|)))))))))) (DEFUN |shoeLineSyntaxError| (|h|) (PROGN - (|shoeConsole| - (CONCAT "INCLUSION SYNTAX ERROR IN LINE " - (WRITE-TO-STRING (CDR |h|)))) - (|shoeConsole| (CAR |h|)) - (|shoeConsole| "LINE IGNORED"))) + (|shoeConsole| + (CONCAT "INCLUSION SYNTAX ERROR IN LINE " (WRITE-TO-STRING (CDR |h|)))) + (|shoeConsole| (CAR |h|)) + (|shoeConsole| "LINE IGNORED"))) (DEFUN |bPremStreamNil| (|h|) (PROGN - (|shoeConsole| - (CONCAT "UNEXPECTED )fin IN LINE " (WRITE-TO-STRING (CDR |h|)))) - (|shoeConsole| (CAR |h|)) - (|shoeConsole| "REST OF FILE IGNORED") - |$bStreamNil|)) + (|shoeConsole| + (CONCAT "UNEXPECTED )fin IN LINE " (WRITE-TO-STRING (CDR |h|)))) + (|shoeConsole| (CAR |h|)) + (|shoeConsole| "REST OF FILE IGNORED") + |$bStreamNil|)) (DEFUN |bPremStreamNull| (|s|) - (COND - ((|bStreamNull| |s|) - (|shoeConsole| "FILE TERMINATED BEFORE )endif") T) - (T NIL))) + (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 index 0d5f4199..898c6192 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -10,39 +10,32 @@ (PROVIDE "parser") (DEFUN |bpFirstToken| () - (DECLARE (SPECIAL |$ttok| |$stok| |$inputStream|)) + (DECLARE (SPECIAL |$inputStream| |$stok| |$ttok|)) (PROGN - (SETQ |$stok| - (COND + (SETQ |$stok| + (COND ((NULL |$inputStream|) - (|shoeTokConstruct| 'ERROR 'NOMORE - (|shoeTokPosn| |$stok|))) + (|shoeTokConstruct| 'ERROR 'NOMORE (|shoeTokPosn| |$stok|))) (T (CAR |$inputStream|)))) - (SETQ |$ttok| (|shoeTokPart| |$stok|)) - T)) + (SETQ |$ttok| (|shoeTokPart| |$stok|)) + T)) (DEFUN |bpFirstTok| () - (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$ttok| |$stok| - |$inputStream|)) + (DECLARE (SPECIAL |$inputStream| |$stok| |$ttok| |$bpParenCount| |$bpCount|)) (PROGN - (SETQ |$stok| - (COND + (SETQ |$stok| + (COND ((NULL |$inputStream|) - (|shoeTokConstruct| 'ERROR 'NOMORE - (|shoeTokPosn| |$stok|))) + (|shoeTokConstruct| 'ERROR 'NOMORE (|shoeTokPosn| |$stok|))) (T (CAR |$inputStream|)))) - (SETQ |$ttok| (|shoeTokPart| |$stok|)) - (COND - ((AND (PLUSP |$bpParenCount|) (CONSP |$stok|) - (EQ (CAR |$stok|) 'KEY)) - (COND - ((EQ |$ttok| 'SETTAB) (SETQ |$bpCount| (+ |$bpCount| 1)) - (|bpNext|)) - ((EQ |$ttok| 'BACKTAB) (SETQ |$bpCount| (- |$bpCount| 1)) - (|bpNext|)) - ((EQ |$ttok| 'BACKSET) (|bpNext|)) - (T T))) - (T T)))) + (SETQ |$ttok| (|shoeTokPart| |$stok|)) + (COND + ((AND (PLUSP |$bpParenCount|) (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY)) + (COND ((EQ |$ttok| 'SETTAB) (SETQ |$bpCount| (+ |$bpCount| 1)) (|bpNext|)) + ((EQ |$ttok| 'BACKTAB) (SETQ |$bpCount| (- |$bpCount| 1)) + (|bpNext|)) + ((EQ |$ttok| 'BACKSET) (|bpNext|)) (T T))) + (T T)))) (DEFUN |bpNext| () (DECLARE (SPECIAL |$inputStream|)) @@ -53,201 +46,179 @@ (PROGN (SETQ |$inputStream| (CDR |$inputStream|)) (|bpFirstToken|))) (DEFUN |bpState| () - (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$stack| |$inputStream|)) + (DECLARE (SPECIAL |$inputStream| |$stack| |$bpParenCount| |$bpCount|)) (LIST |$inputStream| |$stack| |$bpParenCount| |$bpCount|)) (DEFUN |bpRestore| (|x|) - (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$stack| |$inputStream|)) + (DECLARE (SPECIAL |$inputStream| |$stack| |$bpParenCount| |$bpCount|)) (PROGN - (SETQ |$inputStream| (CAR |x|)) - (|bpFirstToken|) - (SETQ |$stack| (CADR |x|)) - (SETQ |$bpParenCount| (CADDR |x|)) - (SETQ |$bpCount| (CADDDR |x|)) - T)) + (SETQ |$inputStream| (CAR |x|)) + (|bpFirstToken|) + (SETQ |$stack| (CADR |x|)) + (SETQ |$bpParenCount| (CADDR |x|)) + (SETQ |$bpCount| (CADDDR |x|)) + T)) (DEFUN |bpPush| (|x|) (DECLARE (SPECIAL |$stack|)) (SETQ |$stack| (CONS |x| |$stack|))) (DEFUN |bpPushId| () - (DECLARE (SPECIAL |$stack| |$ttok|)) + (DECLARE (SPECIAL |$ttok| |$stack|)) (SETQ |$stack| (CONS (|bfReName| |$ttok|) |$stack|))) (DEFUN |bpPop1| () (PROG (|a|) (DECLARE (SPECIAL |$stack|)) (RETURN - (PROGN - (SETQ |a| (CAR |$stack|)) - (SETQ |$stack| (CDR |$stack|)) - |a|)))) + (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|)))) + (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|)))) + (PROGN + (SETQ |a| (CADDR |$stack|)) + (RPLACD (CDR |$stack|) (CDDDR |$stack|)) + |a|)))) (DEFUN |bpIndentParenthesized| (|f|) (PROG (|$bpCount| |a|) - (DECLARE (SPECIAL |$inputStream| |$bpCount| |$bpParenCount| - |$stok|)) + (DECLARE (SPECIAL |$stok| |$bpParenCount| |$inputStream| |$bpCount|)) (RETURN - (PROGN - (SETQ |$bpCount| 0) - (SETQ |a| |$stok|) + (PROGN + (SETQ |$bpCount| 0) + (SETQ |a| |$stok|) + (COND + ((|bpEqPeek| 'OPAREN) (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) + (|bpNext|) (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) - (T (SETQ |$inputStream| - (|append| (|bpAddTokens| |$bpCount|) - |$inputStream|)) - (|bpFirstToken|) - (COND - ((EQL |$bpParenCount| 0) (|bpCancel|) T) - (T T))))) - ((|bpEqPeek| 'CPAREN) (|bpPush| (|bfTuple| NIL)) - (SETQ |$bpParenCount| (- |$bpParenCount| 1)) - (|bpNextToken|) T) - (T (|bpParenTrap| |a|)))) - (T NIL)))))) + ((AND (APPLY |f| NIL) (|bpFirstTok|) + (OR (|bpEqPeek| 'CPAREN) (|bpParenTrap| |a|))) + (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpNextToken|) + (COND ((EQL |$bpCount| 0) T) + (T + (SETQ |$inputStream| + (|append| (|bpAddTokens| |$bpCount|) |$inputStream|)) + (|bpFirstToken|) + (COND ((EQL |$bpParenCount| 0) (|bpCancel|) T) (T T))))) + ((|bpEqPeek| 'CPAREN) (|bpPush| (|bfTuple| NIL)) + (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpNextToken|) T) + (T (|bpParenTrap| |a|)))) + (T NIL)))))) (DEFUN |bpParenthesized| (|f|) (PROG (|a|) (DECLARE (SPECIAL |$stok|)) (RETURN - (PROGN - (SETQ |a| |$stok|) + (PROGN + (SETQ |a| |$stok|) + (COND + ((|bpEqKey| 'OPAREN) (COND - ((|bpEqKey| 'OPAREN) - (COND - ((AND (APPLY |f| NIL) - (OR (|bpEqKey| 'CPAREN) (|bpParenTrap| |a|))) - T) - ((|bpEqKey| 'CPAREN) (|bpPush| (|bfTuple| NIL)) T) - (T (|bpParenTrap| |a|)))) - (T NIL)))))) + ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'CPAREN) (|bpParenTrap| |a|))) T) + ((|bpEqKey| 'CPAREN) (|bpPush| (|bfTuple| NIL)) T) + (T (|bpParenTrap| |a|)))) + (T NIL)))))) (DEFUN |bpBracket| (|f|) (PROG (|a|) (DECLARE (SPECIAL |$stok|)) (RETURN - (PROGN - (SETQ |a| |$stok|) + (PROGN + (SETQ |a| |$stok|) + (COND + ((|bpEqKey| 'OBRACK) (COND - ((|bpEqKey| 'OBRACK) - (COND - ((AND (APPLY |f| NIL) - (OR (|bpEqKey| 'CBRACK) (|bpBrackTrap| |a|))) - (|bpPush| (|bfBracket| (|bpPop1|)))) - ((|bpEqKey| 'CBRACK) (|bpPush| NIL)) - (T (|bpBrackTrap| |a|)))) - (T NIL)))))) + ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'CBRACK) (|bpBrackTrap| |a|))) + (|bpPush| (|bfBracket| (|bpPop1|)))) + ((|bpEqKey| 'CBRACK) (|bpPush| NIL)) (T (|bpBrackTrap| |a|)))) + (T NIL)))))) (DEFUN |bpPileBracketed| (|f|) (COND - ((|bpEqKey| 'SETTAB) - (COND - ((|bpEqKey| 'BACKTAB) T) - ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'BACKTAB) (|bpPileTrap|))) - (|bpPush| (|bfPile| (|bpPop1|)))) - (T NIL))) - (T NIL))) + ((|bpEqKey| 'SETTAB) + (COND ((|bpEqKey| 'BACKTAB) T) + ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'BACKTAB) (|bpPileTrap|))) + (|bpPush| (|bfPile| (|bpPop1|)))) + (T NIL))) + (T 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 (|reverse!| |$stack|) |a|)) - (|bpPush| - (FUNCALL |g| - (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) - (T T))) - (T NIL))))) + (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 (|reverse!| |$stack|) |a|)) + (|bpPush| + (FUNCALL |g| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) + (T T))) + (T 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 (|reverse!| |$stack|) |a|)) - (|bpPush| - (FUNCALL |g| - (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) - (T T))) - (T NIL))))) + (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 (|reverse!| |$stack|) |a|)) + (|bpPush| + (FUNCALL |g| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) + (T T))) + (T NIL))))) (DEFUN |bpList| (|f| |str1|) (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 (|reverse!| |$stack|) |a|)) - (|bpPush| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|))))) - (T (|bpPush| (LIST (|bpPop1|)))))) - (T (|bpPush| NIL)))))) + (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 (|reverse!| |$stack|) |a|)) + (|bpPush| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|))))) + (T (|bpPush| (LIST (|bpPop1|)))))) + (T (|bpPush| NIL)))))) (DEFUN |bpOneOrMore| (|f|) (PROG (|a|) (DECLARE (SPECIAL |$stack|)) (RETURN - (COND - ((APPLY |f| NIL) (SETQ |a| |$stack|) (SETQ |$stack| NIL) - (LOOP (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) (T 0))) - (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|)) - (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))) - (T NIL))))) + (COND + ((APPLY |f| NIL) (SETQ |a| |$stack|) (SETQ |$stack| NIL) + (LOOP (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) (T 0))) + (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|)) + (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))) + (T NIL))))) (DEFUN |bpAnyNo| (|s|) (PROGN (LOOP (COND ((NOT (APPLY |s| NIL)) (RETURN NIL)) (T 0))) T)) @@ -258,48 +229,44 @@ (DEFUN |bpConditional| (|f|) (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))) - (T (|bpMissing| 'THEN)))) + ((AND (|bpEqKey| 'IF) (OR (|bpWhere|) (|bpTrap|)) + (OR (|bpEqKey| 'BACKSET) T)) + (COND + ((|bpEqKey| 'SETTAB) + (COND ((|bpEqKey| 'THEN) - (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|))) - (T (|bpMissing| '|then|)))) - (T NIL))) + (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|) + (|bpEqKey| 'BACKTAB))) + (T (|bpMissing| 'THEN)))) + ((|bpEqKey| 'THEN) (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|))) + (T (|bpMissing| '|then|)))) + (T 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|))))))))) + (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| () - (COND - ((|bpEqKey| 'BACKSET) (|bpEqKey| 'ELSE)) - (T (|bpEqKey| 'ELSE)))) + (COND ((|bpEqKey| 'BACKSET) (|bpEqKey| 'ELSE)) (T (|bpEqKey| 'ELSE)))) (DEFUN |bpEqPeek| (|s|) - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$stok| |$ttok|)) (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|))) (DEFUN |bpEqKey| (|s|) - (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|) - (|bpNext|))) + (DECLARE (SPECIAL |$stok| |$ttok|)) + (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|) (|bpNext|))) (DEFUN |bpEqKeyNextTok| (|s|) - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$stok| |$ttok|)) (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|) (|bpNextToken|))) @@ -311,200 +278,186 @@ (DEFUN |bpMissingMate| (|close| |open|) (PROGN - (|bpSpecificErrorAtToken| |open| "possibly missing mate") - (|bpMissing| |close|))) + (|bpSpecificErrorAtToken| |open| "possibly missing mate") + (|bpMissing| |close|))) (DEFUN |bpMissing| (|s|) (PROGN - (|bpSpecificErrorHere| (CONCAT (PNAME |s|) " possibly missing")) - (THROW :OPEN-AXIOM-CATCH-POINT - (CONS :OPEN-AXIOM-CATCH-POINT - (CONS '(|BootParserException|) 'TRAPPED))))) + (|bpSpecificErrorHere| (CONCAT (PNAME |s|) " possibly missing")) + (THROW :OPEN-AXIOM-CATCH-POINT + (CONS :OPEN-AXIOM-CATCH-POINT (CONS '(|BootParserException|) 'TRAPPED))))) (DEFUN |bpCompMissing| (|s|) (OR (|bpEqKey| |s|) (|bpMissing| |s|))) (DEFUN |bpTrap| () (PROGN - (|bpGeneralErrorHere|) - (THROW :OPEN-AXIOM-CATCH-POINT - (CONS :OPEN-AXIOM-CATCH-POINT - (CONS '(|BootParserException|) 'TRAPPED))))) + (|bpGeneralErrorHere|) + (THROW :OPEN-AXIOM-CATCH-POINT + (CONS :OPEN-AXIOM-CATCH-POINT (CONS '(|BootParserException|) '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"))))))) + (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|)) + (DECLARE (SPECIAL |$stack| |$inputStream|)) (RETURN - (PROGN - (SETQ |a| |$stack|) - (SETQ |b| NIL) - (SETQ |$stack| NIL) - (SETQ |done| NIL) - (SETQ |c| |$inputStream|) - (LOOP - (COND - (|done| (RETURN NIL)) - (T (SETQ |found| - (LET ((#0=#:G1354 - (CATCH :OPEN-AXIOM-CATCH-POINT - (APPLY |f| NIL)))) - (COND - ((AND (CONSP #0#) - (EQUAL (CAR #0#) - :OPEN-AXIOM-CATCH-POINT)) + (PROGN + (SETQ |a| |$stack|) + (SETQ |b| NIL) + (SETQ |$stack| NIL) + (SETQ |done| NIL) + (SETQ |c| |$inputStream|) + (LOOP + (COND (|done| (RETURN NIL)) + (T + (SETQ |found| + (LET ((#1=#:G719 + (CATCH :OPEN-AXIOM-CATCH-POINT (APPLY |f| NIL)))) + (COND + ((AND (CONSP #1#) + (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT)) (COND - ((EQUAL (CAR #1=(CDR #0#)) - '(|BootParserException|)) - (LET ((|e| (CDR #1#))) |e|)) - (T (THROW :OPEN-AXIOM-CATCH-POINT #0#)))) - (T #0#)))) - (COND - ((EQ |found| 'TRAPPED) (SETQ |$inputStream| |c|) - (|bpRecoverTrap|)) - ((NOT |found|) (SETQ |$inputStream| |c|) - (|bpGeneralErrorHere|) (|bpRecoverTrap|))) - (COND - ((|bpEqKey| 'BACKSET) (SETQ |c| |$inputStream|)) - ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|)) - (SETQ |done| T)) - (T (SETQ |$inputStream| |c|) (|bpGeneralErrorHere|) - (|bpRecoverTrap|) - (COND + ((EQUAL (CAR #2=(CDR #1#)) '(|BootParserException|)) + (LET ((|e| (CDR #2#))) + |e|)) + (T (THROW :OPEN-AXIOM-CATCH-POINT #1#)))) + (T #1#)))) + (COND + ((EQ |found| 'TRAPPED) (SETQ |$inputStream| |c|) + (|bpRecoverTrap|)) + ((NOT |found|) (SETQ |$inputStream| |c|) (|bpGeneralErrorHere|) + (|bpRecoverTrap|))) + (COND ((|bpEqKey| 'BACKSET) (SETQ |c| |$inputStream|)) + ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|)) + (SETQ |done| T)) + (T (SETQ |$inputStream| |c|) (|bpGeneralErrorHere|) + (|bpRecoverTrap|) + (COND ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|)) (SETQ |done| T)) (T (|bpNext|) (SETQ |c| |$inputStream|))))) - (SETQ |b| (CONS (|bpPop1|) |b|))))) - (SETQ |$stack| |a|) - (|bpPush| (|reverse!| |b|)))))) + (SETQ |b| (CONS (|bpPop1|) |b|))))) + (SETQ |$stack| |a|) + (|bpPush| (|reverse!| |b|)))))) (DEFUN |bpMoveTo| (|n|) - (DECLARE (SPECIAL |$bpParenCount| |$bpCount| |$inputStream|)) - (COND - ((NULL |$inputStream|) T) - ((|bpEqPeek| 'BACKTAB) - (COND - ((EQL |n| 0) T) - (T (|bpNextToken|) (SETQ |$bpCount| (- |$bpCount| 1)) - (|bpMoveTo| (- |n| 1))))) - ((|bpEqPeek| 'BACKSET) - (COND ((EQL |n| 0) T) (T (|bpNextToken|) (|bpMoveTo| |n|)))) - ((|bpEqPeek| 'SETTAB) (|bpNextToken|) (|bpMoveTo| (+ |n| 1))) - ((|bpEqPeek| 'OPAREN) (|bpNextToken|) - (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) (|bpMoveTo| |n|)) - ((|bpEqPeek| 'CPAREN) (|bpNextToken|) - (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpMoveTo| |n|)) - (T (|bpNextToken|) (|bpMoveTo| |n|)))) + (DECLARE (SPECIAL |$inputStream| |$bpCount| |$bpParenCount|)) + (COND ((NULL |$inputStream|) T) + ((|bpEqPeek| 'BACKTAB) + (COND ((EQL |n| 0) T) + (T (|bpNextToken|) (SETQ |$bpCount| (- |$bpCount| 1)) + (|bpMoveTo| (- |n| 1))))) + ((|bpEqPeek| 'BACKSET) + (COND ((EQL |n| 0) T) (T (|bpNextToken|) (|bpMoveTo| |n|)))) + ((|bpEqPeek| 'SETTAB) (|bpNextToken|) (|bpMoveTo| (+ |n| 1))) + ((|bpEqPeek| 'OPAREN) (|bpNextToken|) + (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) (|bpMoveTo| |n|)) + ((|bpEqPeek| 'CPAREN) (|bpNextToken|) + (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpMoveTo| |n|)) + (T (|bpNextToken|) (|bpMoveTo| |n|)))) (DEFUN |bpQualifiedName| () (DECLARE (SPECIAL |$stok|)) (COND - ((|bpEqPeek| 'COLON-COLON) (|bpNext|) - (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (|bpPushId|) - (|bpNext|) (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|))))) - (T NIL))) + ((|bpEqPeek| 'COLON-COLON) (|bpNext|) + (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (|bpPushId|) (|bpNext|) + (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|))))) + (T NIL))) (DEFUN |bpName| () (DECLARE (SPECIAL |$stok|)) (COND - ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID)) (|bpPushId|) - (|bpNext|) (|bpAnyNo| #'|bpQualifiedName|)) - (T NIL))) + ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID)) (|bpPushId|) (|bpNext|) + (|bpAnyNo| #'|bpQualifiedName|)) + (T NIL))) (DEFUN |bpConstTok| () - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$stok| |$ttok|)) (COND - ((|symbolMember?| (|shoeTokType| |$stok|) '(INTEGER FLOAT)) - (|bpPush| |$ttok|) (|bpNext|)) - ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LISP)) - (AND (|bpPush| (|%Lisp| |$ttok|)) (|bpNext|))) - ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LISPEXP)) - (AND (|bpPush| |$ttok|) (|bpNext|))) - ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LINE)) - (AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|))) - ((|bpEqPeek| 'QUOTE) (|bpNext|) - (AND (OR (|bpSexp|) (|bpTrap|)) - (|bpPush| (|bfSymbol| (|bpPop1|))))) - (T (|bpString|)))) + ((|symbolMember?| (|shoeTokType| |$stok|) '(INTEGER FLOAT)) + (|bpPush| |$ttok|) (|bpNext|)) + ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LISP)) + (AND (|bpPush| (|%Lisp| |$ttok|)) (|bpNext|))) + ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LISPEXP)) + (AND (|bpPush| |$ttok|) (|bpNext|))) + ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LINE)) + (AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|))) + ((|bpEqPeek| 'QUOTE) (|bpNext|) + (AND (OR (|bpSexp|) (|bpTrap|)) (|bpPush| (|bfSymbol| (|bpPop1|))))) + (T (|bpString|)))) (DEFUN |bpExportItemTail| () - (OR (AND (|bpEqKey| 'BEC) (OR (|bpAssign|) (|bpTrap|)) - (|bpPush| (|%Assignment| (|bpPop2|) (|bpPop1|)))) - (|bpSimpleDefinitionTail|))) + (OR + (AND (|bpEqKey| 'BEC) (OR (|bpAssign|) (|bpTrap|)) + (|bpPush| (|%Assignment| (|bpPop2|) (|bpPop1|)))) + (|bpSimpleDefinitionTail|))) (DEFUN |bpExportItem| () (PROG (|a|) (RETURN - (COND - ((|bpEqPeek| 'STRUCTURE) (|bpStruct|)) - (T (SETQ |a| (|bpState|)) - (COND + (COND ((|bpEqPeek| 'STRUCTURE) (|bpStruct|)) + (T (SETQ |a| (|bpState|)) + (COND ((|bpName|) (COND - ((|bpEqPeek| 'COLON) (|bpRestore| |a|) - (OR (|bpSignature|) (|bpTrap|)) - (OR (|bpExportItemTail|) T)) - (T (|bpRestore| |a|) (|bpTypeAliasDefition|)))) + ((|bpEqPeek| 'COLON) (|bpRestore| |a|) + (OR (|bpSignature|) (|bpTrap|)) (OR (|bpExportItemTail|) T)) + (T (|bpRestore| |a|) (|bpTypeAliasDefition|)))) (T NIL))))))) (DEFUN |bpExportItemList| () (|bpListAndRecover| #'|bpExportItem|)) (DEFUN |bpModuleInterface| () (COND - ((|bpEqKey| 'WHERE) - (OR (|bpPileBracketed| #'|bpExportItemList|) - (AND (|bpExportItem|) (|bpPush| (LIST (|bpPop1|)))) - (|bpTrap|))) - (T (|bpPush| NIL)))) + ((|bpEqKey| 'WHERE) + (OR (|bpPileBracketed| #'|bpExportItemList|) + (AND (|bpExportItem|) (|bpPush| (LIST (|bpPop1|)))) (|bpTrap|))) + (T (|bpPush| NIL)))) (DEFUN |bpModuleExports| () - (COND - ((|bpParenthesized| #'|bpIdList|) - (|bpPush| (|bfUntuple| (|bpPop1|)))) - (T (|bpPush| NIL)))) + (COND ((|bpParenthesized| #'|bpIdList|) (|bpPush| (|bfUntuple| (|bpPop1|)))) + (T (|bpPush| NIL)))) (DEFUN |bpModule| () (COND - ((|bpEqKey| 'MODULE) (OR (|bpName|) (|bpTrap|)) (|bpModuleExports|) - (|bpModuleInterface|) - (|bpPush| (|%Module| (|bpPop3|) (|bpPop2|) (|bpPop1|)))) - (T NIL))) + ((|bpEqKey| 'MODULE) (OR (|bpName|) (|bpTrap|)) (|bpModuleExports|) + (|bpModuleInterface|) + (|bpPush| (|%Module| (|bpPop3|) (|bpPop2|) (|bpPop1|)))) + (T NIL))) (DEFUN |bpImport| () (PROG (|a|) (RETURN - (COND - ((|bpEqKey| 'IMPORT) - (COND - ((|bpNamespace|) (|bpPush| (|%Import| (|bpPop1|)))) - (T (SETQ |a| (|bpState|)) (OR (|bpName|) (|bpTrap|)) + (COND + ((|bpEqKey| 'IMPORT) + (COND ((|bpNamespace|) (|bpPush| (|%Import| (|bpPop1|)))) + (T (SETQ |a| (|bpState|)) (OR (|bpName|) (|bpTrap|)) (COND - ((|bpEqPeek| 'COLON) (|bpRestore| |a|) - (AND (OR (|bpSignature|) (|bpTrap|)) - (OR (|bpEqKey| 'FOR) (|bpTrap|)) - (OR (|bpName|) (|bpTrap|)) - (|bpPush| - (|%ImportSignature| (|bpPop1|) (|bpPop1|))))) - (T (|bpPush| (|%Import| (|bpPop1|)))))))) - (T NIL))))) + ((|bpEqPeek| 'COLON) (|bpRestore| |a|) + (AND (OR (|bpSignature|) (|bpTrap|)) + (OR (|bpEqKey| 'FOR) (|bpTrap|)) + (OR (|bpName|) (|bpTrap|)) + (|bpPush| (|%ImportSignature| (|bpPop1|) (|bpPop1|))))) + (T (|bpPush| (|%Import| (|bpPop1|)))))))) + (T NIL))))) (DEFUN |bpNamespace| () (AND (|bpEqKey| 'NAMESPACE) (OR (|bpName|) (|bpDot|)) (|bpPush| (|bfNamespace| (|bpPop1|))))) (DEFUN |bpTypeAliasDefition| () - (AND (OR (|bpTerm| #'|bpIdList|) (|bpTrap|)) (|bpEqKey| 'TDEF) - (|bpLogical|) (|bpPush| (|%TypeAlias| (|bpPop2|) (|bpPop1|))))) + (AND (OR (|bpTerm| #'|bpIdList|) (|bpTrap|)) (|bpEqKey| 'TDEF) (|bpLogical|) + (|bpPush| (|%TypeAlias| (|bpPop2|) (|bpPop1|))))) (DEFUN |bpSignature| () (AND (|bpName|) (|bpEqKey| 'COLON) (|bpTyping|) @@ -512,11 +465,11 @@ (DEFUN |bpSimpleMapping| () (COND - ((|bpApplication|) - (AND (|bpEqKey| 'ARROW) (OR (|bpApplication|) (|bpTrap|)) - (|bpPush| (|%Mapping| (|bpPop1|) (LIST (|bpPop1|))))) - T) - (T NIL))) + ((|bpApplication|) + (AND (|bpEqKey| 'ARROW) (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|%Mapping| (|bpPop1|) (LIST (|bpPop1|))))) + T) + (T NIL))) (DEFUN |bpArgtypeList| () (|bpTuple| #'|bpApplication|)) @@ -528,28 +481,25 @@ (DEFUN |bpCancel| () (PROG (|a|) (RETURN - (PROGN - (SETQ |a| (|bpState|)) + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpEqKeyNextTok| 'SETTAB) (COND - ((|bpEqKeyNextTok| 'SETTAB) - (COND - ((|bpCancel|) - (COND - ((|bpEqKeyNextTok| 'BACKTAB) T) - (T (|bpRestore| |a|) NIL))) - ((|bpEqKeyNextTok| 'BACKTAB) T) - (T (|bpRestore| |a|) NIL))) - (T NIL)))))) + ((|bpCancel|) + (COND ((|bpEqKeyNextTok| 'BACKTAB) T) (T (|bpRestore| |a|) NIL))) + ((|bpEqKeyNextTok| 'BACKTAB) T) (T (|bpRestore| |a|) NIL))) + (T NIL)))))) (DEFUN |bpAddTokens| (|n|) (DECLARE (SPECIAL |$stok|)) - (COND - ((EQL |n| 0) NIL) - ((PLUSP |n|) - (CONS (|shoeTokConstruct| 'KEY 'SETTAB (|shoeTokPosn| |$stok|)) - (|bpAddTokens| (- |n| 1)))) - (T (CONS (|shoeTokConstruct| 'KEY 'BACKTAB (|shoeTokPosn| |$stok|)) - (|bpAddTokens| (+ |n| 1)))))) + (COND ((EQL |n| 0) NIL) + ((PLUSP |n|) + (CONS (|shoeTokConstruct| 'KEY 'SETTAB (|shoeTokPosn| |$stok|)) + (|bpAddTokens| (- |n| 1)))) + (T + (CONS (|shoeTokConstruct| 'KEY 'BACKTAB (|shoeTokPosn| |$stok|)) + (|bpAddTokens| (+ |n| 1)))))) (DEFUN |bpExceptions| () (OR (|bpEqPeek| 'DOT) (|bpEqPeek| 'QUOTE) (|bpEqPeek| 'OPAREN) @@ -558,27 +508,24 @@ (DEFUN |bpSexpKey| () (PROG (|a|) - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$stok| |$ttok|)) (RETURN - (COND - ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) - (NOT (|bpExceptions|))) - (SETQ |a| (GET |$ttok| 'SHOEINF)) - (COND - ((NULL |a|) (AND (|bpPush| |$ttok|) (|bpNext|))) - (T (AND (|bpPush| |a|) (|bpNext|))))) - (T NIL))))) + (COND + ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (NOT (|bpExceptions|))) + (SETQ |a| (GET |$ttok| 'SHOEINF)) + (COND ((NULL |a|) (AND (|bpPush| |$ttok|) (|bpNext|))) + (T (AND (|bpPush| |a|) (|bpNext|))))) + (T NIL))))) (DEFUN |bpAnyId| () - (DECLARE (SPECIAL |$ttok| |$stok|)) - (OR (AND (|bpEqKey| 'MINUS) - (OR (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'INTEGER)) - (|bpTrap|)) - (|bpPush| (- |$ttok|)) (|bpNext|)) - (|bpSexpKey|) - (AND (|symbolMember?| (|shoeTokType| |$stok|) - '(ID INTEGER STRING FLOAT)) - (|bpPush| |$ttok|) (|bpNext|)))) + (DECLARE (SPECIAL |$stok| |$ttok|)) + (OR + (AND (|bpEqKey| 'MINUS) + (OR (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'INTEGER)) (|bpTrap|)) + (|bpPush| (- |$ttok|)) (|bpNext|)) + (|bpSexpKey|) + (AND (|symbolMember?| (|shoeTokType| |$stok|) '(ID INTEGER STRING FLOAT)) + (|bpPush| |$ttok|) (|bpNext|)))) (DEFUN |bpSexp| () (OR (|bpAnyId|) @@ -587,24 +534,23 @@ (|bpIndentParenthesized| #'|bpSexp1|))) (DEFUN |bpSexp1| () - (OR (AND (|bpFirstTok|) (|bpSexp|) - (OR (AND (|bpEqKey| 'DOT) (|bpSexp|) - (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))) - (AND (|bpSexp1|) - (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))))) - (|bpPush| NIL))) + (OR + (AND (|bpFirstTok|) (|bpSexp|) + (OR + (AND (|bpEqKey| 'DOT) (|bpSexp|) + (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))) + (AND (|bpSexp1|) (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))))) + (|bpPush| NIL))) (DEFUN |bpPrimary1| () - (OR (|bpParenthesizedApplication|) (|bpDot|) (|bpConstTok|) - (|bpConstruct|) (|bpCase|) (|bpStruct|) (|bpPDefinition|) - (|bpBPileDefinition|))) + (OR (|bpParenthesizedApplication|) (|bpDot|) (|bpConstTok|) (|bpConstruct|) + (|bpCase|) (|bpStruct|) (|bpPDefinition|) (|bpBPileDefinition|))) (DEFUN |bpParenthesizedApplication| () (AND (|bpName|) (|bpAnyNo| #'|bpArgumentList|))) (DEFUN |bpArgumentList| () - (AND (|bpPDefinition|) - (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|))))) + (AND (|bpPDefinition|) (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|))))) (DEFUN |bpPrimary| () (AND (|bpFirstTok|) (OR (|bpPrimary1|) (|bpPrefixOperator|)))) @@ -612,95 +558,94 @@ (DEFUN |bpDot| () (AND (|bpEqKey| 'DOT) (|bpPush| (|bfDot|)))) (DEFUN |bpPrefixOperator| () - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$stok| |$ttok|)) (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (GET |$ttok| 'SHOEPRE) (|bpPushId|) (|bpNext|))) (DEFUN |bpInfixOperator| () - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$stok| |$ttok|)) (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (GET |$ttok| 'SHOEINF) (|bpPushId|) (|bpNext|))) (DEFUN |bpSelector| () (AND (|bpEqKey| 'DOT) - (OR (AND (|bpPrimary|) - (|bpPush| (|bfElt| (|bpPop2|) (|bpPop1|)))) + (OR (AND (|bpPrimary|) (|bpPush| (|bfElt| (|bpPop2|) (|bpPop1|)))) (|bpPush| (|bfSuffixDot| (|bpPop1|)))))) (DEFUN |bpApplication| () - (OR (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|) - (OR (AND (|bpApplication|) - (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) - T)) - (|bpNamespace|))) + (OR + (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|) + (OR + (AND (|bpApplication|) + (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) + T)) + (|bpNamespace|))) (DEFUN |bpTyping| () (COND - ((|bpEqKey| 'FORALL) (OR (|bpVariable|) (|bpTrap|)) - (OR (AND (|bpDot|) (|bpPop1|)) (|bpTrap|)) - (OR (|bpTyping|) (|bpTrap|)) - (|bpPush| (|%Forall| (|bpPop2|) (|bpPop1|)))) - (T (OR (|bpMapping|) (|bpSimpleMapping|))))) + ((|bpEqKey| 'FORALL) (OR (|bpVariable|) (|bpTrap|)) + (OR (AND (|bpDot|) (|bpPop1|)) (|bpTrap|)) (OR (|bpTyping|) (|bpTrap|)) + (|bpPush| (|%Forall| (|bpPop2|) (|bpPop1|)))) + (T (OR (|bpMapping|) (|bpSimpleMapping|))))) (DEFUN |bpTagged| () (AND (|bpApplication|) - (OR (AND (|bpEqKey| 'COLON) (OR (|bpTyping|) (|bpTrap|)) - (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|)))) - T))) + (OR + (AND (|bpEqKey| 'COLON) (OR (|bpTyping|) (|bpTrap|)) + (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|)))) + T))) (DEFUN |bpExpt| () (|bpRightAssoc| '(POWER) #'|bpTagged|)) (DEFUN |bpInfKey| (|s|) - (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) - (|symbolMember?| |$ttok| |s|) (|bpPushId|) (|bpNext|))) + (DECLARE (SPECIAL |$stok| |$ttok|)) + (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (|symbolMember?| |$ttok| |s|) + (|bpPushId|) (|bpNext|))) -(DEFUN |bpInfGeneric| (|s|) - (AND (|bpInfKey| |s|) (OR (|bpEqKey| 'BACKSET) T))) +(DEFUN |bpInfGeneric| (|s|) (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)))))) + (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|) (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))) + ((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| () - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$stok| |$ttok|)) (AND (EQ (|shoeTokType| |$stok|) 'STRING) (|bpPush| (|quote| (INTERN |$ttok|))) (|bpNext|))) (DEFUN |bpThetaName| () - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$stok| |$ttok|)) (COND - ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) - (GET |$ttok| 'SHOETHETA)) - (|bpPushId|) (|bpNext|)) - (T NIL))) + ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (GET |$ttok| 'SHOETHETA)) + (|bpPushId|) (|bpNext|)) + (T NIL))) (DEFUN |bpReduceOperator| () (OR (|bpInfixOperator|) (|bpString|) (|bpThetaName|))) @@ -708,82 +653,80 @@ (DEFUN |bpReduce| () (PROG (|a|) (RETURN - (PROGN - (SETQ |a| (|bpState|)) + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((AND (|bpReduceOperator|) (|bpEqKey| 'SLASH)) (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)))))) + ((|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| () - (OR (|bpReduce|) (|bpLeftAssoc| '(TIMES SLASH) #'|bpExpt|))) +(DEFUN |bpTimes| () (OR (|bpReduce|) (|bpLeftAssoc| '(TIMES SLASH) #'|bpExpt|))) (DEFUN |bpEuclid| () (|bpLeftAssoc| '(QUO REM) #'|bpTimes|)) (DEFUN |bpMinus| () - (OR (AND (|bpInfGeneric| '(MINUS)) (OR (|bpEuclid|) (|bpTrap|)) - (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) - (|bpEuclid|))) + (OR + (AND (|bpInfGeneric| '(MINUS)) (OR (|bpEuclid|) (|bpTrap|)) + (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) + (|bpEuclid|))) (DEFUN |bpArith| () (|bpLeftAssoc| '(PLUS MINUS) #'|bpMinus|)) (DEFUN |bpIs| () (AND (|bpArith|) (COND - ((AND (|bpInfKey| '(IS ISNT)) (OR (|bpPattern|) (|bpTrap|))) - (|bpPush| - (|bfISApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|)))) - ((AND (|bpEqKey| 'HAS) (OR (|bpApplication|) (|bpTrap|))) - (|bpPush| (|bfHas| (|bpPop2|) (|bpPop1|)))) - (T T)))) + ((AND (|bpInfKey| '(IS ISNT)) (OR (|bpPattern|) (|bpTrap|))) + (|bpPush| (|bfISApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|)))) + ((AND (|bpEqKey| 'HAS) (OR (|bpApplication|) (|bpTrap|))) + (|bpPush| (|bfHas| (|bpPop2|) (|bpPop1|)))) + (T T)))) (DEFUN |bpBracketConstruct| (|f|) (AND (|bpBracket| |f|) (|bpPush| (|bfConstruct| (|bpPop1|))))) (DEFUN |bpCompare| () - (OR (AND (|bpIs|) - (OR (AND (|bpInfKey| '(SHOEEQ SHOENE LT LE GT GE IN)) - (OR (|bpIs|) (|bpTrap|)) - (|bpPush| - (|bfInfApplication| (|bpPop2|) (|bpPop2|) - (|bpPop1|)))) - T)) - (|bpLeave|) (|bpThrow|))) + (OR + (AND (|bpIs|) + (OR + (AND (|bpInfKey| '(SHOEEQ SHOENE LT LE GT GE IN)) + (OR (|bpIs|) (|bpTrap|)) + (|bpPush| (|bfInfApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|)))) + T)) + (|bpLeave|) (|bpThrow|))) (DEFUN |bpAnd| () (|bpLeftAssoc| '(AND) #'|bpCompare|)) (DEFUN |bpThrow| () (COND - ((AND (|bpEqKey| 'THROW) (|bpApplication|)) - (COND - ((|bpEqKey| 'COLON) (OR (|bpApplication|) (|bpTrap|)) - (|bpPush| (|%Pretend| (|bpPop2|) (|bpPop1|))))) - (|bpPush| (|bfThrow| (|bpPop1|)))) - (T NIL))) + ((AND (|bpEqKey| 'THROW) (|bpApplication|)) + (COND + ((|bpEqKey| 'COLON) (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|%Pretend| (|bpPop2|) (|bpPop1|))))) + (|bpPush| (|bfThrow| (|bpPop1|)))) + (T NIL))) (DEFUN |bpTry| () (PROG (|cs|) (RETURN - (COND - ((|bpEqKey| 'TRY) (|bpAssign|) (SETQ |cs| NIL) - (LOOP - (COND - ((NOT (|bpHandler| 'CATCH)) (RETURN NIL)) - (T (|bpCatchItem|) (SETQ |cs| (CONS (|bpPop1|) |cs|))))) - (COND - ((|bpHandler| 'FINALLY) - (AND (|bpFinally|) - (|bpPush| - (|bfTry| (|bpPop2|) - (|reverse!| (CONS (|bpPop1|) |cs|)))))) - ((NULL |cs|) (|bpTrap|)) - (T (|bpPush| (|bfTry| (|bpPop1|) (|reverse!| |cs|)))))) - (T NIL))))) + (COND + ((|bpEqKey| 'TRY) (|bpAssign|) (SETQ |cs| NIL) + (LOOP + (COND ((NOT (|bpHandler| 'CATCH)) (RETURN NIL)) + (T (|bpCatchItem|) (SETQ |cs| (CONS (|bpPop1|) |cs|))))) + (COND + ((|bpHandler| 'FINALLY) + (AND (|bpFinally|) + (|bpPush| + (|bfTry| (|bpPop2|) (|reverse!| (CONS (|bpPop1|) |cs|)))))) + ((NULL |cs|) (|bpTrap|)) + (T (|bpPush| (|bfTry| (|bpPop1|) (|reverse!| |cs|)))))) + (T NIL))))) (DEFUN |bpCatchItem| () (AND (OR (|bpExceptionVariable|) (|bpTrap|)) @@ -794,11 +737,12 @@ (PROG (|t|) (DECLARE (SPECIAL |$stok|)) (RETURN - (PROGN - (SETQ |t| |$stok|) - (OR (AND (|bpEqKey| 'OPAREN) (OR (|bpSignature|) (|bpTrap|)) - (OR (|bpEqKey| 'CPAREN) (|bpMissing| |t|))) - (|bpTrap|)))))) + (PROGN + (SETQ |t| |$stok|) + (OR + (AND (|bpEqKey| 'OPAREN) (OR (|bpSignature|) (|bpTrap|)) + (OR (|bpEqKey| 'CPAREN) (|bpMissing| |t|))) + (|bpTrap|)))))) (DEFUN |bpFinally| () (AND (OR (|bpAssign|) (|bpTrap|)) (|bpPush| (|%Finally| (|bpPop1|))))) @@ -806,13 +750,13 @@ (DEFUN |bpHandler| (|key|) (PROG (|s|) (RETURN - (PROGN - (SETQ |s| (|bpState|)) - (COND - ((AND (OR (|bpEqKey| 'BACKSET) (|bpEqKey| 'SEMICOLON)) - (|bpEqKey| |key|)) - T) - (T (|bpRestore| |s|) NIL)))))) + (PROGN + (SETQ |s| (|bpState|)) + (COND + ((AND (OR (|bpEqKey| 'BACKSET) (|bpEqKey| 'SEMICOLON)) + (|bpEqKey| |key|)) + T) + (T (|bpRestore| |s|) NIL)))))) (DEFUN |bpLeave| () (AND (|bpEqKey| 'LEAVE) (OR (|bpLogical|) (|bpTrap|)) @@ -820,36 +764,36 @@ (DEFUN |bpDo| () (COND - ((|bpEqKey| 'IN) (OR (|bpNamespace|) (|bpTrap|)) - (OR (|bpDo|) (|bpTrap|)) - (|bpPush| (|bfAtScope| (|bpPop2|) (|bpPop1|)))) - (T (AND (|bpEqKey| 'DO) (OR (|bpAssign|) (|bpTrap|)) - (|bpPush| (|bfDo| (|bpPop1|))))))) + ((|bpEqKey| 'IN) (OR (|bpNamespace|) (|bpTrap|)) (OR (|bpDo|) (|bpTrap|)) + (|bpPush| (|bfAtScope| (|bpPop2|) (|bpPop1|)))) + (T + (AND (|bpEqKey| 'DO) (OR (|bpAssign|) (|bpTrap|)) + (|bpPush| (|bfDo| (|bpPop1|))))))) (DEFUN |bpReturn| () - (OR (AND (|bpEqKey| 'RETURN) (OR (|bpAssign|) (|bpTrap|)) - (|bpPush| (|bfReturnNoName| (|bpPop1|)))) - (|bpLeave|) (|bpThrow|) (|bpAnd|) (|bpDo|))) + (OR + (AND (|bpEqKey| 'RETURN) (OR (|bpAssign|) (|bpTrap|)) + (|bpPush| (|bfReturnNoName| (|bpPop1|)))) + (|bpLeave|) (|bpThrow|) (|bpAnd|) (|bpDo|))) (DEFUN |bpLogical| () (|bpLeftAssoc| '(OR) #'|bpReturn|)) (DEFUN |bpExpression| () - (OR (AND (|bpEqKey| 'COLON) - (OR (AND (|bpLogical|) - (|bpPush| (|bfApplication| 'COLON (|bpPop1|)))) - (|bpTrap|))) - (|bpLogical|))) + (OR + (AND (|bpEqKey| 'COLON) + (OR (AND (|bpLogical|) (|bpPush| (|bfApplication| 'COLON (|bpPop1|)))) + (|bpTrap|))) + (|bpLogical|))) (DEFUN |bpStatement| () - (OR (|bpConditional| #'|bpWhere|) (|bpLoop|) (|bpExpression|) - (|bpTry|))) + (OR (|bpConditional| #'|bpWhere|) (|bpLoop|) (|bpExpression|) (|bpTry|))) (DEFUN |bpLoop| () - (OR (AND (|bpIterators|) (|bpCompMissing| 'REPEAT) - (OR (|bpWhere|) (|bpTrap|)) - (|bpPush| (|bfLp| (|bpPop2|) (|bpPop1|)))) - (AND (|bpEqKey| 'REPEAT) (OR (|bpLogical|) (|bpTrap|)) - (|bpPush| (|bfLoop1| (|bpPop1|)))))) + (OR + (AND (|bpIterators|) (|bpCompMissing| 'REPEAT) (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|bfLp| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'REPEAT) (OR (|bpLogical|) (|bpTrap|)) + (|bpPush| (|bfLoop1| (|bpPop1|)))))) (DEFUN |bpSuchThat| () (|bpAndOr| 'BAR #'|bpWhere| #'|bfSuchthat|)) @@ -860,32 +804,28 @@ (DEFUN |bpFormal| () (OR (|bpVariable|) (|bpDot|))) (DEFUN |bpForIn| () - (AND (|bpEqKey| 'FOR) (OR (|bpFormal|) (|bpTrap|)) - (|bpCompMissing| 'IN) - (OR (AND (OR (|bpSeg|) (|bpTrap|)) (|bpEqKey| 'BY) - (OR (|bpArith|) (|bpTrap|)) - (|bpPush| - (|bfForInBy| (|bpPop3|) (|bpPop2|) (|bpPop1|)))) - (|bpPush| (|bfForin| (|bpPop2|) (|bpPop1|)))))) + (AND (|bpEqKey| 'FOR) (OR (|bpFormal|) (|bpTrap|)) (|bpCompMissing| 'IN) + (OR + (AND (OR (|bpSeg|) (|bpTrap|)) (|bpEqKey| 'BY) + (OR (|bpArith|) (|bpTrap|)) + (|bpPush| (|bfForInBy| (|bpPop3|) (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfForin| (|bpPop2|) (|bpPop1|)))))) (DEFUN |bpSeg| () (AND (|bpArith|) - (OR (AND (|bpEqKey| 'SEG) - (OR (AND (|bpArith|) - (|bpPush| - (|bfSegment2| (|bpPop2|) (|bpPop1|)))) - (|bpPush| (|bfSegment1| (|bpPop1|))))) - T))) + (OR + (AND (|bpEqKey| 'SEG) + (OR + (AND (|bpArith|) (|bpPush| (|bfSegment2| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfSegment1| (|bpPop1|))))) + T))) -(DEFUN |bpIterator| () - (OR (|bpForIn|) (|bpSuchThat|) (|bpWhile|) (|bpUntil|))) +(DEFUN |bpIterator| () (OR (|bpForIn|) (|bpSuchThat|) (|bpWhile|) (|bpUntil|))) (DEFUN |bpIteratorList| () - (AND (|bpOneOrMore| #'|bpIterator|) - (|bpPush| (|bfIterators| (|bpPop1|))))) + (AND (|bpOneOrMore| #'|bpIterator|) (|bpPush| (|bfIterators| (|bpPop1|))))) -(DEFUN |bpCrossBackSet| () - (AND (|bpEqKey| 'CROSS) (OR (|bpEqKey| 'BACKSET) T))) +(DEFUN |bpCrossBackSet| () (AND (|bpEqKey| 'CROSS) (OR (|bpEqKey| 'BACKSET) T))) (DEFUN |bpIterators| () (|bpListofFun| #'|bpIteratorList| #'|bpCrossBackSet| #'|bfCross|)) @@ -893,21 +833,18 @@ (DEFUN |bpAssign| () (PROG (|a|) (RETURN - (PROGN - (SETQ |a| (|bpState|)) + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpStatement|) (COND - ((|bpStatement|) - (COND - ((|bpEqPeek| 'BEC) (|bpRestore| |a|) - (OR (|bpAssignment|) (|bpTrap|))) - ((|bpEqPeek| 'GIVES) (|bpRestore| |a|) - (OR (|bpLambda|) (|bpTrap|))) - (T T))) - (T (|bpRestore| |a|) NIL)))))) + ((|bpEqPeek| 'BEC) (|bpRestore| |a|) (OR (|bpAssignment|) (|bpTrap|))) + ((|bpEqPeek| 'GIVES) (|bpRestore| |a|) (OR (|bpLambda|) (|bpTrap|))) + (T T))) + (T (|bpRestore| |a|) NIL)))))) (DEFUN |bpAssignment| () - (AND (|bpAssignVariable|) (|bpEqKey| 'BEC) - (OR (|bpAssign|) (|bpTrap|)) + (AND (|bpAssignVariable|) (|bpEqKey| 'BEC) (OR (|bpAssign|) (|bpTrap|)) (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|))))) (DEFUN |bpLambda| () @@ -916,35 +853,35 @@ (DEFUN |bpExit| () (AND (|bpAssign|) - (OR (AND (|bpEqKey| 'EXIT) (OR (|bpWhere|) (|bpTrap|)) - (|bpPush| (|bfExit| (|bpPop2|) (|bpPop1|)))) - T))) + (OR + (AND (|bpEqKey| 'EXIT) (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|bfExit| (|bpPop2|) (|bpPop1|)))) + T))) (DEFUN |bpDefinition| () (PROG (|a|) (RETURN - (COND - ((|bpEqKey| 'MACRO) - (OR (AND (|bpName|) (|bpStoreName|) - (|bpCompoundDefinitionTail| #'|%Macro|)) - (|bpTrap|))) - (T (SETQ |a| (|bpState|)) - (COND - ((|bpExit|) - (COND - ((|bpEqPeek| 'DEF) (|bpRestore| |a|) (|bpDef|)) - ((|bpEqPeek| 'TDEF) (|bpRestore| |a|) - (|bpTypeAliasDefition|)) - (T T))) - (T (|bpRestore| |a|) NIL))))))) + (COND + ((|bpEqKey| 'MACRO) + (OR + (AND (|bpName|) (|bpStoreName|) + (|bpCompoundDefinitionTail| #'|%Macro|)) + (|bpTrap|))) + (T (SETQ |a| (|bpState|)) + (COND + ((|bpExit|) + (COND ((|bpEqPeek| 'DEF) (|bpRestore| |a|) (|bpDef|)) + ((|bpEqPeek| 'TDEF) (|bpRestore| |a|) (|bpTypeAliasDefition|)) + (T T))) + (T (|bpRestore| |a|) NIL))))))) (DEFUN |bpStoreName| () - (DECLARE (SPECIAL |$typings| |$wheredefs| |$op| |$stack|)) + (DECLARE (SPECIAL |$stack| |$op| |$wheredefs| |$typings|)) (PROGN - (SETQ |$op| (CAR |$stack|)) - (SETQ |$wheredefs| NIL) - (SETQ |$typings| NIL) - T)) + (SETQ |$op| (CAR |$stack|)) + (SETQ |$wheredefs| NIL) + (SETQ |$typings| NIL) + T)) (DEFUN |bpDef| () (AND (|bpName|) (|bpStoreName|) (|bpDefTail| #'|%Definition|))) @@ -964,24 +901,22 @@ (DEFUN |bpWhere| () (AND (|bpDefinition|) - (OR (AND (|bpEqKey| 'WHERE) (OR (|bpDefinitionItem|) (|bpTrap|)) - (|bpPush| (|bfWhere| (|bpPop1|) (|bpPop1|)))) - T))) + (OR + (AND (|bpEqKey| 'WHERE) (OR (|bpDefinitionItem|) (|bpTrap|)) + (|bpPush| (|bfWhere| (|bpPop1|) (|bpPop1|)))) + T))) (DEFUN |bpDefinitionItem| () (PROG (|a|) (RETURN - (PROGN - (SETQ |a| (|bpState|)) - (COND - ((|bpDDef|) T) - (T (|bpRestore| |a|) - (COND - ((|bpBDefinitionPileItems|) T) - (T (|bpRestore| |a|) - (COND - ((|bpPDefinitionItems|) T) - (T (|bpRestore| |a|) (|bpWhere|))))))))))) + (PROGN + (SETQ |a| (|bpState|)) + (COND ((|bpDDef|) T) + (T (|bpRestore| |a|) + (COND ((|bpBDefinitionPileItems|) T) + (T (|bpRestore| |a|) + (COND ((|bpPDefinitionItems|) T) + (T (|bpRestore| |a|) (|bpWhere|))))))))))) (DEFUN |bpDefinitionPileItems| () (AND (|bpListAndRecover| #'|bpDefinitionItem|) @@ -993,23 +928,18 @@ (DEFUN |bpSemiColonDefinition| () (|bpSemiListing| #'|bpDefinitionItem| #'|%Pile|)) -(DEFUN |bpPDefinitionItems| () - (|bpParenthesized| #'|bpSemiColonDefinition|)) +(DEFUN |bpPDefinitionItems| () (|bpParenthesized| #'|bpSemiColonDefinition|)) (DEFUN |bpComma| () - (OR (|bpModule|) (|bpImport|) (|bpNamespace|) - (|bpTuple| #'|bpWhere|))) + (OR (|bpModule|) (|bpImport|) (|bpNamespace|) (|bpTuple| #'|bpWhere|))) -(DEFUN |bpTuple| (|p|) - (|bpListofFun| |p| #'|bpCommaBackSet| #'|bfTuple|)) +(DEFUN |bpTuple| (|p|) (|bpListofFun| |p| #'|bpCommaBackSet| #'|bfTuple|)) -(DEFUN |bpCommaBackSet| () - (AND (|bpEqKey| 'COMMA) (OR (|bpEqKey| 'BACKSET) T))) +(DEFUN |bpCommaBackSet| () (AND (|bpEqKey| 'COMMA) (OR (|bpEqKey| 'BACKSET) T))) (DEFUN |bpSemiColon| () (|bpSemiListing| #'|bpComma| #'|bfSequence|)) -(DEFUN |bpSemiListing| (|p| |f|) - (|bpListofFun| |p| #'|bpSemiBackSet| |f|)) +(DEFUN |bpSemiListing| (|p| |f|) (|bpListofFun| |p| #'|bpSemiBackSet| |f|)) (DEFUN |bpSemiBackSet| () (AND (|bpEqKey| 'SEMICOLON) (OR (|bpEqKey| 'BACKSET) T))) @@ -1022,39 +952,39 @@ (DEFUN |bpBPileDefinition| () (|bpPileBracketed| #'|bpPileItems|)) -(DEFUN |bpIteratorTail| () - (AND (OR (|bpEqKey| 'REPEAT) T) (|bpIterators|))) +(DEFUN |bpIteratorTail| () (AND (OR (|bpEqKey| 'REPEAT) T) (|bpIterators|))) (DEFUN |bpConstruct| () (|bpBracket| #'|bpConstruction|)) (DEFUN |bpConstruction| () (AND (|bpComma|) - (OR (AND (|bpIteratorTail|) - (|bpPush| (|bfCollect| (|bpPop2|) (|bpPop1|)))) - (|bpPush| (|bfTupleConstruct| (|bpPop1|)))))) + (OR + (AND (|bpIteratorTail|) (|bpPush| (|bfCollect| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfTupleConstruct| (|bpPop1|)))))) (DEFUN |bpDConstruct| () (|bpBracket| #'|bpDConstruction|)) (DEFUN |bpDConstruction| () (AND (|bpComma|) - (OR (AND (|bpIteratorTail|) - (|bpPush| (|bfDCollect| (|bpPop2|) (|bpPop1|)))) - (|bpPush| (|bfDTuple| (|bpPop1|)))))) + (OR + (AND (|bpIteratorTail|) + (|bpPush| (|bfDCollect| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfDTuple| (|bpPop1|)))))) (DEFUN |bpPattern| () (OR (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) (|bpConstTok|))) (DEFUN |bpEqual| () - (AND (|bpEqKey| 'SHOEEQ) - (OR (|bpApplication|) (|bpConstTok|) (|bpTrap|)) + (AND (|bpEqKey| 'SHOEEQ) (OR (|bpApplication|) (|bpConstTok|) (|bpTrap|)) (|bpPush| (|bfEqual| (|bpPop1|))))) (DEFUN |bpRegularPatternItem| () (OR (|bpEqual|) (|bpConstTok|) (|bpDot|) (AND (|bpName|) - (OR (AND (|bpEqKey| 'BEC) (OR (|bpPattern|) (|bpTrap|)) - (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) - T)) + (OR + (AND (|bpEqKey| 'BEC) (OR (|bpPattern|) (|bpTrap|)) + (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) + T)) (|bpBracketConstruct| #'|bpPatternL|))) (DEFUN |bpRegularPatternItemL| () @@ -1072,37 +1002,40 @@ (DEFUN |bpPatternList| () (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|)))) + ((|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| () (AND (|bpPatternColon|) - (OR (AND (|bpEqKey| 'COMMA) (OR (|bpRegularList|) (|bpTrap|)) - (|bpPush| (|append| (|bpPop2|) (|bpPop1|)))) - T))) + (OR + (AND (|bpEqKey| 'COMMA) (OR (|bpRegularList|) (|bpTrap|)) + (|bpPush| (|append| (|bpPop2|) (|bpPop1|)))) + T))) (DEFUN |bpRegularBVItemTail| () - (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|)))) - (AND (|bpEqKey| 'DEF) (OR (|bpApplication|) (|bpTrap|)) - (|bpPush| (|%DefaultValue| (|bpPop2|) (|bpPop1|)))))) + (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|)))) + (AND (|bpEqKey| 'DEF) (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|%DefaultValue| (|bpPop2|) (|bpPop1|)))))) (DEFUN |bpRegularBVItem| () (OR (|bpBVString|) (|bpConstTok|) @@ -1110,7 +1043,7 @@ (|bpBracketConstruct| #'|bpPatternL|))) (DEFUN |bpBVString| () - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$stok| |$ttok|)) (AND (EQ (|shoeTokType| |$stok|) 'STRING) (|bpPush| (LIST 'BVQUOTE (INTERN |$ttok|))) (|bpNext|))) @@ -1122,54 +1055,53 @@ (DEFUN |bpBoundVariablelist| () (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|))))))) + ((|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 |bpVariable| () - (OR (AND (|bpParenthesized| #'|bpBoundVariablelist|) - (|bpPush| (|bfTupleIf| (|bpPop1|)))) - (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) (|bpConstTok|))) + (OR + (AND (|bpParenthesized| #'|bpBoundVariablelist|) + (|bpPush| (|bfTupleIf| (|bpPop1|)))) + (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) (|bpConstTok|))) (DEFUN |bpAssignVariable| () (OR (|bpBracketConstruct| #'|bpPatternL|) (|bpAssignLHS|))) (DEFUN |bpAssignLHS| () - (COND - ((NOT (|bpName|)) NIL) - ((|bpEqKey| 'COLON) (OR (|bpApplication|) (|bpTrap|)) - (|bpPush| (|bfLocal| (|bpPop2|) (|bpPop1|)))) - (T (AND (|bpArgumentList|) - (OR (|bpEqPeek| 'DOT) - (AND (|bpEqPeek| 'BEC) - (|bpPush| (|bfPlace| (|bpPop1|)))) - (|bpTrap|))) - (COND - ((|bpEqKey| 'DOT) - (AND (|bpList| #'|bpPrimary| 'DOT) (|bpChecknull|) - (|bpPush| (|bfTuple| (CONS (|bpPop2|) (|bpPop1|)))))) - (T T))))) + (COND ((NOT (|bpName|)) NIL) + ((|bpEqKey| 'COLON) (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|bfLocal| (|bpPop2|) (|bpPop1|)))) + (T + (AND (|bpArgumentList|) + (OR (|bpEqPeek| 'DOT) + (AND (|bpEqPeek| 'BEC) (|bpPush| (|bfPlace| (|bpPop1|)))) + (|bpTrap|))) + (COND + ((|bpEqKey| 'DOT) + (AND (|bpList| #'|bpPrimary| 'DOT) (|bpChecknull|) + (|bpPush| (|bfTuple| (CONS (|bpPop2|) (|bpPop1|)))))) + (T T))))) (DEFUN |bpChecknull| () (PROG (|a|) (RETURN - (PROGN - (SETQ |a| (|bpPop1|)) - (COND ((NULL |a|) (|bpTrap|)) (T (|bpPush| |a|))))))) + (PROGN + (SETQ |a| (|bpPop1|)) + (COND ((NULL |a|) (|bpTrap|)) (T (|bpPush| |a|))))))) (DEFUN |bpStruct| () (AND (|bpEqKey| 'STRUCTURE) (OR (|bpName|) (|bpTrap|)) @@ -1185,12 +1117,13 @@ (DEFUN |bpTypeItemList| () (|bpListAndRecover| #'|bpTypeItem|)) (DEFUN |bpTerm| (|idListParser|) - (OR (AND (OR (|bpName|) (|bpTrap|)) - (OR (AND (|bpParenthesized| |idListParser|) - (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))) - (AND (|bpName|) - (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))))) - (|bpPush| (|bfNameOnly| (|bpPop1|))))) + (OR + (AND (OR (|bpName|) (|bpTrap|)) + (OR + (AND (|bpParenthesized| |idListParser|) + (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))) + (AND (|bpName|) (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))))) + (|bpPush| (|bfNameOnly| (|bpPop1|))))) (DEFUN |bpIdList| () (|bpTuple| #'|bpName|)) @@ -1215,29 +1148,26 @@ (DEFUN |bpOutItem| () (PROG (|$GenVarCounter| |$op| |r| |ISTMP#2| |l| |ISTMP#1| |b|) - (DECLARE (SPECIAL |$GenVarCounter| |$op| |$InteractiveMode|)) + (DECLARE (SPECIAL |$op| |$GenVarCounter| |$InteractiveMode|)) (RETURN - (PROGN - (SETQ |$op| NIL) - (SETQ |$GenVarCounter| 0) - (OR (|bpComma|) (|bpTrap|)) - (SETQ |b| (|bpPop1|)) - (|bpPush| - (COND - ((AND (CONSP |b|) (EQ (CAR |b|) '+LINE)) (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|) - (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |r| (CAR |ISTMP#2|)) T))))) - (SYMBOLP |l|)) - (COND - (|$InteractiveMode| (LIST (LIST 'SETQ |l| |r|))) - (T (LIST (LIST 'DEFPARAMETER |l| |r|))))) - (T (|translateToplevel| |b| NIL)))))))) + (PROGN + (SETQ |$op| NIL) + (SETQ |$GenVarCounter| 0) + (OR (|bpComma|) (|bpTrap|)) + (SETQ |b| (|bpPop1|)) + (|bpPush| + (COND ((AND (CONSP |b|) (EQ (CAR |b|) '+LINE)) (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|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |r| (CAR |ISTMP#2|)) T))))) + (SYMBOLP |l|)) + (COND (|$InteractiveMode| (LIST (LIST 'SETQ |l| |r|))) + (T (LIST (LIST 'DEFPARAMETER |l| |r|))))) + (T (|translateToplevel| |b| NIL)))))))) diff --git a/src/boot/strap/pile.clisp b/src/boot/strap/pile.clisp index 934e6728..eb3ea075 100644 --- a/src/boot/strap/pile.clisp +++ b/src/boot/strap/pile.clisp @@ -16,136 +16,118 @@ (DEFUN |shoePileInsert| (|s|) (PROG (|a| |toktype|) (RETURN - (COND - ((|bStreamNull| |s|) (CONS NIL |s|)) - (T (SETQ |toktype| (|shoeTokType| (CAAAR |s|))) - (COND + (COND ((|bStreamNull| |s|) (CONS NIL |s|)) + (T (SETQ |toktype| (|shoeTokType| (CAAAR |s|))) + (COND ((OR (EQ |toktype| 'LISP) (EQ |toktype| 'LINE)) (CONS (LIST (CAR |s|)) (CDR |s|))) (T (SETQ |a| (|shoePileTree| (- 1) |s|)) - (CONS (LIST (ELT |a| 2)) (ELT |a| 3))))))))) + (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|)) - (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|)) - (T (LIST NIL |n| NIL |s|)))))))) + (COND ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|)) + (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|)) + (T (LIST NIL |n| NIL |s|)))))))) (DEFUN |eqshoePileTree| (|n| |s|) (PROG (|hh| |t| |h| |LETTMP#1|) (RETURN - (COND - ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|)) - (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|)) - (T (LIST NIL |n| NIL |s|)))))))) + (COND ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|)) + (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|)) + (T (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|))))))) + (PROGN + (SETQ |LETTMP#1| (|shoePileTree| |n| |s|)) + (SETQ |b| (CAR |LETTMP#1|)) + (SETQ |hh| (CADR . #1=(|LETTMP#1|))) + (SETQ |h| (CADDR . #1#)) + (SETQ |t| (CADDDR . #1#)) + (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|))))))) + (PROGN + (SETQ |LETTMP#1| (|eqshoePileTree| |n| |s|)) + (SETQ |b| (CAR |LETTMP#1|)) + (SETQ |n1| (CADR . #1=(|LETTMP#1|))) + (SETQ |h| (CADDR . #1#)) + (SETQ |t| (CADDDR . #1#)) + (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|))))))) + (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|) - (|dqAppend| |x| (|shoePileCforest| |y|))) +(DEFUN |shoePileCtree| (|x| |y|) (|dqAppend| |x| (|shoePileCforest| |y|))) (DEFUN |shoePileCforest| (|x|) (PROG (|b| |a|) (RETURN - (COND - ((NULL |x|) NIL) - ((NULL (CDR |x|)) (CAR |x|)) - (T (SETQ |a| (CAR |x|)) - (SETQ |b| (|shoePileCoagulate| |a| (CDR |x|))) - (COND - ((NULL (CDR |b|)) (CAR |b|)) - (T (|shoeEnPile| (|shoeSeparatePiles| |b|))))))))) + (COND ((NULL |x|) NIL) ((NULL (CDR |x|)) (CAR |x|)) + (T (SETQ |a| (CAR |x|)) + (SETQ |b| (|shoePileCoagulate| |a| (CDR |x|))) + (COND ((NULL (CDR |b|)) (CAR |b|)) + (T (|shoeEnPile| (|shoeSeparatePiles| |b|))))))))) (DEFUN |shoePileCoagulate| (|a| |b|) (PROG (|e| |d| |c|) (RETURN - (COND - ((NULL |b|) (LIST |a|)) - (T (SETQ |c| (CAR |b|)) - (COND + (COND ((NULL |b|) (LIST |a|)) + (T (SETQ |c| (CAR |b|)) + (COND ((OR (EQ (|shoeTokPart| (CAAR |c|)) 'THEN) (EQ (|shoeTokPart| (CAAR |c|)) 'ELSE)) (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|))) (T (SETQ |d| (CADR |a|)) (SETQ |e| (|shoeTokPart| |d|)) - (COND - ((AND (CONSP |d|) (EQ (CAR |d|) 'KEY) - (OR (GET |e| 'SHOEINF) (EQ |e| 'COMMA) - (EQ |e| 'SEMICOLON))) - (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|))) - (T (CONS |a| (|shoePileCoagulate| |c| (CDR |b|)))))))))))) + (COND + ((AND (CONSP |d|) (EQ (CAR |d|) 'KEY) + (OR (GET |e| 'SHOEINF) (EQ |e| 'COMMA) + (EQ |e| 'SEMICOLON))) + (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|))) + (T (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| + (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|))))))))) + (|shoeLastTokPosn| |a|)))) + (|dqConcat| + (LIST |a| |semicolon| (|shoeSeparatePiles| (CDR |x|))))))))) (DEFUN |shoeEnPile| (|x|) (|dqConcat| - (LIST (|dqUnit| - (|shoeTokConstruct| 'KEY 'SETTAB - (|shoeFirstTokPosn| |x|))) - |x| - (|dqUnit| - (|shoeTokConstruct| 'KEY 'BACKTAB - (|shoeLastTokPosn| |x|)))))) + (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 index 02b7f8c6..78c63d07 100644 --- a/src/boot/strap/scanner.clisp +++ b/src/boot/strap/scanner.clisp @@ -15,16 +15,12 @@ (PROG (|a|) (RETURN (PROGN (SETQ |a| (LIST |s|)) (CONS |a| |a|))))) (DEFUN |dqAppend| (|x| |y|) - (COND - ((NULL |x|) |y|) - ((NULL |y|) |x|) - (T (RPLACD (CDR |x|) (CAR |y|)) (RPLACD |x| (CDR |y|)) |x|))) + (COND ((NULL |x|) |y|) ((NULL |y|) |x|) + (T (RPLACD (CDR |x|) (CAR |y|)) (RPLACD |x| (CDR |y|)) |x|))) (DEFUN |dqConcat| (|ld|) - (COND - ((NULL |ld|) NIL) - ((NULL (CDR |ld|)) (CAR |ld|)) - (T (|dqAppend| (CAR |ld|) (|dqConcat| (CDR |ld|)))))) + (COND ((NULL |ld|) NIL) ((NULL (CDR |ld|)) (CAR |ld|)) + (T (|dqAppend| (CAR |ld|) (|dqConcat| (CDR |ld|)))))) (DEFUN |dqToList| (|s|) (COND ((NULL |s|) NIL) (T (CAR |s|)))) @@ -41,132 +37,120 @@ (DEFUN |shoeNextLine| (|s|) (PROG (|s1| |a|) - (DECLARE (SPECIAL |$sz| |$n| |$ln| |$r| |$f| |$linepos|)) + (DECLARE (SPECIAL |$linepos| |$f| |$r| |$ln| |$n| |$sz|)) (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) - ((CHAR= (SCHAR |$ln| |$n|) |shoeTAB|) - (SETQ |a| - (|makeString| (- 7 (REM |$n| 8)) (|char| '| |))) - (SETF (SCHAR |$ln| |$n|) (|char| '| |)) - (SETQ |$ln| (CONCAT |a| |$ln|)) - (SETQ |s1| (CONS (CONS |$ln| (CDR |$f|)) |$r|)) - (|shoeNextLine| |s1|)) - (T T))))))) + (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) + ((CHAR= (SCHAR |$ln| |$n|) |shoeTAB|) + (SETQ |a| (|makeString| (- 7 (REM |$n| 8)) (|char| '| |))) + (SETF (SCHAR |$ln| |$n|) (|char| '| |)) + (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| |dq| - |command|) - (DECLARE (SPECIAL |$floatok| |$f| |$sz| |$linepos| |$ln| |$r| |$n|)) + |command|) + (DECLARE (SPECIAL |$f| |$floatok| |$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 - ((NOT (|shoeNextLine| |s|)) (CONS NIL NIL)) - ((NULL |$n|) (|shoeLineToks| |$r|)) - ((CHAR= (SCHAR |$ln| 0) (|char| '|)|)) - (COND - ((SETQ |command| (|shoeLine?| |$ln|)) - (SETQ |dq| - (|dqUnit| + (PROGN + (SETQ |$f| NIL) + (SETQ |$r| NIL) + (SETQ |$ln| NIL) + (SETQ |$n| NIL) + (SETQ |$sz| NIL) + (SETQ |$floatok| T) + (SETQ |$linepos| |s|) + (COND ((NOT (|shoeNextLine| |s|)) (CONS NIL NIL)) + ((NULL |$n|) (|shoeLineToks| |$r|)) + ((CHAR= (SCHAR |$ln| 0) (|char| '|)|)) + (COND + ((SETQ |command| (|shoeLine?| |$ln|)) + (SETQ |dq| + (|dqUnit| (|shoeConstructToken| |$linepos| - (|shoeLeafLine| |command|) 0))) - (CONS (LIST |dq|) |$r|)) - ((SETQ |command| (|shoeLisp?| |$ln|)) - (|shoeLispToken| |$r| |command|)) - (T (|shoeLineToks| |$r|)))) - (T (SETQ |toks| NIL) + (|shoeLeafLine| |command|) 0))) + (CONS (LIST |dq|) |$r|)) + ((SETQ |command| (|shoeLisp?| |$ln|)) + (|shoeLispToken| |$r| |command|)) + (T (|shoeLineToks| |$r|)))) + (T (SETQ |toks| NIL) (LOOP - (COND - ((NOT (< |$n| |$sz|)) (RETURN NIL)) - (T (SETQ |toks| (|dqAppend| |toks| (|shoeToken|)))))) - (COND - ((NULL |toks|) (|shoeLineToks| |$r|)) - (T (CONS (LIST |toks|) |$r|))))))))) + (COND ((NOT (< |$n| |$sz|)) (RETURN NIL)) + (T (SETQ |toks| (|dqAppend| |toks| (|shoeToken|)))))) + (COND ((NULL |toks|) (|shoeLineToks| |$r|)) + (T (CONS (LIST |toks|) |$r|))))))))) (DEFUN |shoeLispToken| (|s| |string|) (PROG (|dq| |st| |r| |LETTMP#1| |linepos| |ln|) - (DECLARE (SPECIAL |$linepos| |$ln|)) + (DECLARE (SPECIAL |$ln| |$linepos|)) (RETURN - (PROGN - (COND - ((OR (EQL (LENGTH |string|) 0) - (CHAR= (SCHAR |string| 0) (|char| '|;|))) - (SETQ |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| + (PROGN + (COND + ((OR (EQL (LENGTH |string|) 0) (CHAR= (SCHAR |string| 0) (|char| '|;|))) + (SETQ |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| |linepos| (|shoeLeafLisp| |st|) - 0))) - (CONS (LIST |dq|) |r|))))) + (|shoeConstructToken| |linepos| (|shoeLeafLisp| |st|) 0))) + (CONS (LIST |dq|) |r|))))) (DEFUN |shoeAccumulateLines| (|s| |string|) (PROG (|a| |command|) - (DECLARE (SPECIAL |$ln| |$r| |$n|)) + (DECLARE (SPECIAL |$n| |$r| |$ln|)) (RETURN - (COND - ((NOT (|shoeNextLine| |s|)) (CONS |s| |string|)) - ((NULL |$n|) (|shoeAccumulateLines| |$r| |string|)) - ((EQL (LENGTH |$ln|) 0) (|shoeAccumulateLines| |$r| |string|)) - ((CHAR= (SCHAR |$ln| 0) (|char| '|)|)) - (SETQ |command| (|shoeLisp?| |$ln|)) - (COND - ((AND |command| (PLUSP (LENGTH |command|))) + (COND ((NOT (|shoeNextLine| |s|)) (CONS |s| |string|)) + ((NULL |$n|) (|shoeAccumulateLines| |$r| |string|)) + ((EQL (LENGTH |$ln|) 0) (|shoeAccumulateLines| |$r| |string|)) + ((CHAR= (SCHAR |$ln| 0) (|char| '|)|)) + (SETQ |command| (|shoeLisp?| |$ln|)) (COND - ((CHAR= (SCHAR |command| 0) (|char| '|;|)) - (|shoeAccumulateLines| |$r| |string|)) - ((SETQ |a| (|charPosition| (|char| '|;|) |command| 0)) - (|shoeAccumulateLines| |$r| - (CONCAT |string| - (|subString| |command| 0 (- |a| 1))))) - (T (|shoeAccumulateLines| |$r| - (CONCAT |string| |command|))))) - (T (|shoeAccumulateLines| |$r| |string|)))) - (T (CONS |s| |string|)))))) + ((AND |command| (PLUSP (LENGTH |command|))) + (COND + ((CHAR= (SCHAR |command| 0) (|char| '|;|)) + (|shoeAccumulateLines| |$r| |string|)) + ((SETQ |a| (|charPosition| (|char| '|;|) |command| 0)) + (|shoeAccumulateLines| |$r| + (CONCAT |string| + (|subString| |command| 0 + (- |a| 1))))) + (T (|shoeAccumulateLines| |$r| (CONCAT |string| |command|))))) + (T (|shoeAccumulateLines| |$r| |string|)))) + (T (CONS |s| |string|)))))) (DEFUN |shoeCloser| (|t|) (|symbolMember?| (|shoeKeyWord| |t|) '(CPAREN CBRACK))) (DEFUN |shoeToken| () (PROG (|b| |ch| |n| |linepos|) - (DECLARE (SPECIAL |$ln| |$n| |$linepos|)) + (DECLARE (SPECIAL |$linepos| |$n| |$ln|)) (RETURN - (PROGN - (SETQ |linepos| |$linepos|) - (SETQ |n| |$n|) - (SETQ |ch| (SCHAR |$ln| |$n|)) - (SETQ |b| - (COND - ((|shoeStartsComment|) (|shoeComment|) NIL) - ((|shoeStartsNegComment|) (|shoeNegComment|) NIL) - ((CHAR= |ch| (|char| '!)) (|shoeLispEscape|)) - ((|shoePunctuation| (CHAR-CODE |ch|)) (|shoePunct|)) - ((|shoeStartsId| |ch|) (|shoeWord| NIL)) - ((CHAR= |ch| (|char| '| |)) (|shoeSpace|) NIL) - ((CHAR= |ch| (|char| '|"|)) (|shoeString|)) - ((DIGIT-CHAR-P |ch|) (|shoeNumber|)) - ((CHAR= |ch| (|char| '_)) (|shoeEscape|)) - ((EQUAL |ch| |shoeTAB|) (SETQ |$n| (+ |$n| 1)) NIL) - (T (|shoeError|)))) - (COND - ((NULL |b|) NIL) - (T (|dqUnit| (|shoeConstructToken| |linepos| |b| |n|)))))))) + (PROGN + (SETQ |linepos| |$linepos|) + (SETQ |n| |$n|) + (SETQ |ch| (SCHAR |$ln| |$n|)) + (SETQ |b| + (COND ((|shoeStartsComment|) (|shoeComment|) NIL) + ((|shoeStartsNegComment|) (|shoeNegComment|) NIL) + ((CHAR= |ch| (|char| '!)) (|shoeLispEscape|)) + ((|shoePunctuation| (CHAR-CODE |ch|)) (|shoePunct|)) + ((|shoeStartsId| |ch|) (|shoeWord| NIL)) + ((CHAR= |ch| (|char| '| |)) (|shoeSpace|) NIL) + ((CHAR= |ch| (|char| '|"|)) (|shoeString|)) + ((DIGIT-CHAR-P |ch|) (|shoeNumber|)) + ((CHAR= |ch| (|char| '_)) (|shoeEscape|)) + ((EQUAL |ch| |shoeTAB|) (SETQ |$n| (+ |$n| 1)) NIL) + (T (|shoeError|)))) + (COND ((NULL |b|) NIL) + (T (|dqUnit| (|shoeConstructToken| |linepos| |b| |n|)))))))) (DEFUN |shoeLeafId| (|x|) (LIST 'ID (INTERN |x|))) @@ -177,12 +161,10 @@ (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|))))) + (PROGN + (SETQ |b| (|shoeIntValue| (CONCAT |a| |w|))) + (SETQ |c| (* (|double| |b|) (EXPT (|double| 10) (- |e| (LENGTH |w|))))) + (LIST 'FLOAT |c|))))) (DEFUN |shoeLeafString| (|x|) (LIST 'STRING |x|)) @@ -202,318 +184,288 @@ (DEFUN |shoeLispEscape| () (PROG (|n| |exp| |a|) - (DECLARE (SPECIAL |$ln| |$linepos| |$sz| |$n|)) + (DECLARE (SPECIAL |$n| |$sz| |$linepos| |$ln|)) (RETURN - (PROGN - (SETQ |$n| (+ |$n| 1)) + (PROGN + (SETQ |$n| (+ |$n| 1)) + (COND + ((NOT (< |$n| |$sz|)) + (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error") + (|shoeLeafError| (SCHAR |$ln| |$n|))) + (T (SETQ |a| (|shoeReadLispString| |$ln| |$n|)) (COND - ((NOT (< |$n| |$sz|)) - (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error") - (|shoeLeafError| (SCHAR |$ln| |$n|))) - (T (SETQ |a| (|shoeReadLispString| |$ln| |$n|)) - (COND - ((NULL |a|) - (|SoftShoeError| (CONS |$linepos| |$n|) - "lisp escape error") - (|shoeLeafError| (SCHAR |$ln| |$n|))) - (T (SETQ |exp| (CAR |a|)) (SETQ |n| (CADR |a|)) - (COND - ((NULL |n|) (SETQ |$n| |$sz|) - (|shoeLeafLispExp| |exp|)) - (T (SETQ |$n| |n|) (|shoeLeafLispExp| |exp|))))))))))) + ((NULL |a|) + (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error") + (|shoeLeafError| (SCHAR |$ln| |$n|))) + (T (SETQ |exp| (CAR |a|)) (SETQ |n| (CADR |a|)) + (COND ((NULL |n|) (SETQ |$n| |$sz|) (|shoeLeafLispExp| |exp|)) + (T (SETQ |$n| |n|) (|shoeLeafLispExp| |exp|))))))))))) (DEFUN |shoeEscape| () (DECLARE (SPECIAL |$n|)) - (PROGN - (SETQ |$n| (+ |$n| 1)) - (COND ((|shoeEsc|) (|shoeWord| T)) (T NIL)))) + (PROGN (SETQ |$n| (+ |$n| 1)) (COND ((|shoeEsc|) (|shoeWord| T)) (T NIL)))) (DEFUN |shoeEsc| () (PROG (|n1|) - (DECLARE (SPECIAL |$ln| |$r| |$sz| |$n|)) + (DECLARE (SPECIAL |$n| |$sz| |$r| |$ln|)) (RETURN - (COND - ((NOT (< |$n| |$sz|)) - (COND - ((|shoeNextLine| |$r|) - (LOOP - (COND (|$n| (RETURN NIL)) (T (|shoeNextLine| |$r|)))) - (|shoeEsc|) NIL) - (T NIL))) - (T (SETQ |n1| (STRPOSL " " |$ln| |$n| T)) - (COND - ((NULL |n1|) (|shoeNextLine| |$r|) - (LOOP - (COND (|$n| (RETURN NIL)) (T (|shoeNextLine| |$r|)))) - (|shoeEsc|) NIL) - (T T))))))) + (COND + ((NOT (< |$n| |$sz|)) + (COND + ((|shoeNextLine| |$r|) + (LOOP (COND (|$n| (RETURN NIL)) (T (|shoeNextLine| |$r|)))) + (|shoeEsc|) NIL) + (T NIL))) + (T (SETQ |n1| (STRPOSL " " |$ln| |$n| T)) + (COND + ((NULL |n1|) (|shoeNextLine| |$r|) + (LOOP (COND (|$n| (RETURN NIL)) (T (|shoeNextLine| |$r|)))) + (|shoeEsc|) NIL) + (T T))))))) (DEFUN |shoeStartsComment| () (PROG (|www|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (DECLARE (SPECIAL |$n| |$sz| |$ln|)) (RETURN - (COND - ((< |$n| |$sz|) - (COND - ((CHAR= (SCHAR |$ln| |$n|) (|char| '+)) - (SETQ |www| (+ |$n| 1)) - (COND - ((NOT (< |www| |$sz|)) NIL) - (T (CHAR= (SCHAR |$ln| |www|) (|char| '+))))) - (T NIL))) - (T NIL))))) + (COND + ((< |$n| |$sz|) + (COND + ((CHAR= (SCHAR |$ln| |$n|) (|char| '+)) (SETQ |www| (+ |$n| 1)) + (COND ((NOT (< |www| |$sz|)) NIL) + (T (CHAR= (SCHAR |$ln| |www|) (|char| '+))))) + (T NIL))) + (T NIL))))) (DEFUN |shoeStartsNegComment| () (PROG (|www|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (DECLARE (SPECIAL |$n| |$sz| |$ln|)) (RETURN - (COND - ((< |$n| |$sz|) - (COND - ((CHAR= (SCHAR |$ln| |$n|) (|char| '-)) - (SETQ |www| (+ |$n| 1)) - (COND - ((NOT (< |www| |$sz|)) NIL) - (T (CHAR= (SCHAR |$ln| |www|) (|char| '-))))) - (T NIL))) - (T NIL))))) + (COND + ((< |$n| |$sz|) + (COND + ((CHAR= (SCHAR |$ln| |$n|) (|char| '-)) (SETQ |www| (+ |$n| 1)) + (COND ((NOT (< |www| |$sz|)) NIL) + (T (CHAR= (SCHAR |$ln| |www|) (|char| '-))))) + (T NIL))) + (T NIL))))) (DEFUN |shoeNegComment| () (PROG (|n|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (DECLARE (SPECIAL |$n| |$sz| |$ln|)) (RETURN - (PROGN - (SETQ |n| |$n|) - (SETQ |$n| |$sz|) - (|shoeLeafNegComment| (|subString| |$ln| |n|)))))) + (PROGN + (SETQ |n| |$n|) + (SETQ |$n| |$sz|) + (|shoeLeafNegComment| (|subString| |$ln| |n|)))))) (DEFUN |shoeComment| () (PROG (|n|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (DECLARE (SPECIAL |$n| |$sz| |$ln|)) (RETURN - (PROGN - (SETQ |n| |$n|) - (SETQ |$n| |$sz|) - (|shoeLeafComment| (|subString| |$ln| |n|)))))) + (PROGN + (SETQ |n| |$n|) + (SETQ |$n| |$sz|) + (|shoeLeafComment| (|subString| |$ln| |n|)))))) (DEFUN |shoePunct| () (PROG (|sss|) - (DECLARE (SPECIAL |$n| |$ln|)) + (DECLARE (SPECIAL |$ln| |$n|)) (RETURN - (PROGN - (SETQ |sss| (|shoeMatch| |$ln| |$n|)) - (SETQ |$n| (+ |$n| (LENGTH |sss|))) - (|shoeKeyTr| |sss|))))) + (PROGN + (SETQ |sss| (|shoeMatch| |$ln| |$n|)) + (SETQ |$n| (+ |$n| (LENGTH |sss|))) + (|shoeKeyTr| |sss|))))) (DEFUN |shoeKeyTr| (|w|) (DECLARE (SPECIAL |$floatok|)) (COND - ((EQ (|shoeKeyWord| |w|) 'DOT) - (COND (|$floatok| (|shoePossFloat| |w|)) (T (|shoeLeafKey| |w|)))) - (T (SETQ |$floatok| (NOT (|shoeCloser| |w|))) (|shoeLeafKey| |w|)))) + ((EQ (|shoeKeyWord| |w|) 'DOT) + (COND (|$floatok| (|shoePossFloat| |w|)) (T (|shoeLeafKey| |w|)))) + (T (SETQ |$floatok| (NOT (|shoeCloser| |w|))) (|shoeLeafKey| |w|)))) (DEFUN |shoePossFloat| (|w|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (DECLARE (SPECIAL |$n| |$sz| |$ln|)) (COND - ((OR (NOT (< |$n| |$sz|)) (NOT (DIGIT-CHAR-P (SCHAR |$ln| |$n|)))) - (|shoeLeafKey| |w|)) - (T (SETQ |w| (|shoeInteger|)) (|shoeExponent| "0" |w|)))) + ((OR (NOT (< |$n| |$sz|)) (NOT (DIGIT-CHAR-P (SCHAR |$ln| |$n|)))) + (|shoeLeafKey| |w|)) + (T (SETQ |w| (|shoeInteger|)) (|shoeExponent| "0" |w|)))) (DEFUN |shoeSpace| () (PROG (|n|) - (DECLARE (SPECIAL |$floatok| |$ln| |$n|)) + (DECLARE (SPECIAL |$n| |$ln| |$floatok|)) (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|)))))))) + (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| () - (DECLARE (SPECIAL |$floatok| |$n|)) + (DECLARE (SPECIAL |$n| |$floatok|)) (PROGN - (SETQ |$n| (+ |$n| 1)) - (SETQ |$floatok| NIL) - (|shoeLeafString| (|shoeS|)))) + (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|)) + (DECLARE (SPECIAL |$n| |$sz| |$linepos| |$ln|)) (RETURN - (COND - ((NOT (< |$n| |$sz|)) - (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") "") - (T (SETQ |n| |$n|) - (SETQ |strsym| - (OR (|charPosition| (|char| '|"|) |$ln| |$n|) |$sz|)) - (SETQ |escsym| - (OR (|charPosition| (|char| '_) |$ln| |$n|) |$sz|)) - (SETQ |mn| (MIN |strsym| |escsym|)) - (COND - ((EQUAL |mn| |$sz|) (SETQ |$n| |$sz|) - (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") - (|subString| |$ln| |n|)) - ((EQUAL |mn| |strsym|) (SETQ |$n| (+ |mn| 1)) - (|subString| |$ln| |n| (- |mn| |n|))) - (T (SETQ |str| (|subString| |$ln| |n| (- |mn| |n|))) - (SETQ |$n| (+ |mn| 1)) (SETQ |a| (|shoeEsc|)) - (SETQ |b| - (COND - (|a| (SETQ |str| - (CONCAT |str| - (STRING (SCHAR |$ln| |$n|)))) - (SETQ |$n| (+ |$n| 1)) (|shoeS|)) - (T (|shoeS|)))) - (CONCAT |str| |b|)))))))) + (COND + ((NOT (< |$n| |$sz|)) + (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") "") + (T (SETQ |n| |$n|) + (SETQ |strsym| (OR (|charPosition| (|char| '|"|) |$ln| |$n|) |$sz|)) + (SETQ |escsym| (OR (|charPosition| (|char| '_) |$ln| |$n|) |$sz|)) + (SETQ |mn| (MIN |strsym| |escsym|)) + (COND + ((EQUAL |mn| |$sz|) (SETQ |$n| |$sz|) + (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") + (|subString| |$ln| |n|)) + ((EQUAL |mn| |strsym|) (SETQ |$n| (+ |mn| 1)) + (|subString| |$ln| |n| (- |mn| |n|))) + (T (SETQ |str| (|subString| |$ln| |n| (- |mn| |n|))) + (SETQ |$n| (+ |mn| 1)) (SETQ |a| (|shoeEsc|)) + (SETQ |b| + (COND + (|a| (SETQ |str| (CONCAT |str| (STRING (SCHAR |$ln| |$n|)))) + (SETQ |$n| (+ |$n| 1)) (|shoeS|)) + (T (|shoeS|)))) + (CONCAT |str| |b|)))))))) (DEFUN |shoeIdEnd| (|line| |n|) (PROGN - (LOOP - (COND - ((NOT (AND (< |n| (LENGTH |line|)) - (|shoeIdChar| (SCHAR |line| |n|)))) - (RETURN NIL)) - (T (SETQ |n| (+ |n| 1))))) - |n|)) + (LOOP + (COND + ((NOT (AND (< |n| (LENGTH |line|)) (|shoeIdChar| (SCHAR |line| |n|)))) + (RETURN NIL)) + (T (SETQ |n| (+ |n| 1))))) + |n|)) (DEFUN |shoeW| (|b|) (PROG (|bb| |a| |str| |endid| |l| |n1|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (DECLARE (SPECIAL |$n| |$sz| |$ln|)) (RETURN - (PROGN - (SETQ |n1| |$n|) - (SETQ |$n| (+ |$n| 1)) - (SETQ |l| |$sz|) - (SETQ |endid| (|shoeIdEnd| |$ln| |$n|)) - (COND - ((OR (EQUAL |endid| |l|) - (NOT (CHAR= (SCHAR |$ln| |endid|) (|char| '_)))) - (SETQ |$n| |endid|) - (LIST |b| (|subString| |$ln| |n1| (- |endid| |n1|)))) - (T (SETQ |str| (|subString| |$ln| |n1| (- |endid| |n1|))) - (SETQ |$n| (+ |endid| 1)) (SETQ |a| (|shoeEsc|)) - (SETQ |bb| (COND (|a| (|shoeW| T)) (T (LIST |b| "")))) - (LIST (OR (ELT |bb| 0) |b|) (CONCAT |str| (ELT |bb| 1))))))))) + (PROGN + (SETQ |n1| |$n|) + (SETQ |$n| (+ |$n| 1)) + (SETQ |l| |$sz|) + (SETQ |endid| (|shoeIdEnd| |$ln| |$n|)) + (COND + ((OR (EQUAL |endid| |l|) + (NOT (CHAR= (SCHAR |$ln| |endid|) (|char| '_)))) + (SETQ |$n| |endid|) + (LIST |b| (|subString| |$ln| |n1| (- |endid| |n1|)))) + (T (SETQ |str| (|subString| |$ln| |n1| (- |endid| |n1|))) + (SETQ |$n| (+ |endid| 1)) (SETQ |a| (|shoeEsc|)) + (SETQ |bb| (COND (|a| (|shoeW| T)) (T (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|))))))) + (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| () (|shoeInteger1| NIL)) (DEFUN |shoeInteger1| (|zro|) (PROG (|bb| |a| |str| |l| |n|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (DECLARE (SPECIAL |$n| |$sz| |$ln|)) (RETURN - (PROGN - (SETQ |n| |$n|) - (SETQ |l| |$sz|) - (LOOP - (COND - ((NOT (AND (< |$n| |l|) (DIGIT-CHAR-P (SCHAR |$ln| |$n|)))) - (RETURN NIL)) - (T (SETQ |$n| (+ |$n| 1))))) - (COND - ((OR (EQUAL |$n| |l|) - (NOT (CHAR= (SCHAR |$ln| |$n|) (|char| '_)))) - (COND - ((AND (EQUAL |n| |$n|) |zro|) "0") - (T (|subString| |$ln| |n| (- |$n| |n|))))) - (T (SETQ |str| (|subString| |$ln| |n| (- |$n| |n|))) - (SETQ |$n| (+ |$n| 1)) (SETQ |a| (|shoeEsc|)) - (SETQ |bb| (|shoeInteger1| |zro|)) (CONCAT |str| |bb|))))))) + (PROGN + (SETQ |n| |$n|) + (SETQ |l| |$sz|) + (LOOP + (COND + ((NOT (AND (< |$n| |l|) (DIGIT-CHAR-P (SCHAR |$ln| |$n|)))) + (RETURN NIL)) + (T (SETQ |$n| (+ |$n| 1))))) + (COND + ((OR (EQUAL |$n| |l|) (NOT (CHAR= (SCHAR |$ln| |$n|) (|char| '_)))) + (COND ((AND (EQUAL |n| |$n|) |zro|) "0") + (T (|subString| |$ln| |n| (- |$n| |n|))))) + (T (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 (SETQ |d| (|shoeOrdToNum| (SCHAR |s| |i|))) - (SETQ |ival| (+ (* 10 |ival|) |d|)))) - (SETQ |i| (+ |i| 1)))) - |ival|)))) + (PROGN + (SETQ |ns| (LENGTH |s|)) + (SETQ |ival| 0) + (LET ((|bfVar#1| (- |ns| 1)) (|i| 0)) + (LOOP + (COND ((> |i| |bfVar#1|) (RETURN NIL)) + (T (SETQ |d| (|shoeOrdToNum| (SCHAR |s| |i|))) + (SETQ |ival| (+ (* 10 |ival|) |d|)))) + (SETQ |i| (+ |i| 1)))) + |ival|)))) (DEFUN |shoeNumber| () (PROG (|w| |n| |a|) - (DECLARE (SPECIAL |$ln| |$floatok| |$sz| |$n|)) + (DECLARE (SPECIAL |$n| |$sz| |$floatok| |$ln|)) (RETURN - (PROGN - (SETQ |a| (|shoeInteger|)) - (COND - ((NOT (< |$n| |$sz|)) (|shoeLeafInteger| |a|)) - ((AND |$floatok| (CHAR= (SCHAR |$ln| |$n|) (|char| '|.|))) - (SETQ |n| |$n|) (SETQ |$n| (+ |$n| 1)) - (COND - ((AND (< |$n| |$sz|) - (CHAR= (SCHAR |$ln| |$n|) (|char| '|.|))) - (SETQ |$n| |n|) (|shoeLeafInteger| |a|)) - (T (SETQ |w| (|shoeInteger1| T)) (|shoeExponent| |a| |w|)))) - (T (|shoeLeafInteger| |a|))))))) + (PROGN + (SETQ |a| (|shoeInteger|)) + (COND ((NOT (< |$n| |$sz|)) (|shoeLeafInteger| |a|)) + ((AND |$floatok| (CHAR= (SCHAR |$ln| |$n|) (|char| '|.|))) + (SETQ |n| |$n|) (SETQ |$n| (+ |$n| 1)) + (COND + ((AND (< |$n| |$sz|) (CHAR= (SCHAR |$ln| |$n|) (|char| '|.|))) + (SETQ |$n| |n|) (|shoeLeafInteger| |a|)) + (T (SETQ |w| (|shoeInteger1| T)) (|shoeExponent| |a| |w|)))) + (T (|shoeLeafInteger| |a|))))))) (DEFUN |shoeExponent| (|a| |w|) (PROG (|c1| |e| |c| |n|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (DECLARE (SPECIAL |$n| |$sz| |$ln|)) (RETURN - (COND - ((NOT (< |$n| |$sz|)) (|shoeLeafFloat| |a| |w| 0)) - (T (SETQ |n| |$n|) (SETQ |c| (SCHAR |$ln| |$n|)) - (COND + (COND ((NOT (< |$n| |$sz|)) (|shoeLeafFloat| |a| |w| 0)) + (T (SETQ |n| |$n|) (SETQ |c| (SCHAR |$ln| |$n|)) + (COND ((OR (CHAR= |c| (|char| 'E)) (CHAR= |c| (|char| '|e|))) (SETQ |$n| (+ |$n| 1)) (COND - ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|) - (|shoeLeafFloat| |a| |w| 0)) - ((DIGIT-CHAR-P (SCHAR |$ln| |$n|)) - (SETQ |e| (|shoeInteger|)) - (SETQ |e| (|shoeIntValue| |e|)) - (|shoeLeafFloat| |a| |w| |e|)) - (T (SETQ |c1| (SCHAR |$ln| |$n|)) - (COND - ((OR (CHAR= |c1| (|char| '+)) - (CHAR= |c1| (|char| '-))) - (SETQ |$n| (+ |$n| 1)) - (COND - ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|) - (|shoeLeafFloat| |a| |w| 0)) - ((DIGIT-CHAR-P (SCHAR |$ln| |$n|)) - (SETQ |e| (|shoeInteger|)) - (SETQ |e| (|shoeIntValue| |e|)) - (|shoeLeafFloat| |a| |w| - (COND - ((CHAR= |c1| (|char| '-)) (- |e|)) - (T |e|)))) - (T (SETQ |$n| |n|) (|shoeLeafFloat| |a| |w| 0)))))))) + ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|) + (|shoeLeafFloat| |a| |w| 0)) + ((DIGIT-CHAR-P (SCHAR |$ln| |$n|)) (SETQ |e| (|shoeInteger|)) + (SETQ |e| (|shoeIntValue| |e|)) (|shoeLeafFloat| |a| |w| |e|)) + (T (SETQ |c1| (SCHAR |$ln| |$n|)) + (COND + ((OR (CHAR= |c1| (|char| '+)) (CHAR= |c1| (|char| '-))) + (SETQ |$n| (+ |$n| 1)) + (COND + ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|) + (|shoeLeafFloat| |a| |w| 0)) + ((DIGIT-CHAR-P (SCHAR |$ln| |$n|)) + (SETQ |e| (|shoeInteger|)) (SETQ |e| (|shoeIntValue| |e|)) + (|shoeLeafFloat| |a| |w| + (COND ((CHAR= |c1| (|char| '-)) (- |e|)) + (T |e|)))) + (T (SETQ |$n| |n|) (|shoeLeafFloat| |a| |w| 0)))))))) (T (|shoeLeafFloat| |a| |w| 0)))))))) (DEFUN |shoeError| () (PROG (|n|) - (DECLARE (SPECIAL |$ln| |$linepos| |$n|)) + (DECLARE (SPECIAL |$n| |$linepos| |$ln|)) (RETURN - (PROGN - (SETQ |n| |$n|) - (SETQ |$n| (+ |$n| 1)) - (|SoftShoeError| (CONS |$linepos| |n|) - (CONCAT "The character whose number is " - (WRITE-TO-STRING (CHAR-CODE (SCHAR |$ln| |n|))) - " is not a Boot character")) - (|shoeLeafError| (SCHAR |$ln| |n|)))))) + (PROGN + (SETQ |n| |$n|) + (SETQ |$n| (+ |$n| 1)) + (|SoftShoeError| (CONS |$linepos| |n|) + (CONCAT "The character whose number is " + (WRITE-TO-STRING (CHAR-CODE (SCHAR |$ln| |n|))) + " is not a Boot character")) + (|shoeLeafError| (SCHAR |$ln| |n|)))))) (DEFUN |shoeOrdToNum| (|x|) (DIGIT-CHAR-P |x|)) @@ -521,39 +473,37 @@ (DEFUN |shoeKeyWordP| (|st|) (|tableValue| |shoeKeyTable| |st|)) -(DEFUN |shoeMatch| (|l| |i|) - (|shoeSubStringMatch| |l| |shoeDict| |i|)) +(DEFUN |shoeMatch| (|l| |i|) (|shoeSubStringMatch| |l| |shoeDict| |i|)) (DEFUN |shoeSubStringMatch| (|l| |d| |i|) (PROG (|eql| |ls| |s| |s1| |done| |ll| |u| |h|) (RETURN - (PROGN - (SETQ |h| (CHAR-CODE (SCHAR |l| |i|))) - (SETQ |u| (ELT |d| |h|)) - (SETQ |ll| (LENGTH |l|)) - (SETQ |done| NIL) - (SETQ |s1| "") - (LET ((|bfVar#1| (- (LENGTH |u|) 1)) (|j| 0)) - (LOOP - (COND - ((OR (> |j| |bfVar#1|) |done|) (RETURN NIL)) - (T (SETQ |s| (ELT |u| |j|)) (SETQ |ls| (LENGTH |s|)) - (SETQ |done| - (COND - ((< |ll| (+ |ls| |i|)) NIL) - (T (SETQ |eql| T) - (LET ((|bfVar#2| (- |ls| 1)) (|k| 1)) - (LOOP - (COND - ((OR (> |k| |bfVar#2|) (NOT |eql|)) - (RETURN NIL)) - (T (SETQ |eql| - (CHAR= (SCHAR |s| |k|) - (SCHAR |l| (+ |k| |i|)))))) - (SETQ |k| (+ |k| 1)))) - (COND (|eql| (SETQ |s1| |s|) T) (T NIL))))))) - (SETQ |j| (+ |j| 1)))) - |s1|)))) + (PROGN + (SETQ |h| (CHAR-CODE (SCHAR |l| |i|))) + (SETQ |u| (ELT |d| |h|)) + (SETQ |ll| (LENGTH |l|)) + (SETQ |done| NIL) + (SETQ |s1| "") + (LET ((|bfVar#1| (- (LENGTH |u|) 1)) (|j| 0)) + (LOOP + (COND ((OR (> |j| |bfVar#1|) |done|) (RETURN NIL)) + (T (SETQ |s| (ELT |u| |j|)) (SETQ |ls| (LENGTH |s|)) + (SETQ |done| + (COND ((< |ll| (+ |ls| |i|)) NIL) + (T (SETQ |eql| T) + (LET ((|bfVar#2| (- |ls| 1)) (|k| 1)) + (LOOP + (COND + ((OR (> |k| |bfVar#2|) (NOT |eql|)) + (RETURN NIL)) + (T + (SETQ |eql| + (CHAR= (SCHAR |s| |k|) + (SCHAR |l| (+ |k| |i|)))))) + (SETQ |k| (+ |k| 1)))) + (COND (|eql| (SETQ |s1| |s|) T) (T NIL))))))) + (SETQ |j| (+ |j| 1)))) + |s1|)))) (DEFUN |shoePunctuation| (|c|) (EQL (ELT |shoePun| |c|) 1)) diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp index c8c4afc3..de9d71e3 100644 --- a/src/boot/strap/tokens.clisp +++ b/src/boot/strap/tokens.clisp @@ -19,290 +19,247 @@ (DEFUN |shoeIdChar| (|x|) (OR (ALPHANUMERICP |x|) (|charMember?| |x| - (LIST (|char| '|'|) (|char| '?) (|char| '%) (|char| '!) - (|char| '&))))) + (LIST (|char| '|'|) (|char| '?) (|char| '%) (|char| '!) + (|char| '&))))) (DEFUN |subString| (|s| |f| &OPTIONAL (|n| NIL)) - (COND - ((NULL |n|) (SUBSEQ |s| |f|)) - (T (SUBSEQ |s| |f| (+ |f| |n|))))) + (COND ((NULL |n|) (SUBSEQ |s| |f|)) (T (SUBSEQ |s| |f| (+ |f| |n|))))) (DEFCONSTANT |shoeKeyWords| - (LIST (LIST "and" 'AND) (LIST "by" 'BY) (LIST "case" 'CASE) - (LIST "catch" 'CATCH) (LIST "cross" 'CROSS) (LIST "do" 'DO) - (LIST "else" 'ELSE) (LIST "finally" 'FINALLY) - (LIST "for" 'FOR) (LIST "forall" 'FORALL) (LIST "has" 'HAS) - (LIST "if" 'IF) (LIST "import" 'IMPORT) (LIST "in" 'IN) - (LIST "is" 'IS) (LIST "isnt" 'ISNT) (LIST "leave" 'LEAVE) - (LIST "macro" 'MACRO) (LIST "module" 'MODULE) - (LIST "namespace" 'NAMESPACE) (LIST "of" 'OF) (LIST "or" 'OR) - (LIST "rem" 'REM) (LIST "repeat" 'REPEAT) - (LIST "return" 'RETURN) (LIST "quo" 'QUO) - (LIST "structure" 'STRUCTURE) (LIST "then" 'THEN) - (LIST "throw" 'THROW) (LIST "try" 'TRY) (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 "~=" 'SHOENE) (LIST ".." 'SEG) - (LIST "#" 'LENGTH) (LIST "=>" 'EXIT) (LIST "->" 'ARROW) - (LIST ":=" 'BEC) (LIST "+->" 'GIVES) (LIST "==" 'DEF) - (LIST "<=>" 'TDEF) (LIST "(" 'OPAREN) (LIST ")" 'CPAREN) - (LIST "[" 'OBRACK) (LIST "]" 'CBRACK) (LIST "'" 'QUOTE) - (LIST "|" 'BAR))) + (LIST (LIST "and" 'AND) (LIST "by" 'BY) (LIST "case" 'CASE) + (LIST "catch" 'CATCH) (LIST "cross" 'CROSS) (LIST "do" 'DO) + (LIST "else" 'ELSE) (LIST "finally" 'FINALLY) (LIST "for" 'FOR) + (LIST "forall" 'FORALL) (LIST "has" 'HAS) (LIST "if" 'IF) + (LIST "import" 'IMPORT) (LIST "in" 'IN) (LIST "is" 'IS) + (LIST "isnt" 'ISNT) (LIST "leave" 'LEAVE) (LIST "macro" 'MACRO) + (LIST "module" 'MODULE) (LIST "namespace" 'NAMESPACE) (LIST "of" 'OF) + (LIST "or" 'OR) (LIST "rem" 'REM) (LIST "repeat" 'REPEAT) + (LIST "return" 'RETURN) (LIST "quo" 'QUO) (LIST "structure" 'STRUCTURE) + (LIST "then" 'THEN) (LIST "throw" 'THROW) (LIST "try" 'TRY) + (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 "~=" 'SHOENE) (LIST ".." 'SEG) + (LIST "#" 'LENGTH) (LIST "=>" 'EXIT) (LIST "->" 'ARROW) + (LIST ":=" 'BEC) (LIST "+->" 'GIVES) (LIST "==" 'DEF) + (LIST "<=>" 'TDEF) (LIST "(" 'OPAREN) (LIST ")" 'CPAREN) + (LIST "[" 'OBRACK) (LIST "]" 'CBRACK) (LIST "'" 'QUOTE) + (LIST "|" 'BAR))) (DEFUN |shoeKeyTableCons| () (PROG (|KeyTable|) (RETURN - (PROGN - (SETQ |KeyTable| (|makeTable| #'EQUAL)) - (LET ((|bfVar#1| |shoeKeyWords|) (|st| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |st| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (SETF (|tableValue| |KeyTable| (CAR |st|)) - (CADR |st|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - |KeyTable|)))) + (PROGN + (SETQ |KeyTable| (|makeTable| #'EQUAL)) + (LET ((|bfVar#1| |shoeKeyWords|) (|st| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |st| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (SETF (|tableValue| |KeyTable| (CAR |st|)) (CADR |st|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + |KeyTable|)))) (DEFPARAMETER |shoeKeyTable| (|shoeKeyTableCons|)) (DEFUN |shoeInsert| (|s| |d|) (PROG (|v| |k| |n| |u| |h| |l|) (RETURN - (PROGN - (SETQ |l| (LENGTH |s|)) - (SETQ |h| (CHAR-CODE (SCHAR |s| 0))) - (SETQ |u| (ELT |d| |h|)) - (SETQ |n| (LENGTH |u|)) - (SETQ |k| 0) + (PROGN + (SETQ |l| (LENGTH |s|)) + (SETQ |h| (CHAR-CODE (SCHAR |s| 0))) + (SETQ |u| (ELT |d| |h|)) + (SETQ |n| (LENGTH |u|)) + (SETQ |k| 0) + (LOOP + (COND ((< (LENGTH (ELT |u| |k|)) |l|) (RETURN NIL)) + (T (SETQ |k| (+ |k| 1))))) + (SETQ |v| (MAKE-ARRAY (+ |n| 1))) + (LET ((|bfVar#1| (- |k| 1)) (|i| 0)) + (LOOP + (COND ((> |i| |bfVar#1|) (RETURN NIL)) + (T (SETF (ELT |v| |i|) (ELT |u| |i|)))) + (SETQ |i| (+ |i| 1)))) + (SETF (ELT |v| |k|) |s|) + (LET ((|bfVar#2| (- |n| 1)) (|i| |k|)) (LOOP - (COND - ((< (LENGTH (ELT |u| |k|)) |l|) (RETURN NIL)) - (T (SETQ |k| (+ |k| 1))))) - (SETQ |v| (MAKE-ARRAY (+ |n| 1))) - (LET ((|bfVar#1| (- |k| 1)) (|i| 0)) - (LOOP - (COND - ((> |i| |bfVar#1|) (RETURN NIL)) - (T (SETF (ELT |v| |i|) (ELT |u| |i|)))) - (SETQ |i| (+ |i| 1)))) - (SETF (ELT |v| |k|) |s|) - (LET ((|bfVar#2| (- |n| 1)) (|i| |k|)) - (LOOP - (COND - ((> |i| |bfVar#2|) (RETURN NIL)) - (T (SETF (ELT |v| (+ |i| 1)) (ELT |u| |i|)))) - (SETQ |i| (+ |i| 1)))) - (SETF (ELT |d| |h|) |v|) - |s|)))) + (COND ((> |i| |bfVar#2|) (RETURN NIL)) + (T (SETF (ELT |v| (+ |i| 1)) (ELT |u| |i|)))) + (SETQ |i| (+ |i| 1)))) + (SETF (ELT |d| |h|) |v|) + |s|)))) (DEFUN |shoeDictCons| () (PROG (|d| |b| |a| |l|) (RETURN - (PROGN - (SETQ |l| (HKEYS |shoeKeyTable|)) - (SETQ |d| + (PROGN + (SETQ |l| (HKEYS |shoeKeyTable|)) + (SETQ |d| (PROGN - (SETQ |a| (MAKE-ARRAY 256)) - (SETQ |b| (MAKE-ARRAY 1)) - (SETF (ELT |b| 0) (MAKE-STRING 0)) - (LET ((|i| 0)) - (LOOP - (COND - ((> |i| 255) (RETURN NIL)) - (T (SETF (ELT |a| |i|) |b|))) - (SETQ |i| (+ |i| 1)))) - |a|)) - (LET ((|bfVar#1| |l|) (|s| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |s| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (|shoeInsert| |s| |d|))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - |d|)))) + (SETQ |a| (MAKE-ARRAY 256)) + (SETQ |b| (MAKE-ARRAY 1)) + (SETF (ELT |b| 0) (MAKE-STRING 0)) + (LET ((|i| 0)) + (LOOP + (COND ((> |i| 255) (RETURN NIL)) + (T (SETF (ELT |a| |i|) |b|))) + (SETQ |i| (+ |i| 1)))) + |a|)) + (LET ((|bfVar#1| |l|) (|s| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |s| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (|shoeInsert| |s| |d|))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + |d|)))) (DEFPARAMETER |shoeDict| (|shoeDictCons|)) (DEFUN |shoePunCons| () (PROG (|a| |listing|) (RETURN - (PROGN - (SETQ |listing| (HKEYS |shoeKeyTable|)) - (SETQ |a| (|makeBitVector| 256)) - (LET ((|i| 0)) - (LOOP - (COND - ((> |i| 255) (RETURN NIL)) - (T (SETF (SBIT |a| |i|) 0))) - (SETQ |i| (+ |i| 1)))) - (LET ((|bfVar#1| |listing|) (|k| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |k| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - ((|shoeStartsId| (ELT |k| 0)) NIL) - (T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - |a|)))) + (PROGN + (SETQ |listing| (HKEYS |shoeKeyTable|)) + (SETQ |a| (|makeBitVector| 256)) + (LET ((|i| 0)) + (LOOP (COND ((> |i| 255) (RETURN NIL)) (T (SETF (SBIT |a| |i|) 0))) + (SETQ |i| (+ |i| 1)))) + (LET ((|bfVar#1| |listing|) (|k| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |k| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + ((|shoeStartsId| (ELT |k| 0)) NIL) + (T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + |a|)))) (DEFPARAMETER |shoePun| (|shoePunCons|)) (LET ((|bfVar#1| (LIST 'NOT 'LENGTH)) (|i| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (SETF (GET |i| 'SHOEPRE) T))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (SETF (GET |i| 'SHOEPRE) T))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) (LET ((|bfVar#1| - (LIST (LIST 'SHOEEQ '=) (LIST 'TIMES '*) (LIST 'REM '|rem|) - (LIST 'QUO '|quo|) (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 '~=))) + (LIST (LIST 'SHOEEQ '=) (LIST 'TIMES '*) (LIST 'REM '|rem|) + (LIST 'QUO '|quo|) (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 (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (SETF (GET (CAR |i|) 'SHOEINF) (CADR |i|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (SETF (GET (CAR |i|) 'SHOEINF) (CADR |i|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) (LET ((|bfVar#1| - (LIST (LIST '+ 0) (LIST '|gcd| 0) (LIST '|lcm| 1) - (LIST 'STRCONC "") (LIST '|strconc| "") - (LIST 'CONCAT "") (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 '|and| T) - (LIST '|or| NIL) (LIST 'AND T) (LIST 'OR NIL))) + (LIST (LIST '+ 0) (LIST '|gcd| 0) (LIST '|lcm| 1) (LIST 'STRCONC "") + (LIST '|strconc| "") (LIST 'CONCAT "") (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 '|and| T) + (LIST '|or| NIL) (LIST 'AND T) (LIST 'OR NIL))) (|i| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (SETF (GET (CAR |i|) 'SHOETHETA) (CDR |i|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (SETF (GET (CAR |i|) 'SHOETHETA) (CDR |i|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) (LET ((|bfVar#1| - (LIST (LIST '|abs| 'ABS) (LIST '|abstractChar| 'CODE-CHAR) - (LIST '|alphabetic?| 'ALPHA-CHAR-P) - (LIST '|alphanumeric?| 'ALPHANUMERICP) - (LIST '|and| 'AND) (LIST '|apply| 'APPLY) - (LIST '|array?| 'ARRAYP) (LIST '|arrayRef| 'AREF) - (LIST '|atom| 'ATOM) (LIST '|bitmask| 'SBIT) - (LIST '|canonicalFilename| 'PROBE-FILE) - (LIST '|charByName| 'NAME-CHAR) - (LIST '|charDowncase| 'CHAR-DOWNCASE) - (LIST '|charEq?| 'CHAR=) - (LIST '|charUpcase| 'CHAR-UPCASE) - (LIST '|charString| 'STRING) - (LIST '|char?| 'CHARACTERP) - (LIST '|codePoint| 'CHAR-CODE) (LIST '|cons?| 'CONSP) - (LIST '|copy| 'COPY) (LIST '|copyString| 'COPY-SEQ) - (LIST '|copyTree| 'COPY-TREE) - (LIST '|copyVector| 'COPY-SEQ) (LIST '|croak| 'CROAK) - (LIST '|digit?| 'DIGIT-CHAR-P) (LIST '|drop| 'DROP) - (LIST '|exit| 'EXIT) (LIST '|false| 'NIL) - (LIST '|first| 'CAR) (LIST '|float?| 'FLOATP) - (LIST '|flushOutput| 'FORCE-OUTPUT) - (LIST '|fourth| 'CADDDR) (LIST '|function| 'FUNCTION) - (LIST '|function?| 'FUNCTIONP) (LIST '|gensym| 'GENSYM) - (LIST '|genvar| 'GENVAR) (LIST '|integer?| 'INTEGERP) - (LIST 'LAST '|last|) (LIST '|list| 'LIST) - (LIST '|listEq?| 'EQUAL) - (LIST '|lowerCase?| 'LOWER-CASE-P) - (LIST '|makeSymbol| 'INTERN) - (LIST '|maxIndex| 'MAXINDEX) (LIST '|mkpf| 'MKPF) - (LIST '|newString| 'MAKE-STRING) - (LIST '|newVector| 'MAKE-ARRAY) (LIST '|nil| NIL) - (LIST '|not| 'NOT) (LIST '|null| 'NULL) - (LIST '|odd?| 'ODDP) (LIST '|or| 'OR) - (LIST '|otherwise| 'T) (LIST '|property| 'GET) - (LIST '|readInteger| 'PARSE-INTEGER) - (LIST '|readLispFromString| 'READ-FROM-STRING) - (LIST '|readOnly?| 'CONSTANTP) - (LIST '|removeDuplicates| 'REMDUP) (LIST '|rest| 'CDR) - (LIST '|sameObject?| 'EQ) (LIST '|scalarEq?| 'EQL) - (LIST '|scalarEqual?| 'EQL) (LIST '|second| 'CADR) - (LIST '|setIntersection| 'INTERSECTION) - (LIST '|setPart| 'SETELT) (LIST '|setUnion| 'UNION) - (LIST '|strconc| 'CONCAT) (LIST '|stringChar| 'SCHAR) - (LIST '|stringDowncase| 'STRING-DOWNCASE) - (LIST '|string?| 'STRINGP) (LIST '|stringEq?| 'STRING=) - (LIST '|stringUpcase| 'STRING-UPCASE) - (LIST '|subSequence| 'SUBSEQ) - (LIST '|symbolScope| 'SYMBOL-PACKAGE) - (LIST '|symbolEq?| 'EQ) - (LIST '|symbolFunction| 'SYMBOL-FUNCTION) - (LIST '|symbolName| 'SYMBOL-NAME) - (LIST '|symbolValue| 'SYMBOL-VALUE) - (LIST '|symbol?| 'SYMBOLP) (LIST '|take| 'TAKE) - (LIST '|third| 'CADDR) - (LIST '|toString| 'WRITE-TO-STRING) (LIST '|true| 'T) - (LIST '|upperCase?| 'UPPER-CASE-P) - (LIST '|valueEq?| 'EQUAL) - (LIST '|vector?| 'SIMPLE-VECTOR-P) - (LIST '|vectorRef| 'SVREF) - (LIST '|writeByte| 'WRITE-BYTE) - (LIST '|writeChar| 'WRITE-CHAR) - (LIST '|writeInteger| 'PRINC) - (LIST '|writeLine| 'WRITE-LINE) - (LIST '|writeNewline| 'TERPRI) - (LIST '|writeString| 'WRITE-STRING) (LIST 'PLUS '+) - (LIST 'MINUS '-) (LIST 'TIMES '*) (LIST 'POWER 'EXPT) - (LIST 'REM 'REM) (LIST 'QUO 'TRUNCATE) (LIST 'SLASH '/) - (LIST 'LT '<) (LIST 'GT '>) (LIST 'LE '<=) - (LIST 'GE '>=) (LIST 'SHOEEQ 'EQUAL) (LIST 'SHOENE '/=) - (LIST 'T 'T$))) + (LIST (LIST '|abs| 'ABS) (LIST '|abstractChar| 'CODE-CHAR) + (LIST '|alphabetic?| 'ALPHA-CHAR-P) + (LIST '|alphanumeric?| 'ALPHANUMERICP) (LIST '|and| 'AND) + (LIST '|apply| 'APPLY) (LIST '|array?| 'ARRAYP) + (LIST '|arrayRef| 'AREF) (LIST '|atom| 'ATOM) + (LIST '|bitmask| 'SBIT) (LIST '|canonicalFilename| 'PROBE-FILE) + (LIST '|charByName| 'NAME-CHAR) + (LIST '|charDowncase| 'CHAR-DOWNCASE) (LIST '|charEq?| 'CHAR=) + (LIST '|charUpcase| 'CHAR-UPCASE) (LIST '|charString| 'STRING) + (LIST '|char?| 'CHARACTERP) (LIST '|codePoint| 'CHAR-CODE) + (LIST '|cons?| 'CONSP) (LIST '|copy| 'COPY) + (LIST '|copyString| 'COPY-SEQ) (LIST '|copyTree| 'COPY-TREE) + (LIST '|copyVector| 'COPY-SEQ) (LIST '|croak| 'CROAK) + (LIST '|digit?| 'DIGIT-CHAR-P) (LIST '|drop| 'DROP) + (LIST '|exit| 'EXIT) (LIST '|false| 'NIL) (LIST '|first| 'CAR) + (LIST '|float?| 'FLOATP) (LIST '|flushOutput| 'FORCE-OUTPUT) + (LIST '|fourth| 'CADDDR) (LIST '|function| 'FUNCTION) + (LIST '|function?| 'FUNCTIONP) (LIST '|gensym| 'GENSYM) + (LIST '|genvar| 'GENVAR) (LIST '|integer?| 'INTEGERP) + (LIST 'LAST '|last|) (LIST '|list| 'LIST) (LIST '|listEq?| 'EQUAL) + (LIST '|lowerCase?| 'LOWER-CASE-P) (LIST '|makeSymbol| 'INTERN) + (LIST '|maxIndex| 'MAXINDEX) (LIST '|mkpf| 'MKPF) + (LIST '|newString| 'MAKE-STRING) (LIST '|newVector| 'MAKE-ARRAY) + (LIST '|nil| NIL) (LIST '|not| 'NOT) (LIST '|null| 'NULL) + (LIST '|odd?| 'ODDP) (LIST '|or| 'OR) (LIST '|otherwise| 'T) + (LIST '|property| 'GET) (LIST '|readInteger| 'PARSE-INTEGER) + (LIST '|readLispFromString| 'READ-FROM-STRING) + (LIST '|readOnly?| 'CONSTANTP) (LIST '|removeDuplicates| 'REMDUP) + (LIST '|rest| 'CDR) (LIST '|sameObject?| 'EQ) + (LIST '|scalarEq?| 'EQL) (LIST '|scalarEqual?| 'EQL) + (LIST '|second| 'CADR) (LIST '|setIntersection| 'INTERSECTION) + (LIST '|setPart| 'SETELT) (LIST '|setUnion| 'UNION) + (LIST '|strconc| 'CONCAT) (LIST '|stringChar| 'SCHAR) + (LIST '|stringDowncase| 'STRING-DOWNCASE) + (LIST '|string?| 'STRINGP) (LIST '|stringEq?| 'STRING=) + (LIST '|stringUpcase| 'STRING-UPCASE) + (LIST '|subSequence| 'SUBSEQ) + (LIST '|symbolScope| 'SYMBOL-PACKAGE) (LIST '|symbolEq?| 'EQ) + (LIST '|symbolFunction| 'SYMBOL-FUNCTION) + (LIST '|symbolName| 'SYMBOL-NAME) + (LIST '|symbolValue| 'SYMBOL-VALUE) (LIST '|symbol?| 'SYMBOLP) + (LIST '|take| 'TAKE) (LIST '|third| 'CADDR) + (LIST '|toString| 'WRITE-TO-STRING) (LIST '|true| 'T) + (LIST '|upperCase?| 'UPPER-CASE-P) (LIST '|valueEq?| 'EQUAL) + (LIST '|vector?| 'SIMPLE-VECTOR-P) (LIST '|vectorRef| 'SVREF) + (LIST '|writeByte| 'WRITE-BYTE) (LIST '|writeChar| 'WRITE-CHAR) + (LIST '|writeInteger| 'PRINC) (LIST '|writeLine| 'WRITE-LINE) + (LIST '|writeNewline| 'TERPRI) (LIST '|writeString| 'WRITE-STRING) + (LIST 'PLUS '+) (LIST 'MINUS '-) (LIST 'TIMES '*) + (LIST 'POWER 'EXPT) (LIST 'REM 'REM) (LIST 'QUO 'TRUNCATE) + (LIST 'SLASH '/) (LIST 'LT '<) (LIST 'GT '>) (LIST 'LE '<=) + (LIST 'GE '>=) (LIST 'SHOEEQ 'EQUAL) (LIST 'SHOENE '/=) + (LIST 'T 'T$))) (|i| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (SETF (GET (CAR |i|) 'SHOERENAME) (CDR |i|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (SETF (GET (CAR |i|) 'SHOERENAME) (CDR |i|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) (LET ((|bfVar#1| - (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 '|args| 'CDR) (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 '|mmSource| 'CDDAR) (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))) + (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 '|args| 'CDR) (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 '|mmSource| 'CDDAR) + (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 (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (SETF (GET (CAR |i|) 'SHOESELFUNCTION) (CADR |i|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (SETF (GET (CAR |i|) 'SHOESELFUNCTION) (CADR |i|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index 79d072bf..12dda96a 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -14,8 +14,9 @@ (PROVIDE "translator") (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) - (EXPORT '(|evalBootFile| |loadNativeModule| |loadSystemRuntimeCore| - |string2BootTree| |genImportDeclaration|))) + (EXPORT + '(|evalBootFile| |loadNativeModule| |loadSystemRuntimeCore| + |string2BootTree| |genImportDeclaration|))) (DEFPARAMETER |$currentModuleName| NIL) @@ -23,102 +24,82 @@ (DEFUN |genModuleFinalization| (|stream|) (PROG (|init|) - (DECLARE (SPECIAL |$currentModuleName| |$foreignsDefsForCLisp|)) + (DECLARE (SPECIAL |$foreignsDefsForCLisp| |$currentModuleName|)) (RETURN - (COND - ((|%hasFeature| :CLISP) - (COND - ((NULL |$foreignsDefsForCLisp|) NIL) - ((NULL |$currentModuleName|) - (|coreError| "current module has no name")) - (T (SETQ |init| - (CONS 'DEFUN - (CONS (INTERN (CONCAT |$currentModuleName| - "InitCLispFFI")) - (CONS NIL - (CONS - (LIST 'MAPC - (LIST 'FUNCTION 'FMAKUNBOUND) - (|quote| - (LET - ((|bfVar#2| NIL) - (|bfVar#3| NIL) - (|bfVar#1| - |$foreignsDefsForCLisp|) - (|d| NIL)) - (LOOP - (COND - ((OR - (NOT - (CONSP |bfVar#1|)) - (PROGN - (SETQ |d| - (CAR |bfVar#1|)) - NIL)) + (COND + ((|%hasFeature| :CLISP) + (COND ((NULL |$foreignsDefsForCLisp|) NIL) + ((NULL |$currentModuleName|) + (|coreError| "current module has no name")) + (T + (SETQ |init| + (CONS 'DEFUN + (CONS + (INTERN + (CONCAT |$currentModuleName| "InitCLispFFI")) + (CONS NIL + (CONS + (LIST 'MAPC (LIST 'FUNCTION 'FMAKUNBOUND) + (|quote| + (LET ((|bfVar#2| NIL) + (|bfVar#3| NIL) + (|bfVar#1| + |$foreignsDefsForCLisp|) + (|d| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN + (SETQ |d| (CAR |bfVar#1|)) + NIL)) (RETURN |bfVar#2|)) ((NULL |bfVar#2|) (SETQ |bfVar#2| - #0=(CONS (CADR |d|) - NIL)) - (SETQ |bfVar#3| - |bfVar#2|)) - (T - (RPLACD |bfVar#3| #0#) + #1=(CONS (CADR |d|) + NIL)) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| - (CDR |bfVar#3|)))) - (SETQ |bfVar#1| - (CDR |bfVar#1|)))))) - (LET - ((|bfVar#5| NIL) - (|bfVar#6| NIL) - (|bfVar#4| - |$foreignsDefsForCLisp|) - (|d| NIL)) - (LOOP - (COND - ((OR - (NOT (CONSP |bfVar#4|)) - (PROGN - (SETQ |d| - (CAR |bfVar#4|)) - NIL)) - (RETURN |bfVar#5|)) - ((NULL |bfVar#5|) - (SETQ |bfVar#5| - #1=(CONS - (LIST 'EVAL - (|quote| |d|)) - NIL)) - (SETQ |bfVar#6| - |bfVar#5|)) - (T (RPLACD |bfVar#6| #1#) - (SETQ |bfVar#6| - (CDR |bfVar#6|)))) - (SETQ |bfVar#4| - (CDR |bfVar#4|))))))))) + (CDR |bfVar#3|)))) + (SETQ |bfVar#1| + (CDR |bfVar#1|)))))) + (LET ((|bfVar#5| NIL) + (|bfVar#6| NIL) + (|bfVar#4| |$foreignsDefsForCLisp|) + (|d| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#4|)) + (PROGN + (SETQ |d| (CAR |bfVar#4|)) + NIL)) + (RETURN |bfVar#5|)) + ((NULL |bfVar#5|) + (SETQ |bfVar#5| + #2=(CONS + (LIST 'EVAL (|quote| |d|)) + NIL)) + (SETQ |bfVar#6| |bfVar#5|)) + (T (RPLACD |bfVar#6| #2#) + (SETQ |bfVar#6| (CDR |bfVar#6|)))) + (SETQ |bfVar#4| (CDR |bfVar#4|))))))))) (REALLYPRETTYPRINT |init| |stream|)))) - (T NIL))))) + (T NIL))))) (DEFUN |genOptimizeOptions| (|stream|) (REALLYPRETTYPRINT - (LIST 'PROCLAIM - (|quote| (CONS 'OPTIMIZE |$LispOptimizeOptions|))) - |stream|)) + (LIST 'PROCLAIM (|quote| (CONS 'OPTIMIZE |$LispOptimizeOptions|))) |stream|)) (DEFUN |AxiomCore|::|%sysInit| () (PROGN - (SETQ *LOAD-VERBOSE* NIL) - (COND - ((|%hasFeature| :GCL) - (SETF (SYMBOL-VALUE - (|bfColonColon| 'COMPILER '*COMPILE-VERBOSE*)) - NIL) - (SETF (SYMBOL-VALUE - (|bfColonColon| 'COMPILER - 'SUPPRESS-COMPILER-WARNINGS*)) + (SETQ *LOAD-VERBOSE* NIL) + (COND + ((|%hasFeature| :GCL) + (SETF (SYMBOL-VALUE (|bfColonColon| 'COMPILER '*COMPILE-VERBOSE*)) NIL) + (SETF (SYMBOL-VALUE + (|bfColonColon| 'COMPILER 'SUPPRESS-COMPILER-WARNINGS*)) NIL) - (SETF (SYMBOL-VALUE - (|bfColonColon| 'COMPILER 'SUPPRESS-COMPILER-NOTES*)) + (SETF (SYMBOL-VALUE (|bfColonColon| 'COMPILER 'SUPPRESS-COMPILER-NOTES*)) T))))) (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Thing|) |setCurrentPackage|)) @@ -127,299 +108,281 @@ (DECLAIM (FTYPE (FUNCTION (|%String|) |%Thing|) |shoeCOMPILE-FILE|)) -(DEFUN |shoeCOMPILE-FILE| (|lspFileName|) - (COMPILE-FILE |lspFileName|)) +(DEFUN |shoeCOMPILE-FILE| (|lspFileName|) (COMPILE-FILE |lspFileName|)) (DEFUN BOOTTOCL (|fn| |out|) (UNWIND-PROTECT - (PROGN - (|startCompileDuration|) - (LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) - (BOOTTOCLLINES NIL |fn| |out|))) + (PROGN + (|startCompileDuration|) + (LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) + (BOOTTOCLLINES NIL |fn| |out|))) (|endCompileDuration|))) (DEFUN BOOTCLAM (|fn| |out|) (PROG (|$bfClamming|) (DECLARE (SPECIAL |$bfClamming|)) - (RETURN - (PROGN (SETQ |$bfClamming| T) (BOOTCLAMLINES NIL |fn| |out|))))) + (RETURN (PROGN (SETQ |$bfClamming| T) (BOOTCLAMLINES NIL |fn| |out|))))) -(DEFUN BOOTCLAMLINES (|lines| |fn| |out|) - (BOOTTOCLLINES |lines| |fn| |out|)) +(DEFUN BOOTCLAMLINES (|lines| |fn| |out|) (BOOTTOCLLINES |lines| |fn| |out|)) (DEFUN BOOTTOCLLINES (|lines| |fn| |outfn|) (PROG (|a|) (RETURN - (UNWIND-PROTECT - (PROGN + (UNWIND-PROTECT + (PROGN (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|))) (|shoeClLines| |a| |fn| |lines| |outfn|)) - (|closeStream| |a|))))) + (|closeStream| |a|))))) (DEFUN |shoeClLines| (|a| |fn| |lines| |outfn|) (PROG (|stream|) (RETURN - (COND - ((NULL |a|) (|shoeNotFound| |fn|)) - (T (UNWIND-PROTECT - (PROGN - (SETQ |stream| (|outputTextFile| |outfn|)) - (|genOptimizeOptions| |stream|) - (LET ((|bfVar#1| |lines|) (|line| NIL)) - (LOOP - (COND + (COND ((NULL |a|) (|shoeNotFound| |fn|)) + (T + (UNWIND-PROTECT + (PROGN + (SETQ |stream| (|outputTextFile| |outfn|)) + (|genOptimizeOptions| |stream|) + (LET ((|bfVar#1| |lines|) (|line| NIL)) + (LOOP + (COND ((OR (NOT (CONSP |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|) - (|genModuleFinalization| |stream|) - |outfn|) - (|closeStream| |stream|))))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (|shoeFileTrees| (|shoeTransformStream| |a|) |stream|) + (|genModuleFinalization| |stream|) + |outfn|) + (|closeStream| |stream|))))))) (DEFUN BOOTTOCLC (|fn| |out|) (UNWIND-PROTECT - (PROGN - (|startCompileDuration|) - (LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) - (BOOTTOCLCLINES NIL |fn| |out|))) + (PROGN + (|startCompileDuration|) + (LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) + (BOOTTOCLCLINES NIL |fn| |out|))) (|endCompileDuration|))) (DEFUN BOOTTOCLCLINES (|lines| |fn| |outfn|) (PROG (|a|) (RETURN - (UNWIND-PROTECT - (PROGN + (UNWIND-PROTECT + (PROGN (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|))) (|shoeClCLines| |a| |fn| |lines| |outfn|)) - (|closeStream| |a|))))) + (|closeStream| |a|))))) (DEFUN |shoeClCLines| (|a| |fn| |lines| |outfn|) (PROG (|stream|) (RETURN - (COND - ((NULL |a|) (|shoeNotFound| |fn|)) - (T (UNWIND-PROTECT - (PROGN - (SETQ |stream| (|outputTextFile| |outfn|)) - (|genOptimizeOptions| |stream|) - (LET ((|bfVar#1| |lines|) (|line| NIL)) - (LOOP - (COND + (COND ((NULL |a|) (|shoeNotFound| |fn|)) + (T + (UNWIND-PROTECT + (PROGN + (SETQ |stream| (|outputTextFile| |outfn|)) + (|genOptimizeOptions| |stream|) + (LET ((|bfVar#1| |lines|) (|line| NIL)) + (LOOP + (COND ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL)) (RETURN NIL)) (T (|shoeFileLine| |line| |stream|))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - (|shoeFileTrees| - (|shoeTransformToFile| |stream| - (|shoeInclude| - (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0)))) - |stream|) - (|genModuleFinalization| |stream|) - |outfn|) - (|closeStream| |stream|))))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (|shoeFileTrees| + (|shoeTransformToFile| |stream| + (|shoeInclude| + (|bAddLineNumber| (|bRgen| |a|) + (|bIgen| 0)))) + |stream|) + (|genModuleFinalization| |stream|) + |outfn|) + (|closeStream| |stream|))))))) (DECLAIM (FTYPE (FUNCTION (|%String|) |%Thing|) BOOTTOMC)) (DEFUN BOOTTOMC (|fn|) (PROG (|a| |callingPackage|) (RETURN - (PROGN - (SETQ |callingPackage| *PACKAGE*) - (IN-PACKAGE "BOOTTRAN") - (UNWIND-PROTECT - (PROGN - (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|))) - (|shoeMc| |a| |fn|)) + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (UNWIND-PROTECT (PROGN - (|closeStream| |a|) - (|setCurrentPackage| |callingPackage|))))))) + (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|))) + (|shoeMc| |a| |fn|)) + (PROGN (|closeStream| |a|) (|setCurrentPackage| |callingPackage|))))))) (DEFUN |shoeMc| (|a| |fn|) - (COND - ((NULL |a|) (|shoeNotFound| |fn|)) - (T (|shoePCompileTrees| (|shoeTransformStream| |a|)) - (|shoeConsole| (CONCAT |fn| " COMPILED AND LOADED"))))) + (COND ((NULL |a|) (|shoeNotFound| |fn|)) + (T (|shoePCompileTrees| (|shoeTransformStream| |a|)) + (|shoeConsole| (CONCAT |fn| " COMPILED AND LOADED"))))) (DEFUN |evalBootFile| (|fn|) (PROG (|a| |outfn| |infn| |b|) (RETURN - (PROGN - (SETQ |b| *PACKAGE*) - (IN-PACKAGE "BOOTTRAN") - (SETQ |infn| (|shoeAddbootIfNec| |fn|)) - (SETQ |outfn| - (CONCAT (|shoeRemovebootIfNec| |fn|) "." - *LISP-SOURCE-FILETYPE*)) - (UNWIND-PROTECT + (PROGN + (SETQ |b| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (SETQ |outfn| + (CONCAT (|shoeRemovebootIfNec| |fn|) "." *LISP-SOURCE-FILETYPE*)) + (UNWIND-PROTECT (PROGN - (SETQ |a| (|inputTextFile| |infn|)) - (|shoeClLines| |a| |infn| NIL |outfn|)) - (PROGN (|closeStream| |a|) (|setCurrentPackage| |b|))) - (LOAD |outfn|))))) + (SETQ |a| (|inputTextFile| |infn|)) + (|shoeClLines| |a| |infn| NIL |outfn|)) + (PROGN (|closeStream| |a|) (|setCurrentPackage| |b|))) + (LOAD |outfn|))))) (DECLAIM (FTYPE (FUNCTION (|%String|) |%Thing|) BO)) (DEFUN BO (|fn|) (PROG (|a| |b|) (RETURN - (PROGN - (SETQ |b| *PACKAGE*) - (IN-PACKAGE "BOOTTRAN") - (UNWIND-PROTECT + (PROGN + (SETQ |b| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (UNWIND-PROTECT (PROGN - (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|))) - (|shoeToConsole| |a| |fn|)) - (PROGN (|closeStream| |a|) (|setCurrentPackage| |b|))))))) + (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|))) + (|shoeToConsole| |a| |fn|)) + (PROGN (|closeStream| |a|) (|setCurrentPackage| |b|))))))) (DEFUN BOCLAM (|fn|) (PROG (|$bfClamming| |a| |callingPackage|) (DECLARE (SPECIAL |$bfClamming|)) (RETURN - (PROGN - (SETQ |callingPackage| *PACKAGE*) - (IN-PACKAGE "BOOTTRAN") - (SETQ |$bfClamming| T) - (UNWIND-PROTECT - (PROGN - (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|))) - (|shoeToConsole| |a| |fn|)) + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$bfClamming| T) + (UNWIND-PROTECT (PROGN - (|closeStream| |a|) - (|setCurrentPackage| |callingPackage|))))))) + (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|))) + (|shoeToConsole| |a| |fn|)) + (PROGN (|closeStream| |a|) (|setCurrentPackage| |callingPackage|))))))) (DEFUN |shoeToConsole| (|a| |fn|) - (COND - ((NULL |a|) (|shoeNotFound| |fn|)) - (T (|shoeConsoleTrees| - (|shoeTransformToConsole| - (|shoeInclude| - (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0)))))))) + (COND ((NULL |a|) (|shoeNotFound| |fn|)) + (T + (|shoeConsoleTrees| + (|shoeTransformToConsole| + (|shoeInclude| (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0)))))))) (DEFUN STOUT (|string|) (PSTOUT (LIST |string|))) (DEFUN |string2BootTree| (|string|) (PROG (|result| |a| |callingPackage|) (RETURN - (PROGN - (SETQ |callingPackage| *PACKAGE*) - (IN-PACKAGE "BOOTTRAN") - (SETQ |a| (|shoeTransformString| (LIST |string|))) - (SETQ |result| - (COND - ((|bStreamNull| |a|) NIL) - (T (|stripm| (CAR |a|) |callingPackage| - (FIND-PACKAGE "BOOTTRAN"))))) - (|setCurrentPackage| |callingPackage|) - |result|)))) + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |a| (|shoeTransformString| (LIST |string|))) + (SETQ |result| + (COND ((|bStreamNull| |a|) NIL) + (T + (|stripm| (CAR |a|) |callingPackage| + (FIND-PACKAGE "BOOTTRAN"))))) + (|setCurrentPackage| |callingPackage|) + |result|)))) (DEFUN STEVAL (|string|) (PROG (|result| |fn| |a| |callingPackage|) (RETURN - (PROGN - (SETQ |callingPackage| *PACKAGE*) - (IN-PACKAGE "BOOTTRAN") - (SETQ |a| (|shoeTransformString| (LIST |string|))) - (SETQ |result| - (COND - ((|bStreamNull| |a|) NIL) - (T (SETQ |fn| - (|stripm| (CAR |a|) *PACKAGE* - (FIND-PACKAGE "BOOTTRAN"))) - (EVAL |fn|)))) - (|setCurrentPackage| |callingPackage|) - |result|)))) + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |a| (|shoeTransformString| (LIST |string|))) + (SETQ |result| + (COND ((|bStreamNull| |a|) NIL) + (T + (SETQ |fn| + (|stripm| (CAR |a|) *PACKAGE* + (FIND-PACKAGE "BOOTTRAN"))) + (EVAL |fn|)))) + (|setCurrentPackage| |callingPackage|) + |result|)))) (DEFUN STTOMC (|string|) (PROG (|result| |a| |callingPackage|) (RETURN - (PROGN - (SETQ |callingPackage| *PACKAGE*) - (IN-PACKAGE "BOOTTRAN") - (SETQ |a| (|shoeTransformString| (LIST |string|))) - (SETQ |result| - (COND - ((|bStreamNull| |a|) NIL) - (T (|shoePCompile| (CAR |a|))))) - (|setCurrentPackage| |callingPackage|) - |result|)))) + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |a| (|shoeTransformString| (LIST |string|))) + (SETQ |result| + (COND ((|bStreamNull| |a|) NIL) (T (|shoePCompile| (CAR |a|))))) + (|setCurrentPackage| |callingPackage|) + |result|)))) (DEFUN |shoeCompileTrees| (|s|) (LOOP - (COND - ((|bStreamNull| |s|) (RETURN NIL)) - (T (|shoeCompile| (CAR |s|)) (SETQ |s| (CDR |s|)))))) + (COND ((|bStreamNull| |s|) (RETURN NIL)) + (T (|shoeCompile| (CAR |s|)) (SETQ |s| (CDR |s|)))))) (DECLAIM (FTYPE (FUNCTION (|%Ast|) |%Thing|) |shoeCompile|)) (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|)))))) + (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|) (|bNext| #'|shoeTreeConstruct| - (|bNext| #'|shoePileInsert| - (|bNext| #'|shoeLineToks| |str|)))) + (|bNext| #'|shoePileInsert| (|bNext| #'|shoeLineToks| |str|)))) (DEFUN |shoeTransformString| (|s|) (|shoeTransform| (|shoeInclude| (|bAddLineNumber| |s| (|bIgen| 0))))) -(DEFUN |shoeTransformStream| (|s|) - (|shoeTransformString| (|bRgen| |s|))) +(DEFUN |shoeTransformStream| (|s|) (|shoeTransformString| (|bRgen| |s|))) (DEFUN |shoeTransformToConsole| (|str|) (|bNext| #'|shoeConsoleItem| - (|bNext| #'|shoePileInsert| - (|bNext| #'|shoeLineToks| |str|)))) + (|bNext| #'|shoePileInsert| (|bNext| #'|shoeLineToks| |str|)))) (DEFUN |shoeTransformToFile| (|fn| |str|) (|bFileNext| |fn| - (|bNext| #'|shoePileInsert| (|bNext| #'|shoeLineToks| |str|)))) + (|bNext| #'|shoePileInsert| (|bNext| #'|shoeLineToks| |str|)))) (DEFUN |shoeConsoleItem| (|str|) (PROG (|dq|) (RETURN - (PROGN - (SETQ |dq| (CAR |str|)) - (|shoeConsoleLines| (|shoeDQlines| |dq|)) - (CONS (|shoeParseTrees| |dq|) (CDR |str|)))))) + (PROGN + (SETQ |dq| (CAR |str|)) + (|shoeConsoleLines| (|shoeDQlines| |dq|)) + (CONS (|shoeParseTrees| |dq|) (CDR |str|)))))) -(DEFUN |bFileNext| (|fn| |s|) - (|bDelay| #'|bFileNext1| (LIST |fn| |s|))) +(DEFUN |bFileNext| (|fn| |s|) (|bDelay| #'|bFileNext1| (LIST |fn| |s|))) (DEFUN |bFileNext1| (|fn| |s|) (PROG (|dq|) (RETURN - (COND - ((|bStreamNull| |s|) (LIST '|nullstream|)) - (T (SETQ |dq| (CAR |s|)) - (|shoeFileLines| (|shoeDQlines| |dq|) |fn|) - (|bAppend| (|shoeParseTrees| |dq|) - (|bFileNext| |fn| (CDR |s|)))))))) + (COND ((|bStreamNull| |s|) (LIST '|nullstream|)) + (T (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|))))))) + (PROGN + (SETQ |toklist| (|dqToList| |dq|)) + (COND ((NULL |toklist|) NIL) (T (|shoeOutParse| |toklist|))))))) (DEFUN |shoeTreeConstruct| (|str|) (CONS (|shoeParseTrees| (CAR |str|)) (CDR |str|))) @@ -427,58 +390,51 @@ (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|))))))) + (PROGN + (SETQ |a| (CDAAR (|shoeLastTokPosn| |dq|))) + (SETQ |b| (CDAAR (|shoeFirstTokPosn| |dq|))) + (|streamTake| (+ (- |a| |b|) 1) (CAR (|shoeFirstTokPosn| |dq|))))))) (DEFUN |streamTake| (|n| |s|) - (COND - ((|bStreamNull| |s|) NIL) - ((EQL |n| 0) NIL) - (T (CONS (CAR |s|) (|streamTake| (- |n| 1) (CDR |s|)))))) + (COND ((|bStreamNull| |s|) NIL) ((EQL |n| 0) NIL) + (T (CONS (CAR |s|) (|streamTake| (- |n| 1) (CDR |s|)))))) (DEFUN |shoeFileLines| (|lines| |fn|) (PROGN - (|shoeFileLine| " " |fn|) - (LET ((|bfVar#1| |lines|) (|line| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (|shoeFileLine| (|shoeAddComment| |line|) |fn|))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - (|shoeFileLine| " " |fn|))) + (|shoeFileLine| " " |fn|) + (LET ((|bfVar#1| |lines|) (|line| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (|shoeFileLine| (|shoeAddComment| |line|) |fn|))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (|shoeFileLine| " " |fn|))) (DEFUN |shoeConsoleLines| (|lines|) (PROGN - (|shoeConsole| " ") - (LET ((|bfVar#1| |lines|) (|line| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (|shoeConsole| (|shoeAddComment| |line|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - (|shoeConsole| " "))) + (|shoeConsole| " ") + (LET ((|bfVar#1| |lines|) (|line| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (|shoeConsole| (|shoeAddComment| |line|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (|shoeConsole| " "))) -(DEFUN |shoeFileLine| (|x| |stream|) - (PROGN (WRITE-LINE |x| |stream|) |x|)) +(DEFUN |shoeFileLine| (|x| |stream|) (PROGN (WRITE-LINE |x| |stream|) |x|)) (DEFUN |shoeFileTrees| (|s| |st|) (PROG (|a|) (RETURN - (LOOP - (COND - ((|bStreamNull| |s|) (RETURN NIL)) - (T (SETQ |a| (CAR |s|)) + (LOOP + (COND ((|bStreamNull| |s|) (RETURN NIL)) + (T (SETQ |a| (CAR |s|)) (COND - ((AND (CONSP |a|) (EQ (CAR |a|) '+LINE)) - (|shoeFileLine| (CADR |a|) |st|)) - (T (REALLYPRETTYPRINT |a| |st|) (TERPRI |st|))) + ((AND (CONSP |a|) (EQ (CAR |a|) '+LINE)) + (|shoeFileLine| (CADR |a|) |st|)) + (T (REALLYPRETTYPRINT |a| |st|) (TERPRI |st|))) (SETQ |s| (CDR |s|)))))))) (DEFUN |shoePPtoFile| (|x| |stream|) @@ -487,313 +443,291 @@ (DEFUN |shoeConsoleTrees| (|s|) (PROG (|fn|) (RETURN - (LOOP - (COND - ((|bStreamPackageNull| |s|) (RETURN NIL)) - (T (SETQ |fn| - (|stripm| (CAR |s|) *PACKAGE* - (FIND-PACKAGE "BOOTTRAN"))) + (LOOP + (COND ((|bStreamPackageNull| |s|) (RETURN NIL)) + (T + (SETQ |fn| + (|stripm| (CAR |s|) *PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) (REALLYPRETTYPRINT |fn|) (SETQ |s| (CDR |s|)))))))) (DEFUN |shoeAddComment| (|l|) (CONCAT "; " (CAR |l|))) (DEFUN |shoeOutParse| (|stream|) (PROG (|found|) - (DECLARE (SPECIAL |$bpParenCount| |$bpCount| |$returns| |$typings| - |$wheredefs| |$op| |$ttok| |$stok| |$stack| - |$inputStream|)) + (DECLARE + (SPECIAL |$inputStream| |$stack| |$stok| |$ttok| |$op| |$wheredefs| + |$typings| |$returns| |$bpCount| |$bpParenCount|)) (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| - (LET ((#0=#:G1364 - (CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem|)))) + (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| + (LET ((#1=#:G729 (CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem|)))) (COND - ((AND (CONSP #0#) - (EQUAL (CAR #0#) :OPEN-AXIOM-CATCH-POINT)) - (COND - ((EQUAL (CAR #1=(CDR #0#)) - '(|BootParserException|)) - (LET ((|e| (CDR #1#))) |e|)) - (T (THROW :OPEN-AXIOM-CATCH-POINT #0#)))) - (T #0#)))) - (COND - ((EQ |found| 'TRAPPED) NIL) - ((NOT (|bStreamNull| |$inputStream|)) (|bpGeneralErrorHere|) - NIL) - ((NULL |$stack|) (|bpGeneralErrorHere|) NIL) - (T (CAR |$stack|))))))) + ((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT)) + (COND + ((EQUAL (CAR #2=(CDR #1#)) '(|BootParserException|)) + (LET ((|e| (CDR #2#))) + |e|)) + (T (THROW :OPEN-AXIOM-CATCH-POINT #1#)))) + (T #1#)))) + (COND ((EQ |found| 'TRAPPED) NIL) + ((NOT (|bStreamNull| |$inputStream|)) (|bpGeneralErrorHere|) NIL) + ((NULL |$stack|) (|bpGeneralErrorHere|) NIL) (T (CAR |$stack|))))))) (DEFUN |genDeclaration| (|n| |t|) (PROG (|t'| |vars| |argTypes| |ISTMP#2| |valType| |ISTMP#1|) (RETURN - (COND - ((AND (CONSP |t|) (EQ (CAR |t|) '|%Mapping|) - (PROGN - (SETQ |ISTMP#1| (CDR |t|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |valType| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN - (SETQ |argTypes| (CAR |ISTMP#2|)) - T)))))) - (COND - ((|bfTupleP| |argTypes|) (SETQ |argTypes| (CDR |argTypes|)))) - (COND - ((AND |argTypes| (SYMBOLP |argTypes|)) - (SETQ |argTypes| (LIST |argTypes|)))) - (LIST 'DECLAIM - (LIST 'FTYPE (LIST 'FUNCTION |argTypes| |valType|) |n|))) - ((AND (CONSP |t|) (EQ (CAR |t|) '|%Forall|) - (PROGN - (SETQ |ISTMP#1| (CDR |t|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |vars| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |t'| (CAR |ISTMP#2|)) T)))))) - (COND - ((NULL |vars|) (|genDeclaration| |n| |t'|)) - (T (COND ((SYMBOLP |vars|) (SETQ |vars| (LIST |vars|)))) + (COND + ((AND (CONSP |t|) (EQ (CAR |t|) '|%Mapping|) + (PROGN + (SETQ |ISTMP#1| (CDR |t|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |valType| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |argTypes| (CAR |ISTMP#2|)) T)))))) + (COND ((|bfTupleP| |argTypes|) (SETQ |argTypes| (CDR |argTypes|)))) + (COND + ((AND |argTypes| (SYMBOLP |argTypes|)) + (SETQ |argTypes| (LIST |argTypes|)))) + (LIST 'DECLAIM (LIST 'FTYPE (LIST 'FUNCTION |argTypes| |valType|) |n|))) + ((AND (CONSP |t|) (EQ (CAR |t|) '|%Forall|) + (PROGN + (SETQ |ISTMP#1| (CDR |t|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |vars| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |t'| (CAR |ISTMP#2|)) T)))))) + (COND ((NULL |vars|) (|genDeclaration| |n| |t'|)) + (T (COND ((SYMBOLP |vars|) (SETQ |vars| (LIST |vars|)))) (|genDeclaration| |n| - (|applySubst| - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) - (|bfVar#1| |vars|) (|v| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN - (SETQ |v| (CAR |bfVar#1|)) - NIL)) - (RETURN |bfVar#2|)) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| - #0=(CONS (CONS |v| '*) NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #0#) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - |t'|))))) - (T (LIST 'DECLAIM (LIST 'TYPE |t| |n|))))))) + (|applySubst| + (LET ((|bfVar#2| NIL) + (|bfVar#3| NIL) + (|bfVar#1| |vars|) + (|v| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN + (SETQ |v| (CAR |bfVar#1|)) + NIL)) + (RETURN |bfVar#2|)) + ((NULL |bfVar#2|) + (SETQ |bfVar#2| + #1=(CONS (CONS |v| '*) NIL)) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #1#) + (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + |t'|))))) + (T (LIST 'DECLAIM (LIST 'TYPE |t| |n|))))))) (DEFUN |translateSignatureDeclaration| (|d|) (CASE (CAR |d|) (|%Signature| - (LET ((|n| (CADR |d|)) (|t| (CADDR |d|))) - (|genDeclaration| |n| |t|))) + (LET ((|n| (CADR |d|)) (|t| (CADDR |d|))) + (|genDeclaration| |n| |t|))) (T (|coreError| "signature expected")))) (DEFUN |translateToplevelExpression| (|expr|) (PROG (|expr'|) (RETURN - (PROGN - (SETQ |expr'| - (CDR (CDR (|shoeCompTran| (LIST 'LAMBDA NIL |expr|))))) - (LET ((|bfVar#1| |expr'|) (|t| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |t| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - ((AND (CONSP |t|) (EQ (CAR |t|) 'DECLARE)) - (IDENTITY (RPLACA |t| 'DECLAIM)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - (COND - ((< 1 (LENGTH |expr'|)) (CONS 'PROGN |expr'|)) - (T (CAR |expr'|))))))) + (PROGN + (SETQ |expr'| (CDR (CDR (|shoeCompTran| (LIST 'LAMBDA NIL |expr|))))) + (LET ((|bfVar#1| |expr'|) (|t| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |t| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + ((AND (CONSP |t|) (EQ (CAR |t|) 'DECLARE)) + (IDENTITY (RPLACA |t| 'DECLAIM)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (COND ((< 1 (LENGTH |expr'|)) (CONS 'PROGN |expr'|)) + (T (CAR |expr'|))))))) (DEFUN |inAllContexts| (|x|) - (LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) - |x|)) + (LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) |x|)) (DEFUN |exportNames| (|ns|) - (COND - ((NULL |ns|) NIL) - (T (LIST (|inAllContexts| (LIST 'EXPORT (|quote| |ns|))))))) + (COND ((NULL |ns|) NIL) + (T (LIST (|inAllContexts| (LIST 'EXPORT (|quote| |ns|))))))) (DEFUN |translateToplevel| (|b| |export?|) (PROG (|lhs| |t| |ISTMP#2| |sig| |n| |ISTMP#1| |xs|) - (DECLARE (SPECIAL |$activeNamespace| |$InteractiveMode| - |$constantIdentifiers| |$foreignsDefsForCLisp| - |$currentModuleName|)) + (DECLARE + (SPECIAL |$currentModuleName| |$foreignsDefsForCLisp| + |$constantIdentifiers| |$InteractiveMode| |$activeNamespace|)) (RETURN - (COND - ((NOT (CONSP |b|)) (LIST |b|)) - ((AND (CONSP |b|) (EQ (CAR |b|) 'TUPLE)) (SETQ |xs| (CDR |b|)) - (|coreError| "invalid AST")) - (T (CASE (CAR |b|) - (|%Signature| - (LET ((|op| (CADR |b|)) (|t| (CADDR |b|))) - (LIST (|genDeclaration| |op| |t|)))) - (|%Definition| - (LET ((|op| (CADR |b|)) (|args| (CADDR |b|)) - (|body| (CADDDR |b|))) - (CDR (|bfDef| |op| |args| |body|)))) - (|%Module| - (LET ((|m| (CADR |b|)) (|ns| (CADDR |b|)) - (|ds| (CADDDR |b|))) - (PROGN - (SETQ |$currentModuleName| |m|) - (SETQ |$foreignsDefsForCLisp| NIL) - (CONS (LIST 'PROVIDE (SYMBOL-NAME |m|)) - (|append| (|exportNames| |ns|) - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) - (|bfVar#1| |ds|) (|d| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN - (SETQ |d| (CAR |bfVar#1|)) - NIL)) - (RETURN |bfVar#2|)) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| - #0=(CONS - (CAR - (|translateToplevel| |d| T)) - NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #0#) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))))))) - (|%Import| - (LET ((|m| (CADR |b|))) + (COND ((NOT (CONSP |b|)) (LIST |b|)) + ((AND (CONSP |b|) (EQ (CAR |b|) 'TUPLE)) (SETQ |xs| (CDR |b|)) + (|coreError| "invalid AST")) + (T + (CASE (CAR |b|) + (|%Signature| + (LET ((|op| (CADR |b|)) (|t| (CADDR |b|))) + (LIST (|genDeclaration| |op| |t|)))) + (|%Definition| + (LET ((|op| (CADR |b|)) + (|args| (CADDR |b|)) + (|body| (CADDDR |b|))) + (CDR (|bfDef| |op| |args| |body|)))) + (|%Module| + (LET ((|m| (CADR |b|)) (|ns| (CADDR |b|)) (|ds| (CADDDR |b|))) + (PROGN + (SETQ |$currentModuleName| |m|) + (SETQ |$foreignsDefsForCLisp| NIL) + (CONS (LIST 'PROVIDE (SYMBOL-NAME |m|)) + (|append| (|exportNames| |ns|) + (LET ((|bfVar#2| NIL) + (|bfVar#3| NIL) + (|bfVar#1| |ds|) + (|d| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN + (SETQ |d| (CAR |bfVar#1|)) + NIL)) + (RETURN |bfVar#2|)) + ((NULL |bfVar#2|) + (SETQ |bfVar#2| + #1=(CONS + (CAR + (|translateToplevel| |d| + T)) + NIL)) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #1#) + (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))))))) + (|%Import| + (LET ((|m| (CADR |b|))) + (COND + ((AND (CONSP |m|) (EQ (CAR |m|) '|%Namespace|) + (PROGN + (SETQ |ISTMP#1| (CDR |m|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |n| (CAR |ISTMP#1|)) T)))) + (LIST + (|inAllContexts| (LIST 'USE-PACKAGE (SYMBOL-NAME |n|))))) + (T (COND - ((AND (CONSP |m|) (EQ (CAR |m|) '|%Namespace|) - (PROGN - (SETQ |ISTMP#1| (CDR |m|)) - (AND (CONSP |ISTMP#1|) - (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |n| (CAR |ISTMP#1|)) T)))) - (LIST (|inAllContexts| - (LIST 'USE-PACKAGE (SYMBOL-NAME |n|))))) - (T (COND - ((NOT (STRING= (|getOptionValue| '|import|) - "skip")) - (|bootImport| (SYMBOL-NAME |m|)))) - (LIST (LIST 'IMPORT-MODULE (SYMBOL-NAME |m|))))))) - (|%ImportSignature| - (LET ((|x| (CADR |b|)) (|sig| (CADDR |b|))) - (|genImportDeclaration| |x| |sig|))) - (|%TypeAlias| - (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|))) - (LIST (|genTypeAlias| |lhs| |rhs|)))) - (|%ConstantDefinition| - (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|))) - (PROGN - (SETQ |sig| NIL) - (COND - ((AND (CONSP |lhs|) - (EQ (CAR |lhs|) '|%Signature|) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |n| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (NULL (CDR |ISTMP#2|)) - (PROGN - (SETQ |t| (CAR |ISTMP#2|)) - T)))))) - (SETQ |sig| (|genDeclaration| |n| |t|)) - (SETQ |lhs| |n|))) - (SETQ |$constantIdentifiers| - (CONS |lhs| |$constantIdentifiers|)) - (LIST (LIST 'DEFCONSTANT |lhs| |rhs|))))) - (|%Assignment| - (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|))) - (PROGN - (SETQ |sig| NIL) - (COND - ((AND (CONSP |lhs|) - (EQ (CAR |lhs|) '|%Signature|) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |n| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (NULL (CDR |ISTMP#2|)) - (PROGN - (SETQ |t| (CAR |ISTMP#2|)) - T)))))) - (SETQ |sig| (|genDeclaration| |n| |t|)) - (SETQ |lhs| |n|))) - (COND - (|$InteractiveMode| - (LIST (LIST 'SETF |lhs| |rhs|))) - (T (LIST (LIST 'DEFPARAMETER |lhs| |rhs|))))))) - (|%Macro| - (LET ((|op| (CADR |b|)) (|args| (CADDR |b|)) - (|body| (CADDDR |b|))) - (|bfMDef| |op| |args| |body|))) - (|%Structure| - (LET ((|t| (CADR |b|)) (|alts| (CADDR |b|))) - (LET ((|bfVar#5| NIL) (|bfVar#6| NIL) - (|bfVar#4| |alts|) (|alt| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#4|)) - (PROGN (SETQ |alt| (CAR |bfVar#4|)) NIL)) - (RETURN |bfVar#5|)) - ((NULL |bfVar#5|) - (SETQ |bfVar#5| - #1=(CONS (|bfCreateDef| |alt|) NIL)) - (SETQ |bfVar#6| |bfVar#5|)) - (T (RPLACD |bfVar#6| #1#) - (SETQ |bfVar#6| (CDR |bfVar#6|)))) - (SETQ |bfVar#4| (CDR |bfVar#4|)))))) - (|%Namespace| - (LET ((|n| (CADR |b|))) - (PROGN - (SETQ |$activeNamespace| (SYMBOL-NAME |n|)) - (LIST (LIST 'IN-PACKAGE (SYMBOL-NAME |n|)))))) - (|%Lisp| (LET ((|s| (CADR |b|))) - (|shoeReadLispString| |s| 0))) - (T (LIST (|translateToplevelExpression| |b|))))))))) + ((NOT (STRING= (|getOptionValue| '|import|) "skip")) + (|bootImport| (SYMBOL-NAME |m|)))) + (LIST (LIST 'IMPORT-MODULE (SYMBOL-NAME |m|))))))) + (|%ImportSignature| + (LET ((|x| (CADR |b|)) (|sig| (CADDR |b|))) + (|genImportDeclaration| |x| |sig|))) + (|%TypeAlias| + (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|))) + (LIST (|genTypeAlias| |lhs| |rhs|)))) + (|%ConstantDefinition| + (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|))) + (PROGN + (SETQ |sig| NIL) + (COND + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Signature|) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |n| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |t| (CAR |ISTMP#2|)) T)))))) + (SETQ |sig| (|genDeclaration| |n| |t|)) (SETQ |lhs| |n|))) + (SETQ |$constantIdentifiers| + (CONS |lhs| |$constantIdentifiers|)) + (LIST (LIST 'DEFCONSTANT |lhs| |rhs|))))) + (|%Assignment| + (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|))) + (PROGN + (SETQ |sig| NIL) + (COND + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Signature|) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |n| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |t| (CAR |ISTMP#2|)) T)))))) + (SETQ |sig| (|genDeclaration| |n| |t|)) (SETQ |lhs| |n|))) + (COND (|$InteractiveMode| (LIST (LIST 'SETF |lhs| |rhs|))) + (T (LIST (LIST 'DEFPARAMETER |lhs| |rhs|))))))) + (|%Macro| + (LET ((|op| (CADR |b|)) + (|args| (CADDR |b|)) + (|body| (CADDDR |b|))) + (|bfMDef| |op| |args| |body|))) + (|%Structure| + (LET ((|t| (CADR |b|)) (|alts| (CADDR |b|))) + (LET ((|bfVar#5| NIL) + (|bfVar#6| NIL) + (|bfVar#4| |alts|) + (|alt| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#4|)) + (PROGN (SETQ |alt| (CAR |bfVar#4|)) NIL)) + (RETURN |bfVar#5|)) + ((NULL |bfVar#5|) + (SETQ |bfVar#5| #2=(CONS (|bfCreateDef| |alt|) NIL)) + (SETQ |bfVar#6| |bfVar#5|)) + (T (RPLACD |bfVar#6| #2#) + (SETQ |bfVar#6| (CDR |bfVar#6|)))) + (SETQ |bfVar#4| (CDR |bfVar#4|)))))) + (|%Namespace| + (LET ((|n| (CADR |b|))) + (PROGN + (SETQ |$activeNamespace| (SYMBOL-NAME |n|)) + (LIST (LIST 'IN-PACKAGE (SYMBOL-NAME |n|)))))) + (|%Lisp| + (LET ((|s| (CADR |b|))) + (|shoeReadLispString| |s| 0))) + (T (LIST (|translateToplevelExpression| |b|))))))))) (DEFUN |shoeAddbootIfNec| (|s|) (|shoeAddStringIfNec| ".boot" |s|)) -(DEFUN |shoeRemovebootIfNec| (|s|) - (|shoeRemoveStringIfNec| ".boot" |s|)) +(DEFUN |shoeRemovebootIfNec| (|s|) (|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|)))))) + (PROGN + (SETQ |a| (STRPOS |str| |s| 0 NIL)) + (COND ((NULL |a|) (CONCAT |s| |str|)) (T |s|)))))) (DEFUN |shoeRemoveStringIfNec| (|str| |s|) (PROG (|n|) (RETURN - (PROGN - (SETQ |n| (SEARCH |str| |s| :FROM-END T)) - (COND ((NULL |n|) |s|) (T (|subString| |s| 0 |n|))))))) + (PROGN + (SETQ |n| (SEARCH |str| |s| :FROM-END T)) + (COND ((NULL |n|) |s|) (T (|subString| |s| 0 |n|))))))) (DEFUN DEFUSE (|fn|) (PROG (|a|) (RETURN - (UNWIND-PROTECT - (PROGN + (UNWIND-PROTECT + (PROGN (SETQ |a| (|inputTextFile| (CONCAT |fn| ".boot"))) (|shoeDfu| |a| |fn|)) - (|closeStream| |a|))))) + (|closeStream| |a|))))) (DEFPARAMETER |$bootDefined| NIL) @@ -805,266 +739,250 @@ (DEFUN |shoeDfu| (|a| |fn|) (PROG (|$bfClamming| |$bootDefinedTwice| |$bootUsed| |$bootDefined| - |$lispWordTable| |stream|) - (DECLARE (SPECIAL |$bfClamming| |$bootDefinedTwice| |$bootUsed| - |$bootDefined| |$lispWordTable|)) + |$lispWordTable| |stream|) + (DECLARE + (SPECIAL |$bootDefined| |$bootUsed| |$bootDefinedTwice| |$bfClamming| + |$lispWordTable|)) (RETURN - (COND - ((NULL |a|) (|shoeNotFound| |fn|)) - (T (SETQ |$lispWordTable| (|makeTable| #'EQ)) - (DO-SYMBOLS (|i| (FIND-PACKAGE "LISP")) - (SETF (|tableValue| |$lispWordTable| |i|) T)) - (SETQ |$bootDefined| (|makeTable| #'EQ)) - (SETQ |$bootUsed| (|makeTable| #'EQ)) - (SETQ |$bootDefinedTwice| NIL) (SETQ |$bfClamming| NIL) - (|shoeDefUse| (|shoeTransformStream| |a|)) - (UNWIND-PROTECT - (PROGN - (SETQ |stream| - (|outputTextFile| (CONCAT |fn| ".defuse"))) - (|shoeReport| |stream|)) - (|closeStream| |stream|))))))) + (COND ((NULL |a|) (|shoeNotFound| |fn|)) + (T (SETQ |$lispWordTable| (|makeTable| #'EQ)) + (DO-SYMBOLS (|i| (FIND-PACKAGE "LISP")) + (SETF (|tableValue| |$lispWordTable| |i|) T)) + (SETQ |$bootDefined| (|makeTable| #'EQ)) + (SETQ |$bootUsed| (|makeTable| #'EQ)) + (SETQ |$bootDefinedTwice| NIL) (SETQ |$bfClamming| NIL) + (|shoeDefUse| (|shoeTransformStream| |a|)) + (UNWIND-PROTECT + (PROGN + (SETQ |stream| (|outputTextFile| (CONCAT |fn| ".defuse"))) + (|shoeReport| |stream|)) + (|closeStream| |stream|))))))) (DEFUN |shoeReport| (|stream|) (PROG (|b| |a|) - (DECLARE (SPECIAL |$bootDefinedTwice| |$bootUsed| |$bootDefined|)) + (DECLARE (SPECIAL |$bootDefined| |$bootUsed| |$bootDefinedTwice|)) (RETURN - (PROGN - (|shoeFileLine| "DEFINED and not USED" |stream|) - (SETQ |a| - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) - (|bfVar#1| (HKEYS |$bootDefined|)) (|i| NIL)) + (PROGN + (|shoeFileLine| "DEFINED and not USED" |stream|) + (SETQ |a| + (LET ((|bfVar#2| NIL) + (|bfVar#3| NIL) + (|bfVar#1| (HKEYS |$bootDefined|)) + (|i| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - (T (AND (NOT (|tableValue| |$bootUsed| |i|)) - (COND - ((NULL |bfVar#2|) - (SETQ |bfVar#2| #0=(CONS |i| NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #0#) - (SETQ |bfVar#3| (CDR |bfVar#3|))))))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))) - (|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#5| NIL) (|bfVar#6| NIL) - (|bfVar#4| (HKEYS |$bootUsed|)) (|i| NIL)) + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + (T + (AND (NOT (|tableValue| |$bootUsed| |i|)) + (COND + ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS |i| NIL)) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #1#) + (SETQ |bfVar#3| (CDR |bfVar#3|))))))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))) + (|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#5| NIL) + (|bfVar#6| NIL) + (|bfVar#4| (HKEYS |$bootUsed|)) + (|i| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#4|)) - (PROGN (SETQ |i| (CAR |bfVar#4|)) NIL)) - (RETURN |bfVar#5|)) - (T (AND (NOT (|tableValue| |$bootDefined| |i|)) - (COND - ((NULL |bfVar#5|) - (SETQ |bfVar#5| #1=(CONS |i| NIL)) - (SETQ |bfVar#6| |bfVar#5|)) - (T (RPLACD |bfVar#6| #1#) - (SETQ |bfVar#6| (CDR |bfVar#6|))))))) - (SETQ |bfVar#4| (CDR |bfVar#4|))))) - (LET ((|bfVar#7| (SSORT |a|)) (|i| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#7|)) - (PROGN (SETQ |i| (CAR |bfVar#7|)) NIL)) - (RETURN NIL)) - (T (SETQ |b| (CONCAT (PNAME |i|) " is used in ")) - (|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|)) - |stream| |b|))) - (SETQ |bfVar#7| (CDR |bfVar#7|)))))))) + (COND + ((OR (NOT (CONSP |bfVar#4|)) + (PROGN (SETQ |i| (CAR |bfVar#4|)) NIL)) + (RETURN |bfVar#5|)) + (T + (AND (NOT (|tableValue| |$bootDefined| |i|)) + (COND + ((NULL |bfVar#5|) (SETQ |bfVar#5| #2=(CONS |i| NIL)) + (SETQ |bfVar#6| |bfVar#5|)) + (T (RPLACD |bfVar#6| #2#) + (SETQ |bfVar#6| (CDR |bfVar#6|))))))) + (SETQ |bfVar#4| (CDR |bfVar#4|))))) + (LET ((|bfVar#7| (SSORT |a|)) (|i| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#7|)) (PROGN (SETQ |i| (CAR |bfVar#7|)) NIL)) + (RETURN NIL)) + (T (SETQ |b| (CONCAT (PNAME |i|) " is used in ")) + (|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|)) |stream| + |b|))) + (SETQ |bfVar#7| (CDR |bfVar#7|)))))))) (DEFUN |shoeDefUse| (|s|) (LOOP - (COND - ((|bStreamPackageNull| |s|) (RETURN NIL)) - (T (|defuse| NIL (CAR |s|)) (SETQ |s| (CDR |s|)))))) + (COND ((|bStreamPackageNull| |s|) (RETURN NIL)) + (T (|defuse| NIL (CAR |s|)) (SETQ |s| (CDR |s|)))))) (DEFUN |defuse| (|e| |x|) - (PROG (|niens| |nee| |LETTMP#1| |exp| |ISTMP#5| |id| |ISTMP#4| - |ISTMP#3| |body| |bv| |ISTMP#2| |name| |ISTMP#1|) - (DECLARE (SPECIAL |$bootUsed| |$bootDefinedTwice| |$bootDefined| - |$used|)) + (PROG (|niens| |nee| |LETTMP#1| |exp| |ISTMP#5| |id| |ISTMP#4| |ISTMP#3| + |body| |bv| |ISTMP#2| |name| |ISTMP#1|) + (DECLARE (SPECIAL |$used| |$bootDefined| |$bootDefinedTwice| |$bootUsed|)) (RETURN - (PROGN - (SETQ |x| (|stripm| |x| *PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) - (SETQ |$used| NIL) - (SETQ |LETTMP#1| + (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|)) - 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|)) - T)))))) - (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|) - (NULL (CDR |ISTMP#2|)) - (PROGN - (SETQ |ISTMP#3| (CAR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) + ((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|)) + 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|)) + T)))))) + (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|) (NULL (CDR |ISTMP#2|)) + (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|) - (NULL (CDR |ISTMP#5|)) + (SETQ |ISTMP#4| (CDR |ISTMP#3|)) + (AND (CONSP |ISTMP#4|) (PROGN - (SETQ |exp| - (CAR |ISTMP#5|)) - T)))))))))))) - (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|) - (NULL (CDR |ISTMP#2|)) - (PROGN - (SETQ |exp| (CAR |ISTMP#2|)) - T)))))) - (LIST |id| |exp|)) - (T (LIST 'TOP-LEVEL |x|)))) - (SETQ |nee| (CAR |LETTMP#1|)) - (SETQ |niens| (CADR |LETTMP#1|)) - (COND - ((|tableValue| |$bootDefined| |nee|) - (SETQ |$bootDefinedTwice| - (COND - ((EQ |nee| 'TOP-LEVEL) |$bootDefinedTwice|) - (T (CONS |nee| |$bootDefinedTwice|))))) - (T (SETF (|tableValue| |$bootDefined| |nee|) T))) - (|defuse1| |e| |niens|) - (LET ((|bfVar#1| |$used|) (|i| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (SETF (|tableValue| |$bootUsed| |i|) - (CONS |nee| (|tableValue| |$bootUsed| |i|))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) + (SETQ |id| (CAR |ISTMP#4|)) + (SETQ |ISTMP#5| (CDR |ISTMP#4|)) + (AND (CONSP |ISTMP#5|) + (NULL (CDR |ISTMP#5|)) + (PROGN + (SETQ |exp| + (CAR |ISTMP#5|)) + T)))))))))))) + (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|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |exp| (CAR |ISTMP#2|)) T)))))) + (LIST |id| |exp|)) + (T (LIST 'TOP-LEVEL |x|)))) + (SETQ |nee| (CAR |LETTMP#1|)) + (SETQ |niens| (CADR |LETTMP#1|)) + (COND + ((|tableValue| |$bootDefined| |nee|) + (SETQ |$bootDefinedTwice| + (COND ((EQ |nee| 'TOP-LEVEL) |$bootDefinedTwice|) + (T (CONS |nee| |$bootDefinedTwice|))))) + (T (SETF (|tableValue| |$bootDefined| |nee|) T))) + (|defuse1| |e| |niens|) + (LET ((|bfVar#1| |$used|) (|i| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T + (SETF (|tableValue| |$bootUsed| |i|) + (CONS |nee| (|tableValue| |$bootUsed| |i|))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) (DEFUN |defuse1| (|e| |y|) (PROG (|ndol| |dol| |LETTMP#1| |b| |a| |ISTMP#1|) - (DECLARE (SPECIAL |$bootDefined| |$used|)) + (DECLARE (SPECIAL |$used| |$bootDefined|)) (RETURN - (COND - ((NOT (CONSP |y|)) - (COND - ((SYMBOLP |y|) - (SETQ |$used| - (COND - ((|symbolMember?| |y| |e|) |$used|) - ((|symbolMember?| |y| |$used|) |$used|) - ((|defusebuiltin| |y|) |$used|) - (T (UNION (LIST |y|) |$used|))))) - (T 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|)) - 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|)) - T)))) - (SETQ |LETTMP#1| (|defSeparate| |a|)) - (SETQ |dol| (CAR |LETTMP#1|)) (SETQ |ndol| (CADR |LETTMP#1|)) - (LET ((|bfVar#1| |dol|) (|i| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (SETF (|tableValue| |$bootDefined| |i|) T))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - (|defuse1| (|append| |ndol| |e|) |b|)) - ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE)) (SETQ |a| (CDR |y|)) - NIL) - ((AND (CONSP |y|) (EQ (CAR |y|) '+LINE)) (SETQ |a| (CDR |y|)) - NIL) - (T (LET ((|bfVar#2| |y|) (|i| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#2|)) - (PROGN (SETQ |i| (CAR |bfVar#2|)) NIL)) - (RETURN NIL)) - (T (|defuse1| |e| |i|))) - (SETQ |bfVar#2| (CDR |bfVar#2|))))))))) + (COND + ((NOT (CONSP |y|)) + (COND + ((SYMBOLP |y|) + (SETQ |$used| + (COND ((|symbolMember?| |y| |e|) |$used|) + ((|symbolMember?| |y| |$used|) |$used|) + ((|defusebuiltin| |y|) |$used|) + (T (UNION (LIST |y|) |$used|))))) + (T 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|)) + 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|)) + T)))) + (SETQ |LETTMP#1| (|defSeparate| |a|)) (SETQ |dol| (CAR |LETTMP#1|)) + (SETQ |ndol| (CADR |LETTMP#1|)) + (LET ((|bfVar#1| |dol|) (|i| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (SETF (|tableValue| |$bootDefined| |i|) T))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (|defuse1| (|append| |ndol| |e|) |b|)) + ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE)) (SETQ |a| (CDR |y|)) NIL) + ((AND (CONSP |y|) (EQ (CAR |y|) '+LINE)) (SETQ |a| (CDR |y|)) NIL) + (T + (LET ((|bfVar#2| |y|) (|i| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#2|)) (PROGN (SETQ |i| (CAR |bfVar#2|)) NIL)) + (RETURN NIL)) + (T (|defuse1| |e| |i|))) + (SETQ |bfVar#2| (CDR |bfVar#2|))))))))) (DEFUN |defSeparate| (|x|) (PROG (|x2| |x1| |LETTMP#1| |f|) (RETURN - (COND - ((NULL |x|) (LIST NIL NIL)) - (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|)) - (T (LIST |x1| (CONS |f| |x2|))))))))) + (COND ((NULL |x|) (LIST NIL NIL)) + (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|)) + (T (LIST |x1| (CONS |f| |x2|))))))))) (DEFUN |unfluidlist| (|x|) (PROG (|y| |ISTMP#1|) (RETURN - (COND - ((NULL |x|) NIL) - ((NOT (CONSP |x|)) (LIST |x|)) - ((AND (CONSP |x|) (EQ (CAR |x|) '&REST) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |y| (CAR |ISTMP#1|)) T)))) - (LIST |y|)) - (T (CONS (CAR |x|) (|unfluidlist| (CDR |x|)))))))) + (COND ((NULL |x|) NIL) ((NOT (CONSP |x|)) (LIST |x|)) + ((AND (CONSP |x|) (EQ (CAR |x|) '&REST) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |y| (CAR |ISTMP#1|)) T)))) + (LIST |y|)) + (T (CONS (CAR |x|) (|unfluidlist| (CDR |x|)))))))) (DEFUN |defusebuiltin| (|x|) (DECLARE (SPECIAL |$lispWordTable|)) @@ -1073,12 +991,11 @@ (DEFUN |bootOut| (|l| |outfn|) (LET ((|bfVar#1| |l|) (|i| NIL)) (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (|shoeFileLine| (CONCAT " " (PNAME |i|)) |outfn|))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))) + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (|shoeFileLine| (CONCAT " " (PNAME |i|)) |outfn|))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))) (DEFUN CLESSP (|s1| |s2|) (NOT (SHOEGREATERP |s1| |s2|))) @@ -1087,131 +1004,122 @@ (DEFUN |bootOutLines| (|l| |outfn| |s|) (PROG (|a|) (RETURN - (COND - ((NULL |l|) (|shoeFileLine| |s| |outfn|)) - (T (SETQ |a| (PNAME (CAR |l|))) - (COND - ((< 70 (+ (LENGTH |s|) (LENGTH |a|))) - (|shoeFileLine| |s| |outfn|) + (COND ((NULL |l|) (|shoeFileLine| |s| |outfn|)) + (T (SETQ |a| (PNAME (CAR |l|))) + (COND + ((< 70 (+ (LENGTH |s|) (LENGTH |a|))) (|shoeFileLine| |s| |outfn|) (|bootOutLines| |l| |outfn| " ")) (T (|bootOutLines| (CDR |l|) |outfn| (CONCAT |s| " " |a|))))))))) (DEFUN XREF (|fn|) (PROG (|a|) (RETURN - (UNWIND-PROTECT - (PROGN + (UNWIND-PROTECT + (PROGN (SETQ |a| (|inputTextFile| (CONCAT |fn| ".boot"))) (|shoeXref| |a| |fn|)) - (|closeStream| |a|))))) + (|closeStream| |a|))))) (DEFUN |shoeXref| (|a| |fn|) - (PROG (|$bfClamming| |$bootUsed| |$bootDefined| |$lispWordTable| - |stream| |out|) - (DECLARE (SPECIAL |$bfClamming| |$bootUsed| |$bootDefined| - |$lispWordTable|)) + (PROG (|$bfClamming| |$bootUsed| |$bootDefined| |$lispWordTable| |stream| + |out|) + (DECLARE + (SPECIAL |$bootDefined| |$bootUsed| |$bfClamming| |$lispWordTable|)) (RETURN - (COND - ((NULL |a|) (|shoeNotFound| |fn|)) - (T (SETQ |$lispWordTable| (|makeTable| #'EQ)) - (DO-SYMBOLS (|i| (FIND-PACKAGE "LISP")) - (SETF (|tableValue| |$lispWordTable| |i|) T)) - (SETQ |$bootDefined| (|makeTable| #'EQ)) - (SETQ |$bootUsed| (|makeTable| #'EQ)) - (SETQ |$bfClamming| NIL) - (|shoeDefUse| (|shoeTransformStream| |a|)) - (SETQ |out| (CONCAT |fn| ".xref")) - (UNWIND-PROTECT - (PROGN - (SETQ |stream| (|outputTextFile| |out|)) - (|shoeXReport| |stream|) - |out|) - (|closeStream| |stream|))))))) + (COND ((NULL |a|) (|shoeNotFound| |fn|)) + (T (SETQ |$lispWordTable| (|makeTable| #'EQ)) + (DO-SYMBOLS (|i| (FIND-PACKAGE "LISP")) + (SETF (|tableValue| |$lispWordTable| |i|) T)) + (SETQ |$bootDefined| (|makeTable| #'EQ)) + (SETQ |$bootUsed| (|makeTable| #'EQ)) (SETQ |$bfClamming| NIL) + (|shoeDefUse| (|shoeTransformStream| |a|)) + (SETQ |out| (CONCAT |fn| ".xref")) + (UNWIND-PROTECT + (PROGN + (SETQ |stream| (|outputTextFile| |out|)) + (|shoeXReport| |stream|) + |out|) + (|closeStream| |stream|))))))) (DEFUN |shoeXReport| (|stream|) (PROG (|a| |c|) (DECLARE (SPECIAL |$bootUsed|)) (RETURN - (PROGN - (|shoeFileLine| "USED and where DEFINED" |stream|) - (SETQ |c| (SSORT (HKEYS |$bootUsed|))) - (LET ((|bfVar#1| |c|) (|i| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (SETQ |a| (CONCAT (PNAME |i|) " is used in ")) - (|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|)) - |stream| |a|))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) + (PROGN + (|shoeFileLine| "USED and where DEFINED" |stream|) + (SETQ |c| (SSORT (HKEYS |$bootUsed|))) + (LET ((|bfVar#1| |c|) (|i| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (SETQ |a| (CONCAT (PNAME |i|) " is used in ")) + (|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|)) |stream| + |a|))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) (DEFUN |shoeItem| (|str|) (PROG (|dq|) (RETURN - (PROGN - (SETQ |dq| (CAR |str|)) - (CONS (LIST (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) - (|bfVar#1| (|shoeDQlines| |dq|)) - (|line| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN - (SETQ |line| (CAR |bfVar#1|)) - NIL)) - (RETURN |bfVar#2|)) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| #0=(CONS (CAR |line|) NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #0#) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))) - (CDR |str|)))))) + (PROGN + (SETQ |dq| (CAR |str|)) + (CONS + (LIST + (LET ((|bfVar#2| NIL) + (|bfVar#3| NIL) + (|bfVar#1| (|shoeDQlines| |dq|)) + (|line| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS (CAR |line|) NIL)) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))) + (CDR |str|)))))) (DEFUN |stripm| (|x| |pk| |bt|) (COND - ((NOT (CONSP |x|)) - (COND - ((SYMBOLP |x|) - (COND - ((EQUAL (SYMBOL-PACKAGE |x|) |bt|) - (INTERN (SYMBOL-NAME |x|) |pk|)) - (T |x|))) - (T |x|))) - (T (CONS (|stripm| (CAR |x|) |pk| |bt|) - (|stripm| (CDR |x|) |pk| |bt|))))) + ((NOT (CONSP |x|)) + (COND + ((SYMBOLP |x|) + (COND ((EQUAL (SYMBOL-PACKAGE |x|) |bt|) (INTERN (SYMBOL-NAME |x|) |pk|)) + (T |x|))) + (T |x|))) + (T (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|))))))) + (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 |shoePCompileTrees| (|s|) (LOOP - (COND - ((|bStreamNull| |s|) (RETURN NIL)) - (T (REALLYPRETTYPRINT (|shoePCompile| (CAR |s|))) - (SETQ |s| (CDR |s|)))))) + (COND ((|bStreamNull| |s|) (RETURN NIL)) + (T (REALLYPRETTYPRINT (|shoePCompile| (CAR |s|))) + (SETQ |s| (CDR |s|)))))) (DEFUN |bStreamPackageNull| (|s|) - (LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) (|bStreamNull| |s|))) + (LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) + (|bStreamNull| |s|))) (DEFUN PSTTOMC (|string|) (|shoePCompileTrees| (|shoeTransformString| |string|))) @@ -1219,32 +1127,32 @@ (DEFUN BOOTLOOP () (PROG (|stream| |b| |a|) (RETURN - (PROGN - (SETQ |a| (|readLine| *STANDARD-INPUT*)) + (PROGN + (SETQ |a| (|readLine| *STANDARD-INPUT*)) + (COND + ((EQL (LENGTH |a|) 0) (WRITE-LINE "Boot Loop; to exit type ] ") + (BOOTLOOP)) + (T (SETQ |b| (|shoePrefix?| ")console" |a|)) (COND - ((EQL (LENGTH |a|) 0) - (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTLOOP)) - (T (SETQ |b| (|shoePrefix?| ")console" |a|)) - (COND - (|b| (SETQ |stream| *TERMINAL-IO*) - (PSTTOMC (|bRgen| |stream|)) (BOOTLOOP)) - ((CHAR= (SCHAR |a| 0) (|char| '])) NIL) - (T (PSTTOMC (LIST |a|)) (BOOTLOOP))))))))) + (|b| (SETQ |stream| *TERMINAL-IO*) (PSTTOMC (|bRgen| |stream|)) + (BOOTLOOP)) + ((CHAR= (SCHAR |a| 0) (|char| '])) NIL) + (T (PSTTOMC (LIST |a|)) (BOOTLOOP))))))))) (DEFUN BOOTPO () (PROG (|stream| |b| |a|) (RETURN - (PROGN - (SETQ |a| (|readLine| *STANDARD-INPUT*)) + (PROGN + (SETQ |a| (|readLine| *STANDARD-INPUT*)) + (COND + ((EQL (LENGTH |a|) 0) (WRITE-LINE "Boot Loop; to exit type ] ") + (BOOTPO)) + (T (SETQ |b| (|shoePrefix?| ")console" |a|)) (COND - ((EQL (LENGTH |a|) 0) - (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTPO)) - (T (SETQ |b| (|shoePrefix?| ")console" |a|)) - (COND - (|b| (SETQ |stream| *TERMINAL-IO*) - (PSTOUT (|bRgen| |stream|)) (BOOTPO)) - ((CHAR= (SCHAR |a| 0) (|char| '])) NIL) - (T (PSTOUT (LIST |a|)) (BOOTPO))))))))) + (|b| (SETQ |stream| *TERMINAL-IO*) (PSTOUT (|bRgen| |stream|)) + (BOOTPO)) + ((CHAR= (SCHAR |a| 0) (|char| '])) NIL) + (T (PSTOUT (LIST |a|)) (BOOTPO))))))))) (DEFUN PSTOUT (|string|) (LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) @@ -1256,72 +1164,67 @@ (DEFUN |getIntermediateLispFile| (|file| |options|) (PROG (|out|) (RETURN - (PROGN - (SETQ |out| (NAMESTRING (|getOutputPathname| |options|))) - (COND - (|out| (CONCAT (|shoeRemoveStringIfNec| - (CONCAT "." |$effectiveFaslType|) |out|) - ".clisp")) - (T (|defaultBootToLispFile| |file|))))))) + (PROGN + (SETQ |out| (NAMESTRING (|getOutputPathname| |options|))) + (COND + (|out| + (CONCAT + (|shoeRemoveStringIfNec| (CONCAT "." |$effectiveFaslType|) |out|) + ".clisp")) + (T (|defaultBootToLispFile| |file|))))))) (DEFUN |translateBootFile| (|progname| |options| |file|) (PROG (|outFile|) (RETURN - (PROGN - (SETQ |outFile| + (PROGN + (SETQ |outFile| (OR (|getOutputPathname| |options|) (|defaultBootToLispFile| |file|))) - (BOOTTOCL |file| (ENOUGH-NAMESTRING |outFile|)))))) + (BOOTTOCL |file| (ENOUGH-NAMESTRING |outFile|)))))) (DEFUN |retainFile?| (|ext|) (COND - ((OR (MEMBER (|Option| '|all|) |$FilesToRetain|) - (MEMBER (|Option| '|yes|) |$FilesToRetain|)) - T) - ((MEMBER (|Option| '|no|) |$FilesToRetain|) NIL) - (T (MEMBER (|Option| |ext|) |$FilesToRetain|)))) + ((OR (MEMBER (|Option| '|all|) |$FilesToRetain|) + (MEMBER (|Option| '|yes|) |$FilesToRetain|)) + T) + ((MEMBER (|Option| '|no|) |$FilesToRetain|) NIL) + (T (MEMBER (|Option| |ext|) |$FilesToRetain|)))) (DEFUN |compileBootHandler| (|progname| |options| |file|) (PROG (|objFile| |intFile|) (RETURN - (PROGN - (SETQ |intFile| - (BOOTTOCL |file| - (|getIntermediateLispFile| |file| |options|))) - (COND - ((NOT (EQL (|errorCount|) 0)) NIL) - (|intFile| - (SETQ |objFile| - (|compileLispHandler| |progname| |options| - |intFile|)) - (COND - ((NOT (|retainFile?| '|lisp|)) (DELETE-FILE |intFile|))) - |objFile|) - (T NIL)))))) + (PROGN + (SETQ |intFile| + (BOOTTOCL |file| (|getIntermediateLispFile| |file| |options|))) + (COND ((NOT (EQL (|errorCount|) 0)) NIL) + (|intFile| + (SETQ |objFile| + (|compileLispHandler| |progname| |options| |intFile|)) + (COND ((NOT (|retainFile?| '|lisp|)) (DELETE-FILE |intFile|))) + |objFile|) + (T NIL)))))) (|associateRequestWithFileType| (|Option| "translate") "boot" - #'|translateBootFile|) + #'|translateBootFile|) (|associateRequestWithFileType| (|Option| "compile") "boot" - #'|compileBootHandler|) + #'|compileBootHandler|) (DEFUN |loadNativeModule| (|m|) (COND - ((|%hasFeature| :SBCL) - (FUNCALL (|bfColonColon| 'SB-ALIEN 'LOAD-SHARED-OBJECT) |m| - :DONT-SAVE T)) - ((|%hasFeature| :CLISP) - (EVAL (LIST (|bfColonColon| 'FFI 'DEFAULT-FOREIGN-LIBRARY) |m|))) - ((|%hasFeature| :ECL) - (EVAL (LIST (|bfColonColon| 'FFI 'LOAD-FOREIGN-LIBRARY) |m|))) - ((|%hasFeature| :CLOZURE) - (EVAL (LIST (|bfColonColon| 'CCL 'OPEN-SHARED-LIBRARY) |m|))) - (T (|coreError| - "don't know how to load a dynamically linked module")))) + ((|%hasFeature| :SBCL) + (FUNCALL (|bfColonColon| 'SB-ALIEN 'LOAD-SHARED-OBJECT) |m| :DONT-SAVE T)) + ((|%hasFeature| :CLISP) + (EVAL (LIST (|bfColonColon| 'FFI 'DEFAULT-FOREIGN-LIBRARY) |m|))) + ((|%hasFeature| :ECL) + (EVAL (LIST (|bfColonColon| 'FFI 'LOAD-FOREIGN-LIBRARY) |m|))) + ((|%hasFeature| :CLOZURE) + (EVAL (LIST (|bfColonColon| 'CCL 'OPEN-SHARED-LIBRARY) |m|))) + (T (|coreError| "don't know how to load a dynamically linked module")))) (DEFUN |loadSystemRuntimeCore| () - (COND - ((OR (|%hasFeature| :ECL) (|%hasFeature| :GCL)) NIL) - (T (|loadNativeModule| - (CONCAT "libopen-axiom-core" |$NativeModuleExt|))))) + (COND ((OR (|%hasFeature| :ECL) (|%hasFeature| :GCL)) NIL) + (T + (|loadNativeModule| + (CONCAT "libopen-axiom-core" |$NativeModuleExt|))))) diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp index f151c06e..4c2f649b 100644 --- a/src/boot/strap/utility.clisp +++ b/src/boot/strap/utility.clisp @@ -6,41 +6,38 @@ (PROVIDE "utility") (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) - (EXPORT '(|objectMember?| |symbolMember?| |stringMember?| - |charMember?| |scalarMember?| |listMember?| |reverse| - |reverse!| |lastNode| |append| |append!| |copyList| - |substitute| |substitute!| |setDifference| |applySubst| - |applySubst!| |applySubstNQ| |remove| |removeSymbol| - |atomic?| |finishLine|))) + (EXPORT + '(|objectMember?| |symbolMember?| |stringMember?| |charMember?| + |scalarMember?| |listMember?| |reverse| |reverse!| + |lastNode| |append| |append!| |copyList| |substitute| + |substitute!| |setDifference| |applySubst| |applySubst!| + |applySubstNQ| |remove| |removeSymbol| |atomic?| + |finishLine|))) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) - |substitute|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) - |substitute!|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute!|)) -(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) - (|%List| |%Thing|)) - |append|)) +(DECLAIM + (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|)) + |append|)) -(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) - (|%List| |%Thing|)) - |append!|)) +(DECLAIM + (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|)) + |append!|)) -(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|)) (|%List| |%Thing|)) - |copyList|)) +(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|)) (|%List| |%Thing|)) |copyList|)) -(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|)) - (|%Maybe| (|%Node| |%Thing|))) - |lastNode|)) +(DECLAIM + (FTYPE (FUNCTION ((|%List| |%Thing|)) (|%Maybe| (|%Node| |%Thing|))) + |lastNode|)) -(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|) |%Symbol|) - (|%List| |%Thing|)) - |removeSymbol|)) +(DECLAIM + (FTYPE (FUNCTION ((|%List| |%Thing|) |%Symbol|) (|%List| |%Thing|)) + |removeSymbol|)) -(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|) |%Thing|) - (|%List| |%Thing|)) - |remove|)) +(DECLAIM + (FTYPE (FUNCTION ((|%List| |%Thing|) |%Thing|) (|%List| |%Thing|)) |remove|)) (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Boolean|) |atomic?|)) @@ -50,276 +47,232 @@ (DEFUN |objectMember?| (|x| |l|) (LOOP - (COND - ((NULL |l|) (RETURN NIL)) - ((CONSP |l|) - (COND ((EQ |x| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|))))) - (T (RETURN (EQ |x| |l|)))))) + (COND ((NULL |l|) (RETURN NIL)) + ((CONSP |l|) + (COND ((EQ |x| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|))))) + (T (RETURN (EQ |x| |l|)))))) (DEFUN |symbolMember?| (|s| |l|) (LOOP - (COND - ((NULL |l|) (RETURN NIL)) - ((CONSP |l|) - (COND ((EQ |s| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|))))) - (T (RETURN (EQ |s| |l|)))))) + (COND ((NULL |l|) (RETURN NIL)) + ((CONSP |l|) + (COND ((EQ |s| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|))))) + (T (RETURN (EQ |s| |l|)))))) (DEFUN |stringMember?| (|s| |l|) (LOOP - (COND - ((NULL |l|) (RETURN NIL)) - ((CONSP |l|) - (COND - ((STRING= |s| (CAR |l|)) (RETURN T)) - (T (SETQ |l| (CDR |l|))))) - (T (RETURN (STRING= |s| |l|)))))) + (COND ((NULL |l|) (RETURN NIL)) + ((CONSP |l|) + (COND ((STRING= |s| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|))))) + (T (RETURN (STRING= |s| |l|)))))) (DEFUN |charMember?| (|c| |l|) (LOOP - (COND - ((NULL |l|) (RETURN NIL)) - ((CONSP |l|) - (COND - ((CHAR= |c| (CAR |l|)) (RETURN T)) - (T (SETQ |l| (CDR |l|))))) - (T (RETURN (CHAR= |c| |l|)))))) + (COND ((NULL |l|) (RETURN NIL)) + ((CONSP |l|) + (COND ((CHAR= |c| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|))))) + (T (RETURN (CHAR= |c| |l|)))))) (DEFUN |scalarMember?| (|s| |l|) (LOOP - (COND - ((NULL |l|) (RETURN NIL)) - ((CONSP |l|) - (COND - ((EQL |s| (CAR |l|)) (RETURN T)) - (T (SETQ |l| (CDR |l|))))) - (T (RETURN (EQL |s| |l|)))))) + (COND ((NULL |l|) (RETURN NIL)) + ((CONSP |l|) + (COND ((EQL |s| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|))))) + (T (RETURN (EQL |s| |l|)))))) (DEFUN |listMember?| (|x| |l|) (LOOP - (COND - ((NULL |l|) (RETURN NIL)) - ((CONSP |l|) - (COND - ((EQUAL |x| (CAR |l|)) (RETURN T)) - (T (SETQ |l| (CDR |l|))))) - (T (RETURN (EQUAL |x| |l|)))))) + (COND ((NULL |l|) (RETURN NIL)) + ((CONSP |l|) + (COND ((EQUAL |x| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|))))) + (T (RETURN (EQUAL |x| |l|)))))) (DEFUN |reverse| (|l|) (PROG (|r|) (RETURN - (PROGN - (SETQ |r| NIL) - (LOOP - (COND - ((CONSP |l|) (SETQ |r| (CONS (CAR |l|) |r|)) - (SETQ |l| (CDR |l|))) - (T (RETURN |r|)))))))) + (PROGN + (SETQ |r| NIL) + (LOOP + (COND ((CONSP |l|) (SETQ |r| (CONS (CAR |l|) |r|)) (SETQ |l| (CDR |l|))) + (T (RETURN |r|)))))))) (DEFUN |reverse!| (|l|) (PROG (|l2| |l1|) (RETURN - (PROGN - (SETQ |l1| NIL) - (LOOP - (COND - ((CONSP |l|) (SETQ |l2| (CDR |l|)) (RPLACD |l| |l1|) - (SETQ |l1| |l|) (SETQ |l| |l2|)) - (T (RETURN |l1|)))))))) + (PROGN + (SETQ |l1| NIL) + (LOOP + (COND + ((CONSP |l|) (SETQ |l2| (CDR |l|)) (RPLACD |l| |l1|) (SETQ |l1| |l|) + (SETQ |l| |l2|)) + (T (RETURN |l1|)))))))) (DEFUN |lastNode| (|l|) (PROG (|l'|) (RETURN - (PROGN - (LOOP - (COND - ((NOT (AND (CONSP |l|) (PROGN (SETQ |l'| (CDR |l|)) T) - (CONSP |l'|))) - (RETURN NIL)) - (T (SETQ |l| |l'|)))) - |l|)))) + (PROGN + (LOOP + (COND + ((NOT (AND (CONSP |l|) (PROGN (SETQ |l'| (CDR |l|)) T) (CONSP |l'|))) + (RETURN NIL)) + (T (SETQ |l| |l'|)))) + |l|)))) (DEFUN |copyList| (|l|) (PROG (|l'| |t|) (RETURN - (COND - ((NOT (CONSP |l|)) |l|) - (T (SETQ |l'| (SETQ |t| (LIST (CAR |l|)))) - (LOOP + (COND ((NOT (CONSP |l|)) |l|) + (T (SETQ |l'| (SETQ |t| (LIST (CAR |l|)))) + (LOOP (PROGN - (SETQ |l| (CDR |l|)) - (COND - ((CONSP |l|) (RPLACD |t| (LIST (CAR |l|))) - (SETQ |t| (CDR |t|))) - (T (RPLACD |t| |l|) (RETURN |l'|)))))))))) + (SETQ |l| (CDR |l|)) + (COND + ((CONSP |l|) (RPLACD |t| (LIST (CAR |l|))) (SETQ |t| (CDR |t|))) + (T (RPLACD |t| |l|) (RETURN |l'|)))))))))) (DEFUN |append!| (|x| |y|) - (COND - ((NULL |x|) |y|) - ((NULL |y|) |x|) - (T (RPLACD (|lastNode| |x|) |y|) |x|))) + (COND ((NULL |x|) |y|) ((NULL |y|) |x|) + (T (RPLACD (|lastNode| |x|) |y|) |x|))) (DEFUN |append| (|x| |y|) (|append!| (|copyList| |x|) |y|)) (DEFUN |assocSymbol| (|s| |al|) (PROG (|x|) (RETURN - (LOOP - (COND - ((AND (CONSP |al|) - (PROGN (SETQ |x| (CAR |al|)) (SETQ |al| (CDR |al|)) T)) - (COND - ((AND (CONSP |x|) (EQ |s| (CAR |x|))) - (IDENTITY (RETURN |x|))))) - (T (RETURN NIL))))))) + (LOOP + (COND + ((AND (CONSP |al|) + (PROGN (SETQ |x| (CAR |al|)) (SETQ |al| (CDR |al|)) T)) + (COND ((AND (CONSP |x|) (EQ |s| (CAR |x|))) (IDENTITY (RETURN |x|))))) + (T (RETURN NIL))))))) (DEFUN |substitute!| (|y| |x| |s|) - (COND - ((NULL |s|) NIL) - ((EQ |x| |s|) |y|) - (T (COND - ((CONSP |s|) (RPLACA |s| (|substitute!| |y| |x| (CAR |s|))) - (RPLACD |s| (|substitute!| |y| |x| (CDR |s|))))) - |s|))) + (COND ((NULL |s|) NIL) ((EQ |x| |s|) |y|) + (T + (COND + ((CONSP |s|) (RPLACA |s| (|substitute!| |y| |x| (CAR |s|))) + (RPLACD |s| (|substitute!| |y| |x| (CDR |s|))))) + |s|))) (DEFUN |substitute| (|y| |x| |s|) (PROG (|t| |h|) (RETURN - (COND - ((NULL |s|) NIL) - ((EQ |x| |s|) |y|) - ((CONSP |s|) (SETQ |h| (|substitute| |y| |x| (CAR |s|))) - (SETQ |t| (|substitute| |y| |x| (CDR |s|))) - (COND - ((AND (EQ |h| (CAR |s|)) (EQ |t| (CDR |s|))) |s|) - (T (CONS |h| |t|)))) - (T |s|))))) + (COND ((NULL |s|) NIL) ((EQ |x| |s|) |y|) + ((CONSP |s|) (SETQ |h| (|substitute| |y| |x| (CAR |s|))) + (SETQ |t| (|substitute| |y| |x| (CDR |s|))) + (COND ((AND (EQ |h| (CAR |s|)) (EQ |t| (CDR |s|))) |s|) + (T (CONS |h| |t|)))) + (T |s|))))) (DEFUN |applySubst| (|sl| |t|) (PROG (|p| |tl| |hd|) (RETURN - (COND - ((CONSP |t|) (SETQ |hd| (|applySubst| |sl| (CAR |t|))) - (SETQ |tl| (|applySubst| |sl| (CDR |t|))) - (COND - ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|) - (T (CONS |hd| |tl|)))) - ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|))) - (CDR |p|)) - (T |t|))))) + (COND + ((CONSP |t|) (SETQ |hd| (|applySubst| |sl| (CAR |t|))) + (SETQ |tl| (|applySubst| |sl| (CDR |t|))) + (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|) + (T (CONS |hd| |tl|)))) + ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|))) (CDR |p|)) + (T |t|))))) (DEFUN |applySubst!| (|sl| |t|) (PROG (|p| |tl| |hd|) (RETURN - (COND - ((CONSP |t|) (SETQ |hd| (|applySubst!| |sl| (CAR |t|))) - (SETQ |tl| (|applySubst!| |sl| (CDR |t|))) (RPLACA |t| |hd|) - (RPLACD |t| |tl|)) - ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|))) - (CDR |p|)) - (T |t|))))) + (COND + ((CONSP |t|) (SETQ |hd| (|applySubst!| |sl| (CAR |t|))) + (SETQ |tl| (|applySubst!| |sl| (CDR |t|))) (RPLACA |t| |hd|) + (RPLACD |t| |tl|)) + ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|))) (CDR |p|)) + (T |t|))))) (DEFUN |applySubstNQ| (|sl| |t|) (PROG (|p| |tl| |hd|) (RETURN - (COND - ((AND (CONSP |t|) - (PROGN (SETQ |hd| (CAR |t|)) (SETQ |tl| (CDR |t|)) T)) - (COND - ((EQ |hd| 'QUOTE) |t|) - (T (SETQ |hd| (|applySubstNQ| |sl| |hd|)) + (COND + ((AND (CONSP |t|) (PROGN (SETQ |hd| (CAR |t|)) (SETQ |tl| (CDR |t|)) T)) + (COND ((EQ |hd| 'QUOTE) |t|) + (T (SETQ |hd| (|applySubstNQ| |sl| |hd|)) (SETQ |tl| (|applySubstNQ| |sl| |tl|)) - (COND - ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|) - (T (CONS |hd| |tl|)))))) - ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|))) - (CDR |p|)) - (T |t|))))) + (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|) + (T (CONS |hd| |tl|)))))) + ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|))) (CDR |p|)) + (T |t|))))) (DEFUN |setDifference| (|x| |y|) (PROG (|a| |l| |p|) (RETURN - (COND - ((NULL |x|) NIL) - ((NULL |y|) |x|) - (T (SETQ |l| (SETQ |p| (LIST NIL))) - (LET ((|bfVar#1| |x|)) - (LOOP - (COND - ((NOT (CONSP |bfVar#1|)) (RETURN NIL)) - (T (AND (CONSP |bfVar#1|) - (PROGN (SETQ |a| (CAR |bfVar#1|)) T) - (NOT (|objectMember?| |a| |y|)) - (PROGN - (RPLACD |p| (LIST |a|)) - (SETQ |p| (CDR |p|)))))) + (COND ((NULL |x|) NIL) ((NULL |y|) |x|) + (T (SETQ |l| (SETQ |p| (LIST NIL))) + (LET ((|bfVar#1| |x|)) + (LOOP + (COND ((NOT (CONSP |bfVar#1|)) (RETURN NIL)) + (T + (AND (CONSP |bfVar#1|) + (PROGN (SETQ |a| (CAR |bfVar#1|)) T) + (NOT (|objectMember?| |a| |y|)) + (PROGN + (RPLACD |p| (LIST |a|)) + (SETQ |p| (CDR |p|)))))) (SETQ |bfVar#1| (CDR |bfVar#1|)))) - (CDR |l|)))))) + (CDR |l|)))))) (DEFUN |removeSymbol| (|l| |x|) (PROG (|y| |LETTMP#1| |l'| |before|) (RETURN - (PROGN - (SETQ |before| NIL) - (SETQ |l'| |l|) - (LOOP - (COND - ((NOT (CONSP |l'|)) (RETURN |l|)) - (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|)) - (SETQ |l'| (CDR |LETTMP#1|)) - (COND - ((EQ |x| |y|) - (RETURN (|append!| (|reverse!| |before|) |l'|))) - (T (SETQ |before| (CONS |y| |before|))))))))))) + (PROGN + (SETQ |before| NIL) + (SETQ |l'| |l|) + (LOOP + (COND ((NOT (CONSP |l'|)) (RETURN |l|)) + (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|)) + (SETQ |l'| (CDR |LETTMP#1|)) + (COND + ((EQ |x| |y|) (RETURN (|append!| (|reverse!| |before|) |l'|))) + (T (SETQ |before| (CONS |y| |before|))))))))))) (DEFUN |removeScalar| (|l| |x|) (PROG (|y| |LETTMP#1| |l'| |before|) (RETURN - (PROGN - (SETQ |before| NIL) - (SETQ |l'| |l|) - (LOOP - (COND - ((NOT (CONSP |l'|)) (RETURN |l|)) - (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|)) - (SETQ |l'| (CDR |LETTMP#1|)) - (COND - ((EQL |x| |y|) - (RETURN (|append!| (|reverse!| |before|) |l'|))) - (T (SETQ |before| (CONS |y| |before|))))))))))) + (PROGN + (SETQ |before| NIL) + (SETQ |l'| |l|) + (LOOP + (COND ((NOT (CONSP |l'|)) (RETURN |l|)) + (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|)) + (SETQ |l'| (CDR |LETTMP#1|)) + (COND + ((EQL |x| |y|) (RETURN (|append!| (|reverse!| |before|) |l'|))) + (T (SETQ |before| (CONS |y| |before|))))))))))) (DEFUN |removeValue| (|l| |x|) (PROG (|y| |LETTMP#1| |l'| |before|) (RETURN - (PROGN - (SETQ |before| NIL) - (SETQ |l'| |l|) - (LOOP - (COND - ((NOT (CONSP |l'|)) (RETURN |l|)) - (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|)) - (SETQ |l'| (CDR |LETTMP#1|)) - (COND - ((EQUAL |x| |y|) - (RETURN (|append!| (|reverse!| |before|) |l'|))) - (T (SETQ |before| (CONS |y| |before|))))))))))) + (PROGN + (SETQ |before| NIL) + (SETQ |l'| |l|) + (LOOP + (COND ((NOT (CONSP |l'|)) (RETURN |l|)) + (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|)) + (SETQ |l'| (CDR |LETTMP#1|)) + (COND + ((EQUAL |x| |y|) + (RETURN (|append!| (|reverse!| |before|) |l'|))) + (T (SETQ |before| (CONS |y| |before|))))))))))) (DEFUN |remove| (|l| |x|) - (COND - ((SYMBOLP |x|) (|removeSymbol| |l| |x|)) - ((OR (CHARACTERP |x|) (INTEGERP |x|)) (|removeScalar| |l| |x|)) - (T (|removeValue| |l| |x|)))) + (COND ((SYMBOLP |x|) (|removeSymbol| |l| |x|)) + ((OR (CHARACTERP |x|) (INTEGERP |x|)) (|removeScalar| |l| |x|)) + (T (|removeValue| |l| |x|)))) (DEFUN |charPosition| (|c| |s| |k|) (PROG (|n|) (RETURN - (PROGN - (SETQ |n| (LENGTH |s|)) - (LOOP - (COND - ((NOT (< |k| |n|)) (RETURN NIL)) - ((CHAR= (SCHAR |s| |k|) |c|) (RETURN |k|)) - (T (SETQ |k| (+ |k| 1))))))))) - -(DEFUN |finishLine| (|out|) - (PROGN (TERPRI |out|) (FORCE-OUTPUT |out|))) + (PROGN + (SETQ |n| (LENGTH |s|)) + (LOOP + (COND ((NOT (< |k| |n|)) (RETURN NIL)) + ((CHAR= (SCHAR |s| |k|) |c|) (RETURN |k|)) + (T (SETQ |k| (+ |k| 1))))))))) + +(DEFUN |finishLine| (|out|) (PROGN (TERPRI |out|) (FORCE-OUTPUT |out|))) |