aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2012-05-22 01:38:27 +0000
committerdos-reis <gdr@axiomatics.org>2012-05-22 01:38:27 +0000
commit08967519aa894f0740d4e120df5db49ab4d2e8b6 (patch)
treef1a4befb60c982dec9d0a3b42014fd49358da4f4 /src
parentec02c6670d57cbb6814c6a79e133e1e2b41ed0af (diff)
downloadopen-axiom-08967519aa894f0740d4e120df5db49ab4d2e8b6.tar.gz
* boot/ast.boot (needsPROG): Remove.
(shoePROG): Likewise. (declareLocalVars): New. (maybeAddBlock): Likewise. (hasReturn?): Likewise. (shoeCompTran): Tidy.
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog9
-rw-r--r--src/boot/ast.boot32
-rw-r--r--src/boot/strap/ast.clisp5385
-rw-r--r--src/boot/strap/includer.clisp268
-rw-r--r--src/boot/strap/parser.clisp685
-rw-r--r--src/boot/strap/pile.clisp173
-rw-r--r--src/boot/strap/scanner.clisp652
-rw-r--r--src/boot/strap/tokens.clisp172
-rw-r--r--src/boot/strap/translator.clisp1820
-rw-r--r--src/boot/strap/utility.clisp356
10 files changed, 4722 insertions, 4830 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 907162dc..b9d767a1 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,12 @@
+2012-05-21 Gabriel Dos Reis <gdr@cse.tamu.edu>
+
+ * boot/ast.boot (needsPROG): Remove.
+ (shoePROG): Likewise.
+ (declareLocalVars): New.
+ (maybeAddBlock): Likewise.
+ (hasReturn?): Likewise.
+ (shoeCompTran): Tidy.
+
2012-05-21 Gabriel Dos Reis <gdr@cs.tamu.edu>
* interp/parsing.lisp: Remove.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index f4f4bedc..467caa3f 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -1008,23 +1008,29 @@ shoeCompTran x==
body' := [["DECLARE",:$typings],:body']
if fvars := setDifference(deref dollarVars,deref fluidVars) then
body' := [["DECLARE",["SPECIAL",:fvars]],:body']
- deref locVars or needsPROG body' => shoePROG(deref locVars,body')
- body'
+ vars := deref locVars => declareLocalVars(vars,body')
+ maybeAddBlock body'
if fl := shoeFluids args then
body := [["DECLARE",["SPECIAL",:fl]],:body]
[lamtype,args,:body]
-needsPROG body ==
- body isnt [.,:.] => false
- [op,:args] := body
- op in '(RETURN RETURN_-FROM) => true
- op in '(LET LET_* PROG LOOP BLOCK DECLARE LAMBDA) => false
- or/[needsPROG t for t in body]
-
-shoePROG(v,b)==
- b = nil => [["PROG", v]]
- [:blist,blast] := b
- [["PROG",v,:blist,["RETURN", blast]]]
+declareLocalVars(vars,stmts) ==
+ stmts is [["LET*",inits,:stmts]] =>
+ [["LET*",[:inits,:vars],:maybeAddBlock stmts]]
+ [["LET*",vars,:maybeAddBlock stmts]]
+
+maybeAddBlock stmts ==
+ [:decls,expr] := stmts
+ hasReturn? expr =>
+ decls = nil => [["BLOCK","NIL",:stmts]]
+ [:decls,["BLOCK","NIL",expr]]
+ stmts
+
+hasReturn? x ==
+ x isnt [.,:.] => false
+ x.op is 'RETURN => true
+ x.op in '(LOOP PROG BLOCK LAMBDA DECLARE) => false
+ or/[hasReturn? t for t in x]
shoeFluids x==
ident? x and bfBeginsDollar x => [x]
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")))))))
diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp
index a5beae8e..f087ddb7 100644
--- a/src/boot/strap/includer.clisp
+++ b/src/boot/strap/includer.clisp
@@ -12,26 +12,24 @@
(DEFUN |shoeNotFound| (|fn|) (PROGN (|coreError| (LIST |fn| " not found")) NIL))
(DEFUN |shoeReadLispString| (|s| |n|)
- (PROG (|l|)
- (RETURN
- (PROGN
- (SETQ |l| (LENGTH |s|))
- (COND ((NOT (< |n| |l|)) NIL)
- (T
- (READ-FROM-STRING
- (CONCAT "(" (|subString| |s| |n| (- |l| |n|)) ")"))))))))
+ (LET* (|l|)
+ (PROGN
+ (SETQ |l| (LENGTH |s|))
+ (COND ((NOT (< |n| |l|)) NIL)
+ (T
+ (READ-FROM-STRING
+ (CONCAT "(" (|subString| |s| |n| (- |l| |n|)) ")")))))))
(DEFUN |shoeConsole| (|line|) (WRITE-LINE |line| *TERMINAL-IO*))
(DEFUN |shoeSpaces| (|n|) (|makeString| |n| (|char| '|.|)))
(DEFUN |diagnosticLocation| (|tok|)
- (PROG (|pos|)
- (RETURN
- (PROGN
- (SETQ |pos| (|shoeTokPosn| |tok|))
- (CONCAT "line " (WRITE-TO-STRING (|lineNo| |pos|)) ", column "
- (WRITE-TO-STRING (|lineCharacter| |pos|)))))))
+ (LET* (|pos|)
+ (PROGN
+ (SETQ |pos| (|shoeTokPosn| |tok|))
+ (CONCAT "line " (WRITE-TO-STRING (|lineNo| |pos|)) ", column "
+ (WRITE-TO-STRING (|lineCharacter| |pos|))))))
(DEFUN |SoftShoeError| (|posn| |key|)
(PROGN
@@ -41,9 +39,8 @@
(|shoeConsole| |key|)))
(DEFUN |bpSpecificErrorAtToken| (|tok| |key|)
- (PROG (|a|)
- (RETURN
- (PROGN (SETQ |a| (|shoeTokPosn| |tok|)) (|SoftShoeError| |a| |key|)))))
+ (LET* (|a|)
+ (PROGN (SETQ |a| (|shoeTokPosn| |tok|)) (|SoftShoeError| |a| |key|))))
(DEFUN |bpSpecificErrorHere| (|key|)
(DECLARE (SPECIAL |$stok|))
@@ -71,25 +68,24 @@
(DEFCONSTANT |$bStreamNil| (LIST '|nullstream|))
(DEFUN |bStreamNull| (|x|)
- (PROG (|st| |args| |op| |ISTMP#1|)
- (RETURN
- (COND ((OR (NULL |x|) (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|))) T)
- (T
- (LOOP
- (COND
- ((NOT
- (AND (CONSP |x|) (EQ (CAR |x|) '|nonnullstream|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |op| (CAR |ISTMP#1|))
- (SETQ |args| (CDR |ISTMP#1|))
- T)))))
- (RETURN NIL))
- (T (SETQ |st| (APPLY |op| |args|)) (RPLACA |x| (CAR |st|))
- (RPLACD |x| (CDR |st|)))))
- (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|)))))))
+ (LET* (|st| |args| |op| |ISTMP#1|)
+ (COND ((OR (NULL |x|) (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|))) T)
+ (T
+ (LOOP
+ (COND
+ ((NOT
+ (AND (CONSP |x|) (EQ (CAR |x|) '|nonnullstream|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |op| (CAR |ISTMP#1|))
+ (SETQ |args| (CDR |ISTMP#1|))
+ T)))))
+ (RETURN NIL))
+ (T (SETQ |st| (APPLY |op| |args|)) (RPLACA |x| (CAR |st|))
+ (RPLACD |x| (CDR |st|)))))
+ (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|))))))
(DEFUN |bMap| (|f| |x|) (|bDelay| #'|bMap1| (LIST |f| |x|)))
@@ -110,21 +106,19 @@
(DEFUN |bNext| (|f| |s|) (|bDelay| #'|bNext1| (LIST |f| |s|)))
(DEFUN |bNext1| (|f| |s|)
- (PROG (|h|)
- (RETURN
- (COND ((|bStreamNull| |s|) (LIST '|nullstream|))
- (T (SETQ |h| (APPLY |f| (LIST |s|)))
- (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|))))))))
+ (LET* (|h|)
+ (COND ((|bStreamNull| |s|) (LIST '|nullstream|))
+ (T (SETQ |h| (APPLY |f| (LIST |s|)))
+ (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|)))))))
(DEFUN |bRgen| (|s|) (|bDelay| #'|bRgen1| (LIST |s|)))
(DEFUN |bRgen1| (|s|)
- (PROG (|a|)
- (RETURN
- (PROGN
- (SETQ |a| (|readLine| |s|))
- (COND ((NOT (EQ |a| |%nothing|)) (CONS |a| (|bRgen| |s|)))
- (T (LIST '|nullstream|)))))))
+ (LET* (|a|)
+ (PROGN
+ (SETQ |a| (|readLine| |s|))
+ (COND ((NOT (EQ |a| |%nothing|)) (CONS |a| (|bRgen| |s|)))
+ (T (LIST '|nullstream|))))))
(DEFUN |bIgen| (|n|) (|bDelay| #'|bIgen1| (LIST |n|)))
@@ -145,21 +139,20 @@
(DEFUN |shoePrefixLine| (|x|) (CONCAT ")line" |x|))
(DEFUN |shoePrefix?| (|prefix| |whole|)
- (PROG (|good|)
- (RETURN
- (COND ((< (LENGTH |whole|) (LENGTH |prefix|)) NIL)
- (T (SETQ |good| T)
- (LET ((|bfVar#1| (- (LENGTH |prefix|) 1)) (|i| 0) (|j| 0))
- (LOOP
- (COND ((OR (> |i| |bfVar#1|) (NOT |good|)) (RETURN NIL))
- (T
- (SETQ |good|
- (CHAR= (SCHAR |prefix| |i|)
- (SCHAR |whole| |j|)))))
- (SETQ |i| (+ |i| 1))
- (SETQ |j| (+ |j| 1))))
- (COND (|good| (|subString| |whole| (LENGTH |prefix|)))
- (T |good|)))))))
+ (LET* (|good|)
+ (COND ((< (LENGTH |whole|) (LENGTH |prefix|)) NIL)
+ (T (SETQ |good| T)
+ (LET ((|bfVar#1| (- (LENGTH |prefix|) 1)) (|i| 0) (|j| 0))
+ (LOOP
+ (COND ((OR (> |i| |bfVar#1|) (NOT |good|)) (RETURN NIL))
+ (T
+ (SETQ |good|
+ (CHAR= (SCHAR |prefix| |i|)
+ (SCHAR |whole| |j|)))))
+ (SETQ |i| (+ |i| 1))
+ (SETQ |j| (+ |j| 1))))
+ (COND (|good| (|subString| |whole| (LENGTH |prefix|)))
+ (T |good|))))))
(DEFUN |shoePlainLine?| (|s|)
(COND ((EQL (LENGTH |s|) 0) T) (T (NOT (CHAR= (SCHAR |s| 0) (|char| '|)|))))))
@@ -185,96 +178,91 @@
(DEFUN |shoeInclude| (|s|) (|bDelay| #'|shoeInclude1| (LIST |s|)))
(DEFUN |shoeInclude1| (|s|)
- (PROG (|command| |string| |t| |h|)
- (RETURN
- (COND ((|bStreamNull| |s|) |s|)
- (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
- (SETQ |string| (CAR |h|))
- (COND ((SETQ |command| (|shoeFin?| |string|)) |$bStreamNil|)
- ((SETQ |command| (|shoeIf?| |string|))
- (|shoeThen| (LIST T) (LIST (STTOMC |command|)) |t|))
- (T
- (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|)))))))))
+ (LET* (|command| |string| |t| |h|)
+ (COND ((|bStreamNull| |s|) |s|)
+ (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
+ (SETQ |string| (CAR |h|))
+ (COND ((SETQ |command| (|shoeFin?| |string|)) |$bStreamNil|)
+ ((SETQ |command| (|shoeIf?| |string|))
+ (|shoeThen| (LIST T) (LIST (STTOMC |command|)) |t|))
+ (T (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|))))))))
(DEFUN |shoeSimpleLine| (|h|)
- (PROG (|command| |string|)
- (RETURN
- (PROGN
- (SETQ |string| (CAR |h|))
- (COND ((|shoePlainLine?| |string|) (LIST |h|))
- ((SETQ |command| (|shoeLisp?| |string|)) (LIST |h|))
- ((SETQ |command| (|shoeLine?| |string|)) (LIST |h|))
- ((SETQ |command| (|shoeSay?| |string|)) (|shoeConsole| |command|)
- NIL)
- ((SETQ |command| (|shoeEval?| |string|)) (STTOMC |command|) NIL)
- (T (|shoeLineSyntaxError| |h|) NIL))))))
+ (LET* (|command| |string|)
+ (PROGN
+ (SETQ |string| (CAR |h|))
+ (COND ((|shoePlainLine?| |string|) (LIST |h|))
+ ((SETQ |command| (|shoeLisp?| |string|)) (LIST |h|))
+ ((SETQ |command| (|shoeLine?| |string|)) (LIST |h|))
+ ((SETQ |command| (|shoeSay?| |string|)) (|shoeConsole| |command|)
+ NIL)
+ ((SETQ |command| (|shoeEval?| |string|)) (STTOMC |command|) NIL)
+ (T (|shoeLineSyntaxError| |h|) NIL)))))
(DEFUN |shoeThen| (|keep| |b| |s|)
(|bDelay| #'|shoeThen1| (LIST |keep| |b| |s|)))
(DEFUN |shoeThen1| (|keep| |b| |s|)
- (PROG (|b1| |keep1| |command| |string| |t| |h|)
- (RETURN
- (COND ((|bPremStreamNull| |s|) |s|)
- (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
- (SETQ |string| (CAR |h|))
- (COND
- ((SETQ |command| (|shoeFin?| |string|)) (|bPremStreamNil| |h|))
- (T (SETQ |keep1| (CAR |keep|)) (SETQ |b1| (CAR |b|))
- (COND
- ((SETQ |command| (|shoeIf?| |string|))
- (COND
- ((AND |keep1| |b1|)
- (|shoeThen| (CONS T |keep|) (CONS (STTOMC |command|) |b|)
- |t|))
- (T (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
- ((SETQ |command| (|shoeElseIf?| |string|))
- (COND
- ((AND |keep1| (NOT |b1|))
- (|shoeThen| (CONS T (CDR |keep|))
- (CONS (STTOMC |command|) (CDR |b|)) |t|))
- (T
- (|shoeThen| (CONS NIL (CDR |keep|)) (CONS NIL (CDR |b|))
- |t|))))
- ((SETQ |command| (|shoeElse?| |string|))
- (COND
- ((AND |keep1| (NOT |b1|))
- (|shoeElse| (CONS T (CDR |keep|)) (CONS T (CDR |b|)) |t|))
- (T
- (|shoeElse| (CONS NIL (CDR |keep|)) (CONS NIL (CDR |b|))
- |t|))))
- ((SETQ |command| (|shoeEndIf?| |string|))
- (COND ((NULL (CDR |b|)) (|shoeInclude| |t|))
- (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
- ((AND |keep1| |b1|)
- (|bAppend| (|shoeSimpleLine| |h|) (|shoeThen| |keep| |b| |t|)))
- (T (|shoeThen| |keep| |b| |t|))))))))))
+ (LET* (|b1| |keep1| |command| |string| |t| |h|)
+ (COND ((|bPremStreamNull| |s|) |s|)
+ (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
+ (SETQ |string| (CAR |h|))
+ (COND
+ ((SETQ |command| (|shoeFin?| |string|)) (|bPremStreamNil| |h|))
+ (T (SETQ |keep1| (CAR |keep|)) (SETQ |b1| (CAR |b|))
+ (COND
+ ((SETQ |command| (|shoeIf?| |string|))
+ (COND
+ ((AND |keep1| |b1|)
+ (|shoeThen| (CONS T |keep|) (CONS (STTOMC |command|) |b|)
+ |t|))
+ (T (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
+ ((SETQ |command| (|shoeElseIf?| |string|))
+ (COND
+ ((AND |keep1| (NOT |b1|))
+ (|shoeThen| (CONS T (CDR |keep|))
+ (CONS (STTOMC |command|) (CDR |b|)) |t|))
+ (T
+ (|shoeThen| (CONS NIL (CDR |keep|)) (CONS NIL (CDR |b|))
+ |t|))))
+ ((SETQ |command| (|shoeElse?| |string|))
+ (COND
+ ((AND |keep1| (NOT |b1|))
+ (|shoeElse| (CONS T (CDR |keep|)) (CONS T (CDR |b|)) |t|))
+ (T
+ (|shoeElse| (CONS NIL (CDR |keep|)) (CONS NIL (CDR |b|))
+ |t|))))
+ ((SETQ |command| (|shoeEndIf?| |string|))
+ (COND ((NULL (CDR |b|)) (|shoeInclude| |t|))
+ (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
+ ((AND |keep1| |b1|)
+ (|bAppend| (|shoeSimpleLine| |h|) (|shoeThen| |keep| |b| |t|)))
+ (T (|shoeThen| |keep| |b| |t|)))))))))
(DEFUN |shoeElse| (|keep| |b| |s|)
(|bDelay| #'|shoeElse1| (LIST |keep| |b| |s|)))
(DEFUN |shoeElse1| (|keep| |b| |s|)
- (PROG (|keep1| |b1| |command| |string| |t| |h|)
- (RETURN
- (COND ((|bPremStreamNull| |s|) |s|)
- (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
- (SETQ |string| (CAR |h|))
- (COND
- ((SETQ |command| (|shoeFin?| |string|)) (|bPremStreamNil| |h|))
- (T (SETQ |b1| (CAR |b|)) (SETQ |keep1| (CAR |keep|))
- (COND
- ((SETQ |command| (|shoeIf?| |string|))
- (COND
- ((AND |keep1| |b1|)
- (|shoeThen| (CONS T |keep|) (CONS (STTOMC |command|) |b|)
- |t|))
- (T (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
- ((SETQ |command| (|shoeEndIf?| |string|))
- (COND ((NULL (CDR |b|)) (|shoeInclude| |t|))
- (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
- ((AND |keep1| |b1|)
- (|bAppend| (|shoeSimpleLine| |h|) (|shoeElse| |keep| |b| |t|)))
- (T (|shoeElse| |keep| |b| |t|))))))))))
+ (LET* (|keep1| |b1| |command| |string| |t| |h|)
+ (COND ((|bPremStreamNull| |s|) |s|)
+ (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
+ (SETQ |string| (CAR |h|))
+ (COND
+ ((SETQ |command| (|shoeFin?| |string|)) (|bPremStreamNil| |h|))
+ (T (SETQ |b1| (CAR |b|)) (SETQ |keep1| (CAR |keep|))
+ (COND
+ ((SETQ |command| (|shoeIf?| |string|))
+ (COND
+ ((AND |keep1| |b1|)
+ (|shoeThen| (CONS T |keep|) (CONS (STTOMC |command|) |b|)
+ |t|))
+ (T (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
+ ((SETQ |command| (|shoeEndIf?| |string|))
+ (COND ((NULL (CDR |b|)) (|shoeInclude| |t|))
+ (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
+ ((AND |keep1| |b1|)
+ (|bAppend| (|shoeSimpleLine| |h|) (|shoeElse| |keep| |b| |t|)))
+ (T (|shoeElse| |keep| |b| |t|)))))))))
(DEFUN |shoeLineSyntaxError| (|h|)
(PROGN
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index c21669f2..85db17da 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -70,80 +70,73 @@
(SETQ |$stack| (CONS (|bfReName| |$ttok|) |$stack|)))
(DEFUN |bpPop1| ()
- (PROG (|a|)
+ (LET* (|a|)
(DECLARE (SPECIAL |$stack|))
- (RETURN
- (PROGN (SETQ |a| (CAR |$stack|)) (SETQ |$stack| (CDR |$stack|)) |a|))))
+ (PROGN (SETQ |a| (CAR |$stack|)) (SETQ |$stack| (CDR |$stack|)) |a|)))
(DEFUN |bpPop2| ()
- (PROG (|a|)
+ (LET* (|a|)
(DECLARE (SPECIAL |$stack|))
- (RETURN
- (PROGN (SETQ |a| (CADR |$stack|)) (RPLACD |$stack| (CDDR |$stack|)) |a|))))
+ (PROGN (SETQ |a| (CADR |$stack|)) (RPLACD |$stack| (CDDR |$stack|)) |a|)))
(DEFUN |bpPop3| ()
- (PROG (|a|)
+ (LET* (|a|)
(DECLARE (SPECIAL |$stack|))
- (RETURN
- (PROGN
- (SETQ |a| (CADDR |$stack|))
- (RPLACD (CDR |$stack|) (CDDDR |$stack|))
- |a|))))
+ (PROGN
+ (SETQ |a| (CADDR |$stack|))
+ (RPLACD (CDR |$stack|) (CDDDR |$stack|))
+ |a|)))
(DEFUN |bpIndentParenthesized| (|f|)
- (PROG (|a|)
+ (LET* (|a|)
(DECLARE (SPECIAL |$inputStream| |$bpParenCount| |$stok|))
- (RETURN
- (LET ((|$bpCount| 0))
- (DECLARE (SPECIAL |$bpCount|))
- (PROGN
- (SETQ |a| |$stok|)
- (COND
- ((|bpEqPeek| 'OPAREN) (SETQ |$bpParenCount| (+ |$bpParenCount| 1))
- (|bpNext|)
- (COND
- ((AND (APPLY |f| NIL) (|bpFirstTok|)
- (OR (|bpEqPeek| 'CPAREN) (|bpParenTrap| |a|)))
- (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpNextToken|)
- (COND ((EQL |$bpCount| 0) T)
- (T
- (SETQ |$inputStream|
- (|append| (|bpAddTokens| |$bpCount|)
- |$inputStream|))
- (|bpFirstToken|)
- (COND ((EQL |$bpParenCount| 0) (|bpCancel|) T) (T T)))))
- ((|bpEqPeek| 'CPAREN) (|bpPush| (|bfTuple| NIL))
- (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpNextToken|) T)
- (T (|bpParenTrap| |a|))))
- (T NIL)))))))
+ (LET ((|$bpCount| 0))
+ (DECLARE (SPECIAL |$bpCount|))
+ (PROGN
+ (SETQ |a| |$stok|)
+ (COND
+ ((|bpEqPeek| 'OPAREN) (SETQ |$bpParenCount| (+ |$bpParenCount| 1))
+ (|bpNext|)
+ (COND
+ ((AND (APPLY |f| NIL) (|bpFirstTok|)
+ (OR (|bpEqPeek| 'CPAREN) (|bpParenTrap| |a|)))
+ (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpNextToken|)
+ (COND ((EQL |$bpCount| 0) T)
+ (T
+ (SETQ |$inputStream|
+ (|append| (|bpAddTokens| |$bpCount|) |$inputStream|))
+ (|bpFirstToken|)
+ (COND ((EQL |$bpParenCount| 0) (|bpCancel|) T) (T T)))))
+ ((|bpEqPeek| 'CPAREN) (|bpPush| (|bfTuple| NIL))
+ (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpNextToken|) T)
+ (T (|bpParenTrap| |a|))))
+ (T NIL))))))
(DEFUN |bpParenthesized| (|f|)
- (PROG (|a|)
+ (LET* (|a|)
(DECLARE (SPECIAL |$stok|))
- (RETURN
- (PROGN
- (SETQ |a| |$stok|)
- (COND
- ((|bpEqKey| 'OPAREN)
- (COND
- ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'CPAREN) (|bpParenTrap| |a|))) T)
- ((|bpEqKey| 'CPAREN) (|bpPush| (|bfTuple| NIL)) T)
- (T (|bpParenTrap| |a|))))
- (T NIL))))))
+ (PROGN
+ (SETQ |a| |$stok|)
+ (COND
+ ((|bpEqKey| 'OPAREN)
+ (COND
+ ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'CPAREN) (|bpParenTrap| |a|))) T)
+ ((|bpEqKey| 'CPAREN) (|bpPush| (|bfTuple| NIL)) T)
+ (T (|bpParenTrap| |a|))))
+ (T NIL)))))
(DEFUN |bpBracket| (|f|)
- (PROG (|a|)
+ (LET* (|a|)
(DECLARE (SPECIAL |$stok|))
- (RETURN
- (PROGN
- (SETQ |a| |$stok|)
- (COND
- ((|bpEqKey| 'OBRACK)
- (COND
- ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'CBRACK) (|bpBrackTrap| |a|)))
- (|bpPush| (|bfBracket| (|bpPop1|))))
- ((|bpEqKey| 'CBRACK) (|bpPush| NIL)) (T (|bpBrackTrap| |a|))))
- (T NIL))))))
+ (PROGN
+ (SETQ |a| |$stok|)
+ (COND
+ ((|bpEqKey| 'OBRACK)
+ (COND
+ ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'CBRACK) (|bpBrackTrap| |a|)))
+ (|bpPush| (|bfBracket| (|bpPop1|))))
+ ((|bpEqKey| 'CBRACK) (|bpPush| NIL)) (T (|bpBrackTrap| |a|))))
+ (T NIL)))))
(DEFUN |bpPileBracketed| (|f|)
(COND
@@ -155,68 +148,64 @@
(T NIL)))
(DEFUN |bpListof| (|f| |str1| |g|)
- (PROG (|a|)
+ (LET* (|a|)
(DECLARE (SPECIAL |$stack|))
- (RETURN
- (COND
- ((APPLY |f| NIL)
- (COND
- ((AND (|bpEqKey| |str1|) (|bpRequire| |f|)) (SETQ |a| |$stack|)
- (SETQ |$stack| NIL)
- (LOOP
- (COND ((NOT (AND (|bpEqKey| |str1|) (|bpRequire| |f|))) (RETURN NIL))
- (T 0)))
- (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
- (|bpPush|
- (FUNCALL |g| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|))))))
- (T T)))
- (T NIL)))))
+ (COND
+ ((APPLY |f| NIL)
+ (COND
+ ((AND (|bpEqKey| |str1|) (|bpRequire| |f|)) (SETQ |a| |$stack|)
+ (SETQ |$stack| NIL)
+ (LOOP
+ (COND ((NOT (AND (|bpEqKey| |str1|) (|bpRequire| |f|))) (RETURN NIL))
+ (T 0)))
+ (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
+ (|bpPush|
+ (FUNCALL |g| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|))))))
+ (T T)))
+ (T NIL))))
(DEFUN |bpListofFun| (|f| |h| |g|)
- (PROG (|a|)
+ (LET* (|a|)
(DECLARE (SPECIAL |$stack|))
- (RETURN
- (COND
- ((APPLY |f| NIL)
- (COND
- ((AND (APPLY |h| NIL) (|bpRequire| |f|)) (SETQ |a| |$stack|)
- (SETQ |$stack| NIL)
- (LOOP
- (COND ((NOT (AND (APPLY |h| NIL) (|bpRequire| |f|))) (RETURN NIL))
- (T 0)))
- (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
- (|bpPush|
- (FUNCALL |g| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|))))))
- (T T)))
- (T NIL)))))
+ (COND
+ ((APPLY |f| NIL)
+ (COND
+ ((AND (APPLY |h| NIL) (|bpRequire| |f|)) (SETQ |a| |$stack|)
+ (SETQ |$stack| NIL)
+ (LOOP
+ (COND ((NOT (AND (APPLY |h| NIL) (|bpRequire| |f|))) (RETURN NIL))
+ (T 0)))
+ (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
+ (|bpPush|
+ (FUNCALL |g| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|))))))
+ (T T)))
+ (T NIL))))
(DEFUN |bpList| (|f| |str1|)
- (PROG (|a|)
+ (LET* (|a|)
(DECLARE (SPECIAL |$stack|))
- (RETURN
- (COND
- ((APPLY |f| NIL)
- (COND
- ((AND (|bpEqKey| |str1|) (|bpRequire| |f|)) (SETQ |a| |$stack|)
- (SETQ |$stack| NIL)
- (LOOP
- (COND ((NOT (AND (|bpEqKey| |str1|) (|bpRequire| |f|))) (RETURN NIL))
- (T 0)))
- (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
- (|bpPush| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))
- (T (|bpPush| (LIST (|bpPop1|))))))
- (T (|bpPush| NIL))))))
+ (COND
+ ((APPLY |f| NIL)
+ (COND
+ ((AND (|bpEqKey| |str1|) (|bpRequire| |f|)) (SETQ |a| |$stack|)
+ (SETQ |$stack| NIL)
+ (LOOP
+ (COND ((NOT (AND (|bpEqKey| |str1|) (|bpRequire| |f|))) (RETURN NIL))
+ (T 0)))
+ (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
+ (|bpPush| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))
+ (T (|bpPush| (LIST (|bpPop1|))))))
+ (T (|bpPush| NIL)))))
(DEFUN |bpOneOrMore| (|f|)
- (PROG (|a|)
+ (LET* (|a|)
(DECLARE (SPECIAL |$stack|))
- (RETURN
- (COND
- ((APPLY |f| NIL) (SETQ |a| |$stack|) (SETQ |$stack| NIL)
- (LOOP (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) (T 0)))
- (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
- (|bpPush| (CONS (|bpPop2|) (|bpPop1|))))
- (T NIL)))))
+ (COND
+ ((APPLY |f| NIL) (SETQ |a| |$stack|) (SETQ |$stack| NIL)
+ (LOOP (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) (T 0)))
+ (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
+ (|bpPush| (CONS (|bpPop2|) (|bpPop1|))))
+ (T NIL))))
(DEFUN |bpAnyNo| (|s|)
(PROGN (LOOP (COND ((NOT (APPLY |s| NIL)) (RETURN NIL)) (T 0))) T))
@@ -239,16 +228,15 @@
(T NIL)))
(DEFUN |bpElse| (|f|)
- (PROG (|a|)
- (RETURN
- (PROGN
- (SETQ |a| (|bpState|))
- (COND
- ((|bpBacksetElse|)
- (AND (|bpRequire| |f|)
- (|bpPush| (|bfIf| (|bpPop3|) (|bpPop2|) (|bpPop1|)))))
- (T (|bpRestore| |a|)
- (|bpPush| (|bfIfThenOnly| (|bpPop2|) (|bpPop1|)))))))))
+ (LET* (|a|)
+ (PROGN
+ (SETQ |a| (|bpState|))
+ (COND
+ ((|bpBacksetElse|)
+ (AND (|bpRequire| |f|)
+ (|bpPush| (|bfIf| (|bpPop3|) (|bpPop2|) (|bpPop1|)))))
+ (T (|bpRestore| |a|)
+ (|bpPush| (|bfIfThenOnly| (|bpPop2|) (|bpPop1|))))))))
(DEFUN |bpBacksetElse| ()
(COND ((|bpEqKey| 'BACKSET) (|bpEqKey| 'ELSE)) (T (|bpEqKey| 'ELSE))))
@@ -292,59 +280,57 @@
(CONS :OPEN-AXIOM-CATCH-POINT (CONS '(|BootParserException|) 'TRAPPED)))))
(DEFUN |bpRecoverTrap| ()
- (PROG (|pos2| |pos1|)
+ (LET* (|pos2| |pos1|)
(DECLARE (SPECIAL |$stok|))
- (RETURN
- (PROGN
- (|bpFirstToken|)
- (SETQ |pos1| (|shoeTokPosn| |$stok|))
- (|bpMoveTo| 0)
- (SETQ |pos2| (|shoeTokPosn| |$stok|))
- (|bpIgnoredFromTo| |pos1| |pos2|)
- (|bpPush| (LIST (LIST "pile syntax error")))))))
+ (PROGN
+ (|bpFirstToken|)
+ (SETQ |pos1| (|shoeTokPosn| |$stok|))
+ (|bpMoveTo| 0)
+ (SETQ |pos2| (|shoeTokPosn| |$stok|))
+ (|bpIgnoredFromTo| |pos1| |pos2|)
+ (|bpPush| (LIST (LIST "pile syntax error"))))))
(DEFUN |bpListAndRecover| (|f|)
- (PROG (|found| |c| |done| |b| |a|)
+ (LET* (|found| |c| |done| |b| |a|)
(DECLARE (SPECIAL |$inputStream| |$stack|))
- (RETURN
- (PROGN
- (SETQ |a| |$stack|)
- (SETQ |b| NIL)
- (SETQ |$stack| NIL)
- (SETQ |done| NIL)
- (SETQ |c| |$inputStream|)
- (LOOP
- (COND (|done| (RETURN NIL))
- (T
- (SETQ |found|
- (LET ((#1=#:G719
- (CATCH :OPEN-AXIOM-CATCH-POINT (APPLY |f| NIL))))
- (COND
- ((AND (CONSP #1#)
- (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT))
- (COND
- ((EQUAL (CAR #2=(CDR #1#)) '(|BootParserException|))
- (LET ((|e| (CDR #2#)))
- |e|))
- (T (THROW :OPEN-AXIOM-CATCH-POINT #1#))))
- (T #1#))))
- (COND
- ((EQ |found| 'TRAPPED) (SETQ |$inputStream| |c|)
- (|bpRecoverTrap|))
- ((NOT |found|) (SETQ |$inputStream| |c|) (|bpGeneralErrorHere|)
- (|bpRecoverTrap|)))
- (COND ((|bpEqKey| 'BACKSET) (SETQ |c| |$inputStream|))
- ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|))
- (SETQ |done| T))
- (T (SETQ |$inputStream| |c|) (|bpGeneralErrorHere|)
- (|bpRecoverTrap|)
- (COND
- ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|))
- (SETQ |done| T))
- (T (|bpNext|) (SETQ |c| |$inputStream|)))))
- (SETQ |b| (CONS (|bpPop1|) |b|)))))
- (SETQ |$stack| |a|)
- (|bpPush| (|reverse!| |b|))))))
+ (PROGN
+ (SETQ |a| |$stack|)
+ (SETQ |b| NIL)
+ (SETQ |$stack| NIL)
+ (SETQ |done| NIL)
+ (SETQ |c| |$inputStream|)
+ (LOOP
+ (COND (|done| (RETURN NIL))
+ (T
+ (SETQ |found|
+ (LET ((#1=#:G719
+ (CATCH :OPEN-AXIOM-CATCH-POINT (APPLY |f| NIL))))
+ (COND
+ ((AND (CONSP #1#)
+ (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT))
+ (COND
+ ((EQUAL (CAR #2=(CDR #1#)) '(|BootParserException|))
+ (LET ((|e| (CDR #2#)))
+ |e|))
+ (T (THROW :OPEN-AXIOM-CATCH-POINT #1#))))
+ (T #1#))))
+ (COND
+ ((EQ |found| 'TRAPPED) (SETQ |$inputStream| |c|)
+ (|bpRecoverTrap|))
+ ((NOT |found|) (SETQ |$inputStream| |c|) (|bpGeneralErrorHere|)
+ (|bpRecoverTrap|)))
+ (COND ((|bpEqKey| 'BACKSET) (SETQ |c| |$inputStream|))
+ ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|))
+ (SETQ |done| T))
+ (T (SETQ |$inputStream| |c|) (|bpGeneralErrorHere|)
+ (|bpRecoverTrap|)
+ (COND
+ ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|))
+ (SETQ |done| T))
+ (T (|bpNext|) (SETQ |c| |$inputStream|)))))
+ (SETQ |b| (CONS (|bpPop1|) |b|)))))
+ (SETQ |$stack| |a|)
+ (|bpPush| (|reverse!| |b|)))))
(DEFUN |bpMoveTo| (|n|)
(DECLARE (SPECIAL |$bpParenCount| |$bpCount| |$inputStream|))
@@ -393,23 +379,22 @@
(T (OR (|bpString|) (|bpFunction|)))))
(DEFUN |bpChar| ()
- (PROG (|ISTMP#1| |s| |a|)
+ (LET* (|ISTMP#1| |s| |a|)
(DECLARE (SPECIAL |$ttok| |$stok|))
- (RETURN
- (COND
- ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (EQ |$ttok| '|char|))
- (SETQ |a| (|bpState|))
- (COND
- ((|bpApplication|) (SETQ |s| (|bpPop1|))
- (COND
- ((AND (CONSP |s|) (EQ (CAR |s|) '|char|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |s|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))))
- (|bpPush| |s|))
- (T (|bpRestore| |a|) NIL)))
- (T NIL)))
- (T NIL)))))
+ (COND
+ ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (EQ |$ttok| '|char|))
+ (SETQ |a| (|bpState|))
+ (COND
+ ((|bpApplication|) (SETQ |s| (|bpPop1|))
+ (COND
+ ((AND (CONSP |s|) (EQ (CAR |s|) '|char|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |s|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))))
+ (|bpPush| |s|))
+ (T (|bpRestore| |a|) NIL)))
+ (T NIL)))
+ (T NIL))))
(DEFUN |bpExportItemTail| ()
(OR
@@ -418,17 +403,16 @@
(|bpSimpleDefinitionTail|)))
(DEFUN |bpExportItem| ()
- (PROG (|a|)
- (RETURN
- (COND ((|bpEqPeek| 'STRUCTURE) (|bpStruct|))
- (T (SETQ |a| (|bpState|))
- (COND
- ((|bpName|)
- (COND
- ((|bpEqPeek| 'COLON) (|bpRestore| |a|)
- (|bpRequire| #'|bpSignature|) (OR (|bpExportItemTail|) T))
- (T (|bpRestore| |a|) (|bpTypeAliasDefition|))))
- (T NIL)))))))
+ (LET* (|a|)
+ (COND ((|bpEqPeek| 'STRUCTURE) (|bpStruct|))
+ (T (SETQ |a| (|bpState|))
+ (COND
+ ((|bpName|)
+ (COND
+ ((|bpEqPeek| 'COLON) (|bpRestore| |a|)
+ (|bpRequire| #'|bpSignature|) (OR (|bpExportItemTail|) T))
+ (T (|bpRestore| |a|) (|bpTypeAliasDefition|))))
+ (T NIL))))))
(DEFUN |bpExportItemList| () (|bpListAndRecover| #'|bpExportItem|))
@@ -451,24 +435,23 @@
(T NIL)))
(DEFUN |bpImport| ()
- (PROG (|a|)
- (RETURN
- (COND
- ((|bpEqKey| 'IMPORT)
- (COND
- ((|bpEqKey| 'NAMESPACE)
- (OR
- (AND (|bpLeftAssoc| '(DOT) #'|bpName|)
- (|bpPush| (|%Import| (|bfNamespace| (|bpPop1|)))))
- (|bpTrap|)))
- (T (SETQ |a| (|bpState|)) (|bpRequire| #'|bpName|)
- (COND
- ((|bpEqPeek| 'COLON) (|bpRestore| |a|)
- (AND (|bpRequire| #'|bpSignature|) (OR (|bpEqKey| 'FOR) (|bpTrap|))
- (|bpRequire| #'|bpName|)
- (|bpPush| (|%ImportSignature| (|bpPop1|) (|bpPop1|)))))
- (T (|bpPush| (|%Import| (|bpPop1|))))))))
- (T NIL)))))
+ (LET* (|a|)
+ (COND
+ ((|bpEqKey| 'IMPORT)
+ (COND
+ ((|bpEqKey| 'NAMESPACE)
+ (OR
+ (AND (|bpLeftAssoc| '(DOT) #'|bpName|)
+ (|bpPush| (|%Import| (|bfNamespace| (|bpPop1|)))))
+ (|bpTrap|)))
+ (T (SETQ |a| (|bpState|)) (|bpRequire| #'|bpName|)
+ (COND
+ ((|bpEqPeek| 'COLON) (|bpRestore| |a|)
+ (AND (|bpRequire| #'|bpSignature|) (OR (|bpEqKey| 'FOR) (|bpTrap|))
+ (|bpRequire| #'|bpName|)
+ (|bpPush| (|%ImportSignature| (|bpPop1|) (|bpPop1|)))))
+ (T (|bpPush| (|%Import| (|bpPop1|))))))))
+ (T NIL))))
(DEFUN |bpNamespace| ()
(AND (|bpEqKey| 'NAMESPACE) (OR (|bpName|) (|bpDot|))
@@ -498,17 +481,16 @@
(|bpPush| (|%Mapping| (|bpPop1|) (|bfUntuple| (|bpPop1|))))))
(DEFUN |bpCancel| ()
- (PROG (|a|)
- (RETURN
- (PROGN
- (SETQ |a| (|bpState|))
- (COND
- ((|bpEqKeyNextTok| 'SETTAB)
- (COND
- ((|bpCancel|)
- (COND ((|bpEqKeyNextTok| 'BACKTAB) T) (T (|bpRestore| |a|) NIL)))
- ((|bpEqKeyNextTok| 'BACKTAB) T) (T (|bpRestore| |a|) NIL)))
- (T NIL))))))
+ (LET* (|a|)
+ (PROGN
+ (SETQ |a| (|bpState|))
+ (COND
+ ((|bpEqKeyNextTok| 'SETTAB)
+ (COND
+ ((|bpCancel|)
+ (COND ((|bpEqKeyNextTok| 'BACKTAB) T) (T (|bpRestore| |a|) NIL)))
+ ((|bpEqKeyNextTok| 'BACKTAB) T) (T (|bpRestore| |a|) NIL)))
+ (T NIL)))))
(DEFUN |bpAddTokens| (|n|)
(DECLARE (SPECIAL |$stok|))
@@ -526,15 +508,14 @@
(|bpEqPeek| 'BACKSET)))
(DEFUN |bpSexpKey| ()
- (PROG (|a|)
+ (LET* (|a|)
(DECLARE (SPECIAL |$ttok| |$stok|))
- (RETURN
- (COND
- ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (NOT (|bpExceptions|)))
- (SETQ |a| (GET |$ttok| 'SHOEINF))
- (COND ((NULL |a|) (AND (|bpPush| (|keywordId| |$ttok|)) (|bpNext|)))
- (T (AND (|bpPush| |a|) (|bpNext|)))))
- (T NIL)))))
+ (COND
+ ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (NOT (|bpExceptions|)))
+ (SETQ |a| (GET |$ttok| 'SHOEINF))
+ (COND ((NULL |a|) (AND (|bpPush| (|keywordId| |$ttok|)) (|bpNext|)))
+ (T (AND (|bpPush| |a|) (|bpNext|)))))
+ (T NIL))))
(DEFUN |bpAnyId| ()
(DECLARE (SPECIAL |$ttok| |$stok|))
@@ -624,22 +605,19 @@
(DEFUN |bpInfGeneric| (|s|) (AND (|bpInfKey| |s|) (OR (|bpEqKey| 'BACKSET) T)))
(DEFUN |bpRightAssoc| (|o| |p|)
- (PROG (|a|)
- (RETURN
- (PROGN
- (SETQ |a| (|bpState|))
- (COND
- ((APPLY |p| NIL)
- (LOOP
- (COND
- ((NOT
- (AND (|bpInfGeneric| |o|)
- (OR (|bpRightAssoc| |o| |p|) (|bpTrap|))))
- (RETURN NIL))
- (T
- (|bpPush| (|bfInfApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|))))))
- T)
- (T (|bpRestore| |a|) NIL))))))
+ (LET* (|a|)
+ (PROGN
+ (SETQ |a| (|bpState|))
+ (COND
+ ((APPLY |p| NIL)
+ (LOOP
+ (COND
+ ((NOT
+ (AND (|bpInfGeneric| |o|) (OR (|bpRightAssoc| |o| |p|) (|bpTrap|))))
+ (RETURN NIL))
+ (T (|bpPush| (|bfInfApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|))))))
+ T)
+ (T (|bpRestore| |a|) NIL)))))
(DEFUN |bpLeftAssoc| (|operations| |parser|)
(COND
@@ -672,20 +650,19 @@
(OR (|bpInfixOperator|) (|bpString|) (|bpThetaName|)))
(DEFUN |bpReduce| ()
- (PROG (|a|)
- (RETURN
- (PROGN
- (SETQ |a| (|bpState|))
- (COND
- ((AND (|bpReduceOperator|) (|bpEqKey| 'SLASH))
- (COND
- ((|bpEqPeek| 'OBRACK)
- (AND (|bpRequire| #'|bpDConstruct|)
- (|bpPush| (|bfReduceCollect| (|bpPop2|) (|bpPop1|)))))
- (T
- (AND (|bpRequire| #'|bpApplication|)
- (|bpPush| (|bfReduce| (|bpPop2|) (|bpPop1|)))))))
- (T (|bpRestore| |a|) NIL))))))
+ (LET* (|a|)
+ (PROGN
+ (SETQ |a| (|bpState|))
+ (COND
+ ((AND (|bpReduceOperator|) (|bpEqKey| 'SLASH))
+ (COND
+ ((|bpEqPeek| 'OBRACK)
+ (AND (|bpRequire| #'|bpDConstruct|)
+ (|bpPush| (|bfReduceCollect| (|bpPop2|) (|bpPop1|)))))
+ (T
+ (AND (|bpRequire| #'|bpApplication|)
+ (|bpPush| (|bfReduce| (|bpPop2|) (|bpPop1|)))))))
+ (T (|bpRestore| |a|) NIL)))))
(DEFUN |bpTimes| () (OR (|bpReduce|) (|bpLeftAssoc| '(TIMES SLASH) #'|bpExpt|)))
@@ -733,50 +710,46 @@
(T NIL)))
(DEFUN |bpTry| ()
- (PROG (|cs|)
- (RETURN
- (COND
- ((|bpEqKey| 'TRY) (|bpAssign|) (SETQ |cs| NIL)
- (LOOP
- (COND ((NOT (|bpHandler| 'CATCH)) (RETURN NIL))
- (T (|bpCatchItem|) (SETQ |cs| (CONS (|bpPop1|) |cs|)))))
- (COND
- ((|bpHandler| 'FINALLY)
- (AND (|bpFinally|)
- (|bpPush|
- (|bfTry| (|bpPop2|) (|reverse!| (CONS (|bpPop1|) |cs|))))))
- ((NULL |cs|) (|bpTrap|))
- (T (|bpPush| (|bfTry| (|bpPop1|) (|reverse!| |cs|))))))
- (T NIL)))))
+ (LET* (|cs|)
+ (COND
+ ((|bpEqKey| 'TRY) (|bpAssign|) (SETQ |cs| NIL)
+ (LOOP
+ (COND ((NOT (|bpHandler| 'CATCH)) (RETURN NIL))
+ (T (|bpCatchItem|) (SETQ |cs| (CONS (|bpPop1|) |cs|)))))
+ (COND
+ ((|bpHandler| 'FINALLY)
+ (AND (|bpFinally|)
+ (|bpPush|
+ (|bfTry| (|bpPop2|) (|reverse!| (CONS (|bpPop1|) |cs|))))))
+ ((NULL |cs|) (|bpTrap|))
+ (T (|bpPush| (|bfTry| (|bpPop1|) (|reverse!| |cs|))))))
+ (T NIL))))
(DEFUN |bpCatchItem| ()
(AND (|bpRequire| #'|bpExceptionVariable|) (OR (|bpEqKey| 'EXIT) (|bpTrap|))
(|bpRequire| #'|bpAssign|) (|bpPush| (|%Catch| (|bpPop2|) (|bpPop1|)))))
(DEFUN |bpExceptionVariable| ()
- (PROG (|t|)
+ (LET* (|t|)
(DECLARE (SPECIAL |$stok|))
- (RETURN
- (PROGN
- (SETQ |t| |$stok|)
- (OR
- (AND (|bpEqKey| 'OPAREN) (|bpRequire| #'|bpSignature|)
- (OR (|bpEqKey| 'CPAREN) (|bpMissing| |t|)))
- (|bpTrap|))))))
+ (PROGN
+ (SETQ |t| |$stok|)
+ (OR
+ (AND (|bpEqKey| 'OPAREN) (|bpRequire| #'|bpSignature|)
+ (OR (|bpEqKey| 'CPAREN) (|bpMissing| |t|)))
+ (|bpTrap|)))))
(DEFUN |bpFinally| ()
(AND (|bpRequire| #'|bpAssign|) (|bpPush| (|%Finally| (|bpPop1|)))))
(DEFUN |bpHandler| (|key|)
- (PROG (|s|)
- (RETURN
- (PROGN
- (SETQ |s| (|bpState|))
- (COND
- ((AND (OR (|bpEqKey| 'BACKSET) (|bpEqKey| 'SEMICOLON))
- (|bpEqKey| |key|))
- T)
- (T (|bpRestore| |s|) NIL))))))
+ (LET* (|s|)
+ (PROGN
+ (SETQ |s| (|bpState|))
+ (COND
+ ((AND (OR (|bpEqKey| 'BACKSET) (|bpEqKey| 'SEMICOLON)) (|bpEqKey| |key|))
+ T)
+ (T (|bpRestore| |s|) NIL)))))
(DEFUN |bpLeave| ()
(AND (|bpEqKey| 'LEAVE) (|bpRequire| #'|bpLogical|)
@@ -850,18 +823,17 @@
(|bpListofFun| #'|bpIteratorList| #'|bpCrossBackSet| #'|bfCross|))
(DEFUN |bpAssign| ()
- (PROG (|a|)
- (RETURN
- (PROGN
- (SETQ |a| (|bpState|))
- (COND
- ((|bpStatement|)
- (COND
- ((|bpEqPeek| 'BEC) (|bpRestore| |a|) (|bpRequire| #'|bpAssignment|))
- ((|bpEqPeek| 'GIVES) (|bpRestore| |a|) (|bpRequire| #'|bpLambda|))
- ((|bpEqPeek| 'LARROW) (|bpRestore| |a|) (|bpRequire| #'|bpKeyArg|))
- (T T)))
- (T (|bpRestore| |a|) NIL))))))
+ (LET* (|a|)
+ (PROGN
+ (SETQ |a| (|bpState|))
+ (COND
+ ((|bpStatement|)
+ (COND
+ ((|bpEqPeek| 'BEC) (|bpRestore| |a|) (|bpRequire| #'|bpAssignment|))
+ ((|bpEqPeek| 'GIVES) (|bpRestore| |a|) (|bpRequire| #'|bpLambda|))
+ ((|bpEqPeek| 'LARROW) (|bpRestore| |a|) (|bpRequire| #'|bpKeyArg|))
+ (T T)))
+ (T (|bpRestore| |a|) NIL)))))
(DEFUN |bpAssignment| ()
(AND (|bpAssignVariable|) (|bpEqKey| 'BEC) (|bpRequire| #'|bpAssign|)
@@ -883,21 +855,19 @@
T)))
(DEFUN |bpDefinition| ()
- (PROG (|a|)
- (RETURN
- (COND
- ((|bpEqKey| 'MACRO)
- (OR
- (AND (|bpName|) (|bpStoreName|)
- (|bpCompoundDefinitionTail| #'|%Macro|))
- (|bpTrap|)))
- (T (SETQ |a| (|bpState|))
- (COND
- ((|bpExit|)
- (COND ((|bpEqPeek| 'DEF) (|bpRestore| |a|) (|bpDef|))
- ((|bpEqPeek| 'TDEF) (|bpRestore| |a|) (|bpTypeAliasDefition|))
- (T T)))
- (T (|bpRestore| |a|) NIL)))))))
+ (LET* (|a|)
+ (COND
+ ((|bpEqKey| 'MACRO)
+ (OR
+ (AND (|bpName|) (|bpStoreName|) (|bpCompoundDefinitionTail| #'|%Macro|))
+ (|bpTrap|)))
+ (T (SETQ |a| (|bpState|))
+ (COND
+ ((|bpExit|)
+ (COND ((|bpEqPeek| 'DEF) (|bpRestore| |a|) (|bpDef|))
+ ((|bpEqPeek| 'TDEF) (|bpRestore| |a|) (|bpTypeAliasDefition|))
+ (T T)))
+ (T (|bpRestore| |a|) NIL))))))
(DEFUN |bpStoreName| ()
(DECLARE (SPECIAL |$typings| |$wheredefs| |$op| |$stack|))
@@ -932,16 +902,15 @@
T)))
(DEFUN |bpDefinitionItem| ()
- (PROG (|a|)
- (RETURN
- (PROGN
- (SETQ |a| (|bpState|))
- (COND ((|bpDDef|) T)
- (T (|bpRestore| |a|)
- (COND ((|bpBDefinitionPileItems|) T)
- (T (|bpRestore| |a|)
- (COND ((|bpPDefinitionItems|) T)
- (T (|bpRestore| |a|) (|bpWhere|)))))))))))
+ (LET* (|a|)
+ (PROGN
+ (SETQ |a| (|bpState|))
+ (COND ((|bpDDef|) T)
+ (T (|bpRestore| |a|)
+ (COND ((|bpBDefinitionPileItems|) T)
+ (T (|bpRestore| |a|)
+ (COND ((|bpPDefinitionItems|) T)
+ (T (|bpRestore| |a|) (|bpWhere|))))))))))
(DEFUN |bpDefinitionPileItems| ()
(AND (|bpListAndRecover| #'|bpDefinitionItem|)
@@ -1122,11 +1091,10 @@
(T T)))))
(DEFUN |bpChecknull| ()
- (PROG (|a|)
- (RETURN
- (PROGN
- (SETQ |a| (|bpPop1|))
- (COND ((NULL |a|) (|bpTrap|)) (T (|bpPush| |a|)))))))
+ (LET* (|a|)
+ (PROGN
+ (SETQ |a| (|bpPop1|))
+ (COND ((NULL |a|) (|bpTrap|)) (T (|bpPush| |a|))))))
(DEFUN |bpStruct| ()
(AND (|bpEqKey| 'STRUCTURE) (|bpRequire| #'|bpName|)
@@ -1172,27 +1140,26 @@
(|bpPush| (|bfCaseItem| (|bpPop2|) (|bpPop1|)))))
(DEFUN |bpOutItem| ()
- (PROG (|r| |ISTMP#2| |l| |ISTMP#1| |b|)
+ (LET* (|r| |ISTMP#2| |l| |ISTMP#1| |b|)
(DECLARE (SPECIAL |$InteractiveMode|))
- (RETURN
- (LET* ((|$op| NIL) (|$GenVarCounter| 0))
- (DECLARE (SPECIAL |$op| |$GenVarCounter|))
- (PROGN
- (|bpRequire| #'|bpComma|)
- (SETQ |b| (|bpPop1|))
- (|bpPush|
- (COND ((AND (CONSP |b|) (EQ (CAR |b|) '+LINE)) (LIST |b|))
- ((AND (CONSP |b|) (EQ (CAR |b|) 'L%T)
- (PROGN
- (SETQ |ISTMP#1| (CDR |b|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |l| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |r| (CAR |ISTMP#2|)) T)))))
- (SYMBOLP |l|))
- (COND (|$InteractiveMode| (LIST (LIST 'SETQ |l| |r|)))
- (T (LIST (LIST 'DEFPARAMETER |l| |r|)))))
- (T (|translateToplevel| |b| NIL)))))))))
+ (LET* ((|$op| NIL) (|$GenVarCounter| 0))
+ (DECLARE (SPECIAL |$op| |$GenVarCounter|))
+ (PROGN
+ (|bpRequire| #'|bpComma|)
+ (SETQ |b| (|bpPop1|))
+ (|bpPush|
+ (COND ((AND (CONSP |b|) (EQ (CAR |b|) '+LINE)) (LIST |b|))
+ ((AND (CONSP |b|) (EQ (CAR |b|) 'L%T)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |b|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |l| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |r| (CAR |ISTMP#2|)) T)))))
+ (SYMBOLP |l|))
+ (COND (|$InteractiveMode| (LIST (LIST 'SETQ |l| |r|)))
+ (T (LIST (LIST 'DEFPARAMETER |l| |r|)))))
+ (T (|translateToplevel| |b| NIL))))))))
diff --git a/src/boot/strap/pile.clisp b/src/boot/strap/pile.clisp
index eb3ea075..516327d2 100644
--- a/src/boot/strap/pile.clisp
+++ b/src/boot/strap/pile.clisp
@@ -14,115 +14,106 @@
(DEFUN |shoePileColumn| (|t|) (CDR (|shoeTokPosn| (CAAR |t|))))
(DEFUN |shoePileInsert| (|s|)
- (PROG (|a| |toktype|)
- (RETURN
- (COND ((|bStreamNull| |s|) (CONS NIL |s|))
- (T (SETQ |toktype| (|shoeTokType| (CAAAR |s|)))
- (COND
- ((OR (EQ |toktype| 'LISP) (EQ |toktype| 'LINE))
- (CONS (LIST (CAR |s|)) (CDR |s|)))
- (T (SETQ |a| (|shoePileTree| (- 1) |s|))
- (CONS (LIST (ELT |a| 2)) (ELT |a| 3)))))))))
+ (LET* (|a| |toktype|)
+ (COND ((|bStreamNull| |s|) (CONS NIL |s|))
+ (T (SETQ |toktype| (|shoeTokType| (CAAAR |s|)))
+ (COND
+ ((OR (EQ |toktype| 'LISP) (EQ |toktype| 'LINE))
+ (CONS (LIST (CAR |s|)) (CDR |s|)))
+ (T (SETQ |a| (|shoePileTree| (- 1) |s|))
+ (CONS (LIST (ELT |a| 2)) (ELT |a| 3))))))))
(DEFUN |shoePileTree| (|n| |s|)
- (PROG (|hh| |t| |h| |LETTMP#1|)
- (RETURN
- (COND ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|))
- (T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|)))
- (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|))
- (SETQ |hh| (|shoePileColumn| |h|))
- (COND ((< |n| |hh|) (|shoePileForests| |h| |hh| |t|))
- (T (LIST NIL |n| NIL |s|))))))))
+ (LET* (|hh| |t| |h| |LETTMP#1|)
+ (COND ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|))
+ (T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|)))
+ (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|))
+ (SETQ |hh| (|shoePileColumn| |h|))
+ (COND ((< |n| |hh|) (|shoePileForests| |h| |hh| |t|))
+ (T (LIST NIL |n| NIL |s|)))))))
(DEFUN |eqshoePileTree| (|n| |s|)
- (PROG (|hh| |t| |h| |LETTMP#1|)
- (RETURN
- (COND ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|))
- (T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|)))
- (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|))
- (SETQ |hh| (|shoePileColumn| |h|))
- (COND ((EQUAL |hh| |n|) (|shoePileForests| |h| |hh| |t|))
- (T (LIST NIL |n| NIL |s|))))))))
+ (LET* (|hh| |t| |h| |LETTMP#1|)
+ (COND ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|))
+ (T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|)))
+ (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|))
+ (SETQ |hh| (|shoePileColumn| |h|))
+ (COND ((EQUAL |hh| |n|) (|shoePileForests| |h| |hh| |t|))
+ (T (LIST NIL |n| NIL |s|)))))))
(DEFUN |shoePileForest| (|n| |s|)
- (PROG (|t1| |h1| |t| |h| |hh| |b| |LETTMP#1|)
- (RETURN
- (PROGN
- (SETQ |LETTMP#1| (|shoePileTree| |n| |s|))
- (SETQ |b| (CAR |LETTMP#1|))
- (SETQ |hh| (CADR . #1=(|LETTMP#1|)))
- (SETQ |h| (CADDR . #1#))
- (SETQ |t| (CADDDR . #1#))
- (COND
- (|b| (SETQ |LETTMP#1| (|shoePileForest1| |hh| |t|))
- (SETQ |h1| (CAR |LETTMP#1|)) (SETQ |t1| (CADR |LETTMP#1|))
- (LIST (CONS |h| |h1|) |t1|))
- (T (LIST NIL |s|)))))))
+ (LET* (|t1| |h1| |t| |h| |hh| |b| |LETTMP#1|)
+ (PROGN
+ (SETQ |LETTMP#1| (|shoePileTree| |n| |s|))
+ (SETQ |b| (CAR |LETTMP#1|))
+ (SETQ |hh| (CADR . #1=(|LETTMP#1|)))
+ (SETQ |h| (CADDR . #1#))
+ (SETQ |t| (CADDDR . #1#))
+ (COND
+ (|b| (SETQ |LETTMP#1| (|shoePileForest1| |hh| |t|))
+ (SETQ |h1| (CAR |LETTMP#1|)) (SETQ |t1| (CADR |LETTMP#1|))
+ (LIST (CONS |h| |h1|) |t1|))
+ (T (LIST NIL |s|))))))
(DEFUN |shoePileForest1| (|n| |s|)
- (PROG (|t1| |h1| |t| |h| |n1| |b| |LETTMP#1|)
- (RETURN
- (PROGN
- (SETQ |LETTMP#1| (|eqshoePileTree| |n| |s|))
- (SETQ |b| (CAR |LETTMP#1|))
- (SETQ |n1| (CADR . #1=(|LETTMP#1|)))
- (SETQ |h| (CADDR . #1#))
- (SETQ |t| (CADDDR . #1#))
- (COND
- (|b| (SETQ |LETTMP#1| (|shoePileForest1| |n| |t|))
- (SETQ |h1| (CAR |LETTMP#1|)) (SETQ |t1| (CADR |LETTMP#1|))
- (LIST (CONS |h| |h1|) |t1|))
- (T (LIST NIL |s|)))))))
+ (LET* (|t1| |h1| |t| |h| |n1| |b| |LETTMP#1|)
+ (PROGN
+ (SETQ |LETTMP#1| (|eqshoePileTree| |n| |s|))
+ (SETQ |b| (CAR |LETTMP#1|))
+ (SETQ |n1| (CADR . #1=(|LETTMP#1|)))
+ (SETQ |h| (CADDR . #1#))
+ (SETQ |t| (CADDDR . #1#))
+ (COND
+ (|b| (SETQ |LETTMP#1| (|shoePileForest1| |n| |t|))
+ (SETQ |h1| (CAR |LETTMP#1|)) (SETQ |t1| (CADR |LETTMP#1|))
+ (LIST (CONS |h| |h1|) |t1|))
+ (T (LIST NIL |s|))))))
(DEFUN |shoePileForests| (|h| |n| |s|)
- (PROG (|t1| |h1| |LETTMP#1|)
- (RETURN
- (PROGN
- (SETQ |LETTMP#1| (|shoePileForest| |n| |s|))
- (SETQ |h1| (CAR |LETTMP#1|))
- (SETQ |t1| (CADR |LETTMP#1|))
- (COND ((|bStreamNull| |h1|) (LIST T |n| |h| |s|))
- (T (|shoePileForests| (|shoePileCtree| |h| |h1|) |n| |t1|)))))))
+ (LET* (|t1| |h1| |LETTMP#1|)
+ (PROGN
+ (SETQ |LETTMP#1| (|shoePileForest| |n| |s|))
+ (SETQ |h1| (CAR |LETTMP#1|))
+ (SETQ |t1| (CADR |LETTMP#1|))
+ (COND ((|bStreamNull| |h1|) (LIST T |n| |h| |s|))
+ (T (|shoePileForests| (|shoePileCtree| |h| |h1|) |n| |t1|))))))
(DEFUN |shoePileCtree| (|x| |y|) (|dqAppend| |x| (|shoePileCforest| |y|)))
(DEFUN |shoePileCforest| (|x|)
- (PROG (|b| |a|)
- (RETURN
- (COND ((NULL |x|) NIL) ((NULL (CDR |x|)) (CAR |x|))
- (T (SETQ |a| (CAR |x|))
- (SETQ |b| (|shoePileCoagulate| |a| (CDR |x|)))
- (COND ((NULL (CDR |b|)) (CAR |b|))
- (T (|shoeEnPile| (|shoeSeparatePiles| |b|)))))))))
+ (LET* (|b| |a|)
+ (COND ((NULL |x|) NIL) ((NULL (CDR |x|)) (CAR |x|))
+ (T (SETQ |a| (CAR |x|))
+ (SETQ |b| (|shoePileCoagulate| |a| (CDR |x|)))
+ (COND ((NULL (CDR |b|)) (CAR |b|))
+ (T (|shoeEnPile| (|shoeSeparatePiles| |b|))))))))
(DEFUN |shoePileCoagulate| (|a| |b|)
- (PROG (|e| |d| |c|)
- (RETURN
- (COND ((NULL |b|) (LIST |a|))
- (T (SETQ |c| (CAR |b|))
- (COND
- ((OR (EQ (|shoeTokPart| (CAAR |c|)) 'THEN)
- (EQ (|shoeTokPart| (CAAR |c|)) 'ELSE))
- (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|)))
- (T (SETQ |d| (CADR |a|)) (SETQ |e| (|shoeTokPart| |d|))
- (COND
- ((AND (CONSP |d|) (EQ (CAR |d|) 'KEY)
- (OR (GET |e| 'SHOEINF) (EQ |e| 'COMMA)
- (EQ |e| 'SEMICOLON)))
- (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|)))
- (T (CONS |a| (|shoePileCoagulate| |c| (CDR |b|))))))))))))
+ (LET* (|e| |d| |c|)
+ (COND ((NULL |b|) (LIST |a|))
+ (T (SETQ |c| (CAR |b|))
+ (COND
+ ((OR (EQ (|shoeTokPart| (CAAR |c|)) 'THEN)
+ (EQ (|shoeTokPart| (CAAR |c|)) 'ELSE))
+ (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|)))
+ (T (SETQ |d| (CADR |a|)) (SETQ |e| (|shoeTokPart| |d|))
+ (COND
+ ((AND (CONSP |d|) (EQ (CAR |d|) 'KEY)
+ (OR (GET |e| 'SHOEINF) (EQ |e| 'COMMA)
+ (EQ |e| 'SEMICOLON)))
+ (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|)))
+ (T (CONS |a| (|shoePileCoagulate| |c| (CDR |b|)))))))))))
(DEFUN |shoeSeparatePiles| (|x|)
- (PROG (|semicolon| |a|)
- (RETURN
- (COND ((NULL |x|) NIL) ((NULL (CDR |x|)) (CAR |x|))
- (T (SETQ |a| (CAR |x|))
- (SETQ |semicolon|
- (|dqUnit|
- (|shoeTokConstruct| 'KEY 'BACKSET
- (|shoeLastTokPosn| |a|))))
- (|dqConcat|
- (LIST |a| |semicolon| (|shoeSeparatePiles| (CDR |x|)))))))))
+ (LET* (|semicolon| |a|)
+ (COND ((NULL |x|) NIL) ((NULL (CDR |x|)) (CAR |x|))
+ (T (SETQ |a| (CAR |x|))
+ (SETQ |semicolon|
+ (|dqUnit|
+ (|shoeTokConstruct| 'KEY 'BACKSET
+ (|shoeLastTokPosn| |a|))))
+ (|dqConcat|
+ (LIST |a| |semicolon| (|shoeSeparatePiles| (CDR |x|))))))))
(DEFUN |shoeEnPile| (|x|)
(|dqConcat|
diff --git a/src/boot/strap/scanner.clisp b/src/boot/strap/scanner.clisp
index b48125fc..958f768b 100644
--- a/src/boot/strap/scanner.clisp
+++ b/src/boot/strap/scanner.clisp
@@ -10,7 +10,8 @@
(DEFCONSTANT |shoeTAB| (CODE-CHAR 9))
(DEFUN |dqUnit| (|s|)
- (PROG (|a|) (RETURN (PROGN (SETQ |a| (LIST |s|)) (CONS |a| |a|)))))
+ (LET* (|a|)
+ (PROGN (SETQ |a| (LIST |s|)) (CONS |a| |a|))))
(DEFUN |dqAppend| (|x| |y|)
(COND ((NULL |x|) |y|) ((NULL |y|) |x|)
@@ -32,123 +33,121 @@
(DEFUN |shoeTokPart| (|x|) (CADR |x|))
(DEFUN |shoeTokPosn| (|x|)
- (PROG (|p|) (RETURN (PROGN (SETQ |p| (CDDR |x|)) |p|))))
+ (LET* (|p|)
+ (PROGN (SETQ |p| (CDDR |x|)) |p|)))
(DEFUN |shoeNextLine| (|s|)
- (PROG (|s1| |a|)
+ (LET* (|s1| |a|)
(DECLARE (SPECIAL |$sz| |$n| |$ln| |$r| |$f| |$linepos|))
- (RETURN
- (COND ((|bStreamNull| |s|) NIL)
- (T (SETQ |$linepos| |s|) (SETQ |$f| (CAR |s|)) (SETQ |$r| (CDR |s|))
- (SETQ |$ln| (CAR |$f|))
- (SETQ |$n| (|firstNonblankPosition| |$ln| 0))
- (SETQ |$sz| (LENGTH |$ln|))
- (COND ((NULL |$n|) T)
- ((CHAR= (SCHAR |$ln| |$n|) |shoeTAB|)
- (SETQ |a| (|makeString| (- 7 (REM |$n| 8)) (|char| '| |)))
- (SETF (SCHAR |$ln| |$n|) (|char| '| |))
- (SETQ |$ln| (CONCAT |a| |$ln|))
- (SETQ |s1| (CONS (CONS |$ln| (CDR |$f|)) |$r|))
- (|shoeNextLine| |s1|))
- (T T)))))))
+ (COND ((|bStreamNull| |s|) NIL)
+ (T (SETQ |$linepos| |s|) (SETQ |$f| (CAR |s|)) (SETQ |$r| (CDR |s|))
+ (SETQ |$ln| (CAR |$f|))
+ (SETQ |$n| (|firstNonblankPosition| |$ln| 0))
+ (SETQ |$sz| (LENGTH |$ln|))
+ (COND ((NULL |$n|) T)
+ ((CHAR= (SCHAR |$ln| |$n|) |shoeTAB|)
+ (SETQ |a| (|makeString| (- 7 (REM |$n| 8)) (|char| '| |)))
+ (SETF (SCHAR |$ln| |$n|) (|char| '| |))
+ (SETQ |$ln| (CONCAT |a| |$ln|))
+ (SETQ |s1| (CONS (CONS |$ln| (CDR |$f|)) |$r|))
+ (|shoeNextLine| |s1|))
+ (T T))))))
(DEFUN |shoeLineToks| (|s|)
- (PROG (|toks| |dq| |command|)
- (RETURN
- (LET* ((|$f| NIL)
- (|$r| NIL)
- (|$ln| NIL)
- (|$n| NIL)
- (|$sz| NIL)
- (|$floatok| T)
- (|$linepos| |s|))
- (DECLARE (SPECIAL |$f| |$r| |$ln| |$n| |$sz| |$floatok| |$linepos|))
- (COND ((NOT (|shoeNextLine| |s|)) (CONS NIL NIL))
- ((NULL |$n|) (|shoeLineToks| |$r|))
- ((CHAR= (SCHAR |$ln| 0) (|char| '|)|))
- (COND
- ((SETQ |command| (|shoeLine?| |$ln|))
- (SETQ |dq|
- (|dqUnit|
- (|shoeConstructToken| |$linepos|
- (|shoeLeafLine| |command|) 0)))
- (CONS (LIST |dq|) |$r|))
- ((SETQ |command| (|shoeLisp?| |$ln|))
- (|shoeLispToken| |$r| |command|))
- (T (|shoeLineToks| |$r|))))
- (T (SETQ |toks| NIL)
- (LOOP
- (COND ((NOT (< |$n| |$sz|)) (RETURN NIL))
- (T (SETQ |toks| (|dqAppend| |toks| (|shoeToken|))))))
- (COND ((NULL |toks|) (|shoeLineToks| |$r|))
- (T (CONS (LIST |toks|) |$r|)))))))))
+ (LET* ((|$f| NIL)
+ (|$r| NIL)
+ (|$ln| NIL)
+ (|$n| NIL)
+ (|$sz| NIL)
+ (|$floatok| T)
+ (|$linepos| |s|)
+ |toks|
+ |dq|
+ |command|)
+ (DECLARE (SPECIAL |$f| |$r| |$ln| |$n| |$sz| |$floatok| |$linepos|))
+ (COND ((NOT (|shoeNextLine| |s|)) (CONS NIL NIL))
+ ((NULL |$n|) (|shoeLineToks| |$r|))
+ ((CHAR= (SCHAR |$ln| 0) (|char| '|)|))
+ (COND
+ ((SETQ |command| (|shoeLine?| |$ln|))
+ (SETQ |dq|
+ (|dqUnit|
+ (|shoeConstructToken| |$linepos|
+ (|shoeLeafLine| |command|) 0)))
+ (CONS (LIST |dq|) |$r|))
+ ((SETQ |command| (|shoeLisp?| |$ln|))
+ (|shoeLispToken| |$r| |command|))
+ (T (|shoeLineToks| |$r|))))
+ (T (SETQ |toks| NIL)
+ (LOOP
+ (COND ((NOT (< |$n| |$sz|)) (RETURN NIL))
+ (T (SETQ |toks| (|dqAppend| |toks| (|shoeToken|))))))
+ (COND ((NULL |toks|) (|shoeLineToks| |$r|))
+ (T (CONS (LIST |toks|) |$r|)))))))
(DEFUN |shoeLispToken| (|s| |string|)
- (PROG (|dq| |st| |r| |LETTMP#1| |linepos| |ln|)
+ (LET* (|dq| |st| |r| |LETTMP#1| |linepos| |ln|)
(DECLARE (SPECIAL |$linepos| |$ln|))
- (RETURN
- (PROGN
- (COND
- ((OR (EQL (LENGTH |string|) 0) (CHAR= (SCHAR |string| 0) (|char| '|;|)))
- (SETQ |string| "")))
- (SETQ |ln| |$ln|)
- (SETQ |linepos| |$linepos|)
- (SETQ |LETTMP#1| (|shoeAccumulateLines| |s| |string|))
- (SETQ |r| (CAR |LETTMP#1|))
- (SETQ |st| (CDR |LETTMP#1|))
- (SETQ |dq|
- (|dqUnit|
- (|shoeConstructToken| |linepos| (|shoeLeafLisp| |st|) 0)))
- (CONS (LIST |dq|) |r|)))))
+ (PROGN
+ (COND
+ ((OR (EQL (LENGTH |string|) 0) (CHAR= (SCHAR |string| 0) (|char| '|;|)))
+ (SETQ |string| "")))
+ (SETQ |ln| |$ln|)
+ (SETQ |linepos| |$linepos|)
+ (SETQ |LETTMP#1| (|shoeAccumulateLines| |s| |string|))
+ (SETQ |r| (CAR |LETTMP#1|))
+ (SETQ |st| (CDR |LETTMP#1|))
+ (SETQ |dq|
+ (|dqUnit|
+ (|shoeConstructToken| |linepos| (|shoeLeafLisp| |st|) 0)))
+ (CONS (LIST |dq|) |r|))))
(DEFUN |shoeAccumulateLines| (|s| |string|)
- (PROG (|a| |command|)
+ (LET* (|a| |command|)
(DECLARE (SPECIAL |$ln| |$r| |$n|))
- (RETURN
- (COND ((NOT (|shoeNextLine| |s|)) (CONS |s| |string|))
- ((NULL |$n|) (|shoeAccumulateLines| |$r| |string|))
- ((EQL (LENGTH |$ln|) 0) (|shoeAccumulateLines| |$r| |string|))
- ((CHAR= (SCHAR |$ln| 0) (|char| '|)|))
- (SETQ |command| (|shoeLisp?| |$ln|))
- (COND
- ((AND |command| (PLUSP (LENGTH |command|)))
- (COND
- ((CHAR= (SCHAR |command| 0) (|char| '|;|))
- (|shoeAccumulateLines| |$r| |string|))
- ((SETQ |a| (|charPosition| (|char| '|;|) |command| 0))
- (|shoeAccumulateLines| |$r|
- (CONCAT |string|
- (|subString| |command| 0
- (- |a| 1)))))
- (T (|shoeAccumulateLines| |$r| (CONCAT |string| |command|)))))
- (T (|shoeAccumulateLines| |$r| |string|))))
- (T (CONS |s| |string|))))))
+ (COND ((NOT (|shoeNextLine| |s|)) (CONS |s| |string|))
+ ((NULL |$n|) (|shoeAccumulateLines| |$r| |string|))
+ ((EQL (LENGTH |$ln|) 0) (|shoeAccumulateLines| |$r| |string|))
+ ((CHAR= (SCHAR |$ln| 0) (|char| '|)|))
+ (SETQ |command| (|shoeLisp?| |$ln|))
+ (COND
+ ((AND |command| (PLUSP (LENGTH |command|)))
+ (COND
+ ((CHAR= (SCHAR |command| 0) (|char| '|;|))
+ (|shoeAccumulateLines| |$r| |string|))
+ ((SETQ |a| (|charPosition| (|char| '|;|) |command| 0))
+ (|shoeAccumulateLines| |$r|
+ (CONCAT |string|
+ (|subString| |command| 0
+ (- |a| 1)))))
+ (T (|shoeAccumulateLines| |$r| (CONCAT |string| |command|)))))
+ (T (|shoeAccumulateLines| |$r| |string|))))
+ (T (CONS |s| |string|)))))
(DEFUN |shoeCloser| (|t|)
(|symbolMember?| (|shoeKeyWord| |t|) '(CPAREN CBRACK)))
(DEFUN |shoeToken| ()
- (PROG (|b| |ch| |n| |linepos|)
+ (LET* (|b| |ch| |n| |linepos|)
(DECLARE (SPECIAL |$ln| |$n| |$linepos|))
- (RETURN
- (PROGN
- (SETQ |linepos| |$linepos|)
- (SETQ |n| |$n|)
- (SETQ |ch| (SCHAR |$ln| |$n|))
- (SETQ |b|
- (COND ((|shoeStartsComment|) (|shoeComment|) NIL)
- ((|shoeStartsNegComment|) (|shoeNegComment|) NIL)
- ((CHAR= |ch| (|char| '!)) (|shoeLispEscape|))
- ((|shoePunctuation| (CHAR-CODE |ch|)) (|shoePunct|))
- ((|shoeStartsId| |ch|) (|shoeWord| NIL))
- ((CHAR= |ch| (|char| '| |)) (|shoeSpace|) NIL)
- ((CHAR= |ch| (|char| '|"|)) (|shoeString|))
- ((DIGIT-CHAR-P |ch|) (|shoeNumber|))
- ((CHAR= |ch| (|char| '_)) (|shoeEscape|))
- ((EQUAL |ch| |shoeTAB|) (SETQ |$n| (+ |$n| 1)) NIL)
- (T (|shoeError|))))
- (COND ((NULL |b|) NIL)
- (T (|dqUnit| (|shoeConstructToken| |linepos| |b| |n|))))))))
+ (PROGN
+ (SETQ |linepos| |$linepos|)
+ (SETQ |n| |$n|)
+ (SETQ |ch| (SCHAR |$ln| |$n|))
+ (SETQ |b|
+ (COND ((|shoeStartsComment|) (|shoeComment|) NIL)
+ ((|shoeStartsNegComment|) (|shoeNegComment|) NIL)
+ ((CHAR= |ch| (|char| '!)) (|shoeLispEscape|))
+ ((|shoePunctuation| (CHAR-CODE |ch|)) (|shoePunct|))
+ ((|shoeStartsId| |ch|) (|shoeWord| NIL))
+ ((CHAR= |ch| (|char| '| |)) (|shoeSpace|) NIL)
+ ((CHAR= |ch| (|char| '|"|)) (|shoeString|))
+ ((DIGIT-CHAR-P |ch|) (|shoeNumber|))
+ ((CHAR= |ch| (|char| '_)) (|shoeEscape|))
+ ((EQUAL |ch| |shoeTAB|) (SETQ |$n| (+ |$n| 1)) NIL)
+ (T (|shoeError|))))
+ (COND ((NULL |b|) NIL)
+ (T (|dqUnit| (|shoeConstructToken| |linepos| |b| |n|)))))))
(DEFUN |shoeLeafId| (|x|) (LIST 'ID (INTERN |x|)))
@@ -157,12 +156,11 @@
(DEFUN |shoeLeafInteger| (|x|) (LIST 'INTEGER (|shoeIntValue| |x|)))
(DEFUN |shoeLeafFloat| (|a| |w| |e|)
- (PROG (|c| |b|)
- (RETURN
- (PROGN
- (SETQ |b| (|shoeIntValue| (CONCAT |a| |w|)))
- (SETQ |c| (* (|double| |b|) (EXPT (|double| 10) (- |e| (LENGTH |w|)))))
- (LIST 'FLOAT |c|)))))
+ (LET* (|c| |b|)
+ (PROGN
+ (SETQ |b| (|shoeIntValue| (CONCAT |a| |w|)))
+ (SETQ |c| (* (|double| |b|) (EXPT (|double| 10) (- |e| (LENGTH |w|)))))
+ (LIST 'FLOAT |c|))))
(DEFUN |shoeLeafString| (|x|) (LIST 'STRING |x|))
@@ -181,98 +179,91 @@
(DEFUN |shoeLeafSpaces| (|x|) (LIST 'SPACES |x|))
(DEFUN |shoeLispEscape| ()
- (PROG (|n| |exp| |a|)
+ (LET* (|n| |exp| |a|)
(DECLARE (SPECIAL |$ln| |$linepos| |$sz| |$n|))
- (RETURN
- (PROGN
- (SETQ |$n| (+ |$n| 1))
- (COND
- ((NOT (< |$n| |$sz|))
- (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error")
- (|shoeLeafError| (SCHAR |$ln| |$n|)))
- (T (SETQ |a| (|shoeReadLispString| |$ln| |$n|))
- (COND
- ((NULL |a|)
- (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error")
- (|shoeLeafError| (SCHAR |$ln| |$n|)))
- (T (SETQ |exp| (CAR |a|)) (SETQ |n| (CADR |a|))
- (COND ((NULL |n|) (SETQ |$n| |$sz|) (|shoeLeafLispExp| |exp|))
- (T (SETQ |$n| |n|) (|shoeLeafLispExp| |exp|)))))))))))
+ (PROGN
+ (SETQ |$n| (+ |$n| 1))
+ (COND
+ ((NOT (< |$n| |$sz|))
+ (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error")
+ (|shoeLeafError| (SCHAR |$ln| |$n|)))
+ (T (SETQ |a| (|shoeReadLispString| |$ln| |$n|))
+ (COND
+ ((NULL |a|)
+ (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error")
+ (|shoeLeafError| (SCHAR |$ln| |$n|)))
+ (T (SETQ |exp| (CAR |a|)) (SETQ |n| (CADR |a|))
+ (COND ((NULL |n|) (SETQ |$n| |$sz|) (|shoeLeafLispExp| |exp|))
+ (T (SETQ |$n| |n|) (|shoeLeafLispExp| |exp|))))))))))
(DEFUN |shoeEscape| ()
(DECLARE (SPECIAL |$n|))
(PROGN (SETQ |$n| (+ |$n| 1)) (COND ((|shoeEsc|) (|shoeWord| T)) (T NIL))))
(DEFUN |shoeEsc| ()
- (PROG (|n1|)
+ (LET* (|n1|)
(DECLARE (SPECIAL |$ln| |$r| |$sz| |$n|))
- (RETURN
- (COND
- ((NOT (< |$n| |$sz|))
- (COND
- ((|shoeNextLine| |$r|)
- (LOOP (COND (|$n| (RETURN NIL)) (T (|shoeNextLine| |$r|))))
- (|shoeEsc|) NIL)
- (T NIL)))
- (T (SETQ |n1| (|firstNonblankPosition| |$ln| |$n|))
- (COND
- ((NULL |n1|) (|shoeNextLine| |$r|)
- (LOOP (COND (|$n| (RETURN NIL)) (T (|shoeNextLine| |$r|))))
- (|shoeEsc|) NIL)
- (T T)))))))
+ (COND
+ ((NOT (< |$n| |$sz|))
+ (COND
+ ((|shoeNextLine| |$r|)
+ (LOOP (COND (|$n| (RETURN NIL)) (T (|shoeNextLine| |$r|)))) (|shoeEsc|)
+ NIL)
+ (T NIL)))
+ (T (SETQ |n1| (|firstNonblankPosition| |$ln| |$n|))
+ (COND
+ ((NULL |n1|) (|shoeNextLine| |$r|)
+ (LOOP (COND (|$n| (RETURN NIL)) (T (|shoeNextLine| |$r|)))) (|shoeEsc|)
+ NIL)
+ (T T))))))
(DEFUN |shoeStartsComment| ()
- (PROG (|www|)
+ (LET* (|www|)
(DECLARE (SPECIAL |$ln| |$sz| |$n|))
- (RETURN
- (COND
- ((< |$n| |$sz|)
- (COND
- ((CHAR= (SCHAR |$ln| |$n|) (|char| '+)) (SETQ |www| (+ |$n| 1))
- (COND ((NOT (< |www| |$sz|)) NIL)
- (T (CHAR= (SCHAR |$ln| |www|) (|char| '+)))))
- (T NIL)))
- (T NIL)))))
+ (COND
+ ((< |$n| |$sz|)
+ (COND
+ ((CHAR= (SCHAR |$ln| |$n|) (|char| '+)) (SETQ |www| (+ |$n| 1))
+ (COND ((NOT (< |www| |$sz|)) NIL)
+ (T (CHAR= (SCHAR |$ln| |www|) (|char| '+)))))
+ (T NIL)))
+ (T NIL))))
(DEFUN |shoeStartsNegComment| ()
- (PROG (|www|)
+ (LET* (|www|)
(DECLARE (SPECIAL |$ln| |$sz| |$n|))
- (RETURN
- (COND
- ((< |$n| |$sz|)
- (COND
- ((CHAR= (SCHAR |$ln| |$n|) (|char| '-)) (SETQ |www| (+ |$n| 1))
- (COND ((NOT (< |www| |$sz|)) NIL)
- (T (CHAR= (SCHAR |$ln| |www|) (|char| '-)))))
- (T NIL)))
- (T NIL)))))
+ (COND
+ ((< |$n| |$sz|)
+ (COND
+ ((CHAR= (SCHAR |$ln| |$n|) (|char| '-)) (SETQ |www| (+ |$n| 1))
+ (COND ((NOT (< |www| |$sz|)) NIL)
+ (T (CHAR= (SCHAR |$ln| |www|) (|char| '-)))))
+ (T NIL)))
+ (T NIL))))
(DEFUN |shoeNegComment| ()
- (PROG (|n|)
+ (LET* (|n|)
(DECLARE (SPECIAL |$ln| |$sz| |$n|))
- (RETURN
- (PROGN
- (SETQ |n| |$n|)
- (SETQ |$n| |$sz|)
- (|shoeLeafNegComment| (|subString| |$ln| |n|))))))
+ (PROGN
+ (SETQ |n| |$n|)
+ (SETQ |$n| |$sz|)
+ (|shoeLeafNegComment| (|subString| |$ln| |n|)))))
(DEFUN |shoeComment| ()
- (PROG (|n|)
+ (LET* (|n|)
(DECLARE (SPECIAL |$ln| |$sz| |$n|))
- (RETURN
- (PROGN
- (SETQ |n| |$n|)
- (SETQ |$n| |$sz|)
- (|shoeLeafComment| (|subString| |$ln| |n|))))))
+ (PROGN
+ (SETQ |n| |$n|)
+ (SETQ |$n| |$sz|)
+ (|shoeLeafComment| (|subString| |$ln| |n|)))))
(DEFUN |shoePunct| ()
- (PROG (|sss|)
+ (LET* (|sss|)
(DECLARE (SPECIAL |$n| |$ln|))
- (RETURN
- (PROGN
- (SETQ |sss| (|shoeMatch| |$ln| |$n|))
- (SETQ |$n| (+ |$n| (LENGTH |sss|)))
- (|shoeKeyTr| |sss|)))))
+ (PROGN
+ (SETQ |sss| (|shoeMatch| |$ln| |$n|))
+ (SETQ |$n| (+ |$n| (LENGTH |sss|)))
+ (|shoeKeyTr| |sss|))))
(DEFUN |shoeKeyTr| (|w|)
(DECLARE (SPECIAL |$floatok|))
@@ -289,15 +280,14 @@
(T (SETQ |w| (|shoeInteger|)) (|shoeExponent| "0" |w|))))
(DEFUN |shoeSpace| ()
- (PROG (|n|)
+ (LET* (|n|)
(DECLARE (SPECIAL |$floatok| |$ln| |$n|))
- (RETURN
- (PROGN
- (SETQ |n| |$n|)
- (SETQ |$n| (|firstNonblankPosition| |$ln| |$n|))
- (SETQ |$floatok| T)
- (COND ((NULL |$n|) (|shoeLeafSpaces| 0) (SETQ |$n| (LENGTH |$ln|)))
- (T (|shoeLeafSpaces| (- |$n| |n|))))))))
+ (PROGN
+ (SETQ |n| |$n|)
+ (SETQ |$n| (|firstNonblankPosition| |$ln| |$n|))
+ (SETQ |$floatok| T)
+ (COND ((NULL |$n|) (|shoeLeafSpaces| 0) (SETQ |$n| (LENGTH |$ln|)))
+ (T (|shoeLeafSpaces| (- |$n| |n|)))))))
(DEFUN |shoeString| ()
(DECLARE (SPECIAL |$floatok| |$n|))
@@ -307,30 +297,29 @@
(|shoeLeafString| (|shoeS|))))
(DEFUN |shoeS| ()
- (PROG (|b| |a| |str| |mn| |escsym| |strsym| |n|)
+ (LET* (|b| |a| |str| |mn| |escsym| |strsym| |n|)
(DECLARE (SPECIAL |$ln| |$linepos| |$sz| |$n|))
- (RETURN
- (COND
- ((NOT (< |$n| |$sz|))
- (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") "")
- (T (SETQ |n| |$n|)
- (SETQ |strsym| (OR (|charPosition| (|char| '|"|) |$ln| |$n|) |$sz|))
- (SETQ |escsym| (OR (|charPosition| (|char| '_) |$ln| |$n|) |$sz|))
- (SETQ |mn| (MIN |strsym| |escsym|))
- (COND
- ((EQUAL |mn| |$sz|) (SETQ |$n| |$sz|)
- (|SoftShoeError| (CONS |$linepos| |$n|) "quote added")
- (|subString| |$ln| |n|))
- ((EQUAL |mn| |strsym|) (SETQ |$n| (+ |mn| 1))
- (|subString| |$ln| |n| (- |mn| |n|)))
- (T (SETQ |str| (|subString| |$ln| |n| (- |mn| |n|)))
- (SETQ |$n| (+ |mn| 1)) (SETQ |a| (|shoeEsc|))
- (SETQ |b|
- (COND
- (|a| (SETQ |str| (CONCAT |str| (STRING (SCHAR |$ln| |$n|))))
- (SETQ |$n| (+ |$n| 1)) (|shoeS|))
- (T (|shoeS|))))
- (CONCAT |str| |b|))))))))
+ (COND
+ ((NOT (< |$n| |$sz|))
+ (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") "")
+ (T (SETQ |n| |$n|)
+ (SETQ |strsym| (OR (|charPosition| (|char| '|"|) |$ln| |$n|) |$sz|))
+ (SETQ |escsym| (OR (|charPosition| (|char| '_) |$ln| |$n|) |$sz|))
+ (SETQ |mn| (MIN |strsym| |escsym|))
+ (COND
+ ((EQUAL |mn| |$sz|) (SETQ |$n| |$sz|)
+ (|SoftShoeError| (CONS |$linepos| |$n|) "quote added")
+ (|subString| |$ln| |n|))
+ ((EQUAL |mn| |strsym|) (SETQ |$n| (+ |mn| 1))
+ (|subString| |$ln| |n| (- |mn| |n|)))
+ (T (SETQ |str| (|subString| |$ln| |n| (- |mn| |n|)))
+ (SETQ |$n| (+ |mn| 1)) (SETQ |a| (|shoeEsc|))
+ (SETQ |b|
+ (COND
+ (|a| (SETQ |str| (CONCAT |str| (STRING (SCHAR |$ln| |$n|))))
+ (SETQ |$n| (+ |$n| 1)) (|shoeS|))
+ (T (|shoeS|))))
+ (CONCAT |str| |b|)))))))
(DEFUN |shoeIdEnd| (|line| |n|)
(PROGN
@@ -342,128 +331,120 @@
|n|))
(DEFUN |shoeW| (|b|)
- (PROG (|bb| |a| |str| |endid| |l| |n1|)
+ (LET* (|bb| |a| |str| |endid| |l| |n1|)
(DECLARE (SPECIAL |$ln| |$sz| |$n|))
- (RETURN
- (PROGN
- (SETQ |n1| |$n|)
- (SETQ |$n| (+ |$n| 1))
- (SETQ |l| |$sz|)
- (SETQ |endid| (|shoeIdEnd| |$ln| |$n|))
- (COND
- ((OR (EQUAL |endid| |l|)
- (NOT (CHAR= (SCHAR |$ln| |endid|) (|char| '_))))
- (SETQ |$n| |endid|)
- (LIST |b| (|subString| |$ln| |n1| (- |endid| |n1|))))
- (T (SETQ |str| (|subString| |$ln| |n1| (- |endid| |n1|)))
- (SETQ |$n| (+ |endid| 1)) (SETQ |a| (|shoeEsc|))
- (SETQ |bb| (COND (|a| (|shoeW| T)) (T (LIST |b| ""))))
- (LIST (OR (ELT |bb| 0) |b|) (CONCAT |str| (ELT |bb| 1)))))))))
+ (PROGN
+ (SETQ |n1| |$n|)
+ (SETQ |$n| (+ |$n| 1))
+ (SETQ |l| |$sz|)
+ (SETQ |endid| (|shoeIdEnd| |$ln| |$n|))
+ (COND
+ ((OR (EQUAL |endid| |l|) (NOT (CHAR= (SCHAR |$ln| |endid|) (|char| '_))))
+ (SETQ |$n| |endid|)
+ (LIST |b| (|subString| |$ln| |n1| (- |endid| |n1|))))
+ (T (SETQ |str| (|subString| |$ln| |n1| (- |endid| |n1|)))
+ (SETQ |$n| (+ |endid| 1)) (SETQ |a| (|shoeEsc|))
+ (SETQ |bb| (COND (|a| (|shoeW| T)) (T (LIST |b| ""))))
+ (LIST (OR (ELT |bb| 0) |b|) (CONCAT |str| (ELT |bb| 1))))))))
(DEFUN |shoeWord| (|esp|)
- (PROG (|w| |aaa|)
+ (LET* (|w| |aaa|)
(DECLARE (SPECIAL |$floatok|))
- (RETURN
- (PROGN
- (SETQ |aaa| (|shoeW| NIL))
- (SETQ |w| (ELT |aaa| 1))
- (SETQ |$floatok| NIL)
- (COND ((OR |esp| (ELT |aaa| 0)) (|shoeLeafId| |w|))
- ((|shoeKeyWordP| |w|) (SETQ |$floatok| T) (|shoeLeafKey| |w|))
- (T (|shoeLeafId| |w|)))))))
+ (PROGN
+ (SETQ |aaa| (|shoeW| NIL))
+ (SETQ |w| (ELT |aaa| 1))
+ (SETQ |$floatok| NIL)
+ (COND ((OR |esp| (ELT |aaa| 0)) (|shoeLeafId| |w|))
+ ((|shoeKeyWordP| |w|) (SETQ |$floatok| T) (|shoeLeafKey| |w|))
+ (T (|shoeLeafId| |w|))))))
(DEFUN |shoeInteger| () (|shoeInteger1| NIL))
(DEFUN |shoeInteger1| (|zro|)
- (PROG (|bb| |a| |str| |l| |n|)
+ (LET* (|bb| |a| |str| |l| |n|)
(DECLARE (SPECIAL |$ln| |$sz| |$n|))
- (RETURN
- (PROGN
- (SETQ |n| |$n|)
- (SETQ |l| |$sz|)
- (LOOP
- (COND
- ((NOT (AND (< |$n| |l|) (DIGIT-CHAR-P (SCHAR |$ln| |$n|))))
- (RETURN NIL))
- (T (SETQ |$n| (+ |$n| 1)))))
+ (PROGN
+ (SETQ |n| |$n|)
+ (SETQ |l| |$sz|)
+ (LOOP
(COND
- ((OR (EQUAL |$n| |l|) (NOT (CHAR= (SCHAR |$ln| |$n|) (|char| '_))))
- (COND ((AND (EQUAL |n| |$n|) |zro|) "0")
- (T (|subString| |$ln| |n| (- |$n| |n|)))))
- (T (SETQ |str| (|subString| |$ln| |n| (- |$n| |n|)))
- (SETQ |$n| (+ |$n| 1)) (SETQ |a| (|shoeEsc|))
- (SETQ |bb| (|shoeInteger1| |zro|)) (CONCAT |str| |bb|)))))))
+ ((NOT (AND (< |$n| |l|) (DIGIT-CHAR-P (SCHAR |$ln| |$n|))))
+ (RETURN NIL))
+ (T (SETQ |$n| (+ |$n| 1)))))
+ (COND
+ ((OR (EQUAL |$n| |l|) (NOT (CHAR= (SCHAR |$ln| |$n|) (|char| '_))))
+ (COND ((AND (EQUAL |n| |$n|) |zro|) "0")
+ (T (|subString| |$ln| |n| (- |$n| |n|)))))
+ (T (SETQ |str| (|subString| |$ln| |n| (- |$n| |n|)))
+ (SETQ |$n| (+ |$n| 1)) (SETQ |a| (|shoeEsc|))
+ (SETQ |bb| (|shoeInteger1| |zro|)) (CONCAT |str| |bb|))))))
(DEFUN |shoeIntValue| (|s|)
- (PROG (|d| |ival| |ns|)
- (RETURN
- (PROGN
- (SETQ |ns| (LENGTH |s|))
- (SETQ |ival| 0)
- (LET ((|bfVar#1| (- |ns| 1)) (|i| 0))
- (LOOP
- (COND ((> |i| |bfVar#1|) (RETURN NIL))
- (T (SETQ |d| (DIGIT-CHAR-P (SCHAR |s| |i|)))
- (SETQ |ival| (+ (* 10 |ival|) |d|))))
- (SETQ |i| (+ |i| 1))))
- |ival|))))
+ (LET* (|d| |ival| |ns|)
+ (PROGN
+ (SETQ |ns| (LENGTH |s|))
+ (SETQ |ival| 0)
+ (LET ((|bfVar#1| (- |ns| 1)) (|i| 0))
+ (LOOP
+ (COND ((> |i| |bfVar#1|) (RETURN NIL))
+ (T (SETQ |d| (DIGIT-CHAR-P (SCHAR |s| |i|)))
+ (SETQ |ival| (+ (* 10 |ival|) |d|))))
+ (SETQ |i| (+ |i| 1))))
+ |ival|)))
(DEFUN |shoeNumber| ()
- (PROG (|w| |n| |a|)
+ (LET* (|w| |n| |a|)
(DECLARE (SPECIAL |$ln| |$floatok| |$sz| |$n|))
- (RETURN
- (PROGN
- (SETQ |a| (|shoeInteger|))
- (COND ((NOT (< |$n| |$sz|)) (|shoeLeafInteger| |a|))
- ((AND |$floatok| (CHAR= (SCHAR |$ln| |$n|) (|char| '|.|)))
- (SETQ |n| |$n|) (SETQ |$n| (+ |$n| 1))
- (COND
- ((AND (< |$n| |$sz|) (CHAR= (SCHAR |$ln| |$n|) (|char| '|.|)))
- (SETQ |$n| |n|) (|shoeLeafInteger| |a|))
- (T (SETQ |w| (|shoeInteger1| T)) (|shoeExponent| |a| |w|))))
- (T (|shoeLeafInteger| |a|)))))))
+ (PROGN
+ (SETQ |a| (|shoeInteger|))
+ (COND ((NOT (< |$n| |$sz|)) (|shoeLeafInteger| |a|))
+ ((AND |$floatok| (CHAR= (SCHAR |$ln| |$n|) (|char| '|.|)))
+ (SETQ |n| |$n|) (SETQ |$n| (+ |$n| 1))
+ (COND
+ ((AND (< |$n| |$sz|) (CHAR= (SCHAR |$ln| |$n|) (|char| '|.|)))
+ (SETQ |$n| |n|) (|shoeLeafInteger| |a|))
+ (T (SETQ |w| (|shoeInteger1| T)) (|shoeExponent| |a| |w|))))
+ (T (|shoeLeafInteger| |a|))))))
(DEFUN |shoeExponent| (|a| |w|)
- (PROG (|c1| |e| |c| |n|)
+ (LET* (|c1| |e| |c| |n|)
(DECLARE (SPECIAL |$ln| |$sz| |$n|))
- (RETURN
- (COND ((NOT (< |$n| |$sz|)) (|shoeLeafFloat| |a| |w| 0))
- (T (SETQ |n| |$n|) (SETQ |c| (SCHAR |$ln| |$n|))
- (COND
- ((OR (CHAR= |c| (|char| 'E)) (CHAR= |c| (|char| '|e|)))
- (SETQ |$n| (+ |$n| 1))
- (COND
- ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|)
- (|shoeLeafFloat| |a| |w| 0))
- ((DIGIT-CHAR-P (SCHAR |$ln| |$n|)) (SETQ |e| (|shoeInteger|))
- (SETQ |e| (|shoeIntValue| |e|)) (|shoeLeafFloat| |a| |w| |e|))
- (T (SETQ |c1| (SCHAR |$ln| |$n|))
- (COND
- ((OR (CHAR= |c1| (|char| '+)) (CHAR= |c1| (|char| '-)))
- (SETQ |$n| (+ |$n| 1))
- (COND
- ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|)
- (|shoeLeafFloat| |a| |w| 0))
- ((DIGIT-CHAR-P (SCHAR |$ln| |$n|))
- (SETQ |e| (|shoeInteger|)) (SETQ |e| (|shoeIntValue| |e|))
- (|shoeLeafFloat| |a| |w|
- (COND ((CHAR= |c1| (|char| '-)) (- |e|))
- (T |e|))))
- (T (SETQ |$n| |n|) (|shoeLeafFloat| |a| |w| 0))))))))
- (T (|shoeLeafFloat| |a| |w| 0))))))))
+ (COND ((NOT (< |$n| |$sz|)) (|shoeLeafFloat| |a| |w| 0))
+ (T (SETQ |n| |$n|) (SETQ |c| (SCHAR |$ln| |$n|))
+ (COND
+ ((OR (CHAR= |c| (|char| 'E)) (CHAR= |c| (|char| '|e|)))
+ (SETQ |$n| (+ |$n| 1))
+ (COND
+ ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|)
+ (|shoeLeafFloat| |a| |w| 0))
+ ((DIGIT-CHAR-P (SCHAR |$ln| |$n|)) (SETQ |e| (|shoeInteger|))
+ (SETQ |e| (|shoeIntValue| |e|)) (|shoeLeafFloat| |a| |w| |e|))
+ (T (SETQ |c1| (SCHAR |$ln| |$n|))
+ (COND
+ ((OR (CHAR= |c1| (|char| '+)) (CHAR= |c1| (|char| '-)))
+ (SETQ |$n| (+ |$n| 1))
+ (COND
+ ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|)
+ (|shoeLeafFloat| |a| |w| 0))
+ ((DIGIT-CHAR-P (SCHAR |$ln| |$n|)) (SETQ |e| (|shoeInteger|))
+ (SETQ |e| (|shoeIntValue| |e|))
+ (|shoeLeafFloat| |a| |w|
+ (COND ((CHAR= |c1| (|char| '-)) (- |e|))
+ (T |e|))))
+ (T (SETQ |$n| |n|) (|shoeLeafFloat| |a| |w| 0))))))))
+ (T (|shoeLeafFloat| |a| |w| 0)))))))
(DEFUN |shoeError| ()
- (PROG (|n|)
+ (LET* (|n|)
(DECLARE (SPECIAL |$ln| |$linepos| |$n|))
- (RETURN
- (PROGN
- (SETQ |n| |$n|)
- (SETQ |$n| (+ |$n| 1))
- (|SoftShoeError| (CONS |$linepos| |n|)
- (CONCAT "The character whose number is "
- (WRITE-TO-STRING (CHAR-CODE (SCHAR |$ln| |n|)))
- " is not a Boot character"))
- (|shoeLeafError| (SCHAR |$ln| |n|))))))
+ (PROGN
+ (SETQ |n| |$n|)
+ (SETQ |$n| (+ |$n| 1))
+ (|SoftShoeError| (CONS |$linepos| |n|)
+ (CONCAT "The character whose number is "
+ (WRITE-TO-STRING (CHAR-CODE (SCHAR |$ln| |n|)))
+ " is not a Boot character"))
+ (|shoeLeafError| (SCHAR |$ln| |n|)))))
(DEFUN |shoeKeyWord| (|st|) (|tableValue| |shoeKeyTable| |st|))
@@ -472,34 +453,33 @@
(DEFUN |shoeMatch| (|l| |i|) (|shoeSubStringMatch| |l| |shoeDict| |i|))
(DEFUN |shoeSubStringMatch| (|l| |d| |i|)
- (PROG (|eql| |ls| |s| |s1| |done| |ll| |u| |h|)
- (RETURN
- (PROGN
- (SETQ |h| (CHAR-CODE (SCHAR |l| |i|)))
- (SETQ |u| (ELT |d| |h|))
- (SETQ |ll| (LENGTH |l|))
- (SETQ |done| NIL)
- (SETQ |s1| "")
- (LET ((|bfVar#1| (- (LENGTH |u|) 1)) (|j| 0))
- (LOOP
- (COND ((OR (> |j| |bfVar#1|) |done|) (RETURN NIL))
- (T (SETQ |s| (ELT |u| |j|)) (SETQ |ls| (LENGTH |s|))
- (SETQ |done|
- (COND ((< |ll| (+ |ls| |i|)) NIL)
- (T (SETQ |eql| T)
- (LET ((|bfVar#2| (- |ls| 1)) (|k| 1))
- (LOOP
- (COND
- ((OR (> |k| |bfVar#2|) (NOT |eql|))
- (RETURN NIL))
- (T
- (SETQ |eql|
- (CHAR= (SCHAR |s| |k|)
- (SCHAR |l| (+ |k| |i|))))))
- (SETQ |k| (+ |k| 1))))
- (COND (|eql| (SETQ |s1| |s|) T) (T NIL)))))))
- (SETQ |j| (+ |j| 1))))
- |s1|))))
+ (LET* (|eql| |ls| |s| |s1| |done| |ll| |u| |h|)
+ (PROGN
+ (SETQ |h| (CHAR-CODE (SCHAR |l| |i|)))
+ (SETQ |u| (ELT |d| |h|))
+ (SETQ |ll| (LENGTH |l|))
+ (SETQ |done| NIL)
+ (SETQ |s1| "")
+ (LET ((|bfVar#1| (- (LENGTH |u|) 1)) (|j| 0))
+ (LOOP
+ (COND ((OR (> |j| |bfVar#1|) |done|) (RETURN NIL))
+ (T (SETQ |s| (ELT |u| |j|)) (SETQ |ls| (LENGTH |s|))
+ (SETQ |done|
+ (COND ((< |ll| (+ |ls| |i|)) NIL)
+ (T (SETQ |eql| T)
+ (LET ((|bfVar#2| (- |ls| 1)) (|k| 1))
+ (LOOP
+ (COND
+ ((OR (> |k| |bfVar#2|) (NOT |eql|))
+ (RETURN NIL))
+ (T
+ (SETQ |eql|
+ (CHAR= (SCHAR |s| |k|)
+ (SCHAR |l| (+ |k| |i|))))))
+ (SETQ |k| (+ |k| 1))))
+ (COND (|eql| (SETQ |s1| |s|) T) (T NIL)))))))
+ (SETQ |j| (+ |j| 1))))
+ |s1|)))
(DEFUN |shoePunctuation| (|c|) (EQL (ELT |shoePun| |c|) 1))
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index 6f2c0f71..0ed1016a 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -51,107 +51,101 @@
(LIST "'" 'QUOTE) (LIST "|" 'BAR)))
(DEFUN |shoeKeyTableCons| ()
- (PROG (|KeyTable|)
- (RETURN
- (PROGN
- (SETQ |KeyTable| (|makeTable| #'EQUAL))
- (LET ((|bfVar#1| |shoeKeyWords|) (|st| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |st| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (SETF (|tableValue| |KeyTable| (CAR |st|)) (CADR |st|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- |KeyTable|))))
+ (LET* (|KeyTable|)
+ (PROGN
+ (SETQ |KeyTable| (|makeTable| #'EQUAL))
+ (LET ((|bfVar#1| |shoeKeyWords|) (|st| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |st| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (SETF (|tableValue| |KeyTable| (CAR |st|)) (CADR |st|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ |KeyTable|)))
(DEFPARAMETER |shoeKeyTable| (|shoeKeyTableCons|))
(DEFUN |keywordId| (|t|)
- (PROG (|s|)
- (RETURN
- (COND
- ((SETQ |s|
- (WITH-HASH-TABLE-ITERATOR (#1=#:G719 |shoeKeyTable|)
- (LET ((|bfVar#1| NIL))
- (LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G720 |k| |v|)
- (#1#)
- (COND ((NOT #2#) (RETURN |bfVar#1|))
- (T
- (AND (EQ |v| |t|)
- (PROGN
- (SETQ |bfVar#1| |k|)
- (COND
- (|bfVar#1| (RETURN |bfVar#1|))))))))))))
- (INTERN |s|))
- (T |t|)))))
+ (LET* (|s|)
+ (COND
+ ((SETQ |s|
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G719 |shoeKeyTable|)
+ (LET ((|bfVar#1| NIL))
+ (LOOP
+ (MULTIPLE-VALUE-BIND (#2=#:G720 |k| |v|)
+ (#1#)
+ (COND ((NOT #2#) (RETURN |bfVar#1|))
+ (T
+ (AND (EQ |v| |t|)
+ (PROGN
+ (SETQ |bfVar#1| |k|)
+ (COND
+ (|bfVar#1| (RETURN |bfVar#1|))))))))))))
+ (INTERN |s|))
+ (T |t|))))
(DEFUN |shoeInsert| (|s| |d|)
- (PROG (|v| |k| |n| |u| |h| |l|)
- (RETURN
- (PROGN
- (SETQ |l| (LENGTH |s|))
- (SETQ |h| (CHAR-CODE (SCHAR |s| 0)))
- (SETQ |u| (ELT |d| |h|))
- (SETQ |n| (LENGTH |u|))
- (SETQ |k| 0)
- (LOOP
- (COND ((< (LENGTH (ELT |u| |k|)) |l|) (RETURN NIL))
- (T (SETQ |k| (+ |k| 1)))))
- (SETQ |v| (MAKE-ARRAY (+ |n| 1)))
- (LET ((|bfVar#1| (- |k| 1)) (|i| 0))
- (LOOP
- (COND ((> |i| |bfVar#1|) (RETURN NIL))
- (T (SETF (ELT |v| |i|) (ELT |u| |i|))))
- (SETQ |i| (+ |i| 1))))
- (SETF (ELT |v| |k|) |s|)
- (LET ((|bfVar#2| (- |n| 1)) (|i| |k|))
- (LOOP
- (COND ((> |i| |bfVar#2|) (RETURN NIL))
- (T (SETF (ELT |v| (+ |i| 1)) (ELT |u| |i|))))
- (SETQ |i| (+ |i| 1))))
- (SETF (ELT |d| |h|) |v|)
- |s|))))
+ (LET* (|v| |k| |n| |u| |h| |l|)
+ (PROGN
+ (SETQ |l| (LENGTH |s|))
+ (SETQ |h| (CHAR-CODE (SCHAR |s| 0)))
+ (SETQ |u| (ELT |d| |h|))
+ (SETQ |n| (LENGTH |u|))
+ (SETQ |k| 0)
+ (LOOP
+ (COND ((< (LENGTH (ELT |u| |k|)) |l|) (RETURN NIL))
+ (T (SETQ |k| (+ |k| 1)))))
+ (SETQ |v| (MAKE-ARRAY (+ |n| 1)))
+ (LET ((|bfVar#1| (- |k| 1)) (|i| 0))
+ (LOOP
+ (COND ((> |i| |bfVar#1|) (RETURN NIL))
+ (T (SETF (ELT |v| |i|) (ELT |u| |i|))))
+ (SETQ |i| (+ |i| 1))))
+ (SETF (ELT |v| |k|) |s|)
+ (LET ((|bfVar#2| (- |n| 1)) (|i| |k|))
+ (LOOP
+ (COND ((> |i| |bfVar#2|) (RETURN NIL))
+ (T (SETF (ELT |v| (+ |i| 1)) (ELT |u| |i|))))
+ (SETQ |i| (+ |i| 1))))
+ (SETF (ELT |d| |h|) |v|)
+ |s|)))
(DEFUN |shoeDictCons| ()
- (PROG (|d| |b| |a|)
- (RETURN
- (PROGN
- (SETQ |d|
- (PROGN
- (SETQ |a| (MAKE-ARRAY 256))
- (SETQ |b| (MAKE-ARRAY 1))
- (SETF (ELT |b| 0) (|makeString| 0))
- (LET ((|i| 0))
- (LOOP
- (COND ((> |i| 255) (RETURN NIL))
- (T (SETF (ELT |a| |i|) |b|)))
- (SETQ |i| (+ |i| 1))))
- |a|))
- (WITH-HASH-TABLE-ITERATOR (#1=#:G721 |shoeKeyTable|)
- (LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G722 |s| #:G723)
- (#1#)
- (COND ((NOT #2#) (RETURN NIL)) (T (|shoeInsert| |s| |d|))))))
- |d|))))
+ (LET* (|d| |b| |a|)
+ (PROGN
+ (SETQ |d|
+ (PROGN
+ (SETQ |a| (MAKE-ARRAY 256))
+ (SETQ |b| (MAKE-ARRAY 1))
+ (SETF (ELT |b| 0) (|makeString| 0))
+ (LET ((|i| 0))
+ (LOOP
+ (COND ((> |i| 255) (RETURN NIL)) (T (SETF (ELT |a| |i|) |b|)))
+ (SETQ |i| (+ |i| 1))))
+ |a|))
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G721 |shoeKeyTable|)
+ (LOOP
+ (MULTIPLE-VALUE-BIND (#2=#:G722 |s| #:G723)
+ (#1#)
+ (COND ((NOT #2#) (RETURN NIL)) (T (|shoeInsert| |s| |d|))))))
+ |d|)))
(DEFPARAMETER |shoeDict| (|shoeDictCons|))
(DEFUN |shoePunCons| ()
- (PROG (|a|)
- (RETURN
- (PROGN
- (SETQ |a| (|makeBitVector| 256))
- (LET ((|i| 0))
- (LOOP (COND ((> |i| 255) (RETURN NIL)) (T (SETF (SBIT |a| |i|) 0)))
- (SETQ |i| (+ |i| 1))))
- (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|)
- (LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G725 |k| #:G726)
- (#1#)
- (COND ((NOT #2#) (RETURN NIL)) ((|shoeStartsId| (SCHAR |k| 0)) NIL)
- (T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1))))))
- |a|))))
+ (LET* (|a|)
+ (PROGN
+ (SETQ |a| (|makeBitVector| 256))
+ (LET ((|i| 0))
+ (LOOP (COND ((> |i| 255) (RETURN NIL)) (T (SETF (SBIT |a| |i|) 0)))
+ (SETQ |i| (+ |i| 1))))
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|)
+ (LOOP
+ (MULTIPLE-VALUE-BIND (#2=#:G725 |k| #:G726)
+ (#1#)
+ (COND ((NOT #2#) (RETURN NIL)) ((|shoeStartsId| (SCHAR |k| 0)) NIL)
+ (T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1))))))
+ |a|)))
(DEFPARAMETER |shoePun| (|shoePunCons|))
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index ff26ab5c..a337d62e 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -26,68 +26,67 @@
(PROGN (|prettyPrint| |x| |st|) (TERPRI |st|)))
(DEFUN |genModuleFinalization| (|stream|)
- (PROG (|init|)
+ (LET* (|init|)
(DECLARE (SPECIAL |$currentModuleName| |$foreignsDefsForCLisp|))
- (RETURN
- (COND
- ((|%hasFeature| :CLISP)
- (COND ((NULL |$foreignsDefsForCLisp|) NIL)
- ((NULL |$currentModuleName|)
- (|coreError| "current module has no name"))
- (T
- (SETQ |init|
- (CONS 'DEFUN
- (CONS
- (INTERN
- (CONCAT |$currentModuleName| "InitCLispFFI"))
- (CONS NIL
- (CONS
- (LIST 'MAPC (LIST 'FUNCTION 'FMAKUNBOUND)
- (|quote|
- (LET ((|bfVar#2| NIL)
- (|bfVar#3| NIL)
- (|bfVar#1|
- |$foreignsDefsForCLisp|)
- (|d| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN
- (SETQ |d| (CAR |bfVar#1|))
- NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #1=(CONS (CADR |d|)
- NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #1#)
- (SETQ |bfVar#3|
- (CDR |bfVar#3|))))
- (SETQ |bfVar#1|
- (CDR |bfVar#1|))))))
- (LET ((|bfVar#5| NIL)
- (|bfVar#6| NIL)
- (|bfVar#4| |$foreignsDefsForCLisp|)
- (|d| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#4|))
- (PROGN
- (SETQ |d| (CAR |bfVar#4|))
- NIL))
- (RETURN |bfVar#5|))
- ((NULL |bfVar#5|)
- (SETQ |bfVar#5|
- #2=(CONS
- (LIST 'EVAL (|quote| |d|))
- NIL))
- (SETQ |bfVar#6| |bfVar#5|))
- (T (RPLACD |bfVar#6| #2#)
- (SETQ |bfVar#6| (CDR |bfVar#6|))))
- (SETQ |bfVar#4| (CDR |bfVar#4|)))))))))
- (|reallyPrettyPrint| |init| |stream|))))
- (T NIL)))))
+ (COND
+ ((|%hasFeature| :CLISP)
+ (COND ((NULL |$foreignsDefsForCLisp|) NIL)
+ ((NULL |$currentModuleName|)
+ (|coreError| "current module has no name"))
+ (T
+ (SETQ |init|
+ (CONS 'DEFUN
+ (CONS
+ (INTERN
+ (CONCAT |$currentModuleName| "InitCLispFFI"))
+ (CONS NIL
+ (CONS
+ (LIST 'MAPC (LIST 'FUNCTION 'FMAKUNBOUND)
+ (|quote|
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1|
+ |$foreignsDefsForCLisp|)
+ (|d| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN
+ (SETQ |d| (CAR |bfVar#1|))
+ NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2|
+ #1=(CONS (CADR |d|)
+ NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#)
+ (SETQ |bfVar#3|
+ (CDR |bfVar#3|))))
+ (SETQ |bfVar#1|
+ (CDR |bfVar#1|))))))
+ (LET ((|bfVar#5| NIL)
+ (|bfVar#6| NIL)
+ (|bfVar#4| |$foreignsDefsForCLisp|)
+ (|d| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#4|))
+ (PROGN
+ (SETQ |d| (CAR |bfVar#4|))
+ NIL))
+ (RETURN |bfVar#5|))
+ ((NULL |bfVar#5|)
+ (SETQ |bfVar#5|
+ #2=(CONS
+ (LIST 'EVAL (|quote| |d|))
+ NIL))
+ (SETQ |bfVar#6| |bfVar#5|))
+ (T (RPLACD |bfVar#6| #2#)
+ (SETQ |bfVar#6| (CDR |bfVar#6|))))
+ (SETQ |bfVar#4| (CDR |bfVar#4|)))))))))
+ (|reallyPrettyPrint| |init| |stream|))))
+ (T NIL))))
(DEFUN |genOptimizeOptions| (|stream|)
(|reallyPrettyPrint|
@@ -129,35 +128,33 @@
(DEFUN BOOTCLAMLINES (|lines| |fn| |out|) (BOOTTOCLLINES |lines| |fn| |out|))
(DEFUN BOOTTOCLLINES (|lines| |fn| |outfn|)
- (PROG (|a|)
- (RETURN
- (UNWIND-PROTECT
- (PROGN
- (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
- (|shoeClLines| |a| |fn| |lines| |outfn|))
- (|closeStream| |a|)))))
+ (LET* (|a|)
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
+ (|shoeClLines| |a| |fn| |lines| |outfn|))
+ (|closeStream| |a|))))
(DEFUN |shoeClLines| (|a| |fn| |lines| |outfn|)
- (PROG (|stream|)
- (RETURN
- (COND ((NULL |a|) (|shoeNotFound| |fn|))
- (T
- (UNWIND-PROTECT
- (PROGN
- (SETQ |stream| (|outputTextFile| |outfn|))
- (|genOptimizeOptions| |stream|)
- (LET ((|bfVar#1| |lines|) (|line| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (|shoeFileLine| |line| |stream|)))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- (|shoeFileTrees| (|shoeTransformStream| |a|) |stream|)
- (|genModuleFinalization| |stream|)
- |outfn|)
- (|closeStream| |stream|)))))))
+ (LET* (|stream|)
+ (COND ((NULL |a|) (|shoeNotFound| |fn|))
+ (T
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |stream| (|outputTextFile| |outfn|))
+ (|genOptimizeOptions| |stream|)
+ (LET ((|bfVar#1| |lines|) (|line| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (|shoeFileLine| |line| |stream|)))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (|shoeFileTrees| (|shoeTransformStream| |a|) |stream|)
+ (|genModuleFinalization| |stream|)
+ |outfn|)
+ (|closeStream| |stream|))))))
(DEFUN BOOTTOCLC (|fn| |out|)
(UNWIND-PROTECT
@@ -168,54 +165,51 @@
(|endCompileDuration|)))
(DEFUN BOOTTOCLCLINES (|lines| |fn| |outfn|)
- (PROG (|a|)
- (RETURN
- (UNWIND-PROTECT
- (PROGN
- (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
- (|shoeClCLines| |a| |fn| |lines| |outfn|))
- (|closeStream| |a|)))))
+ (LET* (|a|)
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
+ (|shoeClCLines| |a| |fn| |lines| |outfn|))
+ (|closeStream| |a|))))
(DEFUN |shoeClCLines| (|a| |fn| |lines| |outfn|)
- (PROG (|stream|)
- (RETURN
- (COND ((NULL |a|) (|shoeNotFound| |fn|))
- (T
- (UNWIND-PROTECT
- (PROGN
- (SETQ |stream| (|outputTextFile| |outfn|))
- (|genOptimizeOptions| |stream|)
- (LET ((|bfVar#1| |lines|) (|line| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (|shoeFileLine| |line| |stream|)))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- (|shoeFileTrees|
- (|shoeTransformToFile| |stream|
- (|shoeInclude|
- (|bAddLineNumber| (|bRgen| |a|)
- (|bIgen| 0))))
- |stream|)
- (|genModuleFinalization| |stream|)
- |outfn|)
- (|closeStream| |stream|)))))))
+ (LET* (|stream|)
+ (COND ((NULL |a|) (|shoeNotFound| |fn|))
+ (T
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |stream| (|outputTextFile| |outfn|))
+ (|genOptimizeOptions| |stream|)
+ (LET ((|bfVar#1| |lines|) (|line| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (|shoeFileLine| |line| |stream|)))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (|shoeFileTrees|
+ (|shoeTransformToFile| |stream|
+ (|shoeInclude|
+ (|bAddLineNumber| (|bRgen| |a|)
+ (|bIgen| 0))))
+ |stream|)
+ (|genModuleFinalization| |stream|)
+ |outfn|)
+ (|closeStream| |stream|))))))
(DECLAIM (FTYPE (FUNCTION (|%String|) |%Thing|) BOOTTOMC))
(DEFUN BOOTTOMC (|fn|)
- (PROG (|a| |callingPackage|)
- (RETURN
- (PROGN
- (SETQ |callingPackage| *PACKAGE*)
- (IN-PACKAGE "BOOTTRAN")
- (UNWIND-PROTECT
- (PROGN
- (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
- (|shoeMc| |a| |fn|))
- (PROGN (|closeStream| |a|) (|setCurrentPackage| |callingPackage|)))))))
+ (LET* (|a| |callingPackage|)
+ (PROGN
+ (SETQ |callingPackage| *PACKAGE*)
+ (IN-PACKAGE "BOOTTRAN")
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
+ (|shoeMc| |a| |fn|))
+ (PROGN (|closeStream| |a|) (|setCurrentPackage| |callingPackage|))))))
(DEFUN |shoeMc| (|a| |fn|)
(COND ((NULL |a|) (|shoeNotFound| |fn|))
@@ -223,49 +217,44 @@
(|shoeConsole| (CONCAT |fn| " COMPILED AND LOADED")))))
(DEFUN |evalBootFile| (|fn|)
- (PROG (|a| |outfn| |infn| |b|)
- (RETURN
- (PROGN
- (SETQ |b| *PACKAGE*)
- (IN-PACKAGE "BOOTTRAN")
- (SETQ |infn| (|shoeAddbootIfNec| |fn|))
- (SETQ |outfn| (CONCAT (|shoeRemovebootIfNec| |fn|) "." "lisp"))
- (UNWIND-PROTECT
- (PROGN
- (SETQ |a| (|inputTextFile| |infn|))
- (|shoeClLines| |a| |infn| NIL |outfn|))
- (PROGN (|closeStream| |a|) (|setCurrentPackage| |b|)))
- (LOAD |outfn|)))))
+ (LET* (|a| |outfn| |infn| |b|)
+ (PROGN
+ (SETQ |b| *PACKAGE*)
+ (IN-PACKAGE "BOOTTRAN")
+ (SETQ |infn| (|shoeAddbootIfNec| |fn|))
+ (SETQ |outfn| (CONCAT (|shoeRemovebootIfNec| |fn|) "." "lisp"))
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |a| (|inputTextFile| |infn|))
+ (|shoeClLines| |a| |infn| NIL |outfn|))
+ (PROGN (|closeStream| |a|) (|setCurrentPackage| |b|)))
+ (LOAD |outfn|))))
(DECLAIM (FTYPE (FUNCTION (|%String|) |%Thing|) BO))
(DEFUN BO (|fn|)
- (PROG (|a| |b|)
- (RETURN
- (PROGN
- (SETQ |b| *PACKAGE*)
- (IN-PACKAGE "BOOTTRAN")
- (UNWIND-PROTECT
- (PROGN
- (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
- (|shoeToConsole| |a| |fn|))
- (PROGN (|closeStream| |a|) (|setCurrentPackage| |b|)))))))
+ (LET* (|a| |b|)
+ (PROGN
+ (SETQ |b| *PACKAGE*)
+ (IN-PACKAGE "BOOTTRAN")
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
+ (|shoeToConsole| |a| |fn|))
+ (PROGN (|closeStream| |a|) (|setCurrentPackage| |b|))))))
(DEFUN BOCLAM (|fn|)
- (PROG (|a| |callingPackage|)
- (RETURN
- (PROGN
- (SETQ |callingPackage| *PACKAGE*)
- (IN-PACKAGE "BOOTTRAN")
- (LET ((|$bfClamming| T))
- (DECLARE (SPECIAL |$bfClamming|))
- (UNWIND-PROTECT
- (PROGN
- (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
- (|shoeToConsole| |a| |fn|))
- (PROGN
- (|closeStream| |a|)
- (|setCurrentPackage| |callingPackage|))))))))
+ (LET* (|a| |callingPackage|)
+ (PROGN
+ (SETQ |callingPackage| *PACKAGE*)
+ (IN-PACKAGE "BOOTTRAN")
+ (LET ((|$bfClamming| T))
+ (DECLARE (SPECIAL |$bfClamming|))
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
+ (|shoeToConsole| |a| |fn|))
+ (PROGN (|closeStream| |a|) (|setCurrentPackage| |callingPackage|)))))))
(DEFUN |shoeToConsole| (|a| |fn|)
(COND ((NULL |a|) (|shoeNotFound| |fn|))
@@ -277,48 +266,45 @@
(DEFUN STOUT (|string|) (PSTOUT (LIST |string|)))
(DEFUN |string2BootTree| (|string|)
- (PROG (|result| |a| |callingPackage|)
- (RETURN
- (PROGN
- (SETQ |callingPackage| *PACKAGE*)
- (IN-PACKAGE "BOOTTRAN")
- (SETQ |a| (|shoeTransformString| (LIST |string|)))
- (SETQ |result|
- (COND ((|bStreamNull| |a|) NIL)
- (T
- (|stripm| (CAR |a|) |callingPackage|
- (FIND-PACKAGE "BOOTTRAN")))))
- (|setCurrentPackage| |callingPackage|)
- |result|))))
+ (LET* (|result| |a| |callingPackage|)
+ (PROGN
+ (SETQ |callingPackage| *PACKAGE*)
+ (IN-PACKAGE "BOOTTRAN")
+ (SETQ |a| (|shoeTransformString| (LIST |string|)))
+ (SETQ |result|
+ (COND ((|bStreamNull| |a|) NIL)
+ (T
+ (|stripm| (CAR |a|) |callingPackage|
+ (FIND-PACKAGE "BOOTTRAN")))))
+ (|setCurrentPackage| |callingPackage|)
+ |result|)))
(DEFUN STEVAL (|string|)
- (PROG (|result| |fn| |a| |callingPackage|)
- (RETURN
- (PROGN
- (SETQ |callingPackage| *PACKAGE*)
- (IN-PACKAGE "BOOTTRAN")
- (SETQ |a| (|shoeTransformString| (LIST |string|)))
- (SETQ |result|
- (COND ((|bStreamNull| |a|) NIL)
- (T
- (SETQ |fn|
- (|stripm| (CAR |a|) *PACKAGE*
- (FIND-PACKAGE "BOOTTRAN")))
- (EVAL |fn|))))
- (|setCurrentPackage| |callingPackage|)
- |result|))))
+ (LET* (|result| |fn| |a| |callingPackage|)
+ (PROGN
+ (SETQ |callingPackage| *PACKAGE*)
+ (IN-PACKAGE "BOOTTRAN")
+ (SETQ |a| (|shoeTransformString| (LIST |string|)))
+ (SETQ |result|
+ (COND ((|bStreamNull| |a|) NIL)
+ (T
+ (SETQ |fn|
+ (|stripm| (CAR |a|) *PACKAGE*
+ (FIND-PACKAGE "BOOTTRAN")))
+ (EVAL |fn|))))
+ (|setCurrentPackage| |callingPackage|)
+ |result|)))
(DEFUN STTOMC (|string|)
- (PROG (|result| |a| |callingPackage|)
- (RETURN
- (PROGN
- (SETQ |callingPackage| *PACKAGE*)
- (IN-PACKAGE "BOOTTRAN")
- (SETQ |a| (|shoeTransformString| (LIST |string|)))
- (SETQ |result|
- (COND ((|bStreamNull| |a|) NIL) (T (|shoePCompile| (CAR |a|)))))
- (|setCurrentPackage| |callingPackage|)
- |result|))))
+ (LET* (|result| |a| |callingPackage|)
+ (PROGN
+ (SETQ |callingPackage| *PACKAGE*)
+ (IN-PACKAGE "BOOTTRAN")
+ (SETQ |a| (|shoeTransformString| (LIST |string|)))
+ (SETQ |result|
+ (COND ((|bStreamNull| |a|) NIL) (T (|shoePCompile| (CAR |a|)))))
+ (|setCurrentPackage| |callingPackage|)
+ |result|)))
(DEFUN |shoeCompileTrees| (|s|)
(LOOP
@@ -328,23 +314,22 @@
(DECLAIM (FTYPE (FUNCTION (|%Ast|) |%Thing|) |shoeCompile|))
(DEFUN |shoeCompile| (|fn|)
- (PROG (|body| |bv| |ISTMP#2| |name| |ISTMP#1|)
- (RETURN
- (COND
- ((AND (CONSP |fn|) (EQ (CAR |fn|) 'DEFUN)
- (PROGN
- (SETQ |ISTMP#1| (CDR |fn|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |name| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (PROGN
- (SETQ |bv| (CAR |ISTMP#2|))
- (SETQ |body| (CDR |ISTMP#2|))
- T))))))
- (COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|))))
- (T (EVAL |fn|))))))
+ (LET* (|body| |bv| |ISTMP#2| |name| |ISTMP#1|)
+ (COND
+ ((AND (CONSP |fn|) (EQ (CAR |fn|) 'DEFUN)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |fn|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |name| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (PROGN
+ (SETQ |bv| (CAR |ISTMP#2|))
+ (SETQ |body| (CDR |ISTMP#2|))
+ T))))))
+ (COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|))))
+ (T (EVAL |fn|)))))
(DEFUN |shoeTransform| (|str|)
(|bNext| #'|shoeTreeConstruct|
@@ -364,40 +349,35 @@
(|bNext| #'|shoePileInsert| (|bNext| #'|shoeLineToks| |str|))))
(DEFUN |shoeConsoleItem| (|str|)
- (PROG (|dq|)
- (RETURN
- (PROGN
- (SETQ |dq| (CAR |str|))
- (|shoeConsoleLines| (|shoeDQlines| |dq|))
- (CONS (|shoeParseTrees| |dq|) (CDR |str|))))))
+ (LET* (|dq|)
+ (PROGN
+ (SETQ |dq| (CAR |str|))
+ (|shoeConsoleLines| (|shoeDQlines| |dq|))
+ (CONS (|shoeParseTrees| |dq|) (CDR |str|)))))
(DEFUN |bFileNext| (|fn| |s|) (|bDelay| #'|bFileNext1| (LIST |fn| |s|)))
(DEFUN |bFileNext1| (|fn| |s|)
- (PROG (|dq|)
- (RETURN
- (COND ((|bStreamNull| |s|) (LIST '|nullstream|))
- (T (SETQ |dq| (CAR |s|)) (|shoeFileLines| (|shoeDQlines| |dq|) |fn|)
- (|bAppend| (|shoeParseTrees| |dq|)
- (|bFileNext| |fn| (CDR |s|))))))))
+ (LET* (|dq|)
+ (COND ((|bStreamNull| |s|) (LIST '|nullstream|))
+ (T (SETQ |dq| (CAR |s|)) (|shoeFileLines| (|shoeDQlines| |dq|) |fn|)
+ (|bAppend| (|shoeParseTrees| |dq|) (|bFileNext| |fn| (CDR |s|)))))))
(DEFUN |shoeParseTrees| (|dq|)
- (PROG (|toklist|)
- (RETURN
- (PROGN
- (SETQ |toklist| (|dqToList| |dq|))
- (COND ((NULL |toklist|) NIL) (T (|shoeOutParse| |toklist|)))))))
+ (LET* (|toklist|)
+ (PROGN
+ (SETQ |toklist| (|dqToList| |dq|))
+ (COND ((NULL |toklist|) NIL) (T (|shoeOutParse| |toklist|))))))
(DEFUN |shoeTreeConstruct| (|str|)
(CONS (|shoeParseTrees| (CAR |str|)) (CDR |str|)))
(DEFUN |shoeDQlines| (|dq|)
- (PROG (|b| |a|)
- (RETURN
- (PROGN
- (SETQ |a| (CDAAR (|shoeLastTokPosn| |dq|)))
- (SETQ |b| (CDAAR (|shoeFirstTokPosn| |dq|)))
- (|streamTake| (+ (- |a| |b|) 1) (CAR (|shoeFirstTokPosn| |dq|)))))))
+ (LET* (|b| |a|)
+ (PROGN
+ (SETQ |a| (CDAAR (|shoeLastTokPosn| |dq|)))
+ (SETQ |b| (CDAAR (|shoeFirstTokPosn| |dq|)))
+ (|streamTake| (+ (- |a| |b|) 1) (CAR (|shoeFirstTokPosn| |dq|))))))
(DEFUN |streamTake| (|n| |s|)
(COND ((|bStreamNull| |s|) NIL) ((EQL |n| 0) NIL)
@@ -430,100 +410,96 @@
(DEFUN |shoeFileLine| (|x| |stream|) (PROGN (WRITE-LINE |x| |stream|) |x|))
(DEFUN |shoeFileTrees| (|s| |st|)
- (PROG (|a|)
- (RETURN
- (LOOP
- (COND ((|bStreamNull| |s|) (RETURN NIL))
- (T (SETQ |a| (CAR |s|))
- (COND
- ((AND (CONSP |a|) (EQ (CAR |a|) '+LINE))
- (|shoeFileLine| (CADR |a|) |st|))
- (T (|reallyPrettyPrint| |a| |st|) (TERPRI |st|)))
- (SETQ |s| (CDR |s|))))))))
+ (LET* (|a|)
+ (LOOP
+ (COND ((|bStreamNull| |s|) (RETURN NIL))
+ (T (SETQ |a| (CAR |s|))
+ (COND
+ ((AND (CONSP |a|) (EQ (CAR |a|) '+LINE))
+ (|shoeFileLine| (CADR |a|) |st|))
+ (T (|reallyPrettyPrint| |a| |st|) (TERPRI |st|)))
+ (SETQ |s| (CDR |s|)))))))
(DEFUN |shoeConsoleTrees| (|s|)
- (PROG (|fn|)
- (RETURN
- (LOOP
- (COND ((|bStreamPackageNull| |s|) (RETURN NIL))
- (T
- (SETQ |fn|
- (|stripm| (CAR |s|) *PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
- (|reallyPrettyPrint| |fn|) (SETQ |s| (CDR |s|))))))))
+ (LET* (|fn|)
+ (LOOP
+ (COND ((|bStreamPackageNull| |s|) (RETURN NIL))
+ (T
+ (SETQ |fn|
+ (|stripm| (CAR |s|) *PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
+ (|reallyPrettyPrint| |fn|) (SETQ |s| (CDR |s|)))))))
(DEFUN |shoeAddComment| (|l|) (CONCAT "; " (CAR |l|)))
(DEFUN |shoeOutParse| (|stream|)
- (PROG (|found|)
+ (LET* (|found|)
(DECLARE
(SPECIAL |$bpParenCount| |$bpCount| |$returns| |$typings| |$wheredefs|
|$op| |$ttok| |$stok| |$stack| |$inputStream|))
- (RETURN
- (PROGN
- (SETQ |$inputStream| |stream|)
- (SETQ |$stack| NIL)
- (SETQ |$stok| NIL)
- (SETQ |$ttok| NIL)
- (SETQ |$op| NIL)
- (SETQ |$wheredefs| NIL)
- (SETQ |$typings| NIL)
- (SETQ |$returns| NIL)
- (SETQ |$bpCount| 0)
- (SETQ |$bpParenCount| 0)
- (|bpFirstTok|)
- (SETQ |found|
- (LET ((#1=#:G729 (CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem|))))
- (COND
- ((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT))
- (COND
- ((EQUAL (CAR #2=(CDR #1#)) '(|BootParserException|))
- (LET ((|e| (CDR #2#)))
- |e|))
- (T (THROW :OPEN-AXIOM-CATCH-POINT #1#))))
- (T #1#))))
- (COND ((EQ |found| 'TRAPPED) NIL)
- ((NOT (|bStreamNull| |$inputStream|)) (|bpGeneralErrorHere|) NIL)
- ((NULL |$stack|) (|bpGeneralErrorHere|) NIL) (T (CAR |$stack|)))))))
+ (PROGN
+ (SETQ |$inputStream| |stream|)
+ (SETQ |$stack| NIL)
+ (SETQ |$stok| NIL)
+ (SETQ |$ttok| NIL)
+ (SETQ |$op| NIL)
+ (SETQ |$wheredefs| NIL)
+ (SETQ |$typings| NIL)
+ (SETQ |$returns| NIL)
+ (SETQ |$bpCount| 0)
+ (SETQ |$bpParenCount| 0)
+ (|bpFirstTok|)
+ (SETQ |found|
+ (LET ((#1=#:G729 (CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem|))))
+ (COND
+ ((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT))
+ (COND
+ ((EQUAL (CAR #2=(CDR #1#)) '(|BootParserException|))
+ (LET ((|e| (CDR #2#)))
+ |e|))
+ (T (THROW :OPEN-AXIOM-CATCH-POINT #1#))))
+ (T #1#))))
+ (COND ((EQ |found| 'TRAPPED) NIL)
+ ((NOT (|bStreamNull| |$inputStream|)) (|bpGeneralErrorHere|) NIL)
+ ((NULL |$stack|) (|bpGeneralErrorHere|) NIL) (T (CAR |$stack|))))))
(DEFUN |genDeclaration| (|n| |t|)
- (PROG (|t'| |ISTMP#2| |vars| |ISTMP#1|)
- (RETURN
- (COND
- ((AND (CONSP |t|) (EQ (CAR |t|) '|%Mapping|))
- (LIST 'DECLAIM (LIST 'FTYPE (|bfType| |t|) |n|)))
- ((AND (CONSP |t|) (EQ (CAR |t|) '|%Forall|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |t|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |vars| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |t'| (CAR |ISTMP#2|)) T))))))
- (COND ((NULL |vars|) (|genDeclaration| |n| |t'|))
- (T (COND ((SYMBOLP |vars|) (SETQ |vars| (LIST |vars|))))
- (|genDeclaration| |n|
- (|applySubst|
- (LET ((|bfVar#2| NIL)
- (|bfVar#3| NIL)
- (|bfVar#1| |vars|)
- (|v| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN
- (SETQ |v| (CAR |bfVar#1|))
- NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #1=(CONS (CONS |v| '*) NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #1#)
- (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- |t'|)))))
- (T (LIST 'DECLAIM (LIST 'TYPE (|bfType| |t|) |n|)))))))
+ (LET* (|t'| |ISTMP#2| |vars| |ISTMP#1|)
+ (COND
+ ((AND (CONSP |t|) (EQ (CAR |t|) '|%Mapping|))
+ (LIST 'DECLAIM (LIST 'FTYPE (|bfType| |t|) |n|)))
+ ((AND (CONSP |t|) (EQ (CAR |t|) '|%Forall|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |t|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |vars| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |t'| (CAR |ISTMP#2|)) T))))))
+ (COND ((NULL |vars|) (|genDeclaration| |n| |t'|))
+ (T (COND ((SYMBOLP |vars|) (SETQ |vars| (LIST |vars|))))
+ (|genDeclaration| |n|
+ (|applySubst|
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| |vars|)
+ (|v| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN
+ (SETQ |v| (CAR |bfVar#1|))
+ NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2|
+ #1=(CONS (CONS |v| '*) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#)
+ (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ |t'|)))))
+ (T (LIST 'DECLAIM (LIST 'TYPE (|bfType| |t|) |n|))))))
(DEFUN |translateSignatureDeclaration| (|d|)
(CASE (CAR |d|)
@@ -533,20 +509,18 @@
(T (|coreError| "signature expected"))))
(DEFUN |translateToplevelExpression| (|expr|)
- (PROG (|expr'|)
- (RETURN
- (PROGN
- (SETQ |expr'| (CDR (CDR (|shoeCompTran| (LIST 'LAMBDA NIL |expr|)))))
- (LET ((|bfVar#1| |expr'|) (|t| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |t| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- ((AND (CONSP |t|) (EQ (CAR |t|) 'DECLARE))
- (IDENTITY (RPLACA |t| 'DECLAIM))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- (COND ((< 1 (LENGTH |expr'|)) (CONS 'PROGN |expr'|))
- (T (CAR |expr'|)))))))
+ (LET* (|expr'|)
+ (PROGN
+ (SETQ |expr'| (CDR (CDR (|shoeCompTran| (LIST 'LAMBDA NIL |expr|)))))
+ (LET ((|bfVar#1| |expr'|) (|t| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |t| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ ((AND (CONSP |t|) (EQ (CAR |t|) 'DECLARE))
+ (IDENTITY (RPLACA |t| 'DECLAIM))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (COND ((< 1 (LENGTH |expr'|)) (CONS 'PROGN |expr'|)) (T (CAR |expr'|))))))
(DEFUN |inAllContexts| (|x|)
(LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) |x|))
@@ -556,157 +530,137 @@
(T (LIST (|inAllContexts| (LIST 'EXPORT (|quote| |ns|)))))))
(DEFUN |packageBody| (|x| |p|)
- (PROG (|z| |user| |ns| |ISTMP#3| |ISTMP#2| |ISTMP#1|)
- (RETURN
- (COND
- ((AND (CONSP |x|) (EQ (CAR |x|) '|%Import|)
- (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|) '|%Namespace|)
- (PROGN
- (SETQ |ISTMP#3| (CDR |ISTMP#2|))
- (AND (CONSP |ISTMP#3|) (NULL (CDR |ISTMP#3|))
- (PROGN (SETQ |ns| (CAR |ISTMP#3|)) T))))))))
- (SETQ |user| (COND ((NULL |p|) NIL) (T (LIST (SYMBOL-NAME |p|)))))
- (COND
- ((EQ |ns| '|System|)
- (LIST 'COND
- (LIST (LIST '|%hasFeature| :COMMON-LISP)
- (CONS 'USE-PACKAGE (CONS "COMMON-LISP" |user|)))
- (LIST 'T (CONS 'USE-PACKAGE (CONS "LISP" |user|)))))
- (T
- (SETQ |z|
+ (LET* (|z| |user| |ns| |ISTMP#3| |ISTMP#2| |ISTMP#1|)
+ (BLOCK NIL
+ (COND
+ ((AND (CONSP |x|) (EQ (CAR |x|) '|%Import|)
+ (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|) '|%Namespace|)
+ (PROGN
+ (SETQ |ISTMP#3| (CDR |ISTMP#2|))
+ (AND (CONSP |ISTMP#3|) (NULL (CDR |ISTMP#3|))
+ (PROGN (SETQ |ns| (CAR |ISTMP#3|)) T))))))))
+ (SETQ |user| (COND ((NULL |p|) NIL) (T (LIST (SYMBOL-NAME |p|)))))
+ (COND
+ ((EQ |ns| '|System|)
+ (LIST 'COND
+ (LIST (LIST '|%hasFeature| :COMMON-LISP)
+ (CONS 'USE-PACKAGE (CONS "COMMON-LISP" |user|)))
+ (LIST 'T (CONS 'USE-PACKAGE (CONS "LISP" |user|)))))
+ (T
+ (SETQ |z|
+ (COND
+ ((AND (CONSP |ns|) (EQ (CAR |ns|) 'DOT)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |ns|))
+ (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) '|System|)
+ (PROGN
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (EQ (CAR |ISTMP#2|) '|Foreign|))))))
+ (COND ((|%hasFeature| :SBCL) 'SB-ALIEN)
+ ((|%hasFeature| :ECL) 'FFI) (T (RETURN NIL))))
+ ((|ident?| |ns|) |ns|) (T (|bpTrap|))))
+ (CONS 'USE-PACKAGE (CONS (SYMBOL-NAME |z|) |user|)))))
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN))
+ (CONS (CAR |x|)
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| (CDR |x|))
+ (|y| NIL))
+ (LOOP
(COND
- ((AND (CONSP |ns|) (EQ (CAR |ns|) 'DOT)
- (PROGN
- (SETQ |ISTMP#1| (CDR |ns|))
- (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) '|System|)
- (PROGN
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (EQ (CAR |ISTMP#2|) '|Foreign|))))))
- (COND ((|%hasFeature| :SBCL) 'SB-ALIEN)
- ((|%hasFeature| :ECL) 'FFI) (T (RETURN NIL))))
- ((|ident?| |ns|) |ns|) (T (|bpTrap|))))
- (CONS 'USE-PACKAGE (CONS (SYMBOL-NAME |z|) |user|)))))
- ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN))
- (CONS (CAR |x|)
- (LET ((|bfVar#2| NIL)
- (|bfVar#3| NIL)
- (|bfVar#1| (CDR |x|))
- (|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 (|packageBody| |y| |p|) NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))))
- (T |x|)))))
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |y| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2| #1=(CONS (|packageBody| |y| |p|) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))))
+ (T |x|)))))
(DEFUN |translateToplevel| (|b| |export?|)
- (PROG (|csts| |lhs| |t| |ISTMP#2| |sig| |ns| |n| |ISTMP#1| |xs|)
+ (LET* (|csts| |lhs| |t| |ISTMP#2| |sig| |ns| |n| |ISTMP#1| |xs|)
(DECLARE
(SPECIAL |$activeNamespace| |$InteractiveMode| |$constantIdentifiers|
|$foreignsDefsForCLisp| |$currentModuleName|))
- (RETURN
- (COND ((NOT (CONSP |b|)) (LIST |b|))
- ((AND (CONSP |b|) (EQ (CAR |b|) 'TUPLE)) (SETQ |xs| (CDR |b|))
- (|coreError| "invalid AST"))
- (T
- (CASE (CAR |b|)
- (|%Signature|
- (LET ((|op| (CADR |b|)) (|t| (CADDR |b|)))
- (LIST (|genDeclaration| |op| |t|))))
- (|%Definition|
- (LET ((|op| (CADR |b|))
- (|args| (CADDR |b|))
- (|body| (CADDDR |b|)))
- (CDR (|bfDef| |op| |args| |body|))))
- (|%Module|
- (LET ((|m| (CADR |b|)) (|ns| (CADDR |b|)) (|ds| (CADDDR |b|)))
- (PROGN
- (SETQ |$currentModuleName| |m|)
- (SETQ |$foreignsDefsForCLisp| NIL)
- (CONS (LIST 'PROVIDE (SYMBOL-NAME |m|))
- (|append| (|exportNames| |ns|)
- (LET ((|bfVar#2| NIL)
- (|bfVar#3| NIL)
- (|bfVar#1| |ds|)
- (|d| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN
- (SETQ |d| (CAR |bfVar#1|))
- NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #1=(CONS
- (CAR
- (|translateToplevel| |d|
- T))
- NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #1#)
- (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))))))
- (|%Import|
- (LET ((|m| (CADR |b|)))
- (COND
- ((AND (CONSP |m|) (EQ (CAR |m|) '|%Namespace|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |m|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |n| (CAR |ISTMP#1|)) T))))
- (LIST (|inAllContexts| (|packageBody| |b| NIL))))
- (T
- (COND
- ((NOT (STRING= (|getOptionValue| '|import|) "skip"))
- (|bootImport| (SYMBOL-NAME |m|))))
- (LIST (LIST 'IMPORT-MODULE (SYMBOL-NAME |m|)))))))
- (|%ImportSignature|
- (LET ((|x| (CADR |b|)) (|sig| (CADDR |b|)))
- (|genImportDeclaration| |x| |sig|)))
- (|%TypeAlias|
- (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|)))
- (LIST (|genTypeAlias| |lhs| |rhs|))))
- (|%ConstantDefinition|
- (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|)))
- (COND
- ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Namespace|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |lhs|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |ns| (CAR |ISTMP#1|)) T))))
- (LIST (LIST 'DEFPACKAGE (SYMBOL-NAME |ns|))
- (|inAllContexts| (|packageBody| |rhs| |ns|))))
- (T (SETQ |sig| NIL)
- (COND
- ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Signature|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |lhs|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |n| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |t| (CAR |ISTMP#2|)) T))))))
- (SETQ |sig| (|genDeclaration| |n| |t|)) (SETQ |lhs| |n|)))
- (SETQ |$constantIdentifiers|
- (CONS |lhs| |$constantIdentifiers|))
- (LIST (LIST 'DEFCONSTANT |lhs| |rhs|))))))
- (|%Assignment|
- (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|)))
- (PROGN
- (SETQ |sig| NIL)
+ (COND ((NOT (CONSP |b|)) (LIST |b|))
+ ((AND (CONSP |b|) (EQ (CAR |b|) 'TUPLE)) (SETQ |xs| (CDR |b|))
+ (|coreError| "invalid AST"))
+ (T
+ (CASE (CAR |b|)
+ (|%Signature|
+ (LET ((|op| (CADR |b|)) (|t| (CADDR |b|)))
+ (LIST (|genDeclaration| |op| |t|))))
+ (|%Definition|
+ (LET ((|op| (CADR |b|))
+ (|args| (CADDR |b|))
+ (|body| (CADDDR |b|)))
+ (CDR (|bfDef| |op| |args| |body|))))
+ (|%Module|
+ (LET ((|m| (CADR |b|)) (|ns| (CADDR |b|)) (|ds| (CADDDR |b|)))
+ (PROGN
+ (SETQ |$currentModuleName| |m|)
+ (SETQ |$foreignsDefsForCLisp| NIL)
+ (CONS (LIST 'PROVIDE (SYMBOL-NAME |m|))
+ (|append| (|exportNames| |ns|)
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| |ds|)
+ (|d| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN
+ (SETQ |d| (CAR |bfVar#1|))
+ NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2|
+ #1=(CONS
+ (CAR
+ (|translateToplevel| |d| T))
+ NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#)
+ (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))))))
+ (|%Import|
+ (LET ((|m| (CADR |b|)))
+ (COND
+ ((AND (CONSP |m|) (EQ (CAR |m|) '|%Namespace|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |m|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |n| (CAR |ISTMP#1|)) T))))
+ (LIST (|inAllContexts| (|packageBody| |b| NIL))))
+ (T
+ (COND
+ ((NOT (STRING= (|getOptionValue| '|import|) "skip"))
+ (|bootImport| (SYMBOL-NAME |m|))))
+ (LIST (LIST 'IMPORT-MODULE (SYMBOL-NAME |m|)))))))
+ (|%ImportSignature|
+ (LET ((|x| (CADR |b|)) (|sig| (CADDR |b|)))
+ (|genImportDeclaration| |x| |sig|)))
+ (|%TypeAlias|
+ (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|)))
+ (LIST (|genTypeAlias| |lhs| |rhs|))))
+ (|%ConstantDefinition|
+ (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|)))
+ (COND
+ ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Namespace|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |lhs|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |ns| (CAR |ISTMP#1|)) T))))
+ (LIST (LIST 'DEFPACKAGE (SYMBOL-NAME |ns|))
+ (|inAllContexts| (|packageBody| |rhs| |ns|))))
+ (T (SETQ |sig| NIL)
(COND
((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Signature|)
(PROGN
@@ -718,84 +672,99 @@
(AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
(PROGN (SETQ |t| (CAR |ISTMP#2|)) T))))))
(SETQ |sig| (|genDeclaration| |n| |t|)) (SETQ |lhs| |n|)))
- (COND (|$InteractiveMode| (LIST (LIST 'SETF |lhs| |rhs|)))
- (T (LIST (LIST 'DEFPARAMETER |lhs| |rhs|)))))))
- (|%Macro|
- (LET ((|op| (CADR |b|))
- (|args| (CADDR |b|))
- (|body| (CADDDR |b|)))
- (|bfMDef| |op| |args| |body|)))
- (|%Structure|
- (LET ((|t| (CADR |b|)) (|alts| (CADDR |b|)))
+ (SETQ |$constantIdentifiers|
+ (CONS |lhs| |$constantIdentifiers|))
+ (LIST (LIST 'DEFCONSTANT |lhs| |rhs|))))))
+ (|%Assignment|
+ (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|)))
+ (PROGN
+ (SETQ |sig| NIL)
(COND
- ((AND (CONSP |alts|) (NULL (CDR |alts|))
+ ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Signature|)
(PROGN
- (SETQ |ISTMP#1| (CAR |alts|))
+ (SETQ |ISTMP#1| (CDR |lhs|))
(AND (CONSP |ISTMP#1|)
- (EQ (CAR |ISTMP#1|) '|Enumeration|)
- (PROGN (SETQ |csts| (CDR |ISTMP#1|)) T))))
- (LIST (|bfEnum| |t| |csts|)))
- (T
- (LET ((|bfVar#5| NIL)
- (|bfVar#6| NIL)
- (|bfVar#4| |alts|)
- (|alt| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#4|))
- (PROGN (SETQ |alt| (CAR |bfVar#4|)) NIL))
- (RETURN |bfVar#5|))
- ((NULL |bfVar#5|)
- (SETQ |bfVar#5| #2=(CONS (|bfCreateDef| |alt|) NIL))
- (SETQ |bfVar#6| |bfVar#5|))
- (T (RPLACD |bfVar#6| #2#)
- (SETQ |bfVar#6| (CDR |bfVar#6|))))
- (SETQ |bfVar#4| (CDR |bfVar#4|))))))))
- (|%Namespace|
- (LET ((|n| (CADR |b|)))
- (PROGN
- (SETQ |$activeNamespace| (SYMBOL-NAME |n|))
- (LIST (LIST 'IN-PACKAGE (SYMBOL-NAME |n|))))))
- (|%Lisp|
- (LET ((|s| (CADR |b|)))
- (|shoeReadLispString| |s| 0)))
- (T (LIST (|translateToplevelExpression| |b|)))))))))
+ (PROGN
+ (SETQ |n| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |t| (CAR |ISTMP#2|)) T))))))
+ (SETQ |sig| (|genDeclaration| |n| |t|)) (SETQ |lhs| |n|)))
+ (COND (|$InteractiveMode| (LIST (LIST 'SETF |lhs| |rhs|)))
+ (T (LIST (LIST 'DEFPARAMETER |lhs| |rhs|)))))))
+ (|%Macro|
+ (LET ((|op| (CADR |b|))
+ (|args| (CADDR |b|))
+ (|body| (CADDDR |b|)))
+ (|bfMDef| |op| |args| |body|)))
+ (|%Structure|
+ (LET ((|t| (CADR |b|)) (|alts| (CADDR |b|)))
+ (COND
+ ((AND (CONSP |alts|) (NULL (CDR |alts|))
+ (PROGN
+ (SETQ |ISTMP#1| (CAR |alts|))
+ (AND (CONSP |ISTMP#1|)
+ (EQ (CAR |ISTMP#1|) '|Enumeration|)
+ (PROGN (SETQ |csts| (CDR |ISTMP#1|)) T))))
+ (LIST (|bfEnum| |t| |csts|)))
+ (T
+ (LET ((|bfVar#5| NIL)
+ (|bfVar#6| NIL)
+ (|bfVar#4| |alts|)
+ (|alt| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#4|))
+ (PROGN (SETQ |alt| (CAR |bfVar#4|)) NIL))
+ (RETURN |bfVar#5|))
+ ((NULL |bfVar#5|)
+ (SETQ |bfVar#5| #2=(CONS (|bfCreateDef| |alt|) NIL))
+ (SETQ |bfVar#6| |bfVar#5|))
+ (T (RPLACD |bfVar#6| #2#)
+ (SETQ |bfVar#6| (CDR |bfVar#6|))))
+ (SETQ |bfVar#4| (CDR |bfVar#4|))))))))
+ (|%Namespace|
+ (LET ((|n| (CADR |b|)))
+ (PROGN
+ (SETQ |$activeNamespace| (SYMBOL-NAME |n|))
+ (LIST (LIST 'IN-PACKAGE (SYMBOL-NAME |n|))))))
+ (|%Lisp|
+ (LET ((|s| (CADR |b|)))
+ (|shoeReadLispString| |s| 0)))
+ (T (LIST (|translateToplevelExpression| |b|))))))))
(DEFUN |shoeAddbootIfNec| (|s|)
- (PROG (|n2| |n1| |ext|)
- (RETURN
- (PROGN
- (SETQ |ext| ".boot")
- (SETQ |n1| (- (LENGTH |ext|) 1))
- (SETQ |n2| (- (- (LENGTH |s|) |n1|) 1))
- (COND
- ((LET ((|bfVar#1| T) (|k| 0))
- (LOOP
- (COND ((> |k| |n1|) (RETURN |bfVar#1|))
- (T
- (SETQ |bfVar#1|
- (CHAR= (SCHAR |ext| |k|) (SCHAR |s| (+ |n2| |k|))))
- (COND ((NOT |bfVar#1|) (RETURN NIL)))))
- (SETQ |k| (+ |k| 1))))
- |s|)
- (T (CONCAT |s| |ext|)))))))
+ (LET* (|n2| |n1| |ext|)
+ (PROGN
+ (SETQ |ext| ".boot")
+ (SETQ |n1| (- (LENGTH |ext|) 1))
+ (SETQ |n2| (- (- (LENGTH |s|) |n1|) 1))
+ (COND
+ ((LET ((|bfVar#1| T) (|k| 0))
+ (LOOP
+ (COND ((> |k| |n1|) (RETURN |bfVar#1|))
+ (T
+ (SETQ |bfVar#1|
+ (CHAR= (SCHAR |ext| |k|) (SCHAR |s| (+ |n2| |k|))))
+ (COND ((NOT |bfVar#1|) (RETURN NIL)))))
+ (SETQ |k| (+ |k| 1))))
+ |s|)
+ (T (CONCAT |s| |ext|))))))
(DEFUN |shoeRemovebootIfNec| (|s|) (|shoeRemoveStringIfNec| ".boot" |s|))
(DEFUN |shoeRemoveStringIfNec| (|str| |s|)
- (PROG (|n|)
- (RETURN
- (COND ((SETQ |n| (|stringSuffix?| |str| |s|)) (|subString| |s| 0 |n|))
- (T |s|)))))
+ (LET* (|n|)
+ (COND ((SETQ |n| (|stringSuffix?| |str| |s|)) (|subString| |s| 0 |n|))
+ (T |s|))))
(DEFUN DEFUSE (|fn|)
- (PROG (|a|)
- (RETURN
- (UNWIND-PROTECT
- (PROGN
- (SETQ |a| (|inputTextFile| (CONCAT |fn| ".boot")))
- (|shoeDfu| |a| |fn|))
- (|closeStream| |a|)))))
+ (LET* (|a|)
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |a| (|inputTextFile| (CONCAT |fn| ".boot")))
+ (|shoeDfu| |a| |fn|))
+ (|closeStream| |a|))))
(DEFPARAMETER |$bootDefined| NIL)
@@ -806,82 +775,80 @@
(DEFPARAMETER |$lispWordTable| NIL)
(DEFUN |shoeDfu| (|a| |fn|)
- (PROG (|stream|)
- (RETURN
- (COND ((NULL |a|) (|shoeNotFound| |fn|))
- (T
- (LET ((|$lispWordTable| (|makeTable| #'EQ)))
- (DECLARE (SPECIAL |$lispWordTable|))
- (PROGN
- (DO-SYMBOLS (|i| (FIND-PACKAGE "LISP"))
- (SETF (|tableValue| |$lispWordTable| |i|) T))
- (LET* ((|$bootDefined| (|makeTable| #'EQ))
- (|$bootUsed| (|makeTable| #'EQ))
- (|$bootDefinedTwice| NIL)
- (|$bfClamming| NIL))
- (DECLARE
- (SPECIAL |$bootDefined| |$bootUsed| |$bootDefinedTwice|
- |$bfClamming|))
- (PROGN
- (|shoeDefUse| (|shoeTransformStream| |a|))
- (UNWIND-PROTECT
- (PROGN
- (SETQ |stream|
- (|outputTextFile| (CONCAT |fn| ".defuse")))
- (|shoeReport| |stream|))
- (|closeStream| |stream|)))))))))))
+ (LET* (|stream|)
+ (COND ((NULL |a|) (|shoeNotFound| |fn|))
+ (T
+ (LET ((|$lispWordTable| (|makeTable| #'EQ)))
+ (DECLARE (SPECIAL |$lispWordTable|))
+ (PROGN
+ (DO-SYMBOLS (|i| (FIND-PACKAGE "LISP"))
+ (SETF (|tableValue| |$lispWordTable| |i|) T))
+ (LET* ((|$bootDefined| (|makeTable| #'EQ))
+ (|$bootUsed| (|makeTable| #'EQ))
+ (|$bootDefinedTwice| NIL)
+ (|$bfClamming| NIL))
+ (DECLARE
+ (SPECIAL |$bootDefined| |$bootUsed| |$bootDefinedTwice|
+ |$bfClamming|))
+ (PROGN
+ (|shoeDefUse| (|shoeTransformStream| |a|))
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |stream|
+ (|outputTextFile| (CONCAT |fn| ".defuse")))
+ (|shoeReport| |stream|))
+ (|closeStream| |stream|))))))))))
(DEFUN |shoeReport| (|stream|)
- (PROG (|b| |a|)
+ (LET* (|b| |a|)
(DECLARE (SPECIAL |$bootUsed| |$bootDefinedTwice| |$bootDefined|))
- (RETURN
- (PROGN
- (|shoeFileLine| "DEFINED and not USED" |stream|)
- (SETQ |a|
- (WITH-HASH-TABLE-ITERATOR (#1=#:G732 |$bootDefined|)
- (LET ((|bfVar#1| NIL) (|bfVar#2| NIL))
- (LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G733 |i| |b|)
- (#1#)
- (COND ((NOT #2#) (RETURN |bfVar#1|))
- (T
- (AND (NOT |b|)
- (COND
- ((NULL |bfVar#1|)
- (SETQ |bfVar#1| #3=(CONS |i| NIL))
- (SETQ |bfVar#2| |bfVar#1|))
- (T (RPLACD |bfVar#2| #3#)
- (SETQ |bfVar#2| (CDR |bfVar#2|))))))))))))
- (|bootOut| (SSORT |a|) |stream|)
- (|shoeFileLine| " " |stream|)
- (|shoeFileLine| "DEFINED TWICE" |stream|)
- (|bootOut| (SSORT |$bootDefinedTwice|) |stream|)
- (|shoeFileLine| " " |stream|)
- (|shoeFileLine| "USED and not DEFINED" |stream|)
- (SETQ |a|
- (WITH-HASH-TABLE-ITERATOR (#4=#:G734 |$bootUsed|)
- (LET ((|bfVar#3| NIL) (|bfVar#4| NIL))
- (LOOP
- (MULTIPLE-VALUE-BIND (#5=#:G735 |i| |b|)
- (#4#)
- (COND ((NOT #5#) (RETURN |bfVar#3|))
- (T
- (AND (NOT |b|)
- (COND
- ((NULL |bfVar#3|)
- (SETQ |bfVar#3| #6=(CONS |i| NIL))
- (SETQ |bfVar#4| |bfVar#3|))
- (T (RPLACD |bfVar#4| #6#)
- (SETQ |bfVar#4| (CDR |bfVar#4|))))))))))))
- (LET ((|bfVar#5| (SSORT |a|)) (|i| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#5|)) (PROGN (SETQ |i| (CAR |bfVar#5|)) NIL))
- (RETURN NIL))
- (T (SETQ |b| (CONCAT (SYMBOL-NAME |i|) " is used in "))
- (|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|)) |stream|
- |b|)))
- (SETQ |bfVar#5| (CDR |bfVar#5|))))))))
+ (PROGN
+ (|shoeFileLine| "DEFINED and not USED" |stream|)
+ (SETQ |a|
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G732 |$bootDefined|)
+ (LET ((|bfVar#1| NIL) (|bfVar#2| NIL))
+ (LOOP
+ (MULTIPLE-VALUE-BIND (#2=#:G733 |i| |b|)
+ (#1#)
+ (COND ((NOT #2#) (RETURN |bfVar#1|))
+ (T
+ (AND (NOT |b|)
+ (COND
+ ((NULL |bfVar#1|)
+ (SETQ |bfVar#1| #3=(CONS |i| NIL))
+ (SETQ |bfVar#2| |bfVar#1|))
+ (T (RPLACD |bfVar#2| #3#)
+ (SETQ |bfVar#2| (CDR |bfVar#2|))))))))))))
+ (|bootOut| (SSORT |a|) |stream|)
+ (|shoeFileLine| " " |stream|)
+ (|shoeFileLine| "DEFINED TWICE" |stream|)
+ (|bootOut| (SSORT |$bootDefinedTwice|) |stream|)
+ (|shoeFileLine| " " |stream|)
+ (|shoeFileLine| "USED and not DEFINED" |stream|)
+ (SETQ |a|
+ (WITH-HASH-TABLE-ITERATOR (#4=#:G734 |$bootUsed|)
+ (LET ((|bfVar#3| NIL) (|bfVar#4| NIL))
+ (LOOP
+ (MULTIPLE-VALUE-BIND (#5=#:G735 |i| |b|)
+ (#4#)
+ (COND ((NOT #5#) (RETURN |bfVar#3|))
+ (T
+ (AND (NOT |b|)
+ (COND
+ ((NULL |bfVar#3|)
+ (SETQ |bfVar#3| #6=(CONS |i| NIL))
+ (SETQ |bfVar#4| |bfVar#3|))
+ (T (RPLACD |bfVar#4| #6#)
+ (SETQ |bfVar#4| (CDR |bfVar#4|))))))))))))
+ (LET ((|bfVar#5| (SSORT |a|)) (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#5|)) (PROGN (SETQ |i| (CAR |bfVar#5|)) NIL))
+ (RETURN NIL))
+ (T (SETQ |b| (CONCAT (SYMBOL-NAME |i|) " is used in "))
+ (|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|)) |stream|
+ |b|)))
+ (SETQ |bfVar#5| (CDR |bfVar#5|)))))))
(DEFUN |shoeDefUse| (|s|)
(LOOP
@@ -889,167 +856,173 @@
(T (|defuse| NIL (CAR |s|)) (SETQ |s| (CDR |s|))))))
(DEFUN |defuse| (|e| |x|)
- (PROG (|niens| |nee| |LETTMP#1| |exp| |ISTMP#5| |id| |ISTMP#4| |ISTMP#3|
- |body| |bv| |ISTMP#2| |name| |ISTMP#1|)
+ (LET* (|niens|
+ |nee|
+ |LETTMP#1|
+ |exp|
+ |ISTMP#5|
+ |id|
+ |ISTMP#4|
+ |ISTMP#3|
+ |body|
+ |bv|
+ |ISTMP#2|
+ |name|
+ |ISTMP#1|)
(DECLARE (SPECIAL |$bootUsed| |$bootDefinedTwice| |$bootDefined| |$used|))
- (RETURN
- (PROGN
- (SETQ |x| (|stripm| |x| *PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
- (SETQ |$used| NIL)
- (SETQ |LETTMP#1|
- (COND
- ((AND (CONSP |x|) (EQ (CAR |x|) 'DEFUN)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |name| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (PROGN
- (SETQ |bv| (CAR |ISTMP#2|))
- (SETQ |body| (CDR |ISTMP#2|))
- T))))))
- (LIST |name| (CONS 'LAMBDA (CONS |bv| |body|))))
- ((AND (CONSP |x|) (EQ (CAR |x|) 'DEFMACRO)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |name| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (PROGN
- (SETQ |bv| (CAR |ISTMP#2|))
- (SETQ |body| (CDR |ISTMP#2|))
- T))))))
- (LIST |name| (CONS 'LAMBDA (CONS |bv| |body|))))
- ((AND (CONSP |x|) (EQ (CAR |x|) 'EVAL-WHEN)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN
- (SETQ |ISTMP#3| (CAR |ISTMP#2|))
- (AND (CONSP |ISTMP#3|)
- (EQ (CAR |ISTMP#3|) 'SETQ)
- (PROGN
- (SETQ |ISTMP#4| (CDR |ISTMP#3|))
- (AND (CONSP |ISTMP#4|)
- (PROGN
- (SETQ |id| (CAR |ISTMP#4|))
- (SETQ |ISTMP#5| (CDR |ISTMP#4|))
- (AND (CONSP |ISTMP#5|)
- (NULL (CDR |ISTMP#5|))
- (PROGN
- (SETQ |exp|
- (CAR |ISTMP#5|))
- T))))))))))))
- (LIST |id| |exp|))
- ((AND (CONSP |x|) (EQ (CAR |x|) 'SETQ)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |id| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |exp| (CAR |ISTMP#2|)) T))))))
- (LIST |id| |exp|))
- (T (LIST 'TOP-LEVEL |x|))))
- (SETQ |nee| (CAR |LETTMP#1|))
- (SETQ |niens| (CADR |LETTMP#1|))
+ (PROGN
+ (SETQ |x| (|stripm| |x| *PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
+ (SETQ |$used| NIL)
+ (SETQ |LETTMP#1|
+ (COND
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'DEFUN)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |name| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (PROGN
+ (SETQ |bv| (CAR |ISTMP#2|))
+ (SETQ |body| (CDR |ISTMP#2|))
+ T))))))
+ (LIST |name| (CONS 'LAMBDA (CONS |bv| |body|))))
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'DEFMACRO)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |name| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (PROGN
+ (SETQ |bv| (CAR |ISTMP#2|))
+ (SETQ |body| (CDR |ISTMP#2|))
+ T))))))
+ (LIST |name| (CONS 'LAMBDA (CONS |bv| |body|))))
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'EVAL-WHEN)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN
+ (SETQ |ISTMP#3| (CAR |ISTMP#2|))
+ (AND (CONSP |ISTMP#3|)
+ (EQ (CAR |ISTMP#3|) 'SETQ)
+ (PROGN
+ (SETQ |ISTMP#4| (CDR |ISTMP#3|))
+ (AND (CONSP |ISTMP#4|)
+ (PROGN
+ (SETQ |id| (CAR |ISTMP#4|))
+ (SETQ |ISTMP#5| (CDR |ISTMP#4|))
+ (AND (CONSP |ISTMP#5|)
+ (NULL (CDR |ISTMP#5|))
+ (PROGN
+ (SETQ |exp| (CAR |ISTMP#5|))
+ T))))))))))))
+ (LIST |id| |exp|))
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'SETQ)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |id| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |exp| (CAR |ISTMP#2|)) T))))))
+ (LIST |id| |exp|))
+ (T (LIST 'TOP-LEVEL |x|))))
+ (SETQ |nee| (CAR |LETTMP#1|))
+ (SETQ |niens| (CADR |LETTMP#1|))
+ (COND
+ ((|tableValue| |$bootDefined| |nee|)
+ (SETQ |$bootDefinedTwice|
+ (COND ((EQ |nee| 'TOP-LEVEL) |$bootDefinedTwice|)
+ (T (CONS |nee| |$bootDefinedTwice|)))))
+ (T (SETF (|tableValue| |$bootDefined| |nee|) T)))
+ (|defuse1| |e| |niens|)
+ (LET ((|bfVar#1| |$used|) (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T
+ (SETF (|tableValue| |$bootUsed| |i|)
+ (CONS |nee| (|tableValue| |$bootUsed| |i|)))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))))
+
+(DEFUN |defuse1| (|e| |y|)
+ (LET* (|ndol| |dol| |LETTMP#1| |b| |a| |ISTMP#1|)
+ (DECLARE (SPECIAL |$bootDefined| |$used|))
+ (COND
+ ((NOT (CONSP |y|))
(COND
- ((|tableValue| |$bootDefined| |nee|)
- (SETQ |$bootDefinedTwice|
- (COND ((EQ |nee| 'TOP-LEVEL) |$bootDefinedTwice|)
- (T (CONS |nee| |$bootDefinedTwice|)))))
- (T (SETF (|tableValue| |$bootDefined| |nee|) T)))
- (|defuse1| |e| |niens|)
- (LET ((|bfVar#1| |$used|) (|i| NIL))
+ ((SYMBOLP |y|)
+ (SETQ |$used|
+ (COND ((|symbolMember?| |y| |e|) |$used|)
+ ((|symbolMember?| |y| |$used|) |$used|)
+ ((|defusebuiltin| |y|) |$used|)
+ (T (UNION (LIST |y|) |$used|)))))
+ (T NIL)))
+ ((AND (CONSP |y|) (EQ (CAR |y|) 'LAMBDA)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |y|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |a| (CAR |ISTMP#1|))
+ (SETQ |b| (CDR |ISTMP#1|))
+ T))))
+ (|defuse1| (|append| (|unfluidlist| |a|) |e|) |b|))
+ ((AND (CONSP |y|) (EQ (CAR |y|) 'PROG)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |y|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |a| (CAR |ISTMP#1|))
+ (SETQ |b| (CDR |ISTMP#1|))
+ T))))
+ (SETQ |LETTMP#1| (|defSeparate| |a|)) (SETQ |dol| (CAR |LETTMP#1|))
+ (SETQ |ndol| (CADR |LETTMP#1|))
+ (LET ((|bfVar#1| |dol|) (|i| NIL))
(LOOP
(COND
((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
(RETURN NIL))
- (T
- (SETF (|tableValue| |$bootUsed| |i|)
- (CONS |nee| (|tableValue| |$bootUsed| |i|)))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
-
-(DEFUN |defuse1| (|e| |y|)
- (PROG (|ndol| |dol| |LETTMP#1| |b| |a| |ISTMP#1|)
- (DECLARE (SPECIAL |$bootDefined| |$used|))
- (RETURN
- (COND
- ((NOT (CONSP |y|))
- (COND
- ((SYMBOLP |y|)
- (SETQ |$used|
- (COND ((|symbolMember?| |y| |e|) |$used|)
- ((|symbolMember?| |y| |$used|) |$used|)
- ((|defusebuiltin| |y|) |$used|)
- (T (UNION (LIST |y|) |$used|)))))
- (T NIL)))
- ((AND (CONSP |y|) (EQ (CAR |y|) 'LAMBDA)
- (PROGN
- (SETQ |ISTMP#1| (CDR |y|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |a| (CAR |ISTMP#1|))
- (SETQ |b| (CDR |ISTMP#1|))
- T))))
- (|defuse1| (|append| (|unfluidlist| |a|) |e|) |b|))
- ((AND (CONSP |y|) (EQ (CAR |y|) 'PROG)
- (PROGN
- (SETQ |ISTMP#1| (CDR |y|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |a| (CAR |ISTMP#1|))
- (SETQ |b| (CDR |ISTMP#1|))
- T))))
- (SETQ |LETTMP#1| (|defSeparate| |a|)) (SETQ |dol| (CAR |LETTMP#1|))
- (SETQ |ndol| (CADR |LETTMP#1|))
- (LET ((|bfVar#1| |dol|) (|i| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (SETF (|tableValue| |$bootDefined| |i|) T)))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- (|defuse1| (|append| |ndol| |e|) |b|))
- ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE)) (SETQ |a| (CDR |y|)) NIL)
- ((AND (CONSP |y|) (EQ (CAR |y|) '+LINE)) (SETQ |a| (CDR |y|)) NIL)
- (T
- (LET ((|bfVar#2| |y|) (|i| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#2|)) (PROGN (SETQ |i| (CAR |bfVar#2|)) NIL))
- (RETURN NIL))
- (T (|defuse1| |e| |i|)))
- (SETQ |bfVar#2| (CDR |bfVar#2|)))))))))
+ (T (SETF (|tableValue| |$bootDefined| |i|) T)))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (|defuse1| (|append| |ndol| |e|) |b|))
+ ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE)) (SETQ |a| (CDR |y|)) NIL)
+ ((AND (CONSP |y|) (EQ (CAR |y|) '+LINE)) (SETQ |a| (CDR |y|)) NIL)
+ (T
+ (LET ((|bfVar#2| |y|) (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#2|)) (PROGN (SETQ |i| (CAR |bfVar#2|)) NIL))
+ (RETURN NIL))
+ (T (|defuse1| |e| |i|)))
+ (SETQ |bfVar#2| (CDR |bfVar#2|))))))))
(DEFUN |defSeparate| (|x|)
- (PROG (|x2| |x1| |LETTMP#1| |f|)
- (RETURN
- (COND ((NULL |x|) (LIST NIL NIL))
- (T (SETQ |f| (CAR |x|)) (SETQ |LETTMP#1| (|defSeparate| (CDR |x|)))
- (SETQ |x1| (CAR |LETTMP#1|)) (SETQ |x2| (CADR |LETTMP#1|))
- (COND ((|bfBeginsDollar| |f|) (LIST (CONS |f| |x1|) |x2|))
- (T (LIST |x1| (CONS |f| |x2|)))))))))
+ (LET* (|x2| |x1| |LETTMP#1| |f|)
+ (COND ((NULL |x|) (LIST NIL NIL))
+ (T (SETQ |f| (CAR |x|)) (SETQ |LETTMP#1| (|defSeparate| (CDR |x|)))
+ (SETQ |x1| (CAR |LETTMP#1|)) (SETQ |x2| (CADR |LETTMP#1|))
+ (COND ((|bfBeginsDollar| |f|) (LIST (CONS |f| |x1|) |x2|))
+ (T (LIST |x1| (CONS |f| |x2|))))))))
(DEFUN |unfluidlist| (|x|)
- (PROG (|y| |ISTMP#1|)
- (RETURN
- (COND ((NULL |x|) NIL) ((NOT (CONSP |x|)) (LIST |x|))
- ((AND (CONSP |x|) (EQ (CAR |x|) '&REST)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |y| (CAR |ISTMP#1|)) T))))
- (LIST |y|))
- (T (CONS (CAR |x|) (|unfluidlist| (CDR |x|))))))))
+ (LET* (|y| |ISTMP#1|)
+ (COND ((NULL |x|) NIL) ((NOT (CONSP |x|)) (LIST |x|))
+ ((AND (CONSP |x|) (EQ (CAR |x|) '&REST)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |y| (CAR |ISTMP#1|)) T))))
+ (LIST |y|))
+ (T (CONS (CAR |x|) (|unfluidlist| (CDR |x|)))))))
(DEFUN |defusebuiltin| (|x|)
(DECLARE (SPECIAL |$lispWordTable|))
@@ -1069,98 +1042,92 @@
(DEFUN SSORT (|l|) (SORT |l| #'CLESSP))
(DEFUN |bootOutLines| (|l| |outfn| |s|)
- (PROG (|a|)
- (RETURN
- (COND ((NULL |l|) (|shoeFileLine| |s| |outfn|))
- (T (SETQ |a| (PNAME (CAR |l|)))
- (COND
- ((< 70 (+ (LENGTH |s|) (LENGTH |a|))) (|shoeFileLine| |s| |outfn|)
- (|bootOutLines| |l| |outfn| " "))
- (T (|bootOutLines| (CDR |l|) |outfn| (CONCAT |s| " " |a|)))))))))
+ (LET* (|a|)
+ (COND ((NULL |l|) (|shoeFileLine| |s| |outfn|))
+ (T (SETQ |a| (PNAME (CAR |l|)))
+ (COND
+ ((< 70 (+ (LENGTH |s|) (LENGTH |a|))) (|shoeFileLine| |s| |outfn|)
+ (|bootOutLines| |l| |outfn| " "))
+ (T (|bootOutLines| (CDR |l|) |outfn| (CONCAT |s| " " |a|))))))))
(DEFUN XREF (|fn|)
- (PROG (|a|)
- (RETURN
- (UNWIND-PROTECT
- (PROGN
- (SETQ |a| (|inputTextFile| (CONCAT |fn| ".boot")))
- (|shoeXref| |a| |fn|))
- (|closeStream| |a|)))))
+ (LET* (|a|)
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |a| (|inputTextFile| (CONCAT |fn| ".boot")))
+ (|shoeXref| |a| |fn|))
+ (|closeStream| |a|))))
(DEFUN |shoeXref| (|a| |fn|)
- (PROG (|stream| |out|)
- (RETURN
- (COND ((NULL |a|) (|shoeNotFound| |fn|))
- (T
- (LET ((|$lispWordTable| (|makeTable| #'EQ)))
- (DECLARE (SPECIAL |$lispWordTable|))
- (PROGN
- (DO-SYMBOLS (|i| (FIND-PACKAGE "LISP"))
- (SETF (|tableValue| |$lispWordTable| |i|) T))
- (LET* ((|$bootDefined| (|makeTable| #'EQ))
- (|$bootUsed| (|makeTable| #'EQ))
- (|$bfClamming| NIL))
- (DECLARE (SPECIAL |$bootDefined| |$bootUsed| |$bfClamming|))
- (PROGN
- (|shoeDefUse| (|shoeTransformStream| |a|))
- (SETQ |out| (CONCAT |fn| ".xref"))
- (UNWIND-PROTECT
- (PROGN
- (SETQ |stream| (|outputTextFile| |out|))
- (|shoeXReport| |stream|)
- |out|)
- (|closeStream| |stream|)))))))))))
+ (LET* (|stream| |out|)
+ (COND ((NULL |a|) (|shoeNotFound| |fn|))
+ (T
+ (LET ((|$lispWordTable| (|makeTable| #'EQ)))
+ (DECLARE (SPECIAL |$lispWordTable|))
+ (PROGN
+ (DO-SYMBOLS (|i| (FIND-PACKAGE "LISP"))
+ (SETF (|tableValue| |$lispWordTable| |i|) T))
+ (LET* ((|$bootDefined| (|makeTable| #'EQ))
+ (|$bootUsed| (|makeTable| #'EQ))
+ (|$bfClamming| NIL))
+ (DECLARE (SPECIAL |$bootDefined| |$bootUsed| |$bfClamming|))
+ (PROGN
+ (|shoeDefUse| (|shoeTransformStream| |a|))
+ (SETQ |out| (CONCAT |fn| ".xref"))
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |stream| (|outputTextFile| |out|))
+ (|shoeXReport| |stream|)
+ |out|)
+ (|closeStream| |stream|))))))))))
(DEFUN |shoeXReport| (|stream|)
- (PROG (|a| |c|)
+ (LET* (|a| |c|)
(DECLARE (SPECIAL |$bootUsed|))
- (RETURN
- (PROGN
- (|shoeFileLine| "USED and where DEFINED" |stream|)
- (SETQ |c|
- (SSORT
- (WITH-HASH-TABLE-ITERATOR (#1=#:G738 |$bootUsed|)
- (LET ((|bfVar#1| NIL) (|bfVar#2| NIL))
- (LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G739 |k| #:G740)
- (#1#)
- (COND ((NOT #2#) (RETURN |bfVar#1|))
- ((NULL |bfVar#1|)
- (SETQ |bfVar#1| #3=(CONS |k| NIL))
- (SETQ |bfVar#2| |bfVar#1|))
- (T (RPLACD |bfVar#2| #3#)
- (SETQ |bfVar#2| (CDR |bfVar#2|))))))))))
- (LET ((|bfVar#3| |c|) (|i| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#3|)) (PROGN (SETQ |i| (CAR |bfVar#3|)) NIL))
- (RETURN NIL))
- (T (SETQ |a| (CONCAT (SYMBOL-NAME |i|) " is used in "))
- (|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|)) |stream|
- |a|)))
- (SETQ |bfVar#3| (CDR |bfVar#3|))))))))
+ (PROGN
+ (|shoeFileLine| "USED and where DEFINED" |stream|)
+ (SETQ |c|
+ (SSORT
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G738 |$bootUsed|)
+ (LET ((|bfVar#1| NIL) (|bfVar#2| NIL))
+ (LOOP
+ (MULTIPLE-VALUE-BIND (#2=#:G739 |k| #:G740)
+ (#1#)
+ (COND ((NOT #2#) (RETURN |bfVar#1|))
+ ((NULL |bfVar#1|) (SETQ |bfVar#1| #3=(CONS |k| NIL))
+ (SETQ |bfVar#2| |bfVar#1|))
+ (T (RPLACD |bfVar#2| #3#)
+ (SETQ |bfVar#2| (CDR |bfVar#2|))))))))))
+ (LET ((|bfVar#3| |c|) (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#3|)) (PROGN (SETQ |i| (CAR |bfVar#3|)) NIL))
+ (RETURN NIL))
+ (T (SETQ |a| (CONCAT (SYMBOL-NAME |i|) " is used in "))
+ (|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|)) |stream|
+ |a|)))
+ (SETQ |bfVar#3| (CDR |bfVar#3|)))))))
(DEFUN |shoeItem| (|str|)
- (PROG (|dq|)
- (RETURN
- (PROGN
- (SETQ |dq| (CAR |str|))
- (CONS
- (LIST
- (LET ((|bfVar#2| NIL)
- (|bfVar#3| NIL)
- (|bfVar#1| (|shoeDQlines| |dq|))
- (|line| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS (CAR |line|) NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))
- (CDR |str|))))))
+ (LET* (|dq|)
+ (PROGN
+ (SETQ |dq| (CAR |str|))
+ (CONS
+ (LIST
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| (|shoeDQlines| |dq|))
+ (|line| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS (CAR |line|) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+ (CDR |str|)))))
(DEFUN |stripm| (|x| |pk| |bt|)
(COND
@@ -1173,25 +1140,24 @@
(T (CONS (|stripm| (CAR |x|) |pk| |bt|) (|stripm| (CDR |x|) |pk| |bt|)))))
(DEFUN |shoePCompile| (|fn|)
- (PROG (|body| |bv| |ISTMP#2| |name| |ISTMP#1|)
- (RETURN
- (PROGN
- (SETQ |fn| (|stripm| |fn| *PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
- (COND
- ((AND (CONSP |fn|) (EQ (CAR |fn|) 'DEFUN)
- (PROGN
- (SETQ |ISTMP#1| (CDR |fn|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |name| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (PROGN
- (SETQ |bv| (CAR |ISTMP#2|))
- (SETQ |body| (CDR |ISTMP#2|))
- T))))))
- (COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|))))
- (T (EVAL |fn|)))))))
+ (LET* (|body| |bv| |ISTMP#2| |name| |ISTMP#1|)
+ (PROGN
+ (SETQ |fn| (|stripm| |fn| *PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
+ (COND
+ ((AND (CONSP |fn|) (EQ (CAR |fn|) 'DEFUN)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |fn|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |name| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (PROGN
+ (SETQ |bv| (CAR |ISTMP#2|))
+ (SETQ |body| (CDR |ISTMP#2|))
+ T))))))
+ (COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|))))
+ (T (EVAL |fn|))))))
(DEFUN |shoePCompileTrees| (|s|)
(LOOP
@@ -1207,30 +1173,27 @@
(|shoePCompileTrees| (|shoeTransformString| |string|)))
(DEFUN BOOTLOOP ()
- (PROG (|stream| |a|)
- (RETURN
- (PROGN
- (SETQ |a| (|readLine| *STANDARD-INPUT*))
- (COND
- ((EQL (LENGTH |a|) 0) (WRITE-LINE "Boot Loop; to exit type ] ")
- (BOOTLOOP))
- ((|shoePrefix?| ")console" |a|) (SETQ |stream| *TERMINAL-IO*)
- (PSTTOMC (|bRgen| |stream|)) (BOOTLOOP))
- ((CHAR= (SCHAR |a| 0) (|char| '])) NIL)
- (T (PSTTOMC (LIST |a|)) (BOOTLOOP)))))))
+ (LET* (|stream| |a|)
+ (PROGN
+ (SETQ |a| (|readLine| *STANDARD-INPUT*))
+ (COND
+ ((EQL (LENGTH |a|) 0) (WRITE-LINE "Boot Loop; to exit type ] ")
+ (BOOTLOOP))
+ ((|shoePrefix?| ")console" |a|) (SETQ |stream| *TERMINAL-IO*)
+ (PSTTOMC (|bRgen| |stream|)) (BOOTLOOP))
+ ((CHAR= (SCHAR |a| 0) (|char| '])) NIL)
+ (T (PSTTOMC (LIST |a|)) (BOOTLOOP))))))
(DEFUN BOOTPO ()
- (PROG (|stream| |a|)
- (RETURN
- (PROGN
- (SETQ |a| (|readLine| *STANDARD-INPUT*))
- (COND
- ((EQL (LENGTH |a|) 0) (WRITE-LINE "Boot Loop; to exit type ] ")
- (BOOTPO))
- ((|shoePrefix?| ")console" |a|) (SETQ |stream| *TERMINAL-IO*)
- (PSTOUT (|bRgen| |stream|)) (BOOTPO))
- ((CHAR= (SCHAR |a| 0) (|char| '])) NIL)
- (T (PSTOUT (LIST |a|)) (BOOTPO)))))))
+ (LET* (|stream| |a|)
+ (PROGN
+ (SETQ |a| (|readLine| *STANDARD-INPUT*))
+ (COND
+ ((EQL (LENGTH |a|) 0) (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTPO))
+ ((|shoePrefix?| ")console" |a|) (SETQ |stream| *TERMINAL-IO*)
+ (PSTOUT (|bRgen| |stream|)) (BOOTPO))
+ ((CHAR= (SCHAR |a| 0) (|char| '])) NIL)
+ (T (PSTOUT (LIST |a|)) (BOOTPO))))))
(DEFUN PSTOUT (|string|)
(LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
@@ -1240,24 +1203,22 @@
(CONCAT (|pathBasename| |file|) ".clisp"))
(DEFUN |getIntermediateLispFile| (|file| |options|)
- (PROG (|out|)
- (RETURN
- (PROGN
- (SETQ |out| (NAMESTRING (|getOutputPathname| |options|)))
- (COND
- (|out|
- (CONCAT (|shoeRemoveStringIfNec| (CONCAT "." |$faslType|) |out|)
- ".clisp"))
- (T (|defaultBootToLispFile| |file|)))))))
+ (LET* (|out|)
+ (PROGN
+ (SETQ |out| (NAMESTRING (|getOutputPathname| |options|)))
+ (COND
+ (|out|
+ (CONCAT (|shoeRemoveStringIfNec| (CONCAT "." |$faslType|) |out|)
+ ".clisp"))
+ (T (|defaultBootToLispFile| |file|))))))
(DEFUN |translateBootFile| (|progname| |options| |file|)
- (PROG (|outFile|)
- (RETURN
- (PROGN
- (SETQ |outFile|
- (OR (|getOutputPathname| |options|)
- (|defaultBootToLispFile| |file|)))
- (BOOTTOCL |file| (ENOUGH-NAMESTRING |outFile|))))))
+ (LET* (|outFile|)
+ (PROGN
+ (SETQ |outFile|
+ (OR (|getOutputPathname| |options|)
+ (|defaultBootToLispFile| |file|)))
+ (BOOTTOCL |file| (ENOUGH-NAMESTRING |outFile|)))))
(DEFUN |retainFile?| (|ext|)
(COND
@@ -1268,18 +1229,17 @@
(T (MEMBER (|Option| |ext|) |$FilesToRetain|))))
(DEFUN |compileBootHandler| (|progname| |options| |file|)
- (PROG (|objFile| |intFile|)
- (RETURN
- (PROGN
- (SETQ |intFile|
- (BOOTTOCL |file| (|getIntermediateLispFile| |file| |options|)))
- (COND ((NOT (EQL (|errorCount|) 0)) NIL)
- (|intFile|
- (SETQ |objFile|
- (|compileLispHandler| |progname| |options| |intFile|))
- (COND ((NOT (|retainFile?| '|lisp|)) (DELETE-FILE |intFile|)))
- |objFile|)
- (T NIL))))))
+ (LET* (|objFile| |intFile|)
+ (PROGN
+ (SETQ |intFile|
+ (BOOTTOCL |file| (|getIntermediateLispFile| |file| |options|)))
+ (COND ((NOT (EQL (|errorCount|) 0)) NIL)
+ (|intFile|
+ (SETQ |objFile|
+ (|compileLispHandler| |progname| |options| |intFile|))
+ (COND ((NOT (|retainFile?| '|lisp|)) (DELETE-FILE |intFile|)))
+ |objFile|)
+ (T NIL)))))
(|associateRequestWithFileType| (|Option| "translate") "boot"
#'|translateBootFile|)
diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp
index f49dbe7e..80244b61 100644
--- a/src/boot/strap/utility.clisp
+++ b/src/boot/strap/utility.clisp
@@ -220,47 +220,43 @@
(T (RETURN (EQUAL |x| |l|))))))
(DEFUN |reverse| (|l|)
- (PROG (|r|)
- (RETURN
- (PROGN
- (SETQ |r| NIL)
- (LOOP
- (COND ((CONSP |l|) (SETQ |r| (CONS (CAR |l|) |r|)) (SETQ |l| (CDR |l|)))
- (T (RETURN |r|))))))))
+ (LET* (|r|)
+ (PROGN
+ (SETQ |r| NIL)
+ (LOOP
+ (COND ((CONSP |l|) (SETQ |r| (CONS (CAR |l|) |r|)) (SETQ |l| (CDR |l|)))
+ (T (RETURN |r|)))))))
(DEFUN |reverse!| (|l|)
- (PROG (|l2| |l1|)
- (RETURN
- (PROGN
- (SETQ |l1| NIL)
- (LOOP
- (COND
- ((CONSP |l|) (SETQ |l2| (CDR |l|)) (RPLACD |l| |l1|) (SETQ |l1| |l|)
- (SETQ |l| |l2|))
- (T (RETURN |l1|))))))))
+ (LET* (|l2| |l1|)
+ (PROGN
+ (SETQ |l1| NIL)
+ (LOOP
+ (COND
+ ((CONSP |l|) (SETQ |l2| (CDR |l|)) (RPLACD |l| |l1|) (SETQ |l1| |l|)
+ (SETQ |l| |l2|))
+ (T (RETURN |l1|)))))))
(DEFUN |lastNode| (|l|)
- (PROG (|l'|)
- (RETURN
- (PROGN
- (LOOP
- (COND
- ((NOT (AND (CONSP |l|) (PROGN (SETQ |l'| (CDR |l|)) T) (CONSP |l'|)))
- (RETURN NIL))
- (T (SETQ |l| |l'|))))
- |l|))))
+ (LET* (|l'|)
+ (PROGN
+ (LOOP
+ (COND
+ ((NOT (AND (CONSP |l|) (PROGN (SETQ |l'| (CDR |l|)) T) (CONSP |l'|)))
+ (RETURN NIL))
+ (T (SETQ |l| |l'|))))
+ |l|)))
(DEFUN |copyList| (|l|)
- (PROG (|l'| |t|)
- (RETURN
- (COND ((NOT (CONSP |l|)) |l|)
- (T (SETQ |l'| (SETQ |t| (LIST (CAR |l|))))
- (LOOP
- (PROGN
- (SETQ |l| (CDR |l|))
- (COND
- ((CONSP |l|) (RPLACD |t| (LIST (CAR |l|))) (SETQ |t| (CDR |t|)))
- (T (RPLACD |t| |l|) (RETURN |l'|))))))))))
+ (LET* (|l'| |t|)
+ (COND ((NOT (CONSP |l|)) |l|)
+ (T (SETQ |l'| (SETQ |t| (LIST (CAR |l|))))
+ (LOOP
+ (PROGN
+ (SETQ |l| (CDR |l|))
+ (COND
+ ((CONSP |l|) (RPLACD |t| (LIST (CAR |l|))) (SETQ |t| (CDR |t|)))
+ (T (RPLACD |t| |l|) (RETURN |l'|)))))))))
(DEFUN |append!| (|x| |y|)
(COND ((NULL |x|) |y|) ((NULL |y|) |x|)
@@ -269,24 +265,22 @@
(DEFUN |append| (|x| |y|) (|append!| (|copyList| |x|) |y|))
(DEFUN |symbolAssoc| (|s| |l|)
- (PROG (|x|)
- (RETURN
- (LOOP
- (COND
- ((NOT
- (AND (CONSP |l|) (PROGN (SETQ |x| (CAR |l|)) (SETQ |l| (CDR |l|)) T)))
- (RETURN NIL))
- ((AND (CONSP |x|) (EQ |s| (CAR |x|))) (RETURN |x|)))))))
+ (LET* (|x|)
+ (LOOP
+ (COND
+ ((NOT
+ (AND (CONSP |l|) (PROGN (SETQ |x| (CAR |l|)) (SETQ |l| (CDR |l|)) T)))
+ (RETURN NIL))
+ ((AND (CONSP |x|) (EQ |s| (CAR |x|))) (RETURN |x|))))))
(DEFUN |objectAssoc| (|x| |l|)
- (PROG (|p|)
- (RETURN
- (LOOP
- (COND
- ((NOT
- (AND (CONSP |l|) (PROGN (SETQ |p| (CAR |l|)) (SETQ |l| (CDR |l|)) T)))
- (RETURN NIL))
- ((AND (CONSP |p|) (EQ (CAR |p|) |x|)) (RETURN |p|)))))))
+ (LET* (|p|)
+ (LOOP
+ (COND
+ ((NOT
+ (AND (CONSP |l|) (PROGN (SETQ |p| (CAR |l|)) (SETQ |l| (CDR |l|)) T)))
+ (RETURN NIL))
+ ((AND (CONSP |p|) (EQ (CAR |p|) |x|)) (RETURN |p|))))))
(DEFUN |substitute!| (|y| |x| |s|)
(COND ((NULL |s|) NIL) ((EQ |x| |s|) |y|)
@@ -297,88 +291,82 @@
|s|)))
(DEFUN |substitute| (|y| |x| |s|)
- (PROG (|t| |h|)
- (RETURN
- (COND ((NULL |s|) NIL) ((EQ |x| |s|) |y|)
- ((CONSP |s|) (SETQ |h| (|substitute| |y| |x| (CAR |s|)))
- (SETQ |t| (|substitute| |y| |x| (CDR |s|)))
- (COND ((AND (EQ |h| (CAR |s|)) (EQ |t| (CDR |s|))) |s|)
- (T (CONS |h| |t|))))
- (T |s|)))))
+ (LET* (|t| |h|)
+ (COND ((NULL |s|) NIL) ((EQ |x| |s|) |y|)
+ ((CONSP |s|) (SETQ |h| (|substitute| |y| |x| (CAR |s|)))
+ (SETQ |t| (|substitute| |y| |x| (CDR |s|)))
+ (COND ((AND (EQ |h| (CAR |s|)) (EQ |t| (CDR |s|))) |s|)
+ (T (CONS |h| |t|))))
+ (T |s|))))
(DEFUN |applySubst| (|sl| |t|)
- (PROG (|p| |tl| |hd|)
- (RETURN
- (COND ((NULL |sl|) |t|)
- ((CONSP |t|) (SETQ |hd| (|applySubst| |sl| (CAR |t|)))
- (SETQ |tl| (|applySubst| |sl| (CDR |t|)))
- (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|)
- (T (CONS |hd| |tl|))))
- ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|))
- (T |t|)))))
+ (LET* (|p| |tl| |hd|)
+ (COND ((NULL |sl|) |t|)
+ ((CONSP |t|) (SETQ |hd| (|applySubst| |sl| (CAR |t|)))
+ (SETQ |tl| (|applySubst| |sl| (CDR |t|)))
+ (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|)
+ (T (CONS |hd| |tl|))))
+ ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|))
+ (T |t|))))
(DEFUN |applySubst!| (|sl| |t|)
- (PROG (|p| |tl| |hd|)
- (RETURN
- (COND ((NULL |sl|) |t|)
- ((CONSP |t|) (SETQ |hd| (|applySubst!| |sl| (CAR |t|)))
- (SETQ |tl| (|applySubst!| |sl| (CDR |t|))) (RPLACA |t| |hd|)
- (RPLACD |t| |tl|))
- ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|))
- (T |t|)))))
+ (LET* (|p| |tl| |hd|)
+ (COND ((NULL |sl|) |t|)
+ ((CONSP |t|) (SETQ |hd| (|applySubst!| |sl| (CAR |t|)))
+ (SETQ |tl| (|applySubst!| |sl| (CDR |t|))) (RPLACA |t| |hd|)
+ (RPLACD |t| |tl|))
+ ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|))
+ (T |t|))))
(DEFUN |applySubstNQ| (|sl| |t|)
- (PROG (|p| |tl| |hd|)
- (RETURN
- (COND ((NULL |sl|) |t|)
- ((AND (CONSP |t|)
- (PROGN (SETQ |hd| (CAR |t|)) (SETQ |tl| (CDR |t|)) T))
- (COND ((EQ |hd| 'QUOTE) |t|)
- (T (SETQ |hd| (|applySubstNQ| |sl| |hd|))
- (SETQ |tl| (|applySubstNQ| |sl| |tl|))
- (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|)
- (T (CONS |hd| |tl|))))))
- ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|))
- (T |t|)))))
+ (LET* (|p| |tl| |hd|)
+ (COND ((NULL |sl|) |t|)
+ ((AND (CONSP |t|)
+ (PROGN (SETQ |hd| (CAR |t|)) (SETQ |tl| (CDR |t|)) T))
+ (COND ((EQ |hd| 'QUOTE) |t|)
+ (T (SETQ |hd| (|applySubstNQ| |sl| |hd|))
+ (SETQ |tl| (|applySubstNQ| |sl| |tl|))
+ (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|)
+ (T (CONS |hd| |tl|))))))
+ ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|))
+ (T |t|))))
(DEFUN |setDifference| (|x| |y|)
- (PROG (|a| |l| |p|)
- (RETURN
- (COND ((NULL |x|) NIL) ((NULL |y|) |x|)
- (T (SETQ |l| (SETQ |p| (LIST NIL)))
- (LET ((|bfVar#1| |x|))
- (LOOP
- (COND ((NOT (CONSP |bfVar#1|)) (RETURN NIL))
- (T
- (AND (CONSP |bfVar#1|)
- (PROGN (SETQ |a| (CAR |bfVar#1|)) T)
- (NOT (|objectMember?| |a| |y|))
- (PROGN
- (RPLACD |p| (LIST |a|))
- (SETQ |p| (CDR |p|))))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- (CDR |l|))))))
+ (LET* (|a| |l| |p|)
+ (COND ((NULL |x|) NIL) ((NULL |y|) |x|)
+ (T (SETQ |l| (SETQ |p| (LIST NIL)))
+ (LET ((|bfVar#1| |x|))
+ (LOOP
+ (COND ((NOT (CONSP |bfVar#1|)) (RETURN NIL))
+ (T
+ (AND (CONSP |bfVar#1|)
+ (PROGN (SETQ |a| (CAR |bfVar#1|)) T)
+ (NOT (|objectMember?| |a| |y|))
+ (PROGN
+ (RPLACD |p| (LIST |a|))
+ (SETQ |p| (CDR |p|))))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (CDR |l|)))))
(DEFUN |setUnion| (|x| |y|)
- (PROG (|z|)
- (RETURN
- (PROGN
- (SETQ |z| NIL)
- (LET ((|bfVar#1| |x|) (|a| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |a| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (AND (NOT (|objectMember?| |a| |z|)) (SETQ |z| (CONS |a| |z|)))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- (LET ((|bfVar#2| |y|) (|a| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#2|)) (PROGN (SETQ |a| (CAR |bfVar#2|)) NIL))
- (RETURN NIL))
- (T (AND (NOT (|objectMember?| |a| |z|)) (SETQ |z| (CONS |a| |z|)))))
- (SETQ |bfVar#2| (CDR |bfVar#2|))))
- (|reverse!| |z|)))))
+ (LET* (|z|)
+ (PROGN
+ (SETQ |z| NIL)
+ (LET ((|bfVar#1| |x|) (|a| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |a| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (AND (NOT (|objectMember?| |a| |z|)) (SETQ |z| (CONS |a| |z|)))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (LET ((|bfVar#2| |y|) (|a| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#2|)) (PROGN (SETQ |a| (CAR |bfVar#2|)) NIL))
+ (RETURN NIL))
+ (T (AND (NOT (|objectMember?| |a| |z|)) (SETQ |z| (CONS |a| |z|)))))
+ (SETQ |bfVar#2| (CDR |bfVar#2|))))
+ (|reverse!| |z|))))
(DEFUN |setIntersection| (|x| |y|)
(LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |x|) (|a| NIL))
@@ -395,47 +383,43 @@
(SETQ |bfVar#1| (CDR |bfVar#1|)))))
(DEFUN |removeSymbol| (|l| |x|)
- (PROG (|y| |LETTMP#1| |l'| |before|)
- (RETURN
- (PROGN
- (SETQ |before| NIL)
- (SETQ |l'| |l|)
- (LOOP
- (COND ((NOT (CONSP |l'|)) (RETURN |l|))
- (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
- (SETQ |l'| (CDR |LETTMP#1|))
- (COND
- ((EQ |x| |y|) (RETURN (|append!| (|reverse!| |before|) |l'|)))
- (T (SETQ |before| (CONS |y| |before|)))))))))))
+ (LET* (|y| |LETTMP#1| |l'| |before|)
+ (PROGN
+ (SETQ |before| NIL)
+ (SETQ |l'| |l|)
+ (LOOP
+ (COND ((NOT (CONSP |l'|)) (RETURN |l|))
+ (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
+ (SETQ |l'| (CDR |LETTMP#1|))
+ (COND
+ ((EQ |x| |y|) (RETURN (|append!| (|reverse!| |before|) |l'|)))
+ (T (SETQ |before| (CONS |y| |before|))))))))))
(DEFUN |removeScalar| (|l| |x|)
- (PROG (|y| |LETTMP#1| |l'| |before|)
- (RETURN
- (PROGN
- (SETQ |before| NIL)
- (SETQ |l'| |l|)
- (LOOP
- (COND ((NOT (CONSP |l'|)) (RETURN |l|))
- (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
- (SETQ |l'| (CDR |LETTMP#1|))
- (COND
- ((EQL |x| |y|) (RETURN (|append!| (|reverse!| |before|) |l'|)))
- (T (SETQ |before| (CONS |y| |before|)))))))))))
+ (LET* (|y| |LETTMP#1| |l'| |before|)
+ (PROGN
+ (SETQ |before| NIL)
+ (SETQ |l'| |l|)
+ (LOOP
+ (COND ((NOT (CONSP |l'|)) (RETURN |l|))
+ (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
+ (SETQ |l'| (CDR |LETTMP#1|))
+ (COND
+ ((EQL |x| |y|) (RETURN (|append!| (|reverse!| |before|) |l'|)))
+ (T (SETQ |before| (CONS |y| |before|))))))))))
(DEFUN |removeValue| (|l| |x|)
- (PROG (|y| |LETTMP#1| |l'| |before|)
- (RETURN
- (PROGN
- (SETQ |before| NIL)
- (SETQ |l'| |l|)
- (LOOP
- (COND ((NOT (CONSP |l'|)) (RETURN |l|))
- (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
- (SETQ |l'| (CDR |LETTMP#1|))
- (COND
- ((EQUAL |x| |y|)
- (RETURN (|append!| (|reverse!| |before|) |l'|)))
- (T (SETQ |before| (CONS |y| |before|)))))))))))
+ (LET* (|y| |LETTMP#1| |l'| |before|)
+ (PROGN
+ (SETQ |before| NIL)
+ (SETQ |l'| |l|)
+ (LOOP
+ (COND ((NOT (CONSP |l'|)) (RETURN |l|))
+ (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
+ (SETQ |l'| (CDR |LETTMP#1|))
+ (COND
+ ((EQUAL |x| |y|) (RETURN (|append!| (|reverse!| |before|) |l'|)))
+ (T (SETQ |before| (CONS |y| |before|))))))))))
(DEFUN |remove| (|l| |x|)
(COND ((SYMBOLP |x|) (|removeSymbol| |l| |x|))
@@ -443,14 +427,13 @@
(T (|removeValue| |l| |x|))))
(DEFUN |charPosition| (|c| |s| |k|)
- (PROG (|n|)
- (RETURN
- (PROGN
- (SETQ |n| (LENGTH |s|))
- (LOOP
- (COND ((NOT (< |k| |n|)) (RETURN NIL))
- ((CHAR= (SCHAR |s| |k|) |c|) (RETURN |k|))
- (T (SETQ |k| (+ |k| 1)))))))))
+ (LET* (|n|)
+ (PROGN
+ (SETQ |n| (LENGTH |s|))
+ (LOOP
+ (COND ((NOT (< |k| |n|)) (RETURN NIL))
+ ((CHAR= (SCHAR |s| |k|) |c|) (RETURN |k|))
+ (T (SETQ |k| (+ |k| 1))))))))
(DEFUN |firstNonblankPosition| (|s| |k|)
(LET ((|bfVar#2| NIL) (|bfVar#1| (- (LENGTH |s|) 1)) (|i| |k|))
@@ -475,25 +458,24 @@
(SETQ |i| (+ |i| 1)))))
(DEFUN |stringSuffix?| (|suf| |str|)
- (PROG (|n| |n2| |n1|)
- (RETURN
- (PROGN
- (SETQ |n1| (LENGTH |suf|))
- (SETQ |n2| (LENGTH |str|))
- (COND ((< |n2| |n1|) NIL)
- (T (SETQ |n| (- |n2| |n1|))
- (COND
- ((LET ((|bfVar#2| T) (|bfVar#1| (- |n1| 1)) (|i| 0) (|j| |n|))
- (LOOP
- (COND ((> |i| |bfVar#1|) (RETURN |bfVar#2|))
- (T
- (SETQ |bfVar#2|
- (CHAR= (SCHAR |suf| |i|) (SCHAR |str| |j|)))
- (COND ((NOT |bfVar#2|) (RETURN NIL)))))
- (SETQ |i| (+ |i| 1))
- (SETQ |j| (+ |j| 1))))
- |n|)
- (T NIL))))))))
+ (LET* (|n| |n2| |n1|)
+ (PROGN
+ (SETQ |n1| (LENGTH |suf|))
+ (SETQ |n2| (LENGTH |str|))
+ (COND ((< |n2| |n1|) NIL)
+ (T (SETQ |n| (- |n2| |n1|))
+ (COND
+ ((LET ((|bfVar#2| T) (|bfVar#1| (- |n1| 1)) (|i| 0) (|j| |n|))
+ (LOOP
+ (COND ((> |i| |bfVar#1|) (RETURN |bfVar#2|))
+ (T
+ (SETQ |bfVar#2|
+ (CHAR= (SCHAR |suf| |i|) (SCHAR |str| |j|)))
+ (COND ((NOT |bfVar#2|) (RETURN NIL)))))
+ (SETQ |i| (+ |i| 1))
+ (SETQ |j| (+ |j| 1))))
+ |n|)
+ (T NIL)))))))
(DEFUN |finishLine| (|out|) (PROGN (TERPRI |out|) (FORCE-OUTPUT |out|)))
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-27 02:35:56 +0000