(PROCLAIM '(OPTIMIZE SPEED)) (IMPORT-MODULE "includer") (IN-PACKAGE "BOOTTRAN") (PROVIDE "ast") (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) (EXPORT '(|quote| |translateForm|))) (DEFPARAMETER |$bfClamming| NIL) (DEFPARAMETER |$constantIdentifiers| NIL) (DEFPARAMETER |$activeNamespace| NIL) (DEFUN |%Command| #1=(|bfVar#1|) (CONS '|%Command| (LIST . #1#))) (DEFUN |%Lisp| #1=(|bfVar#2|) (CONS '|%Lisp| (LIST . #1#))) (DEFUN |%Module| #1=(|bfVar#3| |bfVar#4| |bfVar#5|) (CONS '|%Module| (LIST . #1#))) (DEFUN |%Namespace| #1=(|bfVar#6|) (CONS '|%Namespace| (LIST . #1#))) (DEFUN |%Import| #1=(|bfVar#7|) (CONS '|%Import| (LIST . #1#))) (DEFUN |%LoadUnit| #1=(|bfVar#8|) (CONS '|%LoadUnit| (LIST . #1#))) (DEFUN |%ImportSignature| #1=(|bfVar#9| |bfVar#10| |bfVar#11|) (CONS '|%ImportSignature| (LIST . #1#))) (DEFUN |%Record| #1=(|bfVar#12| |bfVar#13|) (CONS '|%Record| (LIST . #1#))) (DEFUN |%AccessorDef| #1=(|bfVar#14| |bfVar#15|) (CONS '|%AccessorDef| (LIST . #1#))) (DEFUN |%TypeAlias| #1=(|bfVar#16| |bfVar#17|) (CONS '|%TypeAlias| (LIST . #1#))) (DEFUN |%Signature| #1=(|bfVar#18| |bfVar#19|) (CONS '|%Signature| (LIST . #1#))) (DEFUN |%Mapping| #1=(|bfVar#20| |bfVar#21|) (CONS '|%Mapping| (LIST . #1#))) (DEFUN |%Forall| #1=(|bfVar#22| |bfVar#23|) (CONS '|%Forall| (LIST . #1#))) (DEFUN |%Dynamic| #1=(|bfVar#24|) (CONS '|%Dynamic| (LIST . #1#))) (DEFUN |%SuffixDot| #1=(|bfVar#25|) (CONS '|%SuffixDot| (LIST . #1#))) (DEFUN |%Quote| #1=(|bfVar#26|) (CONS '|%Quote| (LIST . #1#))) (DEFUN |%EqualPattern| #1=(|bfVar#27|) (CONS '|%EqualPattern| (LIST . #1#))) (DEFUN |%Colon| #1=(|bfVar#28|) (CONS '|%Colon| (LIST . #1#))) (DEFUN |%QualifiedName| #1=(|bfVar#29| |bfVar#30|) (CONS '|%QualifiedName| (LIST . #1#))) (DEFUN |%Restrict| #1=(|bfVar#31| |bfVar#32|) (CONS '|%Restrict| (LIST . #1#))) (DEFUN |%DefaultValue| #1=(|bfVar#33| |bfVar#34|) (CONS '|%DefaultValue| (LIST . #1#))) (DEFUN |%Key| #1=(|bfVar#35| |bfVar#36|) (CONS '|%Key| (LIST . #1#))) (DEFUN |%Bracket| #1=(|bfVar#37|) (CONS '|%Bracket| (LIST . #1#))) (DEFUN |%UnboundedSegment| #1=(|bfVar#38|) (CONS '|%UnboundedSegment| (LIST . #1#))) (DEFUN |%BoundedSgement| #1=(|bfVar#39| |bfVar#40|) (CONS '|%BoundedSgement| (LIST . #1#))) (DEFUN |%Tuple| #1=(|bfVar#41|) (CONS '|%Tuple| (LIST . #1#))) (DEFUN |%ColonAppend| #1=(|bfVar#42| |bfVar#43|) (CONS '|%ColonAppend| (LIST . #1#))) (DEFUN |%Is| #1=(|bfVar#44| |bfVar#45|) (CONS '|%Is| (LIST . #1#))) (DEFUN |%Isnt| #1=(|bfVar#46| |bfVar#47|) (CONS '|%Isnt| (LIST . #1#))) (DEFUN |%Reduce| #1=(|bfVar#48| |bfVar#49|) (CONS '|%Reduce| (LIST . #1#))) (DEFUN |%PrefixExpr| #1=(|bfVar#50| |bfVar#51|) (CONS '|%PrefixExpr| (LIST . #1#))) (DEFUN |%Call| #1=(|bfVar#52| |bfVar#53|) (CONS '|%Call| (LIST . #1#))) (DEFUN |%InfixExpr| #1=(|bfVar#54| |bfVar#55| |bfVar#56|) (CONS '|%InfixExpr| (LIST . #1#))) (DEFUN |%ConstantDefinition| #1=(|bfVar#57| |bfVar#58|) (CONS '|%ConstantDefinition| (LIST . #1#))) (DEFUN |%Definition| #1=(|bfVar#59| |bfVar#60| |bfVar#61|) (CONS '|%Definition| (LIST . #1#))) (DEFUN |%Macro| #1=(|bfVar#62| |bfVar#63| |bfVar#64|) (CONS '|%Macro| (LIST . #1#))) (DEFUN |%Lambda| #1=(|bfVar#65| |bfVar#66|) (CONS '|%Lambda| (LIST . #1#))) (DEFUN |%SuchThat| #1=(|bfVar#67|) (CONS '|%SuchThat| (LIST . #1#))) (DEFUN |%Assignment| #1=(|bfVar#68| |bfVar#69|) (CONS '|%Assignment| (LIST . #1#))) (DEFUN |%While| #1=(|bfVar#70|) (CONS '|%While| (LIST . #1#))) (DEFUN |%Until| #1=(|bfVar#71|) (CONS '|%Until| (LIST . #1#))) (DEFUN |%For| #1=(|bfVar#72| |bfVar#73| |bfVar#74|) (CONS '|%For| (LIST . #1#))) (DEFUN |%Implies| #1=(|bfVar#75| |bfVar#76|) (CONS '|%Implies| (LIST . #1#))) (DEFUN |%Iterators| #1=(|bfVar#77|) (CONS '|%Iterators| (LIST . #1#))) (DEFUN |%Cross| #1=(|bfVar#78|) (CONS '|%Cross| (LIST . #1#))) (DEFUN |%Repeat| #1=(|bfVar#79| |bfVar#80|) (CONS '|%Repeat| (LIST . #1#))) (DEFUN |%Pile| #1=(|bfVar#81|) (CONS '|%Pile| (LIST . #1#))) (DEFUN |%Append| #1=(|bfVar#82|) (CONS '|%Append| (LIST . #1#))) (DEFUN |%Case| #1=(|bfVar#83| |bfVar#84|) (CONS '|%Case| (LIST . #1#))) (DEFUN |%Return| #1=(|bfVar#85|) (CONS '|%Return| (LIST . #1#))) (DEFUN |%Leave| #1=(|bfVar#86|) (CONS '|%Leave| (LIST . #1#))) (DEFUN |%Throw| #1=(|bfVar#87|) (CONS '|%Throw| (LIST . #1#))) (DEFUN |%Catch| #1=(|bfVar#88| |bfVar#89|) (CONS '|%Catch| (LIST . #1#))) (DEFUN |%Finally| #1=(|bfVar#90|) (CONS '|%Finally| (LIST . #1#))) (DEFUN |%Try| #1=(|bfVar#91| |bfVar#92|) (CONS '|%Try| (LIST . #1#))) (DEFUN |%Where| #1=(|bfVar#93| |bfVar#94|) (CONS '|%Where| (LIST . #1#))) (DEFUN |%Structure| #1=(|bfVar#95| |bfVar#96|) (CONS '|%Structure| (LIST . #1#))) (DEFSTRUCT (|%LoadUnit| (:COPIER |copy%LoadUnit|)) |fdefs| |sigs| |xports| |csts| |varno| |letno| |isno| |sconds| |op|) (DEFMACRO |mk%LoadUnit| (|fdefs| |sigs| |xports| |csts| |varno| |letno| |isno| |sconds| |op|) (LIST '|MAKE-%LoadUnit| :|fdefs| |fdefs| :|sigs| |sigs| :|xports| |xports| :|csts| |csts| :|varno| |varno| :|letno| |letno| :|isno| |isno| :|sconds| |sconds| :|op| |op|)) (DEFMACRO |functionDefinitions| (|bfVar#1|) (LIST '|%LoadUnit-fdefs| |bfVar#1|)) (DEFMACRO |globalSignatures| (|bfVar#1|) (LIST '|%LoadUnit-sigs| |bfVar#1|)) (DEFMACRO |exportedNames| (|bfVar#1|) (LIST '|%LoadUnit-xports| |bfVar#1|)) (DEFMACRO |constantBindings| (|bfVar#1|) (LIST '|%LoadUnit-csts| |bfVar#1|)) (DEFMACRO |currentGensymNumber| (|bfVar#1|) (LIST '|%LoadUnit-varno| |bfVar#1|)) (DEFMACRO |letVariableNumer| (|bfVar#1|) (LIST '|%LoadUnit-letno| |bfVar#1|)) (DEFMACRO |isVariableNumber| (|bfVar#1|) (LIST '|%LoadUnit-isno| |bfVar#1|)) (DEFMACRO |sideConditions| (|bfVar#1|) (LIST '|%LoadUnit-sconds| |bfVar#1|)) (DEFMACRO |enclosingFunction| (|bfVar#1|) (LIST '|%LoadUnit-op| |bfVar#1|)) (DEFUN |makeLoadUnit| () (|mk%LoadUnit| NIL NIL NIL NIL 0 0 0 NIL NIL)) (DEFUN |pushFunctionDefinition| (|tu| |def|) (SETF (|functionDefinitions| |tu|) (CONS |def| (|functionDefinitions| |tu|)))) (DEFPARAMETER |$inDefIS| NIL) (DEFUN |quote| (|x|) (LIST 'QUOTE |x|)) (DEFUN |bfSpecificErrorHere| (|msg|) (THROW :OPEN-AXIOM-CATCH-POINT (CONS :OPEN-AXIOM-CATCH-POINT (CONS '(|BootSpecificError|) |msg|)))) (DECLAIM (FTYPE (FUNCTION (|%LoadUnit|) |%Symbol|) |bfGenSymbol|)) (DEFUN |bfGenSymbol| (|tu|) (PROGN (SETF (|currentGensymNumber| |tu|) (+ (|currentGensymNumber| |tu|) 1)) (INTERN (CONCAT "bfVar#" (WRITE-TO-STRING (|currentGensymNumber| |tu|)))))) (DECLAIM (FTYPE (FUNCTION (|%LoadUnit|) |%Symbol|) |bfLetVar|)) (DEFUN |bfLetVar| (|tu|) (PROGN (SETF (|letVariableNumer| |tu|) (+ (|letVariableNumer| |tu|) 1)) (INTERN (CONCAT "LETTMP#" (WRITE-TO-STRING (|letVariableNumer| |tu|)))))) (DECLAIM (FTYPE (FUNCTION (|%LoadUnit|) |%Symbol|) |bfIsVar|)) (DEFUN |bfIsVar| (|tu|) (PROGN (SETF (|isVariableNumber| |tu|) (+ (|isVariableNumber| |tu|) 1)) (INTERN (CONCAT "ISTMP#" (WRITE-TO-STRING (|isVariableNumber| |tu|)))))) (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Form|) |bfColon|)) (DEFUN |bfColon| (|x|) (LIST 'COLON |x|)) (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|)))) (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Thing|) |bfSymbol|)) (DEFUN |bfSymbol| (|x|) (COND ((STRINGP |x|) |x|) (T (|quote| |x|)))) (DEFUN |bfFunction| (|x|) (LIST 'FUNCTION |x|)) (DECLAIM (FTYPE (FUNCTION NIL |%Symbol|) |bfDot|)) (DEFUN |bfDot| () 'DOT) (DECLAIM (FTYPE (FUNCTION (|%Form|) |%Form|) |bfSuffixDot|)) (DEFUN |bfSuffixDot| (|x|) (LIST |x| 'DOT)) (DECLAIM (FTYPE (FUNCTION (|%Form|) |%Form|) |bfEqual|)) (DEFUN |bfEqual| (|name|) (LIST 'EQUAL |name|)) (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Thing|) |bfBracket|)) (DEFUN |bfBracket| (|part|) |part|) (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|)) (DECLAIM (FTYPE (FUNCTION ((|%List| (|%List| |%Form|))) (|%List| |%Form|)) |bfAppend|)) (DEFUN |bfAppend| (|ls|) (LET* (|p| |r| |l|) (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|)) (DEFUN |bfColonAppend| (|x| |y|) (LET* (|a|) (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 |compFluid| (|id|) (LIST '|%Dynamic| |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|)))))) (DEFUN |bfPlace| (|x|) (CONS '|%Place| |x|)) (DEFUN |bfTuple| (|x|) (CONS 'TUPLE |x|)) (DEFUN |bfTupleP| (|x|) (AND (CONSP |x|) (EQ (CAR |x|) 'TUPLE))) (DEFUN |bfUntuple| (|bf|) (COND ((|bfTupleP| |bf|) (CDR |bf|)) (T |bf|))) (DEFUN |bfTupleIf| (|x|) (COND ((|bfTupleP| |x|) |x|) (T (|bfTuple| |x|)))) (DEFUN |bfTupleConstruct| (|b|) (LET* (|ISTMP#1| |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|) (LET* (|a|) (PROGN (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) (T (LIST |b|)))) (|bfMakeCons| |a|)))) (DEFUN |bfMakeCons| (|l|) (LET* (|l1| |a| |ISTMP#2| |ISTMP#1|) (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| (|tu| |lhs| |u| |step|) (COND ((AND (CONSP |u|) (EQ (CAR |u|) '|tails|)) (|bfForTree| |tu| 'ON |lhs| (CADR |u|))) ((AND (CONSP |u|) (EQ (CAR |u|) 'SEGMENT)) (|bfSTEP| |tu| |lhs| (CADR |u|) |step| (CADDR |u|))) ((AND (CONSP |u|) (EQ (CAR |u|) '|entries|)) (|bfIterateTable| |tu| |lhs| (CADR |u|))) (T (|bfForTree| |tu| 'IN |lhs| |u|)))) (DEFUN |bfForTree| (|tu| OP |lhs| |whole|) (LET* (G) (PROGN (SETQ |whole| (COND ((|bfTupleP| |whole|) (|bfMakeCons| (CDR |whole|))) (T |whole|))) (COND ((NOT (CONSP |lhs|)) (|bfINON| |tu| (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| |tu| (LIST OP G |whole|)) (|bfSuchthat| |tu| (|bfIS| |tu| G (CADDR |lhs|))))) (T (SETQ G (|bfGenSymbol| |tu|)) (|append| (|bfINON| |tu| (LIST OP G |whole|)) (|bfSuchthat| |tu| (|bfIS| |tu| G |lhs|)))))))))) (DEFUN |bfSTEP| (|tu| |id| |fst| |step| |lst|) (LET* (|suc| |ex| |pred| |final| |g2| |inc| |g1| |initval| |initvar|) (PROGN (COND ((EQ |id| 'DOT) (SETQ |id| (|bfGenSymbol| |tu|)))) (SETQ |initvar| (LIST |id|)) (SETQ |initval| (LIST |fst|)) (SETQ |inc| (COND ((NOT (CONSP |step|)) |step|) (T (SETQ |g1| (|bfGenSymbol| |tu|)) (SETQ |initvar| (CONS |g1| |initvar|)) (SETQ |initval| (CONS |step| |initval|)) |g1|))) (SETQ |final| (COND ((NOT (CONSP |lst|)) |lst|) (T (SETQ |g2| (|bfGenSymbol| |tu|)) (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| (|tu| |e| |t|) (LIST '|%tbliter| |e| |t| (GENSYM))) (DEFUN |bfINON| (|tu| |x|) (LET* (|whole| |id| |op|) (PROGN (SETQ |op| (CAR |x|)) (SETQ |id| (CADR . #1=(|x|))) (SETQ |whole| (CADDR . #1#)) (COND ((EQ |op| 'ON) (|bfON| |tu| |id| |whole|)) (T (|bfIN| |tu| |id| |whole|)))))) (DEFUN |bfIN| (|tu| |x| E) (LET* (|exitCond| |inits| |vars| |g|) (PROGN (SETQ |g| (|bfGenSymbol| |tu|)) (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| (|tu| |x| E) (LET* (|var| |init|) (PROGN (COND ((EQ |x| 'DOT) (SETQ |x| (|bfGenSymbol| |tu|)))) (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| (|tu| |p|) (LIST (LIST NIL NIL NIL (LIST |p|) NIL NIL))) (DEFUN |bfWhile| (|tu| |p|) (LIST (LIST NIL NIL NIL NIL (LIST (|bfNOT| |p|)) NIL))) (DEFUN |bfUntil| (|tu| |p|) (LET* (|g|) (PROGN (SETQ |g| (|bfGenSymbol| |tu|)) (LIST (LIST (LIST |g|) (LIST NIL) (LIST (LIST 'SETQ |g| |p|)) NIL (LIST |g|) NIL))))) (DEFUN |bfIterators| (|x|) (CONS 'ITERATORS |x|)) (DEFUN |bfCross| (|x|) (CONS 'CROSS |x|)) (DEFUN |bfLp| (|tu| |iters| |body|) (COND ((AND (CONSP |iters|) (EQ (CAR |iters|) 'ITERATORS)) (|bfLp1| |tu| (CDR |iters|) |body|)) (T (|bfLpCross| |tu| (CDR |iters|) |body|)))) (DEFUN |bfLpCross| (|tu| |iters| |body|) (COND ((NULL (CDR |iters|)) (|bfLp| |tu| (CAR |iters|) |body|)) (T (|bfLp| |tu| (CAR |iters|) (|bfLpCross| |tu| (CDR |iters|) |body|))))) (DEFUN |bfSep| (|iters|) (LET* (|r| |f|) (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| #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| (|tu| |op| |y|) (LET* (|it| |ny| |g2| |body| |g1| |g| |init| |a|) (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| |tu|)) (SETQ |g1| (|bfGenSymbol| |tu|)) (SETQ |body| (LIST 'SETQ |g| (LIST |op| |g| |g1|))) (COND ((NULL |init|) (SETQ |g2| (|bfGenSymbol| |tu|)) (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| |tu| |g1| |ny|)))) (|bfMKPROGN| (LIST (LIST 'L%T |g2| |y|) (|bfLp| |tu| |it| |body|)))) (T (SETQ |init| (CAR |init|)) (SETQ |it| (CONS 'ITERATORS (LIST (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|))) (|bfIN| |tu| |g1| |y|)))) (|bfLp| |tu| |it| |body|)))))) (DEFUN |bfReduceCollect| (|tu| |op| |y|) (LET* (|seq| |init| |a| |itl| |body|) (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| |tu| |body| |itl| '|lastNode| '|skipNil|)) ((EQ |a| '|append|) (|bfDoCollect| |tu| (LIST '|copyList| |body|) |itl| '|lastNode| '|skipNil|)) (T (SETQ |op| (|bfReName| |a|)) (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA))) (|bfOpReduce| |tu| |op| |init| |body| |itl|)))) (T (SETQ |seq| (COND ((NULL |y|) (|bfTuple| NIL)) (T (CADR |y|)))) (|bfReduce| |tu| |op| (|bfTupleConstruct| |seq|)))))) (DEFUN |bfDCollect| (|y| |itl|) (LIST 'COLLECT |y| |itl|)) (DEFUN |bfDTuple| (|x|) (LIST 'DTUPLE |x|)) (DEFUN |bfCollect| (|tu| |y| |itl|) (LET* (|a| |ISTMP#1|) (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| |tu| |a| |itl| '|lastNode| '|skipNil|)) (T (|bfDoCollect| |tu| (LIST '|copyList| |a|) |itl| '|lastNode| '|skipNil|)))) ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) (|bfDoCollect| |tu| (|bfConstruct| |y|) |itl| '|lastNode| '|skipNil|)) (T (|bfDoCollect| |tu| (LIST 'CONS |y| 'NIL) |itl| 'CDR NIL))))) (DEFUN |bfMakeCollectInsn| (|expr| |prev| |head| |adv|) (LET* (|otherTime| |firstTime|) (PROGN (SETQ |firstTime| (|bfMKPROGN| (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|)))) (DEFUN |bfDoCollect| (|tu| |expr| |itl| |adv| |k|) (LET* (|extrait| |body| |x| |prev| |head|) (PROGN (SETQ |head| (|bfGenSymbol| |tu|)) (SETQ |prev| (|bfGenSymbol| |tu|)) (SETQ |body| (COND ((EQ |k| '|skipNil|) (SETQ |x| (|bfGenSymbol| |tu|)) (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| |tu| |extrait| |itl| |body|)))) (DEFUN |separateIterators| (|iters|) (LET* (|y| |x|) (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 |bfTableIteratorBindingForm| (|tu| |keyval| |end?| |succ|) (LET* (|k| |v| |val| |ISTMP#2| |key| |ISTMP#1|) (COND ((AND (CONSP |keyval|) (EQ (CAR |keyval|) 'CONS) (PROGN (SETQ |ISTMP#1| (CDR |keyval|)) (AND (CONSP |ISTMP#1|) (PROGN (SETQ |key| (CAR |ISTMP#1|)) (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) (PROGN (SETQ |val| (CAR |ISTMP#2|)) T)))))) (COND ((EQ |key| 'DOT) (SETQ |key| (GENSYM)))) (COND ((EQ |val| 'DOT) (SETQ |val| (GENSYM)))) (COND ((AND (|ident?| |key|) (|ident?| |val|)) (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |key| |val|) (LIST |succ|))) ((|ident?| |key|) (SETQ |v| (GENSYM)) (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |key| |v|) (LIST |succ|) (|bfLET| |tu| |val| |v|))) (T (SETQ |k| (GENSYM)) (COND ((|ident?| |val|) (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |val|) (LIST |succ|) (|bfLET| |tu| |key| |k|))) (T (SETQ |v| (GENSYM)) (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |v|) (LIST |succ|) (|bfLET| |tu| |key| |k|) (|bfLET| |tu| |val| |v|))))))) (T (SETQ |k| (GENSYM)) (SETQ |v| (GENSYM)) (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |v|) (LIST |succ|) (|bfLET| |tu| |keyval| (LIST 'CONS |k| |v|))))))) (DEFUN |bfExpandTableIters| (|tu| |iters|) (LET* (|x| |g| |ISTMP#2| |t| |ISTMP#1| |e| |exits| |localBindings| |inits|) (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|)) (SETQ |localBindings| (CONS (|bfTableIteratorBindingForm| |tu| |e| |x| |g|) |localBindings|)))))) (SETQ |bfVar#2| (CDR |bfVar#2|)))) (LIST |inits| |localBindings| |exits|)))) (DEFUN |bfLp1| (|tu| |iters| |body|) (LET* (|loop| |nbody| |tblExits| |tblLocs| |tblInits| |value| |exits| |filters| |sucs| |inits| |vars| |tbls| |LETTMP#1|) (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| |tu| |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| (|tu| |extrait| |itl| |body|) (LET* (|iters|) (COND ((AND (CONSP |itl|) (EQ (CAR |itl|) 'ITERATORS)) (|bfLp1| |tu| (CONS |extrait| (CDR |itl|)) |body|)) (T (SETQ |iters| (CDR |itl|)) (|bfLpCross| |tu| (CONS (CONS 'ITERATORS (CONS |extrait| (CDAR |iters|))) (CDR |iters|)) |body|))))) (DEFUN |bfOpReduce| (|tu| |op| |init| |y| |itl|) (LET* (|extrait| |g1| |body| |g|) (PROGN (SETQ |g| (|bfGenSymbol| |tu|)) (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| |tu|)) (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| |tu| |extrait| |itl| |body|)))) (T (SETQ |init| (CAR |init|)) (SETQ |extrait| (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|)))) (|bfLp2| |tu| |extrait| |itl| |body|)))))) (DEFUN |bfLoop1| (|tu| |body|) (|bfLp| |tu| (|bfIterators| NIL) |body|)) (DEFUN |bfSegment1| (|lo|) (LIST 'SEGMENT |lo| NIL)) (DEFUN |bfSegment2| (|lo| |hi|) (LIST 'SEGMENT |lo| |hi|)) (DEFUN |bfForInBy| (|tu| |variable| |collection| |step|) (|bfFor| |tu| |variable| |collection| |step|)) (DEFUN |bfForin| (|tu| |lhs| U) (|bfFor| |tu| |lhs| U 1)) (DEFUN |bfSignature| (|a| |b|) (COND ((EQ |b| '|local|) (|compFluid| |a|)) (T (LIST '|%Signature| |a| |b|)))) (DEFUN |bfTake| (|n| |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|))))) (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|)))))) (DEFUN |bfSUBLIS1| (|p| |e|) (LET* (|f|) (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| (|tu| |x|) (LET* (|defstack| |op1| |opassoc| |argl|) (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| (|translateForm| |body|)))) (LIST |opassoc| NIL NIL)) (T (SETQ |op1| (INTERN (CONCAT (SYMBOL-NAME (|enclosingFunction| |tu|)) "," (SYMBOL-NAME |op|)))) (SETQ |opassoc| (LIST (CONS |op| |op1|))) (SETQ |defstack| (LIST (LIST |op1| |args| (|translateForm| |body|)))) (LIST |opassoc| |defstack| NIL)))))) (|%Pile| (LET ((|defs| (CADR |x|))) (|defSheepAndGoatsList| |tu| |defs|))) (T (LIST NIL NIL (LIST |x|)))))) (DEFUN |defSheepAndGoatsList| (|tu| |x|) (LET* (|nondefs1| |defs1| |opassoc1| |nondefs| |defs| |opassoc| |LETTMP#1|) (COND ((NULL |x|) (LIST NIL NIL NIL)) (T (SETQ |LETTMP#1| (|defSheepAndGoats| |tu| (CAR |x|))) (SETQ |opassoc| (CAR |LETTMP#1|)) (SETQ |defs| (CADR . #1=(|LETTMP#1|))) (SETQ |nondefs| (CADDR . #1#)) (SETQ |LETTMP#1| (|defSheepAndGoatsList| |tu| (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| (|tu| |lhs| |rhs|) (LET* (|let1| |g| |l2| |l1| |name| |rhs1| |ISTMP#1|) (COND ((SYMBOLP |lhs|) (|bfLetForm| |lhs| |rhs|)) ((OR (AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Dynamic|) (PROGN (SETQ |ISTMP#1| (CDR |lhs|)) (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))) (AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Signature|))) (|bfLetForm| |lhs| |rhs|)) ((AND (SYMBOLP |rhs|) (NOT (|bfCONTAINED| |rhs| |lhs|))) (SETQ |rhs1| (|bfLET2| |tu| |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| |tu| |name| (CADDR |rhs|))) (SETQ |l2| (|bfLET1| |tu| |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| |tu|)) (SETQ |rhs1| (LIST 'L%T |g| |rhs|)) (SETQ |let1| (|bfLET1| |tu| |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)))))))))) (DEFUN |bfCONTAINED| (|x| |y|) (COND ((EQ |x| |y|) T) ((NOT (CONSP |y|)) NIL) (T (OR (|bfCONTAINED| |x| (CAR |y|)) (|bfCONTAINED| |x| (CDR |y|)))))) (DEFUN |bfLET2| (|tu| |lhs| |rhs|) (LET* (|isPred| |val1| |ISTMP#3| |g| |rev| |patrev| |l2| |l1| |var2| |var1| |b| |ISTMP#2| |a| |ISTMP#1|) (DECLARE (SPECIAL |$inDefIS|)) (COND ((NULL |lhs|) NIL) ((SYMBOLP |lhs|) (|bfLetForm| |lhs| |rhs|)) ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Dynamic|) (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| |tu| |a| |rhs|)) (COND ((NULL (SETQ |b| (|bfLET2| |tu| |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| |tu| |var2| (|addCARorCDR| 'CDR |rhs|))) (T (SETQ |l1| (|bfLET2| |tu| |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| |tu| |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| |tu|)) (SETQ |l2| (|bfLET2| |tu| |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| |tu| |rhs| |lhs|)) (T (|bfIS| |tu| |rhs| |lhs|)))) (LIST 'COND (LIST |isPred| |rhs|)))))) (DEFUN |bfLET| (|tu| |lhs| |rhs|) (LET* (|letno|) (PROGN (SETQ |letno| (|letVariableNumer| |tu|)) (UNWIND-PROTECT (PROGN (SETF (|letVariableNumer| |tu|) 0) (|bfLET1| |tu| |lhs| |rhs|)) (SETF (|letVariableNumer| |tu|) |letno|))))) (DEFUN |addCARorCDR| (|acc| |expr|) (LET* (|funsR| |funsA| |p| |funs|) (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))))) (DEFUN |bfISApplication| (|tu| |op| |left| |right|) (COND ((EQ |op| 'IS) (|bfIS| |tu| |left| |right|)) ((EQ |op| 'ISNT) (|bfNOT| (|bfIS| |tu| |left| |right|))) (T (LIST |op| |left| |right|)))) (DEFUN |bfIS| (|tu| |left| |right|) (LET* (|isno|) (PROGN (SETQ |isno| (|isVariableNumber| |tu|)) (UNWIND-PROTECT (PROGN (SETF (|isVariableNumber| |tu|) 0) (LET ((|$inDefIS| T)) (DECLARE (SPECIAL |$inDefIS|)) (|bfIS1| |tu| |left| |right|))) (SETF (|isVariableNumber| |tu|) |isno|))))) (DEFUN |bfISReverse| (|x| |a|) (LET* (|y|) (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 (|bfSpecificErrorHere| "Error in bfISReverse"))))) (DEFUN |bfIS1| (|tu| |lhs| |rhs|) (LET* (|l2| |rev| |patrev| |cls| |b1| |a1| |g| |b| |ISTMP#2| |ISTMP#1| |l| |d| |c| |a|) (COND ((NULL |rhs|) (LIST 'NULL |lhs|)) ((EQ |rhs| T) (LIST 'EQ |lhs| |rhs|)) ((|bfString?| |rhs|) (|bfAND| (LIST (LIST 'STRINGP |lhs|) (LIST 'STRING= |lhs| |rhs|)))) ((OR (|bfChar?| |rhs|) (INTEGERP |rhs|)) (LIST 'EQL |lhs| |rhs|)) ((KEYWORDP |rhs|) (LIST 'EQ |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| |tu| |c| |lhs|)) (|bfAND| (LIST (|bfIS1| |tu| |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| |tu|)) (|bfMKPROGN| (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |tu| |g| |rhs|)))) ((EQ (CAR |rhs|) 'CONS) (SETQ |a| (CADR . #2=(|rhs|))) (SETQ |b| (CADDR . #2#)) (COND ((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| |tu| (LIST 'CDR |lhs|) |b|)))))) ((NULL |b|) (|bfAND| (LIST (LIST 'CONSP |lhs|) (LIST 'NULL (LIST 'CDR |lhs|)) (|bfIS1| |tu| (LIST 'CAR |lhs|) |a|)))) ((EQ |b| 'DOT) (|bfAND| (LIST (LIST 'CONSP |lhs|) (|bfIS1| |tu| (LIST 'CAR |lhs|) |a|)))) (T (SETQ |a1| (|bfIS1| |tu| (LIST 'CAR |lhs|) |a|)) (SETQ |b1| (|bfIS1| |tu| (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 . #3=(|rhs|))) (SETQ |b| (CADDR . #3#)) (SETQ |patrev| (|bfISReverse| |b| |a|)) (SETQ |g| (|bfIsVar| |tu|)) (SETQ |rev| (|bfAND| (LIST (LIST 'CONSP |lhs|) (LIST 'PROGN (LIST 'L%T |g| (LIST '|reverse| |lhs|)) 'T)))) (SETQ |l2| (|bfIS1| |tu| |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 (|bfSpecificErrorHere| "bad IS code is generated"))))) (DEFUN |bfHas| (|expr| |prop|) (COND ((SYMBOLP |prop|) (LIST 'GET |expr| (|quote| |prop|))) (T (|bfSpecificErrorHere| "expected identifier as property name")))) (DEFUN |bfKeyArg| (|k| |x|) (LIST '|%Key| |k| |x|)) (DEFUN |bfInert| (|x|) (INTERN |x| "KEYWORD")) (DEFUN |lispKey| (|k|) (|bfInert| (STRING-UPCASE (SYMBOL-NAME |k|)))) (DEFUN |bfExpandKeys| (|l|) (LET* (|x| |ISTMP#2| |k| |ISTMP#1| |a| |args|) (PROGN (SETQ |args| NIL) (LOOP (COND ((NOT (AND (CONSP |l|) (PROGN (SETQ |a| (CAR |l|)) (SETQ |l| (CDR |l|)) T))) (RETURN NIL)) ((AND (CONSP |a|) (EQ (CAR |a|) '|%Key|) (PROGN (SETQ |ISTMP#1| (CDR |a|)) (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 |x| (CAR |ISTMP#2|)) T)))))) (SETQ |args| (CONS |x| (CONS (|lispKey| |k|) |args|)))) (T (SETQ |args| (CONS |a| |args|))))) (|reverse!| |args|)))) (DEFUN |bfApplication| (|bfop| |bfarg|) (LET* (|v| |ISTMP#2| |k| |ISTMP#1|) (COND ((|bfTupleP| |bfarg|) (CONS |bfop| (|bfExpandKeys| (CDR |bfarg|)))) ((AND (CONSP |bfarg|) (EQ (CAR |bfarg|) '|%Key|) (PROGN (SETQ |ISTMP#1| (CDR |bfarg|)) (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 |v| (CAR |ISTMP#2|)) T)))))) (LIST |bfop| (|lispKey| |k|) |v|)) (T (LIST |bfop| |bfarg|))))) (DEFUN |bfReName| (|x|) (LET* (|a|) (COND ((SETQ |a| (GET |x| 'SHOERENAME)) (CAR |a|)) (T |x|)))) (DEFUN |sequence?| (|x| |pred|) (LET* (|seq| |ISTMP#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| (FUNCALL |pred| |y|)) (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|)))))) (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|)))))) (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|)))))) (DEFUN |bfMember| (|var| |seq|) (LET* (|y| |x| |ISTMP#2| |ISTMP#1|) (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|)))) (DEFUN |bfNOT| (|x|) (LET* (|a| |ISTMP#1|) (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|)))) (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 ((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|) (SETQ |bfVar#3| (|lastNode| |bfVar#3|))))))) (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 ((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|) (SETQ |bfVar#3| (|lastNode| |bfVar#3|))))))) (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))))) (DEFUN |bfNumber?| (|x|) (OR (INTEGERP |x|) (FLOATP |x|) (AND (CONSP |x|) (|symbolMember?| (CAR |x|) '(SIZE LENGTH CHAR-CODE MAXINDEX + -))))) (DEFUN |bfString?| (|x|) (OR (STRINGP |x|) (AND (CONSP |x|) (|symbolMember?| (CAR |x|) '(STRING SYMBOL-NAME |subString|))))) (DEFUN |bfQ| (|l| |r|) (COND ((OR (|bfChar?| |l|) (|bfChar?| |r|)) (LIST 'CHAR= |l| |r|)) ((OR (|bfNumber?| |l|) (|bfNumber?| |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 ((AND (OR (INTEGERP |l|) (FLOATP |l|)) (EQL |l| 0)) (LIST 'PLUSP |r|)) ((AND (OR (INTEGERP |r|) (FLOATP |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|))) (DEFUN |bfMDef| (|tu| |op| |args| |body|) (LET* (|def| |lamex| |argl|) (PROGN (SETQ |argl| (COND ((|bfTupleP| |args|) (CDR |args|)) (T (LIST |args|)))) (SETQ |lamex| (LIST 'MLAMBDA |argl| (|backquote| |body| |argl|))) (SETQ |def| (LIST |op| |lamex|)) (CONS (|shoeComp| |def|) (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| (|sideConditions| |tu|)) (|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| |tu| |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 |bfGargl| (|tu| |argl|) (LET* (|f| |d| |c| |b| |a| |LETTMP#1|) (COND ((NULL |argl|) (LIST NIL NIL NIL NIL)) (T (SETQ |LETTMP#1| (|bfGargl| |tu| (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|)))) (T (SETQ |f| (|bfGenSymbol| |tu|)) (LIST (CONS |f| |a|) (CONS |f| |b|) (CONS (CAR |argl|) |c|) (CONS |f| |d|)))))))) (DEFUN |bfDef1| (|tu| |bfVar#1|) (LET* (|arglp| |control| |quotes| |LETTMP#1| |argl| |body| |args| |op|) (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| |tu| |argl| |body|)) (SETQ |quotes| (CAR |LETTMP#1|)) (SETQ |control| (CADR . #2=(|LETTMP#1|))) (SETQ |arglp| (CADDR . #2#)) (SETQ |body| (CADDDR . #2#)) (COND (|quotes| (|shoeLAM| |tu| |op| |arglp| |control| |body|)) (T (LIST (LIST |op| (LIST 'LAMBDA |arglp| |body|)))))))) (DEFUN |shoeLAM| (|tu| |op| |args| |control| |body|) (LET* (|innerfunc| |margs|) (PROGN (SETQ |margs| (|bfGenSymbol| |tu|)) (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| (|tu| |op| |args| |body|) (LET* (|body1| |arg1| |op1| |LETTMP#1|) (DECLARE (SPECIAL |$bfClamming|)) (COND (|$bfClamming| (SETQ |LETTMP#1| (|shoeComp| (CAR (|bfDef1| |tu| (LIST |op| |args| |body|))))) (SETQ |op1| (CADR . #1=(|LETTMP#1|))) (SETQ |arg1| (CADDR . #1#)) (SETQ |body1| (CDDDR . #1#)) (|bfCompHash| |tu| |op1| |arg1| |body1|)) (T (|bfTuple| (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| (CONS (LIST |op| |args| |body|) (|sideConditions| |tu|))) (|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| |tu| |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| #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|) (LET* (|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))) (|bfSpecificErrorHere| "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| (|tu| |x| |body|) (LET* (|body2| |name2| |norq1| |b1| |body1| |name1| |norq| |LETTMP#1| |b| |a| |ISTMP#1|) (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) (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| |tu| (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| |tu| (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| (|tu| |y| |body|) (LET* (|g| |b| |r| |ISTMP#2| |l| |ISTMP#1|) (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| |tu| |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| |tu|)) (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| |tu| (|compFluidize| |y|) |g|) |body|))))))))))) (DEFUN |shoeCompTran| (|x|) (LET* (|fl| |vars| |fvars| |body'| |dollarVars| |locVars| |fluidVars| |body| |args| |lamtype|) (PROGN (SETQ |lamtype| (CAR |x|)) (SETQ |args| (CADR . #1=(|x|))) (SETQ |body| (CDDR . #1#)) (SETQ |fluidVars| (|ref| NIL)) (SETQ |locVars| (|ref| NIL)) (SETQ |dollarVars| (|ref| NIL)) (|shoeCompTran1| |body| |fluidVars| |locVars| |dollarVars|) (SETF (|deref| |locVars|) (|setDifference| (|setDifference| (|deref| |locVars|) (|deref| |fluidVars|)) (|shoeATOMs| |args|))) (SETQ |body| (PROGN (SETQ |body'| |body|) (COND ((SETQ |fvars| (|setDifference| (|deref| |dollarVars|) (|deref| |fluidVars|))) (SETQ |body'| (CONS (LIST 'DECLARE (CONS 'SPECIAL |fvars|)) |body'|)))) (COND ((SETQ |vars| (|deref| |locVars|)) (|declareLocalVars| |vars| |body'|)) (T (|maybeAddBlock| |body'|))))) (COND ((SETQ |fl| (|shoeFluids| |args|)) (SETQ |body| (CONS (LIST 'DECLARE (CONS 'SPECIAL |fl|)) |body|)))) (CONS |lamtype| (CONS |args| |body|))))) (DEFUN |declareLocalVars| (|vars| |stmts|) (LET* (|inits| |ISTMP#2| |ISTMP#1|) (COND ((AND (CONSP |stmts|) (NULL (CDR |stmts|)) (PROGN (SETQ |ISTMP#1| (CAR |stmts|)) (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'LET*) (PROGN (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (PROGN (SETQ |inits| (CAR |ISTMP#2|)) (SETQ |stmts| (CDR |ISTMP#2|)) T)))))) (LIST (CONS 'LET* (CONS (|append| |inits| |vars|) (|maybeAddBlock| |stmts|))))) (T (LIST (CONS 'LET* (CONS |vars| (|maybeAddBlock| |stmts|)))))))) (DEFUN |maybeAddBlock| (|stmts|) (LET* (|decls| |expr| |LETTMP#1|) (PROGN (SETQ |LETTMP#1| (|reverse| |stmts|)) (SETQ |expr| (CAR |LETTMP#1|)) (SETQ |decls| (|reverse!| (CDR |LETTMP#1|))) (COND ((|hasReturn?| |expr|) (COND ((NULL |decls|) (LIST (CONS 'BLOCK (CONS 'NIL |stmts|)))) (T (|append| |decls| (CONS (LIST 'BLOCK 'NIL |expr|) NIL))))) (T |stmts|))))) (DEFUN |hasReturn?| (|x|) (COND ((NOT (CONSP |x|)) NIL) ((EQ (CAR |x|) 'RETURN) T) ((|symbolMember?| (CAR |x|) '(LOOP PROG BLOCK LAMBDA DECLARE)) NIL) (T (LET ((|bfVar#2| NIL) (|bfVar#1| |x|) (|t| NIL)) (LOOP (COND ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |t| (CAR |bfVar#1|)) NIL)) (RETURN |bfVar#2|)) (T (SETQ |bfVar#2| (|hasReturn?| |t|)) (COND (|bfVar#2| (RETURN |bfVar#2|))))) (SETQ |bfVar#1| (CDR |bfVar#1|))))))) (DEFUN |shoeFluids| (|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|)))))) (DEFUN |isDynamicVariable| (|x|) (LET* (|y|) (DECLARE (SPECIAL |$activeNamespace| |$constantIdentifiers|)) (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| |fluidVars| |locVars| |dollarVars|) (LET* (|n| |elts| |newbindings| |r| |ISTMP#2| |l| |zs| |y| |ISTMP#1| U) (COND ((NOT (CONSP |x|)) (COND ((AND (|isDynamicVariable| |x|) (NOT (|symbolMember?| |x| (|deref| |dollarVars|)))) (SETF (|deref| |dollarVars|) (CONS |x| (|deref| |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)))) (SETF (CADR |x|) (|shoeCompTran1| |y| |fluidVars| |locVars| |dollarVars|)) (LOOP (COND ((NOT |zs|) (RETURN NIL)) (T (SETF (CADR (CAR |zs|)) (|shoeCompTran1| (CADR (CAR |zs|)) |fluidVars| |locVars| |dollarVars|)) (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)))))) (SETF (CADDR |x|) (|shoeCompTran1| |r| |fluidVars| |locVars| |dollarVars|)) (COND ((AND (CONSP |l|) (EQ (CAR |l|) '|%Dynamic|) (PROGN (SETQ |ISTMP#1| (CDR |l|)) (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) (PROGN (SETQ |y| (CAR |ISTMP#1|)) T)))) (COND ((NOT (|symbolMember?| |y| (|deref| |fluidVars|))) (SETF (|deref| |fluidVars|) (CONS |y| (|deref| |fluidVars|))))) (SETF (CADR |x|) |y|) |x|) ((AND (CONSP |l|) (EQ (CAR |l|) '|%Signature|)) |x|) (T (RPLACA |x| 'SETQ) (COND ((SYMBOLP |l|) (COND ((|bfBeginsDollar| |l|) (COND ((NOT (|symbolMember?| |l| (|deref| |dollarVars|))) (SETF (|deref| |dollarVars|) (CONS |l| (|deref| |dollarVars|))))) |x|) (T (COND ((NOT (|symbolMember?| |l| (|deref| |locVars|))) (SETF (|deref| |locVars|) (CONS |l| (|deref| |locVars|))))) |x|))) (T |x|))))) ((EQ U '|%Leave|) (RPLACA |x| 'RETURN) (RPLACD |x| (|shoeCompTran1| (CDR |x|) |fluidVars| |locVars| |dollarVars|)) |x|) ((|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| (|deref| |locVars|))) (IDENTITY (PROGN (SETF (|deref| |locVars|) (CONS |y| (|deref| |locVars|))) (SETQ |newbindings| (CONS |y| |newbindings|)))))) (SETQ |bfVar#1| (CDR |bfVar#1|)))) (RPLACD (CDR |x|) (|shoeCompTran1| (CDDR |x|) |fluidVars| |locVars| |dollarVars|)) (SETF (|deref| |locVars|) (LET ((|bfVar#3| NIL) (|bfVar#4| NIL) (|bfVar#2| (|deref| |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| #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)))) (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|) |fluidVars| |locVars| |dollarVars|))) ((NOT (CONSP |elts|)) (SETQ |elts| (|shoeCompTran1| |elts| |fluidVars| |locVars| |dollarVars|)) (RPLACA |x| 'MAKE-ARRAY) (RPLACD |x| (LIST (LIST 'LIST-LENGTH |elts|) :INITIAL-CONTENTS |elts|))) (T (RPLACA |x| 'COERCE) (RPLACD |x| (LIST (|shoeCompTran1| |elts| |fluidVars| |locVars| |dollarVars|) (|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|))))) (T (RPLACA |x| (|shoeCompTran1| (CAR |x|) |fluidVars| |locVars| |dollarVars|)) (RPLACD |x| (|shoeCompTran1| (CDR |x|) |fluidVars| |locVars| |dollarVars|)) (|bindFluidVars!| |x|))))))) (DEFUN |bindFluidVars!| (|x|) (LET* (|y| |init| |stmts| |expr| |ISTMP#6| |t| |ISTMP#5| |v| |ISTMP#4| |ISTMP#3| |ISTMP#2| |ISTMP#1|) (COND ((AND (CONSP |x|) (PROGN (SETQ |ISTMP#1| (CAR |x|)) (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'L%T) (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 |expr| (CAR |ISTMP#6|)) T)))))))) (SETQ |stmts| (CDR |x|)) (RPLACA |x| (COND ((NULL |stmts|) (LIST 'LET (LIST (LIST |v| |expr|)) (LIST 'DECLARE (LIST 'TYPE |t|)) |v|)) (T (CONS 'LET (CONS (LIST (LIST |v| |expr|)) (CONS (LIST 'DECLARE (LIST 'TYPE |t|)) (|bindFluidVars!| |stmts|))))))) (RPLACD |x| NIL) |x|) (T (COND ((AND (CONSP |x|) (PROGN (SETQ |ISTMP#1| (CAR |x|)) (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'L%T) (PROGN (SETQ |init| (CDR |ISTMP#1|)) T))) (PROGN (SETQ |stmts| (CDR |x|)) T)) (RPLACA |x| (|groupFluidVars| (LIST |init|) (LIST (CAR |init|)) |stmts|)) (RPLACD |x| NIL))) (COND ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN) (PROGN (SETQ |ISTMP#1| (CDR |x|)) (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) (PROGN (SETQ |y| (CAR |ISTMP#1|)) T)))) |y|) (T |x|)))))) (DEFUN |groupFluidVars| (|inits| |vars| |stmts|) (LET* (|stmts'| |vars'| |ISTMP#6| |ISTMP#5| |ISTMP#4| |ISTMP#3| |inits'| |ISTMP#2| |ISTMP#1|) (COND ((AND (CONSP |stmts|) (NULL (CDR |stmts|)) (PROGN (SETQ |ISTMP#1| (CAR |stmts|)) (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'LET) (PROGN (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (PROGN (SETQ |inits'| (CAR |ISTMP#2|)) (SETQ |ISTMP#3| (CDR |ISTMP#2|)) (AND (CONSP |ISTMP#3|) (PROGN (SETQ |ISTMP#4| (CAR |ISTMP#3|)) (AND (CONSP |ISTMP#4|) (EQ (CAR |ISTMP#4|) 'DECLARE) (PROGN (SETQ |ISTMP#5| (CDR |ISTMP#4|)) (AND (CONSP |ISTMP#5|) (NULL (CDR |ISTMP#5|)) (PROGN (SETQ |ISTMP#6| (CAR |ISTMP#5|)) (AND (CONSP |ISTMP#6|) (EQ (CAR |ISTMP#6|) 'SPECIAL) (PROGN (SETQ |vars'| (CDR |ISTMP#6|)) T))))))) (PROGN (SETQ |stmts'| (CDR |ISTMP#3|)) T))))))) (CONSP |inits'|) (NULL (CDR |inits'|))) (|groupFluidVars| (|append| |inits| |inits'|) (|append| |vars| |vars'|) |stmts'|)) ((AND (CONSP |stmts|) (NULL (CDR |stmts|)) (PROGN (SETQ |ISTMP#1| (CAR |stmts|)) (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'LET*) (PROGN (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (PROGN (SETQ |inits'| (CAR |ISTMP#2|)) (SETQ |ISTMP#3| (CDR |ISTMP#2|)) (AND (CONSP |ISTMP#3|) (PROGN (SETQ |ISTMP#4| (CAR |ISTMP#3|)) (AND (CONSP |ISTMP#4|) (EQ (CAR |ISTMP#4|) 'DECLARE) (PROGN (SETQ |ISTMP#5| (CDR |ISTMP#4|)) (AND (CONSP |ISTMP#5|) (NULL (CDR |ISTMP#5|)) (PROGN (SETQ |ISTMP#6| (CAR |ISTMP#5|)) (AND (CONSP |ISTMP#6|) (EQ (CAR |ISTMP#6|) 'SPECIAL) (PROGN (SETQ |vars'| (CDR |ISTMP#6|)) T))))))) (PROGN (SETQ |stmts'| (CDR |ISTMP#3|)) T)))))))) (|groupFluidVars| (|append| |inits| |inits'|) (|append| |vars| |vars'|) |stmts'|)) ((AND (CONSP |inits|) (NULL (CDR |inits|))) (LIST 'LET |inits| (LIST 'DECLARE (CONS 'SPECIAL |vars|)) (|bfMKPROGN| |stmts|))) (T (LIST 'LET* |inits| (LIST 'DECLARE (CONS 'SPECIAL |vars|)) (|bfMKPROGN| |stmts|)))))) (DEFUN |bfRestrict| (|x| |t|) (LIST 'THE |t| |x|)) (DEFUN |bfAssign| (|tu| |l| |r|) (LET* (|l'|) (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| |tu| |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|)))) (DEFUN |bfElt| (|expr| |sel|) (LET* (|y|) (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|) (LET* (|y|) (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|) (LET* (|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|) (LET* (|c1| |b1|) (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 |bfFlattenSeq| (|l|) (LET* (|xs| |x|) (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|))) (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|))))) (DEFUN |bfWashCONDBranchBody| (|x|) (LET* (|y|) (COND ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN)) (SETQ |y| (CDR |x|)) |y|) (T (LIST |x|))))) (DEFUN |bfAlternative| (|a| |b|) (LET* (|conds| |ISTMP#5| |stmt| |ISTMP#4| |ISTMP#3| |ISTMP#2| |ISTMP#1|) (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|) (LET* (|f| |aft| |before| |no| |transform| |b| |ISTMP#5| |ISTMP#4| |ISTMP#3| |a| |ISTMP#2| |ISTMP#1|) (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|)) (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|)) (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|))))))) ((NULL |aft|) (CONS 'COND |transform|)) (T (CONS 'COND (|append| |transform| (CONS (|bfAlternative| 'T (|bfSequence| |aft|)) NIL))))))))) (DEFUN |bfWhere| (|tu| |context| |expr|) (LET* (|a| |nondefs| |defs| |opassoc| |LETTMP#1|) (PROGN (SETQ |LETTMP#1| (|defSheepAndGoats| |tu| |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| #2=(CONS (LIST (CAR |d|) (CADR |d|) (|bfSUBLIS| |opassoc| (CADDR |d|))) NIL)) (SETQ |bfVar#3| |bfVar#2|)) (T (RPLACD |bfVar#3| #2#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) (SETQ |bfVar#1| (CDR |bfVar#1|))))) (SETF (|sideConditions| |tu|) (|append| |a| (|sideConditions| |tu|))) (|bfMKPROGN| (|bfSUBLIS| |opassoc| (|append!| |nondefs| (LIST |expr|))))))) (DEFUN |bfCompHash| (|tu| |op| |argl| |body|) (LET* (|computeFunction| |auxfn|) (PROGN (SETQ |auxfn| (INTERN (CONCAT (SYMBOL-NAME |op|) ";"))) (SETQ |computeFunction| (CONS 'DEFUN (CONS |auxfn| (CONS |argl| |body|)))) (|bfTuple| (CONS |computeFunction| (|bfMain| |tu| |auxfn| |op|)))))) (DEFUN |shoeCompileTimeEvaluation| (|x|) (LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL) |x|)) (DEFUN |bfMain| (|tu| |auxfn| |op|) (LET* (|defCode| |cacheVector| |cacheCountCode| |cacheResetCode| |cacheType| |mainFunction| |codeBody| |thirdPredPair| |putCode| |secondPredPair| |getCode| |g2| |cacheName| |computeValue| |arg| |g1|) (PROGN (SETQ |g1| (|bfGenSymbol| |tu|)) (SETQ |arg| (LIST '&REST |g1|)) (SETQ |computeValue| (LIST 'APPLY (LIST 'FUNCTION |auxfn|) |g1|)) (SETQ |cacheName| (INTERN (CONCAT (SYMBOL-NAME |op|) ";AL"))) (SETQ |g2| (|bfGenSymbol| |tu|)) (SETQ |getCode| (LIST 'GETHASH |g1| |cacheName|)) (SETQ |secondPredPair| (LIST (LIST 'SETQ |g2| |getCode|) |g2|)) (SETQ |putCode| (LIST 'SETF |getCode| |computeValue|)) (SETQ |thirdPredPair| (LIST 'T |putCode|)) (SETQ |codeBody| (LIST 'PROG (LIST |g2|) (LIST 'RETURN (LIST 'COND |secondPredPair| |thirdPredPair|)))) (SETQ |mainFunction| (LIST 'DEFUN |op| |arg| |codeBody|)) (SETQ |cacheType| '|hash-table|) (SETQ |cacheResetCode| (LIST 'SETQ |cacheName| (LIST 'MAKE-HASHTABLE (|quote| 'UEQUAL)))) (SETQ |cacheCountCode| (LIST '|hashCount| |cacheName|)) (SETQ |cacheVector| (LIST |op| |cacheName| |cacheType| |cacheResetCode| |cacheCountCode|)) (SETQ |defCode| (LIST 'DEFPARAMETER |cacheName| (LIST 'MAKE-HASHTABLE (|quote| 'UEQUAL)))) (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|)))) (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|))) (DECLAIM (FTYPE (FUNCTION (|%LoadUnit| |%Thing|) |%Form|) |bfCreateDef|)) (DEFUN |bfCreateDef| (|tu| |x|) (LET* (|a| |f|) (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| |tu|) 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|)) (DEFUN |bfCaseItem| (|x| |y|) (LIST |x| |y|)) (DECLAIM (FTYPE (FUNCTION (|%LoadUnit| |%Thing| |%Thing|) |%Form|) |bfCase|)) (DEFUN |bfCase| (|tu| |x| |y|) (LET* (|body| |g|) (PROGN (SETQ |g| (COND ((NOT (CONSP |x|)) |x|) (T (|bfGenSymbol| |tu|)))) (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|)) (DEFUN |bfCaseItems| (|g| |x|) (LET* (|j| |ISTMP#1| |i|) (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|) (LET* (|b| |a|) (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| #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|)) (DECLAIM (FTYPE (FUNCTION (|%Short|) |%String|) |bfDs|)) (DEFUN |bfDs| (|n|) (COND ((EQL |n| 0) "") (T (CONCAT "D" (|bfDs| (- |n| 1)))))) (DEFUN |ctorName| (|x|) (COND ((CONSP |x|) (|ctorName| (CAR |x|))) (T |x|))) (DEFUN |bfEnum| (|t| |csts|) (LIST 'DEFTYPE (|ctorName| |t|) NIL (|backquote| (CONS 'MEMBER |csts|) NIL))) (DEFUN |bfRecordDef| (|tu| |s| |fields| |accessors|) (LET* (|accDefs| |f| |acc| |ctorDef| |args| |recDef| |ctor| |fun| |parms| |ISTMP#2| |x| |ISTMP#1|) (PROGN (SETQ |s| (|ctorName| |s|)) (SETQ |parms| (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |fields|) (|f| NIL)) (LOOP (COND ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |f| (CAR |bfVar#1|)) NIL)) (RETURN |bfVar#2|)) (T (AND (CONSP |f|) (EQ (CAR |f|) '|%Signature|) (PROGN (SETQ |ISTMP#1| (CDR |f|)) (AND (CONSP |ISTMP#1|) (PROGN (SETQ |x| (CAR |ISTMP#1|)) (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)))))) (COND ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS |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 |fun| (INTERN (CONCAT "mk" (SYMBOL-NAME |s|)))) (SETQ |ctor| (INTERN (CONCAT "MAKE-" (SYMBOL-NAME |s|)))) (SETQ |recDef| (CONS 'DEFSTRUCT (CONS (LIST |s| (LIST (|bfColonColon| 'KEYWORD 'COPIER) (INTERN (CONCAT "copy" (SYMBOL-NAME |s|))))) (LET ((|bfVar#6| NIL) (|bfVar#7| NIL) (|bfVar#5| |fields|) (|bfVar#4| NIL)) (LOOP (COND ((OR (NOT (CONSP |bfVar#5|)) (PROGN (SETQ |bfVar#4| (CAR |bfVar#5|)) NIL)) (RETURN |bfVar#6|)) (T (AND (CONSP |bfVar#4|) (EQ (CAR |bfVar#4|) '|%Signature|) (PROGN (SETQ |ISTMP#1| (CDR |bfVar#4|)) (AND (CONSP |ISTMP#1|) (PROGN (SETQ |x| (CAR |ISTMP#1|)) (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)))))) (COND ((NULL |bfVar#6|) (SETQ |bfVar#6| #2=(CONS |x| NIL)) (SETQ |bfVar#7| |bfVar#6|)) (T (RPLACD |bfVar#7| #2#) (SETQ |bfVar#7| (CDR |bfVar#7|))))))) (SETQ |bfVar#5| (CDR |bfVar#5|))))))) (SETQ |ctorDef| (PROGN (SETQ |args| (LET ((|bfVar#9| NIL) (|bfVar#10| NIL) (|bfVar#8| |parms|) (|p| NIL)) (LOOP (COND ((OR (NOT (CONSP |bfVar#8|)) (PROGN (SETQ |p| (CAR |bfVar#8|)) NIL)) (RETURN |bfVar#9|)) (T (LET ((|bfVar#11| (LIST (|bfColonColon| 'KEYWORD |p|) |p|))) (COND ((NULL |bfVar#11|) NIL) ((NULL |bfVar#9|) (SETQ |bfVar#9| |bfVar#11|) (SETQ |bfVar#10| (|lastNode| |bfVar#9|))) (T (RPLACD |bfVar#10| |bfVar#11|) (SETQ |bfVar#10| (|lastNode| |bfVar#10|))))))) (SETQ |bfVar#8| (CDR |bfVar#8|))))) (LIST 'DEFMACRO |fun| |parms| (CONS 'LIST (CONS (|quote| |ctor|) |args|))))) (SETQ |accDefs| (COND ((NULL |accessors|) NIL) (T (SETQ |x| (|bfGenSymbol| |tu|)) (LET ((|bfVar#14| NIL) (|bfVar#15| NIL) (|bfVar#13| |accessors|) (|bfVar#12| NIL)) (LOOP (COND ((OR (NOT (CONSP |bfVar#13|)) (PROGN (SETQ |bfVar#12| (CAR |bfVar#13|)) NIL)) (RETURN |bfVar#14|)) (T (AND (CONSP |bfVar#12|) (EQ (CAR |bfVar#12|) '|%AccessorDef|) (PROGN (SETQ |ISTMP#1| (CDR |bfVar#12|)) (AND (CONSP |ISTMP#1|) (PROGN (SETQ |acc| (CAR |ISTMP#1|)) (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) (PROGN (SETQ |f| (CAR |ISTMP#2|)) T))))) (COND ((NULL |bfVar#14|) (SETQ |bfVar#14| #3=(CONS (LIST 'DEFMACRO |acc| (LIST |x|) (LIST 'LIST (|quote| (INTERN (CONCAT (SYMBOL-NAME |s|) "-" (SYMBOL-NAME |f|)))) |x|)) NIL)) (SETQ |bfVar#15| |bfVar#14|)) (T (RPLACD |bfVar#15| #3#) (SETQ |bfVar#15| (CDR |bfVar#15|))))))) (SETQ |bfVar#13| (CDR |bfVar#13|))))))) (CONS |recDef| (CONS |ctorDef| |accDefs|))))) (DEFUN |bfHandlers| (|n| |e| |hs|) (|bfHandlers,main| |n| |e| |hs| NIL)) (DEFUN |bfHandlers,main| (|n| |e| |hs| |xs|) (LET* (|hs'| |s| |ISTMP#6| |t| |ISTMP#5| |v| |ISTMP#4| |ISTMP#3| |ISTMP#2| |ISTMP#1|) (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 (|bfSpecificErrorHere| "invalid handler message"))))) (DEFUN |codeForCatchHandlers| (|g| |e| |cs|) (LET* (|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|)))))) (DECLAIM (FTYPE (FUNCTION (|%Thing| (|%List| |%Form|)) |%Thing|) |bfTry|)) (DEFUN |bfTry| (|e| |cs|) (LET* (|s| |cs'| |f| |ISTMP#1| |g|) (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|) (LET* (|x| |t|) (PROGN (SETQ |t| NIL) (SETQ |x| NIL) (COND ((AND (CONSP |e|) (EQ (CAR |e|) '|%Signature|)) (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|)))))) (DEFUN |bfType| (|x|) (LET* (|s| |ISTMP#2| |t| |ISTMP#1|) (COND ((AND (CONSP |x|) (EQ (CAR |x|) '|%Mapping|) (PROGN (SETQ |ISTMP#1| (CDR |x|)) (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)))))) (COND ((|bfTupleP| |s|) (SETQ |s| (CDR |s|)))) (COND ((|ident?| |s|) (SETQ |s| (LIST |s|)))) (LIST 'FUNCTION (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) (|y| NIL)) (LOOP (COND ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |y| (CAR |bfVar#1|)) NIL)) (RETURN |bfVar#2|)) ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS (|bfType| |y|) NIL)) (SETQ |bfVar#3| |bfVar#2|)) (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) (SETQ |bfVar#1| (CDR |bfVar#1|)))) (|bfType| |t|))) ((CONSP |x|) (CONS (CAR |x|) (LET ((|bfVar#5| NIL) (|bfVar#6| NIL) (|bfVar#4| (CDR |x|)) (|y| NIL)) (LOOP (COND ((OR (NOT (CONSP |bfVar#4|)) (PROGN (SETQ |y| (CAR |bfVar#4|)) NIL)) (RETURN |bfVar#5|)) ((NULL |bfVar#5|) (SETQ |bfVar#5| #2=(CONS (|bfType| |y|) NIL)) (SETQ |bfVar#6| |bfVar#5|)) (T (RPLACD |bfVar#6| #2#) (SETQ |bfVar#6| (CDR |bfVar#6|)))) (SETQ |bfVar#4| (CDR |bfVar#4|)))))) (T |x|)))) (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|) ((OR (INTEGERP |form|) (STRINGP |form|)) |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| #1=(CONS (|backquote| |t| |params|) NIL)) (SETQ |bfVar#3| |bfVar#2|)) (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) (DEFUN |genTypeAlias| (|head| |body|) (LET* (|args| |op|) (PROGN (SETQ |op| (CAR |head|)) (SETQ |args| (CDR |head|)) (LIST 'DEFTYPE |op| |args| (|backquote| |body| |args|))))) (DEFUN |translateForm| (|x|) (LET* (|ISTMP#2| |bindings| |init| |var| |ys| |args| |fun| |ISTMP#1|) (COND ((NOT (CONSP |x|)) |x|) ((EQ (CAR |x|) 'QUOTE) |x|) ((AND (EQ (CAR |x|) '|apply|) (PROGN (SETQ |ISTMP#1| (CDR |x|)) (AND (CONSP |ISTMP#1|) (PROGN (SETQ |fun| (CAR |ISTMP#1|)) (SETQ |args| (CDR |ISTMP#1|)) T)))) (COND ((EQ (|last| |args|) 'NIL) (CONS 'FUNCALL (|listMap!| (|butLast!| (CDR |x|)) #'|translateForm|))) ((AND (CONSP |args|) (NULL (CDR |args|)) (PROGN (SETQ |ISTMP#1| (CAR |args|)) (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'LIST) (PROGN (SETQ |ys| (CDR |ISTMP#1|)) T)))) (CONS 'FUNCALL (CONS (|translateForm| |fun|) (|listMap!| |ys| #'|translateForm|)))) (T (CONS 'APPLY (|listMap!| (CDR |x|) #'|translateForm|))))) ((EQ (CAR |x|) 'LET) (SETQ |bindings| (LET ((|bfVar#3| NIL) (|bfVar#4| NIL) (|bfVar#2| (CAR (CDR |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 |var| (CAR |bfVar#1|)) (SETQ |ISTMP#1| (CDR |bfVar#1|)) (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) (PROGN (SETQ |init| (CAR |ISTMP#1|)) T))) (COND ((NULL |bfVar#3|) (SETQ |bfVar#3| #1=(CONS (LIST |var| (|translateForm| |init|)) NIL)) (SETQ |bfVar#4| |bfVar#3|)) (T (RPLACD |bfVar#4| #1#) (SETQ |bfVar#4| (CDR |bfVar#4|))))))) (SETQ |bfVar#2| (CDR |bfVar#2|))))) (LIST (CAR |x|) |bindings| (|translateForm| (CADR (CDR |x|))))) ((AND (CONSP |x|) (EQ (CAR |x|) 'L%T) (PROGN (SETQ |ISTMP#1| (CDR |x|)) (AND (CONSP |ISTMP#1|) (PROGN (SETQ |var| (CAR |ISTMP#1|)) (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) (PROGN (SETQ |init| (CAR |ISTMP#2|)) T)))))) (LIST (CAR |x|) |var| (|translateForm| |init|))) ((|symbolMember?| (CAR |x|) '(PROGN LOOP RETURN)) (CONS (CAR |x|) (|listMap!| (CDR |x|) #'|translateForm|))) (T (|listMap!| |x| #'|translateForm|))))) (DEFCONSTANT |$NativeSimpleDataTypes| '(|char| |byte| |int| |pointer| |int8| |uint8| |int16| |uint16| |int32| |uint32| |int64| |uint64| |float| |float32| |double| |float64|)) (DEFCONSTANT |$NativeSimpleReturnTypes| (|append| |$NativeSimpleDataTypes| '(|void| |string|))) (DEFUN |isSimpleNativeType| (|t|) (|objectMember?| |t| |$NativeSimpleReturnTypes|)) (DECLAIM (FTYPE (FUNCTION (|%Symbol|) |%Symbol|) |coreSymbol|)) (DEFUN |coreSymbol| (|s|) (INTERN (SYMBOL-NAME |s|) '|AxiomCore|)) (DECLAIM (FTYPE (FUNCTION (|%Symbol|) |%Symbol|) |bootSymbol|)) (DEFUN |bootSymbol| (|s|) (INTERN (SYMBOL-NAME |s|))) (DEFUN |unknownNativeTypeError| (|t|) (|fatalError| (CONCAT "unsupported native type: " (PNAME |t|)))) (DEFUN |nativeType| (|t|) (LET* (|t'|) (COND ((NULL |t|) |t|) ((NOT (CONSP |t|)) (COND ((SETQ |t'| (CDR (|objectAssoc| (|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|)))))) (DEFUN |nativeArgumentType| (|t|) (LET* (|t'| |c| |m|) (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")) ((NOT (|symbolMember?| |c| '(|buffer| |pointer|))) (|coreError| "expected 'buffer' or 'pointer' type instance")) ((NOT (|objectMember?| |t'| |$NativeSimpleDataTypes|)) (|coreError| "expected simple native data type")) (T (|nativeType| (CADR |t|)))))))) (DEFUN |needsStableReference?| (|t|) (LET* (|m|) (AND (CONSP |t|) (PROGN (SETQ |m| (CAR |t|)) T) (|symbolMember?| |m| '(|readonly| |writeonly| |readwrite|))))) (DEFUN |coerceToNativeType| (|a| |t|) (LET* (|y| |c|) (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"))))) (DEFUN |genGCLnativeTranslation| (|op| |s| |t| |op'|) (LET* (|ccode| |cargs| |cop| |rettype| |argtypes|) (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| #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)) (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|)))))))) (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 "")))) (DEFUN |genGCLnativeTranslation,gclTypeInC| (|x|) (LET* (|ISTMP#3| |ISTMP#2| |ISTMP#1|) (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")))) (DEFUN |genGCLnativeTranslation,gclArgInC| (|x| |a|) (LET* (|y| |c|) (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|)) (COND ((CDR |x|) ", ") (T "")))) (DEFUN |genECLnativeTranslation| (|op| |s| |t| |op'|) (LET* (|rettype| |argtypes| |args|) (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))))) (|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|))))) (DEFUN |genECLnativeTranslation,sharpArg| (|i| |x|) (COND ((EQL |i| 0) (CONCAT "(#0)" (|genECLnativeTranslation,selectDatum| |x|))) (T (CONCAT "," "(#" (WRITE-TO-STRING |i|) ")" (|genECLnativeTranslation,selectDatum| |x|))))) (DEFUN |genECLnativeTranslation,selectDatum| (|x|) (LET* (|y| |c|) (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")))) ((EQ |c| '|pointer|) "") (T (|coreError| "unknown type constructor"))))))) (DEFUN |genCLISPnativeTranslation| (|op| |s| |t| |op'|) (LET* (|forwardingFun| |ISTMP#2| |p| |fixups| |q| |call| |localPairs| |y| |x| |ISTMP#1| |a| |foreignDecl| |unstableArgs| |parms| |n| |argtypes| |rettype|) (DECLARE (SPECIAL |$foreignsDefsForCLisp|)) (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| #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| #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)) (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| #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 (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| (LIST 'FUNCALL (LIST 'INTERN "getCLISPType" "BOOTTRAN") |p|) |p|) |call|))))))) (SETQ |bfVar#25| (CDR |bfVar#25|)))) (CONS 'DEFUN (CONS |op| (CONS |parms| |call|)))))) (SETQ |$foreignsDefsForCLisp| (CONS |foreignDecl| |$foreignsDefsForCLisp|)) (LIST |forwardingFun|)))) (DEFUN |genCLISPnativeTranslation,copyBack| (|bfVar#1|) (LET* (|a| |y| |x| |p|) (PROGN (SETQ |p| (CAR |bfVar#1|)) (SETQ |x| (CADR . #1=(|bfVar#1|))) (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|) (LET* (|a'|) (COND ((SETQ |a'| (CDR (|objectAssoc| |p| |pairs|))) (CDR (CDR |a'|))) (T |p|)))) (DEFUN |getCLISPType| (|a|) (LIST (|bfColonColon| 'FFI 'C-ARRAY) (LENGTH |a|))) (DEFUN |genSBCLnativeTranslation| (|op| |s| |t| |op'|) (LET* (|newArgs| |unstableArgs| |args| |argtypes| |rettype|) (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| #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| #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'| (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'|) (LET* (|call| |p'| |ISTMP#3| |ISTMP#2| |ISTMP#1| |aryPairs| |strPairs| |parms| |argtypes| |rettype|) (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| #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| #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'| (|objectAssoc| |p| |strPairs|)) (CDR |p'|)) ((SETQ |p'| (|objectAssoc| |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 '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)) (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|))))) (DEFPARAMETER |$ffs| NIL) (DEFUN |genImportDeclaration| (|op| |sig| |dom|) (LET* (|lib| |s| |t| |m| |ISTMP#2| |op'| |ISTMP#1|) (DECLARE (SPECIAL |$foreignLoadUnits| |$ffs|)) (COND ((NOT (AND (CONSP |sig|) (EQ (CAR |sig|) '|%Signature|) (PROGN (SETQ |ISTMP#1| (CDR |sig|)) (AND (CONSP |ISTMP#1|) (PROGN (SETQ |op'| (CAR |ISTMP#1|)) (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (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 |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|)))) (SETQ |$ffs| (CONS |op| |$ffs|)) (COND ((AND (CONSP |dom|) (EQ (CAR |dom|) '|%LoadUnit|) (PROGN (SETQ |ISTMP#1| (CDR |dom|)) (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) (PROGN (SETQ |lib| (CAR |ISTMP#1|)) T))) (NOT (|symbolMember?| |lib| |$foreignLoadUnits|))) (SETQ |$foreignLoadUnits| (CONS |lib| |$foreignLoadUnits|)))) (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")))))))