diff options
| author | dos-reis <gdr@axiomatics.org> | 2012-05-22 01:38:27 +0000 |
|---|---|---|
| committer | dos-reis <gdr@axiomatics.org> | 2012-05-22 01:38:27 +0000 |
| commit | 08967519aa894f0740d4e120df5db49ab4d2e8b6 (patch) | |
| tree | f1a4befb60c982dec9d0a3b42014fd49358da4f4 /src/boot/strap/ast.clisp | |
| parent | ec02c6670d57cbb6814c6a79e133e1e2b41ed0af (diff) | |
| download | open-axiom-08967519aa894f0740d4e120df5db49ab4d2e8b6.tar.gz | |
* boot/ast.boot (needsPROG): Remove.
(shoePROG): Likewise.
(declareLocalVars): New.
(maybeAddBlock): Likewise.
(hasReturn?): Likewise.
(shoeCompTran): Tidy.
Diffstat (limited to 'src/boot/strap/ast.clisp')
| -rw-r--r-- | src/boot/strap/ast.clisp | 5385 |
1 files changed, 2700 insertions, 2685 deletions
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index 0eb9fefd..808755db 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -211,36 +211,34 @@ (FTYPE (FUNCTION ((|%List| (|%List| |%Form|))) (|%List| |%Form|)) |bfAppend|)) (DEFUN |bfAppend| (|ls|) - (PROG (|p| |r| |l|) - (RETURN - (COND - ((NOT - (AND (CONSP |ls|) - (PROGN (SETQ |l| (CAR |ls|)) (SETQ |ls| (CDR |ls|)) T))) - NIL) - (T (SETQ |r| (|copyList| |l|)) (SETQ |p| |r|) - (LOOP - (COND - ((NOT - (AND (CONSP |ls|) - (PROGN (SETQ |l| (CAR |ls|)) (SETQ |ls| (CDR |ls|)) T))) - (RETURN |r|)) - ((NULL |l|) NIL) - (T (RPLACD (|lastNode| |p|) (|copyList| |l|)) - (SETQ |p| (CDR |p|)))))))))) + (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|) - (PROG (|a|) - (RETURN - (COND - ((NULL |x|) - (COND - ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE)) (SETQ |a| (CDR |y|)) - (LIST '&REST (CONS 'QUOTE |a|))) - (T (LIST '&REST |y|)))) - (T (CONS (CAR |x|) (|bfColonAppend| (CDR |x|) |y|))))))) + (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|)) @@ -265,50 +263,46 @@ (DEFUN |bfTupleIf| (|x|) (COND ((|bfTupleP| |x|) |x|) (T (|bfTuple| |x|)))) (DEFUN |bfTupleConstruct| (|b|) - (PROG (|ISTMP#1| |a|) - (RETURN - (PROGN - (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) (T (LIST |b|)))) - (COND - ((LET ((|bfVar#2| NIL) (|bfVar#1| |a|) (|x| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - (T - (SETQ |bfVar#2| - (AND (CONSP |x|) (EQ (CAR |x|) 'COLON) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))))) - (COND (|bfVar#2| (RETURN |bfVar#2|))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - (|bfMakeCons| |a|)) - (T (CONS 'LIST |a|))))))) + (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|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) (T (LIST |b|)))) - (|bfMakeCons| |a|))))) + (LET* (|a|) + (PROGN + (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) (T (LIST |b|)))) + (|bfMakeCons| |a|)))) (DEFUN |bfMakeCons| (|l|) - (PROG (|l1| |a| |ISTMP#2| |ISTMP#1|) - (RETURN - (COND ((NULL |l|) NIL) - ((AND (CONSP |l|) - (PROGN - (SETQ |ISTMP#1| (CAR |l|)) - (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'COLON) - (PROGN - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |a| (CAR |ISTMP#2|)) T)))))) - (SETQ |l1| (CDR |l|)) - (COND (|l1| (LIST '|append| |a| (|bfMakeCons| |l1|))) (T |a|))) - (T (LIST 'CONS (CAR |l|) (|bfMakeCons| (CDR |l|)))))))) + (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| (|lhs| |u| |step|) (COND @@ -321,106 +315,100 @@ (T (|bfForTree| 'IN |lhs| |u|)))) (DEFUN |bfForTree| (OP |lhs| |whole|) - (PROG (G) - (RETURN - (PROGN - (SETQ |whole| - (COND ((|bfTupleP| |whole|) (|bfMakeCons| (CDR |whole|))) - (T |whole|))) - (COND ((NOT (CONSP |lhs|)) (|bfINON| (LIST OP |lhs| |whole|))) - (T (SETQ |lhs| (COND ((|bfTupleP| |lhs|) (CADR |lhs|)) (T |lhs|))) - (COND - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'L%T)) (SETQ G (CADR |lhs|)) - (|append| (|bfINON| (LIST OP G |whole|)) - (|bfSuchthat| (|bfIS| G (CADDR |lhs|))))) - (T (SETQ G (|bfGenSymbol|)) - (|append| (|bfINON| (LIST OP G |whole|)) - (|bfSuchthat| (|bfIS| G |lhs|))))))))))) + (LET* (G) + (PROGN + (SETQ |whole| + (COND ((|bfTupleP| |whole|) (|bfMakeCons| (CDR |whole|))) + (T |whole|))) + (COND ((NOT (CONSP |lhs|)) (|bfINON| (LIST OP |lhs| |whole|))) + (T (SETQ |lhs| (COND ((|bfTupleP| |lhs|) (CADR |lhs|)) (T |lhs|))) + (COND + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'L%T)) (SETQ G (CADR |lhs|)) + (|append| (|bfINON| (LIST OP G |whole|)) + (|bfSuchthat| (|bfIS| G (CADDR |lhs|))))) + (T (SETQ G (|bfGenSymbol|)) + (|append| (|bfINON| (LIST OP G |whole|)) + (|bfSuchthat| (|bfIS| G |lhs|)))))))))) (DEFUN |bfSTEP| (|id| |fst| |step| |lst|) - (PROG (|suc| |ex| |pred| |final| |g2| |inc| |g1| |initval| |initvar|) - (RETURN - (PROGN - (COND ((EQ |id| 'DOT) (SETQ |id| (|bfGenSymbol|)))) - (SETQ |initvar| (LIST |id|)) - (SETQ |initval| (LIST |fst|)) - (SETQ |inc| - (COND ((NOT (CONSP |step|)) |step|) - (T (SETQ |g1| (|bfGenSymbol|)) - (SETQ |initvar| (CONS |g1| |initvar|)) - (SETQ |initval| (CONS |step| |initval|)) |g1|))) - (SETQ |final| - (COND ((NOT (CONSP |lst|)) |lst|) - (T (SETQ |g2| (|bfGenSymbol|)) - (SETQ |initvar| (CONS |g2| |initvar|)) - (SETQ |initval| (CONS |lst| |initval|)) |g2|))) - (SETQ |ex| - (COND ((NULL |lst|) NIL) - ((INTEGERP |inc|) - (SETQ |pred| (COND ((MINUSP |inc|) '<) (T '>))) - (LIST (LIST |pred| |id| |final|))) - (T - (LIST - (LIST 'COND - (LIST (LIST 'MINUSP |inc|) (LIST '< |id| |final|)) - (LIST 'T (LIST '> |id| |final|))))))) - (SETQ |suc| (LIST (LIST 'SETQ |id| (LIST '+ |id| |inc|)))) - (LIST (LIST |initvar| |initval| |suc| NIL |ex| NIL)))))) + (LET* (|suc| |ex| |pred| |final| |g2| |inc| |g1| |initval| |initvar|) + (PROGN + (COND ((EQ |id| 'DOT) (SETQ |id| (|bfGenSymbol|)))) + (SETQ |initvar| (LIST |id|)) + (SETQ |initval| (LIST |fst|)) + (SETQ |inc| + (COND ((NOT (CONSP |step|)) |step|) + (T (SETQ |g1| (|bfGenSymbol|)) + (SETQ |initvar| (CONS |g1| |initvar|)) + (SETQ |initval| (CONS |step| |initval|)) |g1|))) + (SETQ |final| + (COND ((NOT (CONSP |lst|)) |lst|) + (T (SETQ |g2| (|bfGenSymbol|)) + (SETQ |initvar| (CONS |g2| |initvar|)) + (SETQ |initval| (CONS |lst| |initval|)) |g2|))) + (SETQ |ex| + (COND ((NULL |lst|) NIL) + ((INTEGERP |inc|) + (SETQ |pred| (COND ((MINUSP |inc|) '<) (T '>))) + (LIST (LIST |pred| |id| |final|))) + (T + (LIST + (LIST 'COND + (LIST (LIST 'MINUSP |inc|) (LIST '< |id| |final|)) + (LIST 'T (LIST '> |id| |final|))))))) + (SETQ |suc| (LIST (LIST 'SETQ |id| (LIST '+ |id| |inc|)))) + (LIST (LIST |initvar| |initval| |suc| NIL |ex| NIL))))) (DEFUN |bfIterateTable| (|e| |t|) (LIST '|%tbliter| |e| |t| (GENSYM))) (DEFUN |bfINON| (|x|) - (PROG (|whole| |id| |op|) - (RETURN - (PROGN - (SETQ |op| (CAR |x|)) - (SETQ |id| (CADR . #1=(|x|))) - (SETQ |whole| (CADDR . #1#)) - (COND ((EQ |op| 'ON) (|bfON| |id| |whole|)) (T (|bfIN| |id| |whole|))))))) + (LET* (|whole| |id| |op|) + (PROGN + (SETQ |op| (CAR |x|)) + (SETQ |id| (CADR . #1=(|x|))) + (SETQ |whole| (CADDR . #1#)) + (COND ((EQ |op| 'ON) (|bfON| |id| |whole|)) (T (|bfIN| |id| |whole|)))))) (DEFUN |bfIN| (|x| E) - (PROG (|exitCond| |inits| |vars| |g|) - (RETURN - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (SETQ |vars| (LIST |g|)) - (SETQ |inits| (LIST E)) - (SETQ |exitCond| (LIST 'NOT (LIST 'CONSP |g|))) - (COND - ((NOT (EQ |x| 'DOT)) (SETQ |vars| (|append| |vars| (CONS |x| NIL))) - (SETQ |inits| (|append| |inits| (CONS NIL NIL))) - (SETQ |exitCond| - (LIST 'OR |exitCond| - (LIST 'PROGN (LIST 'SETQ |x| (LIST 'CAR |g|)) 'NIL))))) - (LIST - (LIST |vars| |inits| (LIST (LIST 'SETQ |g| (LIST 'CDR |g|))) NIL - (LIST |exitCond|) NIL)))))) + (LET* (|exitCond| |inits| |vars| |g|) + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (SETQ |vars| (LIST |g|)) + (SETQ |inits| (LIST E)) + (SETQ |exitCond| (LIST 'NOT (LIST 'CONSP |g|))) + (COND + ((NOT (EQ |x| 'DOT)) (SETQ |vars| (|append| |vars| (CONS |x| NIL))) + (SETQ |inits| (|append| |inits| (CONS NIL NIL))) + (SETQ |exitCond| + (LIST 'OR |exitCond| + (LIST 'PROGN (LIST 'SETQ |x| (LIST 'CAR |g|)) 'NIL))))) + (LIST + (LIST |vars| |inits| (LIST (LIST 'SETQ |g| (LIST 'CDR |g|))) NIL + (LIST |exitCond|) NIL))))) (DEFUN |bfON| (|x| E) - (PROG (|var| |init|) - (RETURN - (PROGN - (COND ((EQ |x| 'DOT) (SETQ |x| (|bfGenSymbol|)))) - (SETQ |var| (SETQ |init| NIL)) - (COND - ((OR (NOT (SYMBOLP E)) (NOT (EQ |x| E))) (SETQ |var| (LIST |x|)) - (SETQ |init| (LIST E)))) - (LIST - (LIST |var| |init| (LIST (LIST 'SETQ |x| (LIST 'CDR |x|))) NIL - (LIST (LIST 'NOT (LIST 'CONSP |x|))) NIL)))))) + (LET* (|var| |init|) + (PROGN + (COND ((EQ |x| 'DOT) (SETQ |x| (|bfGenSymbol|)))) + (SETQ |var| (SETQ |init| NIL)) + (COND + ((OR (NOT (SYMBOLP E)) (NOT (EQ |x| E))) (SETQ |var| (LIST |x|)) + (SETQ |init| (LIST E)))) + (LIST + (LIST |var| |init| (LIST (LIST 'SETQ |x| (LIST 'CDR |x|))) NIL + (LIST (LIST 'NOT (LIST 'CONSP |x|))) NIL))))) (DEFUN |bfSuchthat| (|p|) (LIST (LIST NIL NIL NIL (LIST |p|) NIL NIL))) (DEFUN |bfWhile| (|p|) (LIST (LIST NIL NIL NIL NIL (LIST (|bfNOT| |p|)) NIL))) (DEFUN |bfUntil| (|p|) - (PROG (|g|) - (RETURN - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (LIST - (LIST (LIST |g|) (LIST NIL) (LIST (LIST 'SETQ |g| |p|)) NIL (LIST |g|) - NIL)))))) + (LET* (|g|) + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (LIST + (LIST (LIST |g|) (LIST NIL) (LIST (LIST 'SETQ |g| |p|)) NIL (LIST |g|) + NIL))))) (DEFUN |bfIterators| (|x|) (CONS 'ITERATORS |x|)) @@ -437,335 +425,333 @@ (T (|bfLp| (CAR |iters|) (|bfLpCross| (CDR |iters|) |body|))))) (DEFUN |bfSep| (|iters|) - (PROG (|r| |f|) - (RETURN - (COND ((NULL |iters|) (LIST NIL NIL NIL NIL NIL NIL)) - (T (SETQ |f| (CAR |iters|)) (SETQ |r| (|bfSep| (CDR |iters|))) - (LET ((|bfVar#3| NIL) - (|bfVar#4| NIL) - (|bfVar#1| |f|) - (|i| NIL) - (|bfVar#2| |r|) - (|j| NIL)) - (LOOP - (COND - ((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|))))))))) + (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| (|op| |y|) - (PROG (|it| |ny| |g2| |body| |g1| |g| |init| |a|) - (RETURN - (PROGN - (SETQ |a| - (COND ((AND (CONSP |op|) (EQ (CAR |op|) 'QUOTE)) (CADR |op|)) - (T |op|))) - (SETQ |op| (|bfReName| |a|)) - (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA))) - (SETQ |g| (|bfGenSymbol|)) - (SETQ |g1| (|bfGenSymbol|)) - (SETQ |body| (LIST 'SETQ |g| (LIST |op| |g| |g1|))) - (COND - ((NULL |init|) (SETQ |g2| (|bfGenSymbol|)) - (SETQ |init| (LIST 'CAR |g2|)) (SETQ |ny| (LIST 'CDR |g2|)) - (SETQ |it| - (CONS 'ITERATORS + (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|)) + (SETQ |g1| (|bfGenSymbol|)) + (SETQ |body| (LIST 'SETQ |g| (LIST |op| |g| |g1|))) + (COND + ((NULL |init|) (SETQ |g2| (|bfGenSymbol|)) (SETQ |init| (LIST 'CAR |g2|)) + (SETQ |ny| (LIST 'CDR |g2|)) + (SETQ |it| + (CONS 'ITERATORS + (LIST (LIST - (LIST - (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|))) - (|bfIN| |g1| |ny|)))) - (|bfMKPROGN| (LIST (LIST 'L%T |g2| |y|) (|bfLp| |it| |body|)))) - (T (SETQ |init| (CAR |init|)) - (SETQ |it| - (CONS 'ITERATORS + (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|))) + (|bfIN| |g1| |ny|)))) + (|bfMKPROGN| (LIST (LIST 'L%T |g2| |y|) (|bfLp| |it| |body|)))) + (T (SETQ |init| (CAR |init|)) + (SETQ |it| + (CONS 'ITERATORS + (LIST (LIST - (LIST - (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|))) - (|bfIN| |g1| |y|)))) - (|bfLp| |it| |body|))))))) + (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|))) + (|bfIN| |g1| |y|)))) + (|bfLp| |it| |body|)))))) (DEFUN |bfReduceCollect| (|op| |y|) - (PROG (|seq| |init| |a| |itl| |body|) - (RETURN - (COND - ((AND (CONSP |y|) (EQ (CAR |y|) 'COLLECT)) (SETQ |body| (CADR |y|)) - (SETQ |itl| (CADDR |y|)) - (SETQ |a| - (COND ((AND (CONSP |op|) (EQ (CAR |op|) 'QUOTE)) (CADR |op|)) - (T |op|))) - (COND - ((EQ |a| '|append!|) - (|bfDoCollect| |body| |itl| '|lastNode| '|skipNil|)) - ((EQ |a| '|append|) - (|bfDoCollect| (LIST '|copyList| |body|) |itl| '|lastNode| - '|skipNil|)) - (T (SETQ |op| (|bfReName| |a|)) - (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA))) - (|bfOpReduce| |op| |init| |body| |itl|)))) - (T (SETQ |seq| (COND ((NULL |y|) (|bfTuple| NIL)) (T (CADR |y|)))) - (|bfReduce| |op| (|bfTupleConstruct| |seq|))))))) + (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| |body| |itl| '|lastNode| '|skipNil|)) + ((EQ |a| '|append|) + (|bfDoCollect| (LIST '|copyList| |body|) |itl| '|lastNode| '|skipNil|)) + (T (SETQ |op| (|bfReName| |a|)) + (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA))) + (|bfOpReduce| |op| |init| |body| |itl|)))) + (T (SETQ |seq| (COND ((NULL |y|) (|bfTuple| NIL)) (T (CADR |y|)))) + (|bfReduce| |op| (|bfTupleConstruct| |seq|)))))) (DEFUN |bfDCollect| (|y| |itl|) (LIST 'COLLECT |y| |itl|)) (DEFUN |bfDTuple| (|x|) (LIST 'DTUPLE |x|)) (DEFUN |bfCollect| (|y| |itl|) - (PROG (|a| |ISTMP#1|) - (RETURN - (COND - ((AND (CONSP |y|) (EQ (CAR |y|) 'COLON) - (PROGN - (SETQ |ISTMP#1| (CDR |y|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) - (COND - ((OR (AND (CONSP |a|) (EQ (CAR |a|) 'CONS)) - (AND (CONSP |a|) (EQ (CAR |a|) 'LIST))) - (|bfDoCollect| |a| |itl| '|lastNode| '|skipNil|)) - (T - (|bfDoCollect| (LIST '|copyList| |a|) |itl| '|lastNode| '|skipNil|)))) - ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) - (|bfDoCollect| (|bfConstruct| |y|) |itl| '|lastNode| '|skipNil|)) - (T (|bfDoCollect| (LIST 'CONS |y| 'NIL) |itl| 'CDR NIL)))))) + (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| |a| |itl| '|lastNode| '|skipNil|)) + (T + (|bfDoCollect| (LIST '|copyList| |a|) |itl| '|lastNode| '|skipNil|)))) + ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) + (|bfDoCollect| (|bfConstruct| |y|) |itl| '|lastNode| '|skipNil|)) + (T (|bfDoCollect| (LIST 'CONS |y| 'NIL) |itl| 'CDR NIL))))) (DEFUN |bfMakeCollectInsn| (|expr| |prev| |head| |adv|) - (PROG (|otherTime| |firstTime|) - (RETURN - (PROGN - (SETQ |firstTime| - (|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|))))) + (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| (|expr| |itl| |adv| |k|) - (PROG (|extrait| |body| |x| |prev| |head|) - (RETURN - (PROGN - (SETQ |head| (|bfGenSymbol|)) - (SETQ |prev| (|bfGenSymbol|)) - (SETQ |body| - (COND - ((EQ |k| '|skipNil|) (SETQ |x| (|bfGenSymbol|)) - (LIST 'LET (LIST (LIST |x| |expr|)) - (|bfIf| (LIST 'NULL |x|) 'NIL - (|bfMakeCollectInsn| |x| |prev| |head| |adv|)))) - (T (|bfMakeCollectInsn| |expr| |prev| |head| |adv|)))) - (SETQ |extrait| - (LIST - (LIST (LIST |head| |prev|) (LIST 'NIL 'NIL) NIL NIL NIL - (LIST |head|)))) - (|bfLp2| |extrait| |itl| |body|))))) + (LET* (|extrait| |body| |x| |prev| |head|) + (PROGN + (SETQ |head| (|bfGenSymbol|)) + (SETQ |prev| (|bfGenSymbol|)) + (SETQ |body| + (COND + ((EQ |k| '|skipNil|) (SETQ |x| (|bfGenSymbol|)) + (LIST 'LET (LIST (LIST |x| |expr|)) + (|bfIf| (LIST 'NULL |x|) 'NIL + (|bfMakeCollectInsn| |x| |prev| |head| |adv|)))) + (T (|bfMakeCollectInsn| |expr| |prev| |head| |adv|)))) + (SETQ |extrait| + (LIST + (LIST (LIST |head| |prev|) (LIST 'NIL 'NIL) NIL NIL NIL + (LIST |head|)))) + (|bfLp2| |extrait| |itl| |body|)))) (DEFUN |separateIterators| (|iters|) - (PROG (|y| |x|) - (RETURN - (PROGN - (SETQ |x| NIL) - (SETQ |y| NIL) - (LET ((|bfVar#1| |iters|) (|iter| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |iter| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - ((AND (CONSP |iter|) (EQ (CAR |iter|) '|%tbliter|)) - (SETQ |y| (CONS (CDR |iter|) |y|))) - (T (SETQ |x| (CONS |iter| |x|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - (LIST (|reverse!| |x|) (|reverse!| |y|)))))) + (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| (|keyval| |end?| |succ|) - (PROG (|k| |v| |val| |ISTMP#2| |key| |ISTMP#1|) - (RETURN - (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| |val| |v|))) - (T (SETQ |k| (GENSYM)) - (COND - ((|ident?| |val|) - (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |val|) (LIST |succ|) - (|bfLET| |key| |k|))) - (T (SETQ |v| (GENSYM)) - (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |v|) (LIST |succ|) - (|bfLET| |key| |k|) (|bfLET| |val| |v|))))))) - (T (SETQ |k| (GENSYM)) (SETQ |v| (GENSYM)) - (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |v|) (LIST |succ|) - (|bfLET| |keyval| (LIST 'CONS |k| |v|)))))))) + (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| |val| |v|))) + (T (SETQ |k| (GENSYM)) + (COND + ((|ident?| |val|) + (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |val|) (LIST |succ|) + (|bfLET| |key| |k|))) + (T (SETQ |v| (GENSYM)) + (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |v|) (LIST |succ|) + (|bfLET| |key| |k|) (|bfLET| |val| |v|))))))) + (T (SETQ |k| (GENSYM)) (SETQ |v| (GENSYM)) + (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |v|) (LIST |succ|) + (|bfLET| |keyval| (LIST 'CONS |k| |v|))))))) (DEFUN |bfExpandTableIters| (|iters|) - (PROG (|x| |g| |ISTMP#2| |t| |ISTMP#1| |e| |exits| |localBindings| |inits|) - (RETURN - (PROGN - (SETQ |inits| NIL) - (SETQ |localBindings| NIL) - (SETQ |exits| NIL) - (LET ((|bfVar#2| |iters|) (|bfVar#1| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#2|)) - (PROGN (SETQ |bfVar#1| (CAR |bfVar#2|)) NIL)) - (RETURN NIL)) - (T - (AND (CONSP |bfVar#1|) - (PROGN - (SETQ |e| (CAR |bfVar#1|)) - (SETQ |ISTMP#1| (CDR |bfVar#1|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |t| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |g| (CAR |ISTMP#2|)) T))))) - (PROGN - (SETQ |inits| (CONS (LIST |g| |t|) |inits|)) - (SETQ |x| (GENSYM)) - (SETQ |exits| (CONS (LIST 'NOT |x|) |exits|)) - (SETQ |localBindings| - (CONS (|bfTableIteratorBindingForm| |e| |x| |g|) - |localBindings|)))))) - (SETQ |bfVar#2| (CDR |bfVar#2|)))) - (LIST |inits| |localBindings| |exits|))))) + (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| |e| |x| |g|) + |localBindings|)))))) + (SETQ |bfVar#2| (CDR |bfVar#2|)))) + (LIST |inits| |localBindings| |exits|)))) (DEFUN |bfLp1| (|iters| |body|) - (PROG (|loop| |nbody| |tblExits| |tblLocs| |tblInits| |value| |exits| - |filters| |sucs| |inits| |vars| |tbls| |LETTMP#1|) - (RETURN - (PROGN - (SETQ |LETTMP#1| (|separateIterators| |iters|)) - (SETQ |iters| (CAR |LETTMP#1|)) - (SETQ |tbls| (CADR |LETTMP#1|)) - (SETQ |LETTMP#1| (|bfSep| (|bfAppend| |iters|))) - (SETQ |vars| (CAR |LETTMP#1|)) - (SETQ |inits| (CADR . #1=(|LETTMP#1|))) - (SETQ |sucs| (CADDR . #1#)) - (SETQ |filters| (CADDDR . #1#)) - (SETQ |exits| (CAR #2=(CDDDDR . #1#))) - (SETQ |value| (CADR #2#)) - (SETQ |LETTMP#1| (|bfExpandTableIters| |tbls|)) - (SETQ |tblInits| (CAR |LETTMP#1|)) - (SETQ |tblLocs| (CADR . #3=(|LETTMP#1|))) - (SETQ |tblExits| (CADDR . #3#)) - (SETQ |nbody| - (COND ((NULL |filters|) |body|) - (T (|bfAND| (|append| |filters| (CONS |body| NIL)))))) - (SETQ |value| (COND ((NULL |value|) 'NIL) (T (CAR |value|)))) - (SETQ |exits| - (COND ((AND (NULL |exits|) (NULL |tblExits|)) |nbody|) - (T - (|bfIf| (|bfOR| (|append| |exits| |tblExits|)) - (LIST 'RETURN |value|) |nbody|)))) - (LET ((|bfVar#1| |tblLocs|) (|locBinding| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |locBinding| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (SETQ |exits| (|append| |locBinding| (CONS |exits| NIL))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - (SETQ |loop| (CONS 'LOOP (CONS |exits| |sucs|))) - (COND - (|vars| - (SETQ |loop| - (LIST 'LET - (LET ((|bfVar#4| NIL) - (|bfVar#5| NIL) - (|bfVar#2| |vars|) - (|v| NIL) - (|bfVar#3| |inits|) - (|i| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#2|)) - (PROGN (SETQ |v| (CAR |bfVar#2|)) NIL) - (NOT (CONSP |bfVar#3|)) - (PROGN (SETQ |i| (CAR |bfVar#3|)) NIL)) - (RETURN |bfVar#4|)) - ((NULL |bfVar#4|) - (SETQ |bfVar#4| #4=(CONS (LIST |v| |i|) NIL)) - (SETQ |bfVar#5| |bfVar#4|)) - (T (RPLACD |bfVar#5| #4#) - (SETQ |bfVar#5| (CDR |bfVar#5|)))) - (SETQ |bfVar#2| (CDR |bfVar#2|)) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - |loop|)))) - (LET ((|bfVar#6| |tblInits|) (|x| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#6|)) (PROGN (SETQ |x| (CAR |bfVar#6|)) NIL)) - (RETURN NIL)) - (T (SETQ |loop| (LIST 'WITH-HASH-TABLE-ITERATOR |x| |loop|)))) - (SETQ |bfVar#6| (CDR |bfVar#6|)))) - |loop|)))) + (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| |tbls|)) + (SETQ |tblInits| (CAR |LETTMP#1|)) + (SETQ |tblLocs| (CADR . #3=(|LETTMP#1|))) + (SETQ |tblExits| (CADDR . #3#)) + (SETQ |nbody| + (COND ((NULL |filters|) |body|) + (T (|bfAND| (|append| |filters| (CONS |body| NIL)))))) + (SETQ |value| (COND ((NULL |value|) 'NIL) (T (CAR |value|)))) + (SETQ |exits| + (COND ((AND (NULL |exits|) (NULL |tblExits|)) |nbody|) + (T + (|bfIf| (|bfOR| (|append| |exits| |tblExits|)) + (LIST 'RETURN |value|) |nbody|)))) + (LET ((|bfVar#1| |tblLocs|) (|locBinding| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |locBinding| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + (T (SETQ |exits| (|append| |locBinding| (CONS |exits| NIL))))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + (SETQ |loop| (CONS 'LOOP (CONS |exits| |sucs|))) + (COND + (|vars| + (SETQ |loop| + (LIST 'LET + (LET ((|bfVar#4| NIL) + (|bfVar#5| NIL) + (|bfVar#2| |vars|) + (|v| NIL) + (|bfVar#3| |inits|) + (|i| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#2|)) + (PROGN (SETQ |v| (CAR |bfVar#2|)) NIL) + (NOT (CONSP |bfVar#3|)) + (PROGN (SETQ |i| (CAR |bfVar#3|)) NIL)) + (RETURN |bfVar#4|)) + ((NULL |bfVar#4|) + (SETQ |bfVar#4| #4=(CONS (LIST |v| |i|) NIL)) + (SETQ |bfVar#5| |bfVar#4|)) + (T (RPLACD |bfVar#5| #4#) + (SETQ |bfVar#5| (CDR |bfVar#5|)))) + (SETQ |bfVar#2| (CDR |bfVar#2|)) + (SETQ |bfVar#3| (CDR |bfVar#3|)))) + |loop|)))) + (LET ((|bfVar#6| |tblInits|) (|x| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#6|)) (PROGN (SETQ |x| (CAR |bfVar#6|)) NIL)) + (RETURN NIL)) + (T (SETQ |loop| (LIST 'WITH-HASH-TABLE-ITERATOR |x| |loop|)))) + (SETQ |bfVar#6| (CDR |bfVar#6|)))) + |loop|))) (DEFUN |bfLp2| (|extrait| |itl| |body|) - (PROG (|iters|) - (RETURN - (COND - ((AND (CONSP |itl|) (EQ (CAR |itl|) 'ITERATORS)) - (|bfLp1| (CONS |extrait| (CDR |itl|)) |body|)) - (T (SETQ |iters| (CDR |itl|)) - (|bfLpCross| - (CONS (CONS 'ITERATORS (CONS |extrait| (CDAR |iters|))) (CDR |iters|)) - |body|)))))) + (LET* (|iters|) + (COND + ((AND (CONSP |itl|) (EQ (CAR |itl|) 'ITERATORS)) + (|bfLp1| (CONS |extrait| (CDR |itl|)) |body|)) + (T (SETQ |iters| (CDR |itl|)) + (|bfLpCross| + (CONS (CONS 'ITERATORS (CONS |extrait| (CDAR |iters|))) (CDR |iters|)) + |body|))))) (DEFUN |bfOpReduce| (|op| |init| |y| |itl|) - (PROG (|extrait| |g1| |body| |g|) - (RETURN - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (SETQ |body| - (COND - ((EQ |op| 'AND) - (|bfMKPROGN| - (LIST (LIST 'SETQ |g| |y|) - (LIST 'COND - (LIST (LIST 'NOT |g|) (LIST 'RETURN 'NIL)))))) - ((EQ |op| 'OR) - (|bfMKPROGN| - (LIST (LIST 'SETQ |g| |y|) - (LIST 'COND (LIST |g| (LIST 'RETURN |g|)))))) - (T (LIST 'SETQ |g| (LIST |op| |g| |y|))))) - (COND - ((NULL |init|) (SETQ |g1| (|bfGenSymbol|)) - (SETQ |init| (LIST 'CAR |g1|)) (SETQ |y| (LIST 'CDR |g1|)) - (SETQ |extrait| - (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|)))) - (|bfMKPROGN| - (LIST (LIST 'L%T |g1| |y|) (|bfLp2| |extrait| |itl| |body|)))) - (T (SETQ |init| (CAR |init|)) - (SETQ |extrait| - (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|)))) - (|bfLp2| |extrait| |itl| |body|))))))) + (LET* (|extrait| |g1| |body| |g|) + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (SETQ |body| + (COND + ((EQ |op| 'AND) + (|bfMKPROGN| + (LIST (LIST 'SETQ |g| |y|) + (LIST 'COND + (LIST (LIST 'NOT |g|) (LIST 'RETURN 'NIL)))))) + ((EQ |op| 'OR) + (|bfMKPROGN| + (LIST (LIST 'SETQ |g| |y|) + (LIST 'COND (LIST |g| (LIST 'RETURN |g|)))))) + (T (LIST 'SETQ |g| (LIST |op| |g| |y|))))) + (COND + ((NULL |init|) (SETQ |g1| (|bfGenSymbol|)) (SETQ |init| (LIST 'CAR |g1|)) + (SETQ |y| (LIST 'CDR |g1|)) + (SETQ |extrait| + (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|)))) + (|bfMKPROGN| + (LIST (LIST 'L%T |g1| |y|) (|bfLp2| |extrait| |itl| |body|)))) + (T (SETQ |init| (CAR |init|)) + (SETQ |extrait| + (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|)))) + (|bfLp2| |extrait| |itl| |body|)))))) (DEFUN |bfLoop1| (|body|) (|bfLp| (|bfIterators| NIL) |body|)) @@ -796,203 +782,209 @@ (T (CONS (|bfSUBLIS| |p| (CAR |e|)) (|bfSUBLIS| |p| (CDR |e|)))))) (DEFUN |bfSUBLIS1| (|p| |e|) - (PROG (|f|) - (RETURN - (COND ((NULL |p|) |e|) - (T (SETQ |f| (CAR |p|)) - (COND ((EQ (CAR |f|) |e|) (|bfSUBLIS| |p| (CDR |f|))) - (T (|bfSUBLIS1| (CDR |p|) |e|)))))))) + (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| (|x|) - (PROG (|defstack| |op1| |opassoc| |argl|) + (LET* (|defstack| |op1| |opassoc| |argl|) (DECLARE (SPECIAL |$op|)) - (RETURN - (CASE (CAR |x|) - (|%Definition| - (LET ((|op| (CADR |x|)) (|args| (CADDR |x|)) (|body| (CADDDR |x|))) - (PROGN - (SETQ |argl| - (COND ((|bfTupleP| |args|) (CDR |args|)) (T (LIST |args|)))) - (COND - ((NULL |argl|) (SETQ |opassoc| (LIST (CONS |op| |body|))) - (LIST |opassoc| NIL NIL)) - (T - (SETQ |op1| - (INTERN - (CONCAT (SYMBOL-NAME |$op|) "," (SYMBOL-NAME |op|)))) - (SETQ |opassoc| (LIST (CONS |op| |op1|))) - (SETQ |defstack| (LIST (LIST |op1| |args| |body|))) - (LIST |opassoc| |defstack| NIL)))))) - (|%Pile| - (LET ((|defs| (CADR |x|))) - (|defSheepAndGoatsList| |defs|))) - (T (LIST NIL NIL (LIST |x|))))))) + (CASE (CAR |x|) + (|%Definition| + (LET ((|op| (CADR |x|)) (|args| (CADDR |x|)) (|body| (CADDDR |x|))) + (PROGN + (SETQ |argl| + (COND ((|bfTupleP| |args|) (CDR |args|)) (T (LIST |args|)))) + (COND + ((NULL |argl|) (SETQ |opassoc| (LIST (CONS |op| |body|))) + (LIST |opassoc| NIL NIL)) + (T + (SETQ |op1| + (INTERN + (CONCAT (SYMBOL-NAME |$op|) "," (SYMBOL-NAME |op|)))) + (SETQ |opassoc| (LIST (CONS |op| |op1|))) + (SETQ |defstack| (LIST (LIST |op1| |args| |body|))) + (LIST |opassoc| |defstack| NIL)))))) + (|%Pile| + (LET ((|defs| (CADR |x|))) + (|defSheepAndGoatsList| |defs|))) + (T (LIST NIL NIL (LIST |x|)))))) (DEFUN |defSheepAndGoatsList| (|x|) - (PROG (|nondefs1| |defs1| |opassoc1| |nondefs| |defs| |opassoc| |LETTMP#1|) - (RETURN - (COND ((NULL |x|) (LIST NIL NIL NIL)) - (T (SETQ |LETTMP#1| (|defSheepAndGoats| (CAR |x|))) - (SETQ |opassoc| (CAR |LETTMP#1|)) - (SETQ |defs| (CADR . #1=(|LETTMP#1|))) - (SETQ |nondefs| (CADDR . #1#)) - (SETQ |LETTMP#1| (|defSheepAndGoatsList| (CDR |x|))) - (SETQ |opassoc1| (CAR |LETTMP#1|)) - (SETQ |defs1| (CADR . #2=(|LETTMP#1|))) - (SETQ |nondefs1| (CADDR . #2#)) - (LIST (|append| |opassoc| |opassoc1|) (|append| |defs| |defs1|) - (|append| |nondefs| |nondefs1|))))))) + (LET* (|nondefs1| |defs1| |opassoc1| |nondefs| |defs| |opassoc| |LETTMP#1|) + (COND ((NULL |x|) (LIST NIL NIL NIL)) + (T (SETQ |LETTMP#1| (|defSheepAndGoats| (CAR |x|))) + (SETQ |opassoc| (CAR |LETTMP#1|)) + (SETQ |defs| (CADR . #1=(|LETTMP#1|))) + (SETQ |nondefs| (CADDR . #1#)) + (SETQ |LETTMP#1| (|defSheepAndGoatsList| (CDR |x|))) + (SETQ |opassoc1| (CAR |LETTMP#1|)) + (SETQ |defs1| (CADR . #2=(|LETTMP#1|))) + (SETQ |nondefs1| (CADDR . #2#)) + (LIST (|append| |opassoc| |opassoc1|) (|append| |defs| |defs1|) + (|append| |nondefs| |nondefs1|)))))) (DEFUN |bfLetForm| (|lhs| |rhs|) (LIST 'L%T |lhs| |rhs|)) (DEFUN |bfLET1| (|lhs| |rhs|) - (PROG (|let1| |g| |l2| |l1| |name| |rhs1| |ISTMP#1|) - (RETURN - (COND ((SYMBOLP |lhs|) (|bfLetForm| |lhs| |rhs|)) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Dynamic|) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))) - (|bfLetForm| |lhs| |rhs|)) - ((AND (SYMBOLP |rhs|) (NOT (|bfCONTAINED| |rhs| |lhs|))) - (SETQ |rhs1| (|bfLET2| |lhs| |rhs|)) - (COND - ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'L%T)) - (|bfMKPROGN| (LIST |rhs1| |rhs|))) - ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'PROGN)) - (|append| |rhs1| (LIST |rhs|))) - (T (COND ((SYMBOLP (CAR |rhs1|)) (SETQ |rhs1| (CONS |rhs1| NIL)))) - (|bfMKPROGN| (|append| |rhs1| (CONS |rhs| NIL)))))) - ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'L%T) - (SYMBOLP (SETQ |name| (CADR |rhs|)))) - (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|))) - (SETQ |l2| (|bfLET1| |lhs| |name|)) - (COND - ((AND (CONSP |l2|) (EQ (CAR |l2|) 'PROGN)) - (|bfMKPROGN| (CONS |l1| (CDR |l2|)))) - (T (COND ((SYMBOLP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL)))) - (|bfMKPROGN| (CONS |l1| (|append| |l2| (CONS |name| NIL))))))) - (T (SETQ |g| (|bfLetVar|)) (SETQ |rhs1| (LIST 'L%T |g| |rhs|)) - (SETQ |let1| (|bfLET1| |lhs| |g|)) - (COND - ((AND (CONSP |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))))))))))) + (LET* (|let1| |g| |l2| |l1| |name| |rhs1| |ISTMP#1|) + (COND ((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 (SYMBOLP |rhs|) (NOT (|bfCONTAINED| |rhs| |lhs|))) + (SETQ |rhs1| (|bfLET2| |lhs| |rhs|)) + (COND + ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'L%T)) + (|bfMKPROGN| (LIST |rhs1| |rhs|))) + ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'PROGN)) + (|append| |rhs1| (LIST |rhs|))) + (T (COND ((SYMBOLP (CAR |rhs1|)) (SETQ |rhs1| (CONS |rhs1| NIL)))) + (|bfMKPROGN| (|append| |rhs1| (CONS |rhs| NIL)))))) + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'L%T) + (SYMBOLP (SETQ |name| (CADR |rhs|)))) + (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|))) + (SETQ |l2| (|bfLET1| |lhs| |name|)) + (COND + ((AND (CONSP |l2|) (EQ (CAR |l2|) 'PROGN)) + (|bfMKPROGN| (CONS |l1| (CDR |l2|)))) + (T (COND ((SYMBOLP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL)))) + (|bfMKPROGN| (CONS |l1| (|append| |l2| (CONS |name| NIL))))))) + (T (SETQ |g| (|bfLetVar|)) (SETQ |rhs1| (LIST 'L%T |g| |rhs|)) + (SETQ |let1| (|bfLET1| |lhs| |g|)) + (COND + ((AND (CONSP |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| (|lhs| |rhs|) - (PROG (|isPred| |val1| |ISTMP#3| |g| |rev| |patrev| |l2| |l1| |var2| |var1| - |b| |ISTMP#2| |a| |ISTMP#1|) + (LET* (|isPred| + |val1| + |ISTMP#3| + |g| + |rev| + |patrev| + |l2| + |l1| + |var2| + |var1| + |b| + |ISTMP#2| + |a| + |ISTMP#1|) (DECLARE (SPECIAL |$inDefIS|)) - (RETURN - (COND ((NULL |lhs|) NIL) ((SYMBOLP |lhs|) (|bfLetForm| |lhs| |rhs|)) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%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| |a| |rhs|)) - (COND ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|) - ((NOT (CONSP |b|)) (LIST |a| |b|)) - ((CONSP (CAR |b|)) (CONS |a| |b|)) (T (LIST |a| |b|)))) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'CONS) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |var1| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |var2| (CAR |ISTMP#2|)) T)))))) - (COND - ((OR (EQ |var1| 'DOT) - (AND (CONSP |var1|) (EQ (CAR |var1|) 'QUOTE))) - (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) - (T (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|))) - (COND ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|) - (T - (COND - ((AND (CONSP |l1|) (NOT (CONSP (CAR |l1|)))) - (SETQ |l1| (CONS |l1| NIL)))) - (COND - ((SYMBOLP |var2|) - (|append| |l1| - (CONS - (|bfLetForm| |var2| - (|addCARorCDR| 'CDR |rhs|)) - NIL))) - (T - (SETQ |l2| (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) - (COND - ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|)))) - (SETQ |l2| (CONS |l2| NIL)))) - (|append| |l1| |l2|)))))))) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|append|) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |var1| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |var2| (CAR |ISTMP#2|)) T)))))) - (SETQ |patrev| (|bfISReverse| |var2| |var1|)) - (SETQ |rev| (LIST '|reverse| |rhs|)) (SETQ |g| (|bfLetVar|)) - (SETQ |l2| (|bfLET2| |patrev| |g|)) - (COND - ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|)))) - (SETQ |l2| (CONS |l2| NIL)))) - (COND ((EQ |var1| 'DOT) (CONS (LIST 'L%T |g| |rev|) |l2|)) - ((PROGN - (SETQ |ISTMP#1| (CAR (|lastNode| |l2|))) - (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'L%T) - (PROGN - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (EQUAL (CAR |ISTMP#2|) |var1|) - (PROGN - (SETQ |ISTMP#3| (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) (NULL (CDR |ISTMP#3|)) - (PROGN - (SETQ |val1| (CAR |ISTMP#3|)) - T))))))) - (CONS (LIST 'L%T |g| |rev|) - (|append| (|reverse| (CDR (|reverse| |l2|))) - (CONS - (|bfLetForm| |var1| - (LIST '|reverse!| |val1|)) - NIL)))) - (T - (CONS (LIST 'L%T |g| |rev|) - (|append| |l2| - (CONS - (|bfLetForm| |var1| - (LIST '|reverse!| |var1|)) - NIL)))))) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'EQUAL) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |var1| (CAR |ISTMP#1|)) T)))) - (LIST 'COND (LIST (|bfQ| |var1| |rhs|) |var1|))) - (T - (SETQ |isPred| - (COND (|$inDefIS| (|bfIS1| |rhs| |lhs|)) - (T (|bfIS| |rhs| |lhs|)))) - (LIST 'COND (LIST |isPred| |rhs|))))))) + (COND ((NULL |lhs|) NIL) ((SYMBOLP |lhs|) (|bfLetForm| |lhs| |rhs|)) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%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| |a| |rhs|)) + (COND ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|) + ((NOT (CONSP |b|)) (LIST |a| |b|)) + ((CONSP (CAR |b|)) (CONS |a| |b|)) (T (LIST |a| |b|)))) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'CONS) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |var1| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |var2| (CAR |ISTMP#2|)) T)))))) + (COND + ((OR (EQ |var1| 'DOT) + (AND (CONSP |var1|) (EQ (CAR |var1|) 'QUOTE))) + (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) + (T (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|))) + (COND ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|) + (T + (COND + ((AND (CONSP |l1|) (NOT (CONSP (CAR |l1|)))) + (SETQ |l1| (CONS |l1| NIL)))) + (COND + ((SYMBOLP |var2|) + (|append| |l1| + (CONS + (|bfLetForm| |var2| + (|addCARorCDR| 'CDR |rhs|)) + NIL))) + (T + (SETQ |l2| (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) + (COND + ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|)))) + (SETQ |l2| (CONS |l2| NIL)))) + (|append| |l1| |l2|)))))))) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|append|) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |var1| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |var2| (CAR |ISTMP#2|)) T)))))) + (SETQ |patrev| (|bfISReverse| |var2| |var1|)) + (SETQ |rev| (LIST '|reverse| |rhs|)) (SETQ |g| (|bfLetVar|)) + (SETQ |l2| (|bfLET2| |patrev| |g|)) + (COND + ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|)))) + (SETQ |l2| (CONS |l2| NIL)))) + (COND ((EQ |var1| 'DOT) (CONS (LIST 'L%T |g| |rev|) |l2|)) + ((PROGN + (SETQ |ISTMP#1| (CAR (|lastNode| |l2|))) + (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'L%T) + (PROGN + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQUAL (CAR |ISTMP#2|) |var1|) + (PROGN + (SETQ |ISTMP#3| (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) (NULL (CDR |ISTMP#3|)) + (PROGN + (SETQ |val1| (CAR |ISTMP#3|)) + T))))))) + (CONS (LIST 'L%T |g| |rev|) + (|append| (|reverse| (CDR (|reverse| |l2|))) + (CONS + (|bfLetForm| |var1| + (LIST '|reverse!| |val1|)) + NIL)))) + (T + (CONS (LIST 'L%T |g| |rev|) + (|append| |l2| + (CONS + (|bfLetForm| |var1| + (LIST '|reverse!| |var1|)) + NIL)))))) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'EQUAL) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |var1| (CAR |ISTMP#1|)) T)))) + (LIST 'COND (LIST (|bfQ| |var1| |rhs|) |var1|))) + (T + (SETQ |isPred| + (COND (|$inDefIS| (|bfIS1| |rhs| |lhs|)) + (T (|bfIS| |rhs| |lhs|)))) + (LIST 'COND (LIST |isPred| |rhs|)))))) (DEFUN |bfLET| (|lhs| |rhs|) (LET ((|$letGenVarCounter| 0)) @@ -1000,27 +992,25 @@ (|bfLET1| |lhs| |rhs|))) (DEFUN |addCARorCDR| (|acc| |expr|) - (PROG (|funsR| |funsA| |p| |funs|) - (RETURN - (COND ((NOT (CONSP |expr|)) (LIST |acc| |expr|)) - ((AND (EQ |acc| 'CAR) (CONSP |expr|) (EQ (CAR |expr|) '|reverse|)) - (LIST 'CAR (CONS '|lastNode| (CDR |expr|)))) - (T - (SETQ |funs| - '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR CDAAR - CDDAR CDADR CDDDR)) - (SETQ |p| (|bfPosition| (CAR |expr|) |funs|)) - (COND ((EQL |p| (- 1)) (LIST |acc| |expr|)) - (T - (SETQ |funsA| - '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR - CAAADR CAADDR CADAAR CADDAR CADADR CADDDR)) - (SETQ |funsR| - '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR - CDAADR CDADDR CDDAAR CDDDAR CDDADR CDDDDR)) - (COND - ((EQ |acc| 'CAR) (CONS (ELT |funsA| |p|) (CDR |expr|))) - (T (CONS (ELT |funsR| |p|) (CDR |expr|))))))))))) + (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)) @@ -1039,113 +1029,123 @@ (|bfIS1| |left| |right|))) (DEFUN |bfISReverse| (|x| |a|) - (PROG (|y|) - (RETURN - (COND - ((AND (CONSP |x|) (EQ (CAR |x|) 'CONS)) - (COND ((NULL (CADDR |x|)) (LIST 'CONS (CADR |x|) |a|)) - (T (SETQ |y| (|bfISReverse| (CADDR |x|) NIL)) - (RPLACA (CDR (CDR |y|)) (LIST 'CONS (CADR |x|) |a|)) |y|))) - (T (|bpSpecificErrorHere| "Error in bfISReverse") (|bpTrap|)))))) + (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 (|bpSpecificErrorHere| "Error in bfISReverse") (|bpTrap|))))) (DEFUN |bfIS1| (|lhs| |rhs|) - (PROG (|l2| |rev| |patrev| |cls| |b1| |a1| |g| |b| |ISTMP#2| |ISTMP#1| |l| - |d| |c| |a|) - (RETURN - (COND ((NULL |rhs|) (LIST 'NULL |lhs|)) - ((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|)) - ((NOT (CONSP |rhs|)) (LIST 'PROGN (|bfLetForm| |rhs| |lhs|) 'T)) - ((EQ (CAR |rhs|) 'QUOTE) (SETQ |a| (CADR |rhs|)) - (COND ((SYMBOLP |a|) (LIST 'EQ |lhs| |rhs|)) - ((STRINGP |a|) - (|bfAND| - (LIST (LIST 'STRINGP |lhs|) (LIST 'STRING= |lhs| |a|)))) - (T (LIST 'EQUAL |lhs| |rhs|)))) - ((EQ (CAR |rhs|) 'L%T) (SETQ |c| (CADR . #1=(|rhs|))) - (SETQ |d| (CADDR . #1#)) (SETQ |l| (|bfLET| |c| |lhs|)) - (|bfAND| (LIST (|bfIS1| |lhs| |d|) (|bfMKPROGN| (LIST |l| 'T))))) - ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'EQUAL) - (PROGN - (SETQ |ISTMP#1| (CDR |rhs|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) - (|bfQ| |lhs| |a|)) - ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'CONS) - (PROGN - (SETQ |ISTMP#1| (CDR |rhs|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |a| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |b| (CAR |ISTMP#2|)) T))))) - (EQ |a| 'DOT) (EQ |b| 'DOT)) - (LIST 'CONSP |lhs|)) - ((CONSP |lhs|) (SETQ |g| (|bfIsVar|)) - (|bfMKPROGN| (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|)))) - ((EQ (CAR |rhs|) 'CONS) (SETQ |a| (CADR . #2=(|rhs|))) - (SETQ |b| (CADDR . #2#)) - (COND - ((EQ |a| 'DOT) - (COND - ((NULL |b|) - (|bfAND| - (LIST (LIST 'CONSP |lhs|) (LIST 'NULL (LIST 'CDR |lhs|))))) - ((EQ |b| 'DOT) (LIST 'CONSP |lhs|)) - (T - (|bfAND| - (LIST (LIST 'CONSP |lhs|) (|bfIS1| (LIST 'CDR |lhs|) |b|)))))) - ((NULL |b|) - (|bfAND| - (LIST (LIST 'CONSP |lhs|) (LIST 'NULL (LIST 'CDR |lhs|)) - (|bfIS1| (LIST 'CAR |lhs|) |a|)))) - ((EQ |b| 'DOT) - (|bfAND| - (LIST (LIST 'CONSP |lhs|) (|bfIS1| (LIST 'CAR |lhs|) |a|)))) - (T (SETQ |a1| (|bfIS1| (LIST 'CAR |lhs|) |a|)) - (SETQ |b1| (|bfIS1| (LIST 'CDR |lhs|) |b|)) - (COND - ((AND (CONSP |a1|) (EQ (CAR |a1|) 'PROGN) - (PROGN - (SETQ |ISTMP#1| (CDR |a1|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |c| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (EQ (CAR |ISTMP#2|) 'T))))) - (CONSP |b1|) (EQ (CAR |b1|) 'PROGN)) - (SETQ |cls| (CDR |b1|)) - (|bfAND| - (LIST (LIST 'CONSP |lhs|) (|bfMKPROGN| (CONS |c| |cls|))))) - (T (|bfAND| (LIST (LIST 'CONSP |lhs|) |a1| |b1|))))))) - ((EQ (CAR |rhs|) '|append|) (SETQ |a| (CADR . #3=(|rhs|))) - (SETQ |b| (CADDR . #3#)) (SETQ |patrev| (|bfISReverse| |b| |a|)) - (SETQ |g| (|bfIsVar|)) - (SETQ |rev| - (|bfAND| - (LIST (LIST 'CONSP |lhs|) - (LIST 'PROGN (LIST 'L%T |g| (LIST '|reverse| |lhs|)) - 'T)))) - (SETQ |l2| (|bfIS1| |g| |patrev|)) - (COND - ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|)))) - (SETQ |l2| (CONS |l2| NIL)))) - (COND ((EQ |a| 'DOT) (|bfAND| (CONS |rev| |l2|))) - (T + (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|)) + ((NOT (CONSP |rhs|)) (LIST 'PROGN (|bfLetForm| |rhs| |lhs|) 'T)) + ((EQ (CAR |rhs|) 'QUOTE) (SETQ |a| (CADR |rhs|)) + (COND ((SYMBOLP |a|) (LIST 'EQ |lhs| |rhs|)) + ((STRINGP |a|) + (|bfAND| + (LIST (LIST 'STRINGP |lhs|) (LIST 'STRING= |lhs| |a|)))) + (T (LIST 'EQUAL |lhs| |rhs|)))) + ((EQ (CAR |rhs|) 'L%T) (SETQ |c| (CADR . #1=(|rhs|))) + (SETQ |d| (CADDR . #1#)) (SETQ |l| (|bfLET| |c| |lhs|)) + (|bfAND| (LIST (|bfIS1| |lhs| |d|) (|bfMKPROGN| (LIST |l| 'T))))) + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'EQUAL) + (PROGN + (SETQ |ISTMP#1| (CDR |rhs|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) + (|bfQ| |lhs| |a|)) + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'CONS) + (PROGN + (SETQ |ISTMP#1| (CDR |rhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |a| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |b| (CAR |ISTMP#2|)) T))))) + (EQ |a| 'DOT) (EQ |b| 'DOT)) + (LIST 'CONSP |lhs|)) + ((CONSP |lhs|) (SETQ |g| (|bfIsVar|)) + (|bfMKPROGN| (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|)))) + ((EQ (CAR |rhs|) 'CONS) (SETQ |a| (CADR . #2=(|rhs|))) + (SETQ |b| (CADDR . #2#)) + (COND + ((EQ |a| 'DOT) + (COND + ((NULL |b|) + (|bfAND| + (LIST (LIST 'CONSP |lhs|) (LIST 'NULL (LIST 'CDR |lhs|))))) + ((EQ |b| 'DOT) (LIST 'CONSP |lhs|)) + (T + (|bfAND| + (LIST (LIST 'CONSP |lhs|) (|bfIS1| (LIST 'CDR |lhs|) |b|)))))) + ((NULL |b|) + (|bfAND| + (LIST (LIST 'CONSP |lhs|) (LIST 'NULL (LIST 'CDR |lhs|)) + (|bfIS1| (LIST 'CAR |lhs|) |a|)))) + ((EQ |b| 'DOT) + (|bfAND| + (LIST (LIST 'CONSP |lhs|) (|bfIS1| (LIST 'CAR |lhs|) |a|)))) + (T (SETQ |a1| (|bfIS1| (LIST 'CAR |lhs|) |a|)) + (SETQ |b1| (|bfIS1| (LIST 'CDR |lhs|) |b|)) + (COND + ((AND (CONSP |a1|) (EQ (CAR |a1|) 'PROGN) + (PROGN + (SETQ |ISTMP#1| (CDR |a1|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |c| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (EQ (CAR |ISTMP#2|) 'T))))) + (CONSP |b1|) (EQ (CAR |b1|) 'PROGN)) + (SETQ |cls| (CDR |b1|)) + (|bfAND| + (LIST (LIST 'CONSP |lhs|) (|bfMKPROGN| (CONS |c| |cls|))))) + (T (|bfAND| (LIST (LIST 'CONSP |lhs|) |a1| |b1|))))))) + ((EQ (CAR |rhs|) '|append|) (SETQ |a| (CADR . #3=(|rhs|))) + (SETQ |b| (CADDR . #3#)) (SETQ |patrev| (|bfISReverse| |b| |a|)) + (SETQ |g| (|bfIsVar|)) + (SETQ |rev| (|bfAND| - (CONS |rev| - (|append| |l2| - (CONS - (LIST 'PROGN - (|bfLetForm| |a| - (LIST '|reverse!| |a|)) - 'T) - NIL))))))) - (T (|bpSpecificErrorHere| "bad IS code is generated") (|bpTrap|)))))) + (LIST (LIST 'CONSP |lhs|) + (LIST 'PROGN (LIST 'L%T |g| (LIST '|reverse| |lhs|)) + 'T)))) + (SETQ |l2| (|bfIS1| |g| |patrev|)) + (COND + ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|)))) + (SETQ |l2| (CONS |l2| NIL)))) + (COND ((EQ |a| 'DOT) (|bfAND| (CONS |rev| |l2|))) + (T + (|bfAND| + (CONS |rev| + (|append| |l2| + (CONS + (LIST 'PROGN + (|bfLetForm| |a| + (LIST '|reverse!| |a|)) + 'T) + NIL))))))) + (T (|bpSpecificErrorHere| "bad IS code is generated") (|bpTrap|))))) (DEFUN |bfHas| (|expr| |prop|) (COND ((SYMBOLP |prop|) (LIST 'GET |expr| (|quote| |prop|))) @@ -1154,59 +1154,56 @@ (DEFUN |bfKeyArg| (|k| |x|) (LIST '|%Key| |k| |x|)) (DEFUN |bfExpandKeys| (|l|) - (PROG (|x| |ISTMP#2| |k| |ISTMP#1| |a| |args|) - (RETURN - (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 - (INTERN (STRING-UPCASE (SYMBOL-NAME |k|)) "KEYWORD") - |args|)))) - (T (SETQ |args| (CONS |a| |args|))))) - (|reverse!| |args|))))) + (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 + (INTERN (STRING-UPCASE (SYMBOL-NAME |k|)) "KEYWORD") + |args|)))) + (T (SETQ |args| (CONS |a| |args|))))) + (|reverse!| |args|)))) (DEFUN |bfApplication| (|bfop| |bfarg|) (COND ((|bfTupleP| |bfarg|) (CONS |bfop| (|bfExpandKeys| (CDR |bfarg|)))) (T (LIST |bfop| |bfarg|)))) (DEFUN |bfReName| (|x|) - (PROG (|a|) - (RETURN (COND ((SETQ |a| (GET |x| 'SHOERENAME)) (CAR |a|)) (T |x|))))) + (LET* (|a|) + (COND ((SETQ |a| (GET |x| 'SHOERENAME)) (CAR |a|)) (T |x|)))) (DEFUN |sequence?| (|x| |pred|) - (PROG (|seq| |ISTMP#1|) - (RETURN - (AND (CONSP |x|) (EQ (CAR |x|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |seq| (CAR |ISTMP#1|)) T))) - (CONSP |seq|) - (LET ((|bfVar#2| T) (|bfVar#1| |seq|) (|y| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |y| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - (T (SETQ |bfVar#2| (APPLY |pred| |y| NIL)) - (COND ((NOT |bfVar#2|) (RETURN NIL))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) + (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| (APPLY |pred| |y| NIL)) + (COND ((NOT |bfVar#2|) (RETURN NIL))))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))))) (DEFUN |idList?| (|x|) (AND (CONSP |x|) (EQ (CAR |x|) 'LIST) @@ -1245,109 +1242,108 @@ (SETQ |bfVar#1| (CDR |bfVar#1|)))))) (DEFUN |bfMember| (|var| |seq|) - (PROG (|y| |x| |ISTMP#2| |ISTMP#1|) - (RETURN - (COND - ((OR (INTEGERP |var|) (|sequence?| |seq| #'INTEGERP)) - (COND - ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN - (SETQ |ISTMP#2| (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |x| (CAR |ISTMP#2|)) T)))))) - (LIST 'EQL |var| |x|)) - (T (LIST '|scalarMember?| |var| |seq|)))) - ((OR (|defQuoteId| |var|) (|sequence?| |seq| #'SYMBOLP)) - (COND - ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN - (SETQ |ISTMP#2| (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |x| (CAR |ISTMP#2|)) T)))))) - (LIST 'EQ |var| (|quote| |x|))) - (T (LIST '|symbolMember?| |var| |seq|)))) - ((|idList?| |seq|) - (COND - ((PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))) - (CONS 'EQ (CONS |var| (CDR |seq|)))) - ((AND (SYMBOLP |var|) - (PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |x| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |y| (CAR |ISTMP#2|)) T)))))) - (|bfOR| (LIST (LIST 'EQ |var| |x|) (LIST 'EQ |var| |y|)))) - (T (LIST '|symbolMember?| |var| |seq|)))) - ((OR (|bfChar?| |var|) (|sequence?| |seq| #'CHARACTERP)) - (COND - ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN - (SETQ |ISTMP#2| (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |x| (CAR |ISTMP#2|)) T)))))) - (LIST 'CHAR= |var| |x|)) - (T (LIST '|charMember?| |var| |seq|)))) - ((|charList?| |seq|) - (COND - ((PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))) - (CONS 'CHAR= (CONS |var| (CDR |seq|)))) - ((AND (SYMBOLP |var|) - (PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |x| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |y| (CAR |ISTMP#2|)) T)))))) - (|bfOR| (LIST (LIST 'CHAR= |var| |x|) (LIST 'CHAR= |var| |y|)))) - (T (LIST '|charMember?| |var| |seq|)))) - ((OR (|bfString?| |var|) (|sequence?| |seq| #'STRINGP)) - (COND - ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN - (SETQ |ISTMP#2| (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |x| (CAR |ISTMP#2|)) T)))))) - (LIST 'STRING= |var| |x|)) - (T (LIST '|stringMember?| |var| |seq|)))) - ((|stringList?| |seq|) - (COND - ((PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))) - (CONS 'STRING= (CONS |var| (CDR |seq|)))) - ((AND (SYMBOLP |var|) - (PROGN - (SETQ |ISTMP#1| (CDR |seq|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |x| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |y| (CAR |ISTMP#2|)) T)))))) - (|bfOR| (LIST (LIST 'STRING= |var| |x|) (LIST 'STRING= |var| |y|)))) - (T (LIST '|stringMember?| |var| |seq|)))) - (T (LIST 'MEMBER |var| |seq|)))))) + (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|)) @@ -1362,22 +1358,21 @@ (T (LIST |op| |left| |right|)))) (DEFUN |bfNOT| (|x|) - (PROG (|a| |ISTMP#1|) - (RETURN - (COND - ((AND (CONSP |x|) (EQ (CAR |x|) 'NOT) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) - |a|) - ((AND (CONSP |x|) (EQ (CAR |x|) 'NULL) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) - |a|) - (T (LIST 'NOT |x|)))))) + (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|)))) @@ -1460,153 +1455,153 @@ (LIST 'LAMBDA |vars| |body|))) (DEFUN |bfMDef| (|op| |args| |body|) - (PROG (|def| |lamex| |sb2| |sb| |largl| |nargl| |sgargl| |gargl| |LETTMP#1| + (LET* (|def| + |lamex| + |sb2| + |sb| + |largl| + |nargl| + |sgargl| + |gargl| + |LETTMP#1| |argl|) (DECLARE (SPECIAL |$wheredefs|)) - (RETURN - (PROGN - (SETQ |argl| (COND ((|bfTupleP| |args|) (CDR |args|)) (T (LIST |args|)))) - (SETQ |LETTMP#1| (|bfGargl| |argl|)) - (SETQ |gargl| (CAR |LETTMP#1|)) - (SETQ |sgargl| (CADR . #1=(|LETTMP#1|))) - (SETQ |nargl| (CADDR . #1#)) - (SETQ |largl| (CADDDR . #1#)) - (SETQ |sb| - (LET ((|bfVar#3| NIL) - (|bfVar#4| NIL) - (|bfVar#1| |nargl|) - (|i| NIL) - (|bfVar#2| |sgargl|) - (|j| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL) - (NOT (CONSP |bfVar#2|)) - (PROGN (SETQ |j| (CAR |bfVar#2|)) NIL)) - (RETURN |bfVar#3|)) - ((NULL |bfVar#3|) - (SETQ |bfVar#3| #2=(CONS (CONS |i| |j|) NIL)) - (SETQ |bfVar#4| |bfVar#3|)) - (T (RPLACD |bfVar#4| #2#) (SETQ |bfVar#4| (CDR |bfVar#4|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)) - (SETQ |bfVar#2| (CDR |bfVar#2|))))) - (SETQ |body| (|applySubst| |sb| |body|)) - (SETQ |sb2| - (LET ((|bfVar#7| NIL) - (|bfVar#8| NIL) - (|bfVar#5| |sgargl|) - (|i| NIL) - (|bfVar#6| |largl|) - (|j| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#5|)) - (PROGN (SETQ |i| (CAR |bfVar#5|)) NIL) - (NOT (CONSP |bfVar#6|)) - (PROGN (SETQ |j| (CAR |bfVar#6|)) NIL)) - (RETURN |bfVar#7|)) - ((NULL |bfVar#7|) - (SETQ |bfVar#7| - #3=(CONS (LIST 'CONS (|quote| |i|) |j|) NIL)) - (SETQ |bfVar#8| |bfVar#7|)) - (T (RPLACD |bfVar#8| #3#) (SETQ |bfVar#8| (CDR |bfVar#8|)))) - (SETQ |bfVar#5| (CDR |bfVar#5|)) - (SETQ |bfVar#6| (CDR |bfVar#6|))))) - (SETQ |body| (LIST '|applySubst| (CONS 'LIST |sb2|) (|quote| |body|))) - (SETQ |lamex| (LIST 'MLAMBDA |gargl| |body|)) - (SETQ |def| (LIST |op| |lamex|)) - (CONS (|shoeComp| |def|) - (LET ((|bfVar#10| NIL) - (|bfVar#11| NIL) - (|bfVar#9| |$wheredefs|) - (|d| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#9|)) - (PROGN (SETQ |d| (CAR |bfVar#9|)) NIL)) - (RETURN |bfVar#10|)) - (T - (LET ((|bfVar#12| (|copyList| (|shoeComps| (|bfDef1| |d|))))) - (COND ((NULL |bfVar#12|) NIL) - ((NULL |bfVar#10|) (SETQ |bfVar#10| |bfVar#12|) - (SETQ |bfVar#11| (|lastNode| |bfVar#10|))) - (T (RPLACD |bfVar#11| |bfVar#12|) - (SETQ |bfVar#11| (|lastNode| |bfVar#11|))))))) - (SETQ |bfVar#9| (CDR |bfVar#9|))))))))) + (PROGN + (SETQ |argl| (COND ((|bfTupleP| |args|) (CDR |args|)) (T (LIST |args|)))) + (SETQ |LETTMP#1| (|bfGargl| |argl|)) + (SETQ |gargl| (CAR |LETTMP#1|)) + (SETQ |sgargl| (CADR . #1=(|LETTMP#1|))) + (SETQ |nargl| (CADDR . #1#)) + (SETQ |largl| (CADDDR . #1#)) + (SETQ |sb| + (LET ((|bfVar#3| NIL) + (|bfVar#4| NIL) + (|bfVar#1| |nargl|) + (|i| NIL) + (|bfVar#2| |sgargl|) + (|j| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL) + (NOT (CONSP |bfVar#2|)) + (PROGN (SETQ |j| (CAR |bfVar#2|)) NIL)) + (RETURN |bfVar#3|)) + ((NULL |bfVar#3|) + (SETQ |bfVar#3| #2=(CONS (CONS |i| |j|) NIL)) + (SETQ |bfVar#4| |bfVar#3|)) + (T (RPLACD |bfVar#4| #2#) (SETQ |bfVar#4| (CDR |bfVar#4|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)) + (SETQ |bfVar#2| (CDR |bfVar#2|))))) + (SETQ |body| (|applySubst| |sb| |body|)) + (SETQ |sb2| + (LET ((|bfVar#7| NIL) + (|bfVar#8| NIL) + (|bfVar#5| |sgargl|) + (|i| NIL) + (|bfVar#6| |largl|) + (|j| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#5|)) + (PROGN (SETQ |i| (CAR |bfVar#5|)) NIL) + (NOT (CONSP |bfVar#6|)) + (PROGN (SETQ |j| (CAR |bfVar#6|)) NIL)) + (RETURN |bfVar#7|)) + ((NULL |bfVar#7|) + (SETQ |bfVar#7| #3=(CONS (LIST 'CONS (|quote| |i|) |j|) NIL)) + (SETQ |bfVar#8| |bfVar#7|)) + (T (RPLACD |bfVar#8| #3#) (SETQ |bfVar#8| (CDR |bfVar#8|)))) + (SETQ |bfVar#5| (CDR |bfVar#5|)) + (SETQ |bfVar#6| (CDR |bfVar#6|))))) + (SETQ |body| (LIST '|applySubst| (CONS 'LIST |sb2|) (|quote| |body|))) + (SETQ |lamex| (LIST 'MLAMBDA |gargl| |body|)) + (SETQ |def| (LIST |op| |lamex|)) + (CONS (|shoeComp| |def|) + (LET ((|bfVar#10| NIL) + (|bfVar#11| NIL) + (|bfVar#9| |$wheredefs|) + (|d| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#9|)) + (PROGN (SETQ |d| (CAR |bfVar#9|)) NIL)) + (RETURN |bfVar#10|)) + (T + (LET ((|bfVar#12| (|copyList| (|shoeComps| (|bfDef1| |d|))))) + (COND ((NULL |bfVar#12|) NIL) + ((NULL |bfVar#10|) (SETQ |bfVar#10| |bfVar#12|) + (SETQ |bfVar#11| (|lastNode| |bfVar#10|))) + (T (RPLACD |bfVar#11| |bfVar#12|) + (SETQ |bfVar#11| (|lastNode| |bfVar#11|))))))) + (SETQ |bfVar#9| (CDR |bfVar#9|)))))))) (DEFUN |bfGargl| (|argl|) - (PROG (|f| |d| |c| |b| |a| |LETTMP#1|) - (RETURN - (COND ((NULL |argl|) (LIST NIL NIL NIL NIL)) - (T (SETQ |LETTMP#1| (|bfGargl| (CDR |argl|))) - (SETQ |a| (CAR |LETTMP#1|)) (SETQ |b| (CADR . #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|)) - (LIST (CONS |f| |a|) (CONS |f| |b|) (CONS (CAR |argl|) |c|) - (CONS |f| |d|))))))))) + (LET* (|f| |d| |c| |b| |a| |LETTMP#1|) + (COND ((NULL |argl|) (LIST NIL NIL NIL NIL)) + (T (SETQ |LETTMP#1| (|bfGargl| (CDR |argl|))) + (SETQ |a| (CAR |LETTMP#1|)) (SETQ |b| (CADR . #1=(|LETTMP#1|))) + (SETQ |c| (CADDR . #1#)) (SETQ |d| (CADDDR . #1#)) + (COND + ((EQ (CAR |argl|) '&REST) + (LIST (CONS (CAR |argl|) |b|) |b| |c| + (CONS (LIST 'CONS (|quote| 'LIST) (CAR |d|)) (CDR |d|)))) + (T (SETQ |f| (|bfGenSymbol|)) + (LIST (CONS |f| |a|) (CONS |f| |b|) (CONS (CAR |argl|) |c|) + (CONS |f| |d|)))))))) (DEFUN |bfDef1| (|bfVar#1|) - (PROG (|arglp| |control| |quotes| |LETTMP#1| |argl| |body| |args| |op|) - (RETURN - (PROGN - (SETQ |op| (CAR |bfVar#1|)) - (SETQ |args| (CADR . #1=(|bfVar#1|))) - (SETQ |body| (CADDR . #1#)) - (SETQ |argl| (COND ((|bfTupleP| |args|) (CDR |args|)) (T (LIST |args|)))) - (SETQ |LETTMP#1| (|bfInsertLet| |argl| |body|)) - (SETQ |quotes| (CAR |LETTMP#1|)) - (SETQ |control| (CADR . #2=(|LETTMP#1|))) - (SETQ |arglp| (CADDR . #2#)) - (SETQ |body| (CADDDR . #2#)) - (COND (|quotes| (|shoeLAM| |op| |arglp| |control| |body|)) - (T (LIST (LIST |op| (LIST 'LAMBDA |arglp| |body|))))))))) + (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| |argl| |body|)) + (SETQ |quotes| (CAR |LETTMP#1|)) + (SETQ |control| (CADR . #2=(|LETTMP#1|))) + (SETQ |arglp| (CADDR . #2#)) + (SETQ |body| (CADDDR . #2#)) + (COND (|quotes| (|shoeLAM| |op| |arglp| |control| |body|)) + (T (LIST (LIST |op| (LIST 'LAMBDA |arglp| |body|)))))))) (DEFUN |shoeLAM| (|op| |args| |control| |body|) - (PROG (|innerfunc| |margs|) - (RETURN - (PROGN - (SETQ |margs| (|bfGenSymbol|)) - (SETQ |innerfunc| (INTERN (CONCAT (SYMBOL-NAME |op|) ",LAM"))) - (LIST (LIST |innerfunc| (LIST 'LAMBDA |args| |body|)) - (LIST |op| - (LIST 'MLAMBDA (LIST '&REST |margs|) - (LIST 'CONS (|quote| |innerfunc|) - (LIST 'WRAP |margs| (|quote| |control|)))))))))) + (LET* (|innerfunc| |margs|) + (PROGN + (SETQ |margs| (|bfGenSymbol|)) + (SETQ |innerfunc| (INTERN (CONCAT (SYMBOL-NAME |op|) ",LAM"))) + (LIST (LIST |innerfunc| (LIST 'LAMBDA |args| |body|)) + (LIST |op| + (LIST 'MLAMBDA (LIST '&REST |margs|) + (LIST 'CONS (|quote| |innerfunc|) + (LIST 'WRAP |margs| (|quote| |control|))))))))) (DEFUN |bfDef| (|op| |args| |body|) - (PROG (|body1| |arg1| |op1| |LETTMP#1|) + (LET* (|body1| |arg1| |op1| |LETTMP#1|) (DECLARE (SPECIAL |$wheredefs| |$bfClamming|)) - (RETURN - (COND - (|$bfClamming| - (SETQ |LETTMP#1| - (|shoeComp| (CAR (|bfDef1| (LIST |op| |args| |body|))))) - (SETQ |op1| (CADR . #1=(|LETTMP#1|))) (SETQ |arg1| (CADDR . #1#)) - (SETQ |body1| (CDDDR . #1#)) (|bfCompHash| |op1| |arg1| |body1|)) - (T - (|bfTuple| - (LET ((|bfVar#2| NIL) - (|bfVar#3| NIL) - (|bfVar#1| (CONS (LIST |op| |args| |body|) |$wheredefs|)) - (|d| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |d| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - (T - (LET ((|bfVar#4| (|copyList| (|shoeComps| (|bfDef1| |d|))))) - (COND ((NULL |bfVar#4|) NIL) - ((NULL |bfVar#2|) (SETQ |bfVar#2| |bfVar#4|) - (SETQ |bfVar#3| (|lastNode| |bfVar#2|))) - (T (RPLACD |bfVar#3| |bfVar#4|) - (SETQ |bfVar#3| (|lastNode| |bfVar#3|))))))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))))))))) + (COND + (|$bfClamming| + (SETQ |LETTMP#1| (|shoeComp| (CAR (|bfDef1| (LIST |op| |args| |body|))))) + (SETQ |op1| (CADR . #1=(|LETTMP#1|))) (SETQ |arg1| (CADDR . #1#)) + (SETQ |body1| (CDDDR . #1#)) (|bfCompHash| |op1| |arg1| |body1|)) + (T + (|bfTuple| + (LET ((|bfVar#2| NIL) + (|bfVar#3| NIL) + (|bfVar#1| (CONS (LIST |op| |args| |body|) |$wheredefs|)) + (|d| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |d| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + (T + (LET ((|bfVar#4| (|copyList| (|shoeComps| (|bfDef1| |d|))))) + (COND ((NULL |bfVar#4|) NIL) + ((NULL |bfVar#2|) (SETQ |bfVar#2| |bfVar#4|) + (SETQ |bfVar#3| (|lastNode| |bfVar#2|))) + (T (RPLACD |bfVar#3| |bfVar#4|) + (SETQ |bfVar#3| (|lastNode| |bfVar#3|))))))) + (SETQ |bfVar#1| (CDR |bfVar#1|))))))))) (DEFUN |shoeComps| (|x|) (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |x|) (|def| NIL)) @@ -1620,14 +1615,13 @@ (SETQ |bfVar#1| (CDR |bfVar#1|))))) (DEFUN |shoeComp| (|x|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (|shoeCompTran| (CADR |x|))) - (COND - ((AND (CONSP |a|) (EQ (CAR |a|) 'LAMBDA)) - (CONS 'DEFUN (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|))))) - (T (CONS 'DEFMACRO (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|)))))))))) + (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|) @@ -1641,142 +1635,163 @@ (T (CONS |p1| |p2|)))) (DEFUN |bfInsertLet| (|x| |body|) - (PROG (|body2| |name2| |norq1| |b1| |body1| |name1| |norq| |LETTMP#1| |b| |a| + (LET* (|body2| + |name2| + |norq1| + |b1| + |body1| + |name1| + |norq| + |LETTMP#1| + |b| + |a| |ISTMP#1|) - (RETURN - (COND ((NULL |x|) (LIST NIL NIL |x| |body|)) - ((AND (CONSP |x|) (EQ (CAR |x|) '&REST) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) T)))) - (COND - ((AND (CONSP |a|) (EQ (CAR |a|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |a|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |b| (CAR |ISTMP#1|)) T)))) - (LIST T 'QUOTE (LIST '&REST |b|) |body|)) - (T (LIST NIL NIL |x| |body|)))) - (T (SETQ |LETTMP#1| (|bfInsertLet1| (CAR |x|) |body|)) - (SETQ |b| (CAR |LETTMP#1|)) (SETQ |norq| (CADR . #1=(|LETTMP#1|))) - (SETQ |name1| (CADDR . #1#)) (SETQ |body1| (CADDDR . #1#)) - (SETQ |LETTMP#1| (|bfInsertLet| (CDR |x|) |body1|)) - (SETQ |b1| (CAR |LETTMP#1|)) - (SETQ |norq1| (CADR . #2=(|LETTMP#1|))) - (SETQ |name2| (CADDR . #2#)) (SETQ |body2| (CADDDR . #2#)) - (LIST (OR |b| |b1|) (CONS |norq| |norq1|) - (|bfParameterList| |name1| |name2|) |body2|)))))) + (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| (CAR |x|) |body|)) + (SETQ |b| (CAR |LETTMP#1|)) (SETQ |norq| (CADR . #1=(|LETTMP#1|))) + (SETQ |name1| (CADDR . #1#)) (SETQ |body1| (CADDDR . #1#)) + (SETQ |LETTMP#1| (|bfInsertLet| (CDR |x|) |body1|)) + (SETQ |b1| (CAR |LETTMP#1|)) (SETQ |norq1| (CADR . #2=(|LETTMP#1|))) + (SETQ |name2| (CADDR . #2#)) (SETQ |body2| (CADDDR . #2#)) + (LIST (OR |b| |b1|) (CONS |norq| |norq1|) + (|bfParameterList| |name1| |name2|) |body2|))))) (DEFUN |bfInsertLet1| (|y| |body|) - (PROG (|g| |b| |r| |ISTMP#2| |l| |ISTMP#1|) - (RETURN - (COND - ((AND (CONSP |y|) (EQ (CAR |y|) 'L%T) - (PROGN - (SETQ |ISTMP#1| (CDR |y|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |l| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |r| (CAR |ISTMP#2|)) T)))))) - (LIST NIL NIL |l| (|bfMKPROGN| (LIST (|bfLET| |r| |l|) |body|)))) - ((SYMBOLP |y|) (LIST NIL NIL |y| |body|)) - ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |y|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |b| (CAR |ISTMP#1|)) T)))) - (LIST T 'QUOTE |b| |body|)) - (T (SETQ |g| (|bfGenSymbol|)) - (COND ((NOT (CONSP |y|)) (LIST NIL NIL |g| |body|)) - (T - (CASE (CAR |y|) - (|%DefaultValue| - (LET ((|p| (CADR |y|)) (|v| (CADDR |y|))) - (LIST NIL NIL (LIST '&OPTIONAL (LIST |p| |v|)) |body|))) - (T - (LIST NIL NIL |g| - (|bfMKPROGN| - (LIST (|bfLET| (|compFluidize| |y|) |g|) - |body|)))))))))))) + (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| |r| |l|) |body|)))) + ((SYMBOLP |y|) (LIST NIL NIL |y| |body|)) + ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE) + (PROGN + (SETQ |ISTMP#1| (CDR |y|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (PROGN (SETQ |b| (CAR |ISTMP#1|)) T)))) + (LIST T 'QUOTE |b| |body|)) + (T (SETQ |g| (|bfGenSymbol|)) + (COND ((NOT (CONSP |y|)) (LIST NIL NIL |g| |body|)) + (T + (CASE (CAR |y|) + (|%DefaultValue| + (LET ((|p| (CADR |y|)) (|v| (CADDR |y|))) + (LIST NIL NIL (LIST '&OPTIONAL (LIST |p| |v|)) |body|))) + (T + (LIST NIL NIL |g| + (|bfMKPROGN| + (LIST (|bfLET| (|compFluidize| |y|) |g|) + |body|))))))))))) (DEFUN |shoeCompTran| (|x|) - (PROG (|fl| |fvars| |body'| |dollarVars| |locVars| |fluidVars| |body| |args| + (LET* (|fl| + |vars| + |fvars| + |body'| + |dollarVars| + |locVars| + |fluidVars| + |body| + |args| |lamtype|) (DECLARE (SPECIAL |$typings|)) - (RETURN - (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 - (|$typings| - (SETQ |body'| (CONS (CONS 'DECLARE |$typings|) |body'|)))) - (COND - ((SETQ |fvars| - (|setDifference| (|deref| |dollarVars|) - (|deref| |fluidVars|))) - (SETQ |body'| - (CONS (LIST 'DECLARE (CONS 'SPECIAL |fvars|)) - |body'|)))) - (COND - ((OR (|deref| |locVars|) (|needsPROG| |body'|)) - (|shoePROG| (|deref| |locVars|) |body'|)) - (T |body'|)))) - (COND - ((SETQ |fl| (|shoeFluids| |args|)) - (SETQ |body| (CONS (LIST 'DECLARE (CONS 'SPECIAL |fl|)) |body|)))) - (CONS |lamtype| (CONS |args| |body|)))))) - -(DEFUN |needsPROG| (|body|) - (PROG (|args| |op|) - (RETURN - (COND ((NOT (CONSP |body|)) NIL) - (T (SETQ |op| (CAR |body|)) (SETQ |args| (CDR |body|)) - (COND ((|symbolMember?| |op| '(RETURN RETURN-FROM)) T) - ((|symbolMember?| |op| - '(LET LET* - PROG - LOOP - BLOCK - DECLARE - LAMBDA)) - NIL) - (T - (LET ((|bfVar#2| NIL) (|bfVar#1| |body|) (|t| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |t| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - (T (SETQ |bfVar#2| (|needsPROG| |t|)) - (COND (|bfVar#2| (RETURN |bfVar#2|))))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))))))))) - -(DEFUN |shoePROG| (|v| |b|) - (PROG (|blist| |blast| |LETTMP#1|) - (RETURN - (COND ((NULL |b|) (LIST (LIST 'PROG |v|))) - (T (SETQ |LETTMP#1| (|reverse| |b|)) (SETQ |blast| (CAR |LETTMP#1|)) - (SETQ |blist| (|reverse!| (CDR |LETTMP#1|))) - (LIST - (CONS 'PROG - (CONS |v| - (|append| |blist| - (CONS (LIST 'RETURN |blast|) NIL)))))))))) + (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 + (|$typings| + (SETQ |body'| (CONS (CONS 'DECLARE |$typings|) |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|)) @@ -1788,260 +1803,263 @@ (T (|append| (|shoeATOMs| (CAR |x|)) (|shoeATOMs| (CDR |x|)))))) (DEFUN |isDynamicVariable| (|x|) - (PROG (|y|) + (LET* (|y|) (DECLARE (SPECIAL |$activeNamespace| |$constantIdentifiers|)) - (RETURN - (COND - ((AND (SYMBOLP |x|) (|bfBeginsDollar| |x|)) - (COND ((|symbolMember?| |x| |$constantIdentifiers|) NIL) - ((CONSTANTP |x|) NIL) - ((OR (BOUNDP |x|) (NULL |$activeNamespace|)) T) - ((SETQ |y| (FIND-SYMBOL (SYMBOL-NAME |x|) |$activeNamespace|)) - (NOT (CONSTANTP |y|))) - (T T))) - (T NIL))))) + (COND + ((AND (SYMBOLP |x|) (|bfBeginsDollar| |x|)) + (COND ((|symbolMember?| |x| |$constantIdentifiers|) NIL) + ((CONSTANTP |x|) NIL) + ((OR (BOUNDP |x|) (NULL |$activeNamespace|)) T) + ((SETQ |y| (FIND-SYMBOL (SYMBOL-NAME |x|) |$activeNamespace|)) + (NOT (CONSTANTP |y|))) + (T T))) + (T NIL)))) (DEFUN |shoeCompTran1| (|x| |fluidVars| |locVars| |dollarVars|) - (PROG (|n| |elts| |newbindings| |r| |ISTMP#2| |l| |zs| |y| |ISTMP#1| U) - (RETURN - (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|) - (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) |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 + (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 - (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|) + (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|) + (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) |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 - (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| + (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|)) - (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|)))))))) + |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|) - (PROG (|y| |stmts| |init| |ISTMP#1|) - (RETURN - (PROGN - (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|) - (PROG (|stmts'| |vars'| |ISTMP#6| |ISTMP#5| |ISTMP#4| |ISTMP#3| |inits'| - |ISTMP#2| |ISTMP#1|) - (RETURN + (LET* (|y| |stmts| |init| |ISTMP#1|) + (PROGN (COND - ((AND (CONSP |stmts|) (NULL (CDR |stmts|)) + ((AND (CONSP |x|) (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|)) + (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| (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|))))))) + (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 |bfTagged| (|a| |b|) (DECLARE (SPECIAL |$typings| |$op|)) @@ -2053,77 +2071,71 @@ (T (LIST 'THE |b| |a|)))) (DEFUN |bfAssign| (|l| |r|) - (PROG (|l'|) - (RETURN - (COND ((|bfTupleP| |l|) (|bfSetelt| (CADR |l|) (CDDR |l|) |r|)) - ((AND (CONSP |l|) (EQ (CAR |l|) '|%Place|)) (SETQ |l'| (CDR |l|)) - (LIST 'SETF |l'| |r|)) - (T (|bfLET| |l| |r|)))))) + (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| |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|) - (PROG (|y|) - (RETURN - (PROGN - (SETQ |y| (AND (SYMBOLP |sel|) (GET |sel| 'SHOESELFUNCTION))) - (COND - (|y| - (COND ((INTEGERP |y|) (LIST 'ELT |expr| |y|)) (T (LIST |y| |expr|)))) - (T (LIST 'ELT |expr| |sel|))))))) + (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|) - (PROG (|y|) - (RETURN - (PROGN - (SETQ |y| (AND (SYMBOLP |sel|) (GET |sel| 'SHOESELFUNCTION))) - (COND - (|y| - (COND ((INTEGERP |y|) (LIST 'SETF (LIST 'ELT |var| |y|) |expr|)) - ((EQ |y| 'CAR) (LIST 'RPLACA |var| |expr|)) - ((EQ |y| 'CDR) (LIST 'RPLACD |var| |expr|)) - (T (LIST 'SETF (LIST |y| |var|) |expr|)))) - (T (LIST 'SETF (LIST 'ELT |var| |sel|) |expr|))))))) + (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|) - (PROG (|b1|) - (RETURN - (PROGN - (SETQ |b1| - (COND ((AND (CONSP |b|) (EQ (CAR |b|) 'PROGN)) (CDR |b|)) - (T (LIST |b|)))) - (LIST 'COND (CONS |a| |b1|)))))) + (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|) - (PROG (|c1| |b1|) - (RETURN - (PROGN - (SETQ |b1| - (COND ((AND (CONSP |b|) (EQ (CAR |b|) 'PROGN)) (CDR |b|)) - (T (LIST |b|)))) - (COND - ((AND (CONSP |c|) (EQ (CAR |c|) 'COND)) - (CONS 'COND (CONS (CONS |a| |b1|) (CDR |c|)))) - (T - (SETQ |c1| - (COND ((AND (CONSP |c|) (EQ (CAR |c|) 'PROGN)) (CDR |c|)) - (T (LIST |c|)))) - (LIST 'COND (CONS |a| |b1|) (CONS 'T |c1|)))))))) + (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|) - (PROG (|xs| |x|) - (RETURN - (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|))))))))) + (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 @@ -2132,192 +2144,201 @@ (T (CONS 'PROGN |l|))))) (DEFUN |bfWashCONDBranchBody| (|x|) - (PROG (|y|) - (RETURN - (COND ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN)) (SETQ |y| (CDR |x|)) |y|) - (T (LIST |x|)))))) + (LET* (|y|) + (COND ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN)) (SETQ |y| (CDR |x|)) |y|) + (T (LIST |x|))))) (DEFUN |bfAlternative| (|a| |b|) - (PROG (|conds| |ISTMP#5| |stmt| |ISTMP#4| |ISTMP#3| |ISTMP#2| |ISTMP#1|) - (RETURN - (COND - ((AND (CONSP |a|) (EQ (CAR |a|) 'AND) - (PROGN - (SETQ |ISTMP#1| (CDR |a|)) - (AND (CONSP |ISTMP#1|) - (PROGN (SETQ |ISTMP#2| (|reverse| |ISTMP#1|)) T) - (CONSP |ISTMP#2|) - (PROGN - (SETQ |ISTMP#3| (CAR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) (EQ (CAR |ISTMP#3|) 'PROGN) - (PROGN - (SETQ |ISTMP#4| (CDR |ISTMP#3|)) - (AND (CONSP |ISTMP#4|) - (PROGN - (SETQ |stmt| (CAR |ISTMP#4|)) - (SETQ |ISTMP#5| (CDR |ISTMP#4|)) - (AND (CONSP |ISTMP#5|) (NULL (CDR |ISTMP#5|)) - (EQ (CAR |ISTMP#5|) 'T))))))) - (PROGN (SETQ |conds| (CDR |ISTMP#2|)) T) - (PROGN (SETQ |conds| (|reverse!| |conds|)) T)))) - (CONS (CONS 'AND |conds|) - (|bfWashCONDBranchBody| (|bfMKPROGN| (LIST |stmt| |b|))))) - (T (CONS |a| (|bfWashCONDBranchBody| |b|))))))) + (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|) - (PROG (|f| |aft| |before| |no| |transform| |b| |ISTMP#5| |ISTMP#4| |ISTMP#3| - |a| |ISTMP#2| |ISTMP#1|) - (RETURN - (COND ((NULL |l|) NIL) - (T - (SETQ |transform| - (LET ((|bfVar#2| NIL) - (|bfVar#3| NIL) - (|bfVar#1| |l|) - (|x| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL) - (NOT - (AND (CONSP |x|) (EQ (CAR |x|) 'COND) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (NULL (CDR |ISTMP#1|)) - (PROGN - (SETQ |ISTMP#2| (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |a| (CAR |ISTMP#2|)) - (SETQ |ISTMP#3| - (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (NULL (CDR |ISTMP#3|)) - (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)))))))))) + (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| (|context| |expr|) - (PROG (|a| |nondefs| |defs| |opassoc| |LETTMP#1|) + (LET* (|a| |nondefs| |defs| |opassoc| |LETTMP#1|) (DECLARE (SPECIAL |$wheredefs|)) - (RETURN - (PROGN - (SETQ |LETTMP#1| (|defSheepAndGoats| |context|)) - (SETQ |opassoc| (CAR |LETTMP#1|)) - (SETQ |defs| (CADR . #1=(|LETTMP#1|))) - (SETQ |nondefs| (CADDR . #1#)) - (SETQ |a| - (LET ((|bfVar#2| NIL) - (|bfVar#3| NIL) - (|bfVar#1| |defs|) - (|d| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |d| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| - #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|))))) - (SETQ |$wheredefs| (|append| |a| |$wheredefs|)) - (|bfMKPROGN| - (|bfSUBLIS| |opassoc| (|append!| |nondefs| (LIST |expr|)))))))) + (PROGN + (SETQ |LETTMP#1| (|defSheepAndGoats| |context|)) + (SETQ |opassoc| (CAR |LETTMP#1|)) + (SETQ |defs| (CADR . #1=(|LETTMP#1|))) + (SETQ |nondefs| (CADDR . #1#)) + (SETQ |a| + (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |defs|) (|d| NIL)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) + (PROGN (SETQ |d| (CAR |bfVar#1|)) NIL)) + (RETURN |bfVar#2|)) + ((NULL |bfVar#2|) + (SETQ |bfVar#2| + #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|))))) + (SETQ |$wheredefs| (|append| |a| |$wheredefs|)) + (|bfMKPROGN| (|bfSUBLIS| |opassoc| (|append!| |nondefs| (LIST |expr|))))))) (DEFUN |bfCompHash| (|op| |argl| |body|) - (PROG (|computeFunction| |auxfn|) - (RETURN - (PROGN - (SETQ |auxfn| (INTERN (CONCAT (SYMBOL-NAME |op|) ";"))) - (SETQ |computeFunction| - (CONS 'DEFUN (CONS |auxfn| (CONS |argl| |body|)))) - (|bfTuple| (CONS |computeFunction| (|bfMain| |auxfn| |op|))))))) + (LET* (|computeFunction| |auxfn|) + (PROGN + (SETQ |auxfn| (INTERN (CONCAT (SYMBOL-NAME |op|) ";"))) + (SETQ |computeFunction| (CONS 'DEFUN (CONS |auxfn| (CONS |argl| |body|)))) + (|bfTuple| (CONS |computeFunction| (|bfMain| |auxfn| |op|)))))) (DEFUN |shoeCompileTimeEvaluation| (|x|) (LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL) |x|)) (DEFUN |bfMain| (|auxfn| |op|) - (PROG (|defCode| |cacheVector| |cacheCountCode| |cacheResetCode| |cacheType| - |mainFunction| |codeBody| |thirdPredPair| |putCode| |secondPredPair| - |getCode| |g2| |cacheName| |computeValue| |arg| |g1|) - (RETURN - (PROGN - (SETQ |g1| (|bfGenSymbol|)) - (SETQ |arg| (LIST '&REST |g1|)) - (SETQ |computeValue| (LIST 'APPLY (LIST 'FUNCTION |auxfn|) |g1|)) - (SETQ |cacheName| (INTERN (CONCAT (SYMBOL-NAME |op|) ";AL"))) - (SETQ |g2| (|bfGenSymbol|)) - (SETQ |getCode| (LIST 'GETHASH |g1| |cacheName|)) - (SETQ |secondPredPair| (LIST (LIST 'SETQ |g2| |getCode|) |g2|)) - (SETQ |putCode| (LIST 'SETF |getCode| |computeValue|)) - (SETQ |thirdPredPair| (LIST 'T |putCode|)) - (SETQ |codeBody| - (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|))))))) + (LET* (|defCode| + |cacheVector| + |cacheCountCode| + |cacheResetCode| + |cacheType| + |mainFunction| + |codeBody| + |thirdPredPair| + |putCode| + |secondPredPair| + |getCode| + |g2| + |cacheName| + |computeValue| + |arg| + |g1|) + (PROGN + (SETQ |g1| (|bfGenSymbol|)) + (SETQ |arg| (LIST '&REST |g1|)) + (SETQ |computeValue| (LIST 'APPLY (LIST 'FUNCTION |auxfn|) |g1|)) + (SETQ |cacheName| (INTERN (CONCAT (SYMBOL-NAME |op|) ";AL"))) + (SETQ |g2| (|bfGenSymbol|)) + (SETQ |getCode| (LIST 'GETHASH |g1| |cacheName|)) + (SETQ |secondPredPair| (LIST (LIST 'SETQ |g2| |getCode|) |g2|)) + (SETQ |putCode| (LIST 'SETF |getCode| |computeValue|)) + (SETQ |thirdPredPair| (LIST 'T |putCode|)) + (SETQ |codeBody| + (LIST 'PROG (LIST |g2|) + (LIST 'RETURN + (LIST 'COND |secondPredPair| |thirdPredPair|)))) + (SETQ |mainFunction| (LIST 'DEFUN |op| |arg| |codeBody|)) + (SETQ |cacheType| '|hash-table|) + (SETQ |cacheResetCode| + (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|)) @@ -2337,29 +2358,28 @@ (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Form|) |bfCreateDef|)) (DEFUN |bfCreateDef| (|x|) - (PROG (|a| |f|) - (RETURN - (COND - ((AND (CONSP |x|) (NULL (CDR |x|))) (SETQ |f| (CAR |x|)) - (LIST 'DEFCONSTANT |f| (LIST 'LIST (|quote| |f|)))) - (T - (SETQ |a| - (LET ((|bfVar#2| NIL) - (|bfVar#3| NIL) - (|bfVar#1| (CDR |x|)) - (|i| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#2|)) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| #1=(CONS (|bfGenSymbol|) NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|))))) - (LIST 'DEFUN (CAR |x|) |a| - (LIST 'CONS (|quote| (CAR |x|)) (CONS 'LIST |a|)))))))) + (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|) 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|)) @@ -2368,76 +2388,73 @@ (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) |%Form|) |bfCase|)) (DEFUN |bfCase| (|x| |y|) - (PROG (|body| |g|) - (RETURN - (PROGN - (SETQ |g| (COND ((NOT (CONSP |x|)) |x|) (T (|bfGenSymbol|)))) - (SETQ |body| (CONS 'CASE (CONS (LIST 'CAR |g|) (|bfCaseItems| |g| |y|)))) - (COND ((EQ |g| |x|) |body|) - (T (LIST 'LET (LIST (LIST |g| |x|)) |body|))))))) + (LET* (|body| |g|) + (PROGN + (SETQ |g| (COND ((NOT (CONSP |x|)) |x|) (T (|bfGenSymbol|)))) + (SETQ |body| (CONS 'CASE (CONS (LIST 'CAR |g|) (|bfCaseItems| |g| |y|)))) + (COND ((EQ |g| |x|) |body|) + (T (LIST 'LET (LIST (LIST |g| |x|)) |body|)))))) (DECLAIM (FTYPE (FUNCTION (|%Thing| (|%List| |%Form|)) (|%List| |%Form|)) |bfCaseItems|)) (DEFUN |bfCaseItems| (|g| |x|) - (PROG (|j| |ISTMP#1| |i|) - (RETURN - (LET ((|bfVar#3| NIL) (|bfVar#4| NIL) (|bfVar#2| |x|) (|bfVar#1| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#2|)) - (PROGN (SETQ |bfVar#1| (CAR |bfVar#2|)) NIL)) - (RETURN |bfVar#3|)) - (T - (AND (CONSP |bfVar#1|) - (PROGN - (SETQ |i| (CAR |bfVar#1|)) - (SETQ |ISTMP#1| (CDR |bfVar#1|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |j| (CAR |ISTMP#1|)) T))) - (COND - ((NULL |bfVar#3|) - (SETQ |bfVar#3| #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|))))))) + (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|) - (PROG (|b| |a|) - (RETURN - (PROGN - (SETQ |a| (CDR |x|)) - (COND ((NULL |a|) (LIST (CAR |x|) |y|)) - (T - (SETQ |b| - (LET ((|bfVar#2| NIL) - (|bfVar#3| NIL) - (|bfVar#1| |a|) - (|i| NIL) - (|j| 1)) - (LOOP - (COND - ((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|)))))))))) + (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|)) @@ -2453,143 +2470,144 @@ (DEFUN |bfHandlers| (|n| |e| |hs|) (|bfHandlers,main| |n| |e| |hs| NIL)) (DEFUN |bfHandlers,main| (|n| |e| |hs| |xs|) - (PROG (|hs'| |s| |ISTMP#6| |t| |ISTMP#5| |v| |ISTMP#4| |ISTMP#3| |ISTMP#2| + (LET* (|hs'| + |s| + |ISTMP#6| + |t| + |ISTMP#5| + |v| + |ISTMP#4| + |ISTMP#3| + |ISTMP#2| |ISTMP#1|) - (RETURN - (COND - ((NULL |hs|) - (CONS 'COND - (|reverse!| - (CONS (LIST T (LIST 'THROW :OPEN-AXIOM-CATCH-POINT |n|)) |xs|)))) - ((AND (CONSP |hs|) - (PROGN - (SETQ |ISTMP#1| (CAR |hs|)) - (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) '|%Catch|) - (PROGN - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |ISTMP#3| (CAR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CAR |ISTMP#3|) '|%Signature|) - (PROGN - (SETQ |ISTMP#4| (CDR |ISTMP#3|)) - (AND (CONSP |ISTMP#4|) - (PROGN - (SETQ |v| (CAR |ISTMP#4|)) - (SETQ |ISTMP#5| (CDR |ISTMP#4|)) - (AND (CONSP |ISTMP#5|) - (NULL (CDR |ISTMP#5|)) - (PROGN - (SETQ |t| (CAR |ISTMP#5|)) - T))))))) - (PROGN - (SETQ |ISTMP#6| (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#6|) (NULL (CDR |ISTMP#6|)) - (PROGN (SETQ |s| (CAR |ISTMP#6|)) T)))))))) - (SETQ |hs'| (CDR |hs|)) - (SETQ |t| (COND ((SYMBOLP |t|) (|quote| (LIST |t|))) (T (|quote| |t|)))) - (|bfHandlers,main| |n| |e| |hs'| - (CONS - (LIST (|bfQ| (LIST 'CAR |e|) |t|) - (LIST 'LET (LIST (LIST |v| (LIST 'CDR |e|))) - |s|)) - |xs|))) - (T (|bpTrap|)))))) + (COND + ((NULL |hs|) + (CONS 'COND + (|reverse!| + (CONS (LIST T (LIST 'THROW :OPEN-AXIOM-CATCH-POINT |n|)) |xs|)))) + ((AND (CONSP |hs|) + (PROGN + (SETQ |ISTMP#1| (CAR |hs|)) + (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) '|%Catch|) + (PROGN + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |ISTMP#3| (CAR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CAR |ISTMP#3|) '|%Signature|) + (PROGN + (SETQ |ISTMP#4| (CDR |ISTMP#3|)) + (AND (CONSP |ISTMP#4|) + (PROGN + (SETQ |v| (CAR |ISTMP#4|)) + (SETQ |ISTMP#5| (CDR |ISTMP#4|)) + (AND (CONSP |ISTMP#5|) + (NULL (CDR |ISTMP#5|)) + (PROGN + (SETQ |t| (CAR |ISTMP#5|)) + T))))))) + (PROGN + (SETQ |ISTMP#6| (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#6|) (NULL (CDR |ISTMP#6|)) + (PROGN (SETQ |s| (CAR |ISTMP#6|)) T)))))))) + (SETQ |hs'| (CDR |hs|)) + (SETQ |t| (COND ((SYMBOLP |t|) (|quote| (LIST |t|))) (T (|quote| |t|)))) + (|bfHandlers,main| |n| |e| |hs'| + (CONS + (LIST (|bfQ| (LIST 'CAR |e|) |t|) + (LIST 'LET (LIST (LIST |v| (LIST 'CDR |e|))) + |s|)) + |xs|))) + (T (|bpTrap|))))) (DEFUN |codeForCatchHandlers| (|g| |e| |cs|) - (PROG (|ehTest|) - (RETURN - (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|))))))) + (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|) - (PROG (|s| |cs'| |f| |ISTMP#1| |g|) - (RETURN - (PROGN - (SETQ |g| (GENSYM)) - (COND - ((AND (CONSP |cs|) (PROGN (SETQ |ISTMP#1| (|reverse| |cs|)) T) - (CONSP |ISTMP#1|) - (PROGN (SETQ |f| (CAR |ISTMP#1|)) (SETQ |cs'| (CDR |ISTMP#1|)) T) - (PROGN (SETQ |cs'| (|reverse!| |cs'|)) T) (CONSP |f|) - (EQ (CAR |f|) '|%Finally|) - (PROGN - (SETQ |ISTMP#1| (CDR |f|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN (SETQ |s| (CAR |ISTMP#1|)) T)))) - (COND ((NULL |cs'|) (LIST 'UNWIND-PROTECT |e| |s|)) - (T - (LIST 'UNWIND-PROTECT (|codeForCatchHandlers| |g| |e| |cs'|) - |s|)))) - (T (|codeForCatchHandlers| |g| |e| |cs|))))))) + (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|) - (PROG (|x| |t|) - (RETURN - (PROGN - (SETQ |t| NIL) - (SETQ |x| NIL) - (COND - ((AND (CONSP |e|) (EQ (CAR |e|) '|%Pretend|)) (SETQ |t| (CADDR |e|)) - (SETQ |x| (CADR |e|))) - (T (SETQ |t| '|SystemException|) (SETQ |x| |e|))) - (SETQ |t| (COND ((SYMBOLP |t|) (|quote| (LIST |t|))) (T (|quote| |t|)))) - (LIST 'THROW :OPEN-AXIOM-CATCH-POINT - (LIST 'CONS :OPEN-AXIOM-CATCH-POINT (LIST 'CONS |t| |x|))))))) + (LET* (|x| |t|) + (PROGN + (SETQ |t| NIL) + (SETQ |x| NIL) + (COND + ((AND (CONSP |e|) (EQ (CAR |e|) '|%Pretend|)) (SETQ |t| (CADDR |e|)) + (SETQ |x| (CADR |e|))) + (T (SETQ |t| '|SystemException|) (SETQ |x| |e|))) + (SETQ |t| (COND ((SYMBOLP |t|) (|quote| (LIST |t|))) (T (|quote| |t|)))) + (LIST 'THROW :OPEN-AXIOM-CATCH-POINT + (LIST 'CONS :OPEN-AXIOM-CATCH-POINT (LIST 'CONS |t| |x|)))))) (DEFUN |bfType| (|x|) - (PROG (|s| |ISTMP#2| |t| |ISTMP#1|) - (RETURN - (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|))))) + (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|)) @@ -2616,12 +2634,11 @@ (SETQ |bfVar#1| (CDR |bfVar#1|)))))))) (DEFUN |genTypeAlias| (|head| |body|) - (PROG (|args| |op|) - (RETURN - (PROGN - (SETQ |op| (CAR |head|)) - (SETQ |args| (CDR |head|)) - (LIST 'DEFTYPE |op| |args| (|backquote| |body| |args|)))))) + (LET* (|args| |op|) + (PROGN + (SETQ |op| (CAR |head|)) + (SETQ |args| (CDR |head|)) + (LIST 'DEFTYPE |op| |args| (|backquote| |body| |args|))))) (DEFCONSTANT |$NativeSimpleDataTypes| '(|char| |byte| |int| |pointer| |int8| |uint8| |int16| |uint16| |int32| @@ -2645,99 +2662,97 @@ (|fatalError| (CONCAT "unsupported native type: " (PNAME |t|)))) (DEFUN |nativeType| (|t|) - (PROG (|t'|) - (RETURN - (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|)))))) + (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|)) @@ -2746,203 +2761,197 @@ (CONCAT "invalid return type for native function: " (PNAME |t|)))))) (DEFUN |nativeArgumentType| (|t|) - (PROG (|t'| |c| |m|) - (RETURN - (COND ((|objectMember?| |t| |$NativeSimpleDataTypes|) (|nativeType| |t|)) - ((EQ |t| '|string|) (|nativeType| |t|)) - ((OR (NOT (CONSP |t|)) (NOT (EQL (LENGTH |t|) 2))) - (|coreError| "invalid argument type for a native function")) - (T (SETQ |m| (CAR |t|)) (SETQ |c| (CAADR . #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|))))))))) + (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|) - (PROG (|m|) - (RETURN - (AND (CONSP |t|) (PROGN (SETQ |m| (CAR |t|)) T) - (|symbolMember?| |m| '(|readonly| |writeonly| |readwrite|)))))) + (LET* (|m|) + (AND (CONSP |t|) (PROGN (SETQ |m| (CAR |t|)) T) + (|symbolMember?| |m| '(|readonly| |writeonly| |readwrite|))))) (DEFUN |coerceToNativeType| (|a| |t|) - (PROG (|y| |c|) - (RETURN - (COND - ((OR (|%hasFeature| :GCL) (|%hasFeature| :ECL) (|%hasFeature| :CLISP) - (|%hasFeature| :CLOZURE)) - |a|) - ((|%hasFeature| :SBCL) - (COND ((NOT (|needsStableReference?| |t|)) |a|) - (T (SETQ |c| (CAADR . #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")))))) + (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'|) - (PROG (|ccode| |cargs| |cop| |rettype| |argtypes|) - (RETURN - (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 + (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|)) - (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|))))))))) + (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|))) @@ -2952,65 +2961,62 @@ (COND ((CDR |x|) ", ") (T "")))) (DEFUN |genGCLnativeTranslation,gclTypeInC| (|x|) - (PROG (|ISTMP#3| |ISTMP#2| |ISTMP#1|) - (RETURN - (COND ((|objectMember?| |x| |$NativeSimpleDataTypes|) (SYMBOL-NAME |x|)) - ((EQ |x| '|void|) "void") ((EQ |x| '|string|) "char*") - ((AND (CONSP |x|) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) - (PROGN - (SETQ |ISTMP#2| (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (EQ (CAR |ISTMP#2|) '|pointer|) - (PROGN - (SETQ |ISTMP#3| (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (NULL (CDR |ISTMP#3|))))))))) - '|fixnum|) - (T "object"))))) + (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|) - (PROG (|y| |c|) - (RETURN - (COND ((|objectMember?| |x| |$NativeSimpleDataTypes|) |a|) - ((EQ |x| '|string|) |a|) - (T (SETQ |c| (CAADR |x|)) (SETQ |y| (CADADR |x|)) - (COND ((EQ |c| '|pointer|) |a|) - ((EQ |y| '|char|) (CONCAT |a| "->st.st_self")) - ((EQ |y| '|byte|) (CONCAT |a| "->ust.ust_self")) - ((EQ |y| '|int|) (CONCAT |a| "->fixa.fixa_self")) - ((EQ |y| '|float|) (CONCAT |a| "->sfa.sfa_self")) - ((EQ |y| '|double|) (CONCAT |a| "->lfa.lfa_self")) - (T (|coreError| "unknown argument type")))))))) + (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'|) - (PROG (|rettype| |argtypes| |args|) - (RETURN - (PROGN - (SETQ |args| NIL) - (SETQ |argtypes| NIL) - (LET ((|bfVar#1| |s|) (|x| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - (T (SETQ |argtypes| (CONS (|nativeArgumentType| |x|) |argtypes|)) - (SETQ |args| (CONS (GENSYM) |args|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - (SETQ |args| (|reverse| |args|)) - (SETQ |rettype| (|nativeReturnType| |t|)) - (LIST - (LIST 'DEFUN |op| |args| - (LIST (|bfColonColon| 'FFI 'C-INLINE) |args| - (|reverse!| |argtypes|) |rettype| - (|genECLnativeTranslation,callTemplate| |op'| - (LENGTH |args|) |s|) - :ONE-LINER T))))))) + (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| "") @@ -3063,496 +3069,505 @@ (|genECLnativeTranslation,selectDatum| |x|))))) (DEFUN |genECLnativeTranslation,selectDatum| (|x|) - (PROG (|y| |c|) - (RETURN - (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")))))))) + (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'|) - (PROG (|forwardingFun| |ISTMP#2| |p| |fixups| |q| |call| |localPairs| |y| |x| - |ISTMP#1| |a| |foreignDecl| |unstableArgs| |parms| |n| |argtypes| + (LET* (|forwardingFun| + |ISTMP#2| + |p| + |fixups| + |q| + |call| + |localPairs| + |y| + |x| + |ISTMP#1| + |a| + |foreignDecl| + |unstableArgs| + |parms| + |n| + |argtypes| |rettype|) (DECLARE (SPECIAL |$foreignsDefsForCLisp|)) - (RETURN - (PROGN - (SETQ |rettype| (|nativeReturnType| |t|)) - (SETQ |argtypes| - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) (|x| NIL)) - (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 |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 |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 + (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 - ((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|)) + ((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)) - (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 + (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 - (|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|))))) + (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#26|) - (PROG (|a| |y| |x| |p|) - (RETURN - (PROGN - (SETQ |p| (CAR |bfVar#26|)) - (SETQ |x| (CADR . #1=(|bfVar#26|))) - (SETQ |y| (CADDR . #1#)) - (SETQ |a| (CDDDR . #1#)) - (COND ((AND (CONSP |x|) (EQ (CAR |x|) '|readonly|)) NIL) - (T - (LIST 'SETF |p| - (LIST (|bfColonColon| 'FFI 'FOREIGN-VALUE) |a|)))))))) + (LET* (|a| |y| |x| |p|) + (PROGN + (SETQ |p| (CAR |bfVar#26|)) + (SETQ |x| (CADR . #1=(|bfVar#26|))) + (SETQ |y| (CADDR . #1#)) + (SETQ |a| (CDDDR . #1#)) + (COND ((AND (CONSP |x|) (EQ (CAR |x|) '|readonly|)) NIL) + (T + (LIST 'SETF |p| + (LIST (|bfColonColon| 'FFI 'FOREIGN-VALUE) |a|))))))) (DEFUN |genCLISPnativeTranslation,actualArg| (|p| |pairs|) - (PROG (|a'|) - (RETURN - (COND ((SETQ |a'| (CDR (|objectAssoc| |p| |pairs|))) (CDR (CDR |a'|))) - (T |p|))))) + (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'|) - (PROG (|newArgs| |unstableArgs| |args| |argtypes| |rettype|) - (RETURN - (PROGN - (SETQ |rettype| (|nativeReturnType| |t|)) - (SETQ |argtypes| - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) (|x| NIL)) - (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'| - (COND ((|%hasFeature| :WIN32) (CONCAT "_" (SYMBOL-NAME |op'|))) - (T (SYMBOL-NAME |op'|)))) - (COND - ((NULL |unstableArgs|) - (LIST - (LIST 'DEFUN |op| |args| - (CONS (INTERN "ALIEN-FUNCALL" "SB-ALIEN") - (CONS - (LIST (INTERN "EXTERN-ALIEN" "SB-ALIEN") |op'| - (CONS 'FUNCTION (CONS |rettype| |argtypes|))) - |args|))))) - (T - (LIST - (LIST 'DEFUN |op| |args| - (LIST (|bfColonColon| 'SB-SYS 'WITH-PINNED-OBJECTS) - (|reverse!| |unstableArgs|) - (CONS (INTERN "ALIEN-FUNCALL" "SB-ALIEN") - (CONS - (LIST (INTERN "EXTERN-ALIEN" "SB-ALIEN") |op'| - (CONS 'FUNCTION (CONS |rettype| |argtypes|))) - (|reverse!| |newArgs|)))))))))))) + (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'| + (COND ((|%hasFeature| :WIN32) (CONCAT "_" (SYMBOL-NAME |op'|))) + (T (SYMBOL-NAME |op'|)))) + (COND + ((NULL |unstableArgs|) + (LIST + (LIST 'DEFUN |op| |args| + (CONS (INTERN "ALIEN-FUNCALL" "SB-ALIEN") + (CONS + (LIST (INTERN "EXTERN-ALIEN" "SB-ALIEN") |op'| + (CONS 'FUNCTION (CONS |rettype| |argtypes|))) + |args|))))) + (T + (LIST + (LIST 'DEFUN |op| |args| + (LIST (|bfColonColon| 'SB-SYS 'WITH-PINNED-OBJECTS) + (|reverse!| |unstableArgs|) + (CONS (INTERN "ALIEN-FUNCALL" "SB-ALIEN") + (CONS + (LIST (INTERN "EXTERN-ALIEN" "SB-ALIEN") |op'| + (CONS 'FUNCTION (CONS |rettype| |argtypes|))) + (|reverse!| |newArgs|))))))))))) (DEFUN |genCLOZUREnativeTranslation| (|op| |s| |t| |op'|) - (PROG (|call| |p'| |ISTMP#3| |ISTMP#2| |ISTMP#1| |aryPairs| |strPairs| - |parms| |argtypes| |rettype|) - (RETURN - (PROGN - (SETQ |rettype| (|nativeReturnType| |t|)) - (SETQ |argtypes| - (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) (|x| NIL)) - (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|)))))) + (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|))))) (DEFUN |genImportDeclaration| (|op| |sig|) - (PROG (|s| |t| |m| |ISTMP#2| |op'| |ISTMP#1|) - (RETURN - (COND - ((NOT - (AND (CONSP |sig|) (EQ (CAR |sig|) '|%Signature|) - (PROGN - (SETQ |ISTMP#1| (CDR |sig|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |op'| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (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|)))) - (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")))))))) + (LET* (|s| |t| |m| |ISTMP#2| |op'| |ISTMP#1|) + (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|)))) + (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"))))))) |