aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog4
-rw-r--r--src/boot/ast.boot19
-rw-r--r--src/boot/strap/ast.clisp1407
-rw-r--r--src/boot/strap/includer.clisp293
-rw-r--r--src/boot/strap/parser.clisp159
-rw-r--r--src/boot/strap/scanner.clisp146
-rw-r--r--src/boot/strap/translator.clisp357
7 files changed, 1093 insertions, 1292 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 272b67e9..12e0a19c 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,7 @@
+2009-08-30 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * boot/ast.boot (bfSequence): Simplify COND branch bodies.
+
2009-08-29 Gabriel Dos Reis <gdr@cs.tamu.edu>
* boot/parser.boot ($sawParenthesizedHead): Remove.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 0d8c17a8..13a813e0 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -995,22 +995,27 @@ bfFlattenSeq x ==
rest f
[f]
+++ The body of each branch of a COND form is an implicit PROGN.
+++ For readability purpose, we want to refrain from including
+++ any explicit PROGN.
+bfWashCONDBranchBody x ==
+ x is ["PROGN",:y] => y
+ [x]
+
bfSequence l ==
null l=> NIL
- transform:= [[a,b] for x in l while
+ transform:= [[a,:bfWashCONDBranchBody b] for x in l while
x is ["COND",[a,["IDENTITY",b]]]]
no:=#transform
before:= bfTake(no,l)
aft := bfDrop(no,l)
null before =>
- null rest l =>
- f:=first l
- if EQCAR(f,"PROGN")
- then bfSequence rest f
- else f
+ l is [f] =>
+ f is ["PROGN",:.] => bfSequence rest f
+ f
bfMKPROGN [first l,bfSequence rest l]
null aft => ["COND",:transform]
- ["COND",:transform,['(QUOTE T),bfSequence aft]]
+ ["COND",:transform,['(QUOTE T),:bfWashCONDBranchBody bfSequence aft]]
bfWhere (context,expr)==
[opassoc,defs,nondefs] := defSheepAndGoats context
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index 3e30419e..64b6779a 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -307,22 +307,15 @@
(COND
((ATOM |lhs|) (|bfINON| (LIST OP |lhs| |whole|)))
(#1='T
- (PROGN
- (SETQ |lhs|
- (COND
- ((|bfTupleP| |lhs|) (CADR |lhs|))
- (#0# |lhs|)))
- (COND
- ((EQCAR |lhs| 'L%T)
- (PROGN
- (SETQ G (CADR |lhs|))
- (APPEND (|bfINON| (LIST OP G |whole|))
- (|bfSuchthat| (|bfIS| G (CADDR |lhs|))))))
- (#1#
- (PROGN
- (SETQ G (|bfGenSymbol|))
- (APPEND (|bfINON| (LIST OP G |whole|))
- (|bfSuchthat| (|bfIS| G |lhs|)))))))))))))
+ (SETQ |lhs|
+ (COND ((|bfTupleP| |lhs|) (CADR |lhs|)) (#0# |lhs|)))
+ (COND
+ ((EQCAR |lhs| 'L%T) (SETQ G (CADR |lhs|))
+ (APPEND (|bfINON| (LIST OP G |whole|))
+ (|bfSuchthat| (|bfIS| G (CADDR |lhs|)))))
+ (#1# (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|)
@@ -346,9 +339,8 @@
(COND
((NULL |lst|) NIL)
((INTEGERP |inc|)
- (PROGN
- (SETQ |pred| (COND ((MINUSP |inc|) '<) (#0# '>)))
- (LIST (LIST |pred| |id| |final|))))
+ (SETQ |pred| (COND ((MINUSP |inc|) '<) (#0# '>)))
+ (LIST (LIST |pred| |id| |final|)))
('T
(LIST (LIST 'COND
(LIST (LIST 'MINUSP |inc|)
@@ -492,9 +484,8 @@
(PROGN (SETQ |a| (CAR |ISTMP#1|)) 'T))))
(|bf0APPEND| |a| |itl|))
((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE))
- (PROGN
- (SETQ |newBody| (|bfConstruct| |y|))
- (|bf0APPEND| |newBody| |itl|)))
+ (SETQ |newBody| (|bfConstruct| |y|))
+ (|bf0APPEND| |newBody| |itl|))
('T (|bf0COLLECT| |y| |itl|))))))
(DEFUN |bf0COLLECT| (|y| |itl|) (|bfListReduce| 'CONS |y| |itl|))
@@ -575,13 +566,11 @@
(COND
((EQCAR |itl| 'ITERATORS)
(|bfLp1| (CONS |extrait| (CDR |itl|)) |body|))
- ('T
- (PROGN
- (SETQ |iters| (CDR |itl|))
- (|bfLpCross|
- (CONS (CONS 'ITERATORS (CONS |extrait| (CDAR |iters|)))
- (CDR |iters|))
- |body|)))))))
+ ('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|)
@@ -658,12 +647,10 @@
(RETURN
(COND
((NULL |p|) |e|)
- (#0='T
- (PROGN
- (SETQ |f| (CAR |p|))
- (COND
- ((EQ (CAR |f|) |e|) (|bfSUBLIS| |p| (CDR |f|)))
- (#0# (|bfSUBLIS1| (CDR |p|) |e|)))))))))
+ (#0='T (SETQ |f| (CAR |p|))
+ (COND
+ ((EQ (CAR |f|) |e|) (|bfSUBLIS| |p| (CDR |f|)))
+ (#0# (|bfSUBLIS1| (CDR |p|) |e|))))))))
(DEFUN |defSheepAndGoats| (|x|)
(PROG (|defstack| |op1| |opassoc| |argl|)
@@ -724,48 +711,37 @@
(AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL))))
(|bfLetForm| |lhs| |rhs|))
((AND (IDENTP |rhs|) (NOT (|bfCONTAINED| |rhs| |lhs|)))
- (PROGN
- (SETQ |rhs1| (|bfLET2| |lhs| |rhs|))
- (COND
- ((EQCAR |rhs1| 'L%T) (|bfMKPROGN| (LIST |rhs1| |rhs|)))
- ((EQCAR |rhs1| 'PROGN) (APPEND |rhs1| (LIST |rhs|)))
- (#0='T
- (PROGN
- (COND
- ((IDENTP (CAR |rhs1|))
- (SETQ |rhs1| (CONS |rhs1| NIL))))
- (|bfMKPROGN| (APPEND |rhs1| (CONS |rhs| NIL))))))))
+ (SETQ |rhs1| (|bfLET2| |lhs| |rhs|))
+ (COND
+ ((EQCAR |rhs1| 'L%T) (|bfMKPROGN| (LIST |rhs1| |rhs|)))
+ ((EQCAR |rhs1| 'PROGN) (APPEND |rhs1| (LIST |rhs|)))
+ (#0='T
+ (COND
+ ((IDENTP (CAR |rhs1|)) (SETQ |rhs1| (CONS |rhs1| NIL))))
+ (|bfMKPROGN| (APPEND |rhs1| (CONS |rhs| NIL))))))
((AND (CONSP |rhs|) (EQCAR |rhs| 'L%T)
(IDENTP (SETQ |name| (CADR |rhs|))))
- (PROGN
- (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|)))
- (SETQ |l2| (|bfLET1| |lhs| |name|))
- (COND
- ((EQCAR |l2| 'PROGN) (|bfMKPROGN| (CONS |l1| (CDR |l2|))))
- (#0#
- (PROGN
- (COND
- ((IDENTP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL))))
- (|bfMKPROGN|
- (CONS |l1| (APPEND |l2| (CONS |name| NIL)))))))))
+ (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|)))
+ (SETQ |l2| (|bfLET1| |lhs| |name|))
+ (COND
+ ((EQCAR |l2| 'PROGN) (|bfMKPROGN| (CONS |l1| (CDR |l2|))))
+ (#0#
+ (COND ((IDENTP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL))))
+ (|bfMKPROGN| (CONS |l1| (APPEND |l2| (CONS |name| NIL)))))))
(#0#
- (PROGN
- (SETQ |g|
- (INTERN (CONCAT "LETTMP#"
- (STRINGIMAGE |$letGenVarCounter|))))
- (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1))
- (SETQ |rhs1| (LIST 'L%T |g| |rhs|))
- (SETQ |let1| (|bfLET1| |lhs| |g|))
- (COND
- ((EQCAR |let1| 'PROGN)
- (|bfMKPROGN| (CONS |rhs1| (CDR |let1|))))
- (#0#
- (PROGN
- (COND
- ((IDENTP (CAR |let1|))
- (SETQ |let1| (CONS |let1| NIL))))
- (|bfMKPROGN|
- (CONS |rhs1| (APPEND |let1| (CONS |g| NIL)))))))))))))
+ (SETQ |g|
+ (INTERN (CONCAT "LETTMP#"
+ (STRINGIMAGE |$letGenVarCounter|))))
+ (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1))
+ (SETQ |rhs1| (LIST 'L%T |g| |rhs|))
+ (SETQ |let1| (|bfLET1| |lhs| |g|))
+ (COND
+ ((EQCAR |let1| 'PROGN)
+ (|bfMKPROGN| (CONS |rhs1| (CDR |let1|))))
+ (#0#
+ (COND
+ ((IDENTP (CAR |let1|)) (SETQ |let1| (CONS |let1| NIL))))
+ (|bfMKPROGN| (CONS |rhs1| (APPEND |let1| (CONS |g| NIL)))))))))))
(DEFUN |bfCONTAINED| (|x| |y|)
(COND
@@ -796,13 +772,12 @@
(SETQ |ISTMP#2| (CDR |ISTMP#1|))
(AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL)
(PROGN (SETQ |b| (CAR |ISTMP#2|)) #0='T))))))
- (PROGN
- (SETQ |a| (|bfLET2| |a| |rhs|))
- (COND
- ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|)
- ((ATOM |b|) (LIST |a| |b|))
- ((CONSP (CAR |b|)) (CONS |a| |b|))
- (#1='T (LIST |a| |b|)))))
+ (SETQ |a| (|bfLET2| |a| |rhs|))
+ (COND
+ ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|)
+ ((ATOM |b|) (LIST |a| |b|))
+ ((CONSP (CAR |b|)) (CONS |a| |b|))
+ (#1='T (LIST |a| |b|))))
((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'CONS)
(PROGN
(SETQ |ISTMP#1| (CDR |lhs|))
@@ -817,30 +792,26 @@
(AND (CONSP |var1|) (EQCAR |var1| 'QUOTE)))
(|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|)))
(#1#
- (PROGN
- (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|)))
- (COND
- ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|)
- (#1#
- (PROGN
- (COND
- ((AND (CONSP |l1|) (ATOM (CAR |l1|)))
- (SETQ |l1| (CONS |l1| NIL))))
- (COND
- ((IDENTP |var2|)
- (APPEND |l1|
- (CONS (|bfLetForm| |var2|
- (|addCARorCDR| 'CDR |rhs|))
- NIL)))
- (#1#
- (PROGN
- (SETQ |l2|
- (|bfLET2| |var2|
- (|addCARorCDR| 'CDR |rhs|)))
- (COND
- ((AND (CONSP |l2|) (ATOM (CAR |l2|)))
- (SETQ |l2| (CONS |l2| NIL))))
- (APPEND |l1| |l2|)))))))))))
+ (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|)))
+ (COND
+ ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|)
+ (#1#
+ (COND
+ ((AND (CONSP |l1|) (ATOM (CAR |l1|)))
+ (SETQ |l1| (CONS |l1| NIL))))
+ (COND
+ ((IDENTP |var2|)
+ (APPEND |l1|
+ (CONS (|bfLetForm| |var2|
+ (|addCARorCDR| 'CDR |rhs|))
+ NIL)))
+ (#1#
+ (SETQ |l2|
+ (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|)))
+ (COND
+ ((AND (CONSP |l2|) (ATOM (CAR |l2|)))
+ (SETQ |l2| (CONS |l2| NIL))))
+ (APPEND |l1| |l2|))))))))
((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'APPEND)
(PROGN
(SETQ |ISTMP#1| (CDR |lhs|))
@@ -850,44 +821,43 @@
(SETQ |ISTMP#2| (CDR |ISTMP#1|))
(AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL)
(PROGN (SETQ |var2| (CAR |ISTMP#2|)) #0#))))))
- (PROGN
- (SETQ |patrev| (|bfISReverse| |var2| |var1|))
- (SETQ |rev| (LIST 'REVERSE |rhs|))
- (SETQ |g|
- (INTERN (CONCAT "LETTMP#"
- (STRINGIMAGE |$letGenVarCounter|))))
- (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1))
- (SETQ |l2| (|bfLET2| |patrev| |g|))
- (COND
- ((AND (CONSP |l2|) (ATOM (CAR |l2|)))
- (SETQ |l2| (CONS |l2| NIL))))
- (COND
- ((EQ |var1| 'DOT) (CONS (LIST 'L%T |g| |rev|) |l2|))
- ((PROGN
- (SETQ |ISTMP#1| (|last| |l2|))
- (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'L%T)
- (PROGN
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (EQUAL (CAR |ISTMP#2|) |var1|)
- (PROGN
- (SETQ |ISTMP#3| (CDR |ISTMP#2|))
- (AND (CONSP |ISTMP#3|)
- (EQ (CDR |ISTMP#3|) NIL)
- (PROGN
- (SETQ |val1| (CAR |ISTMP#3|))
- #0#)))))))
- (CONS (LIST 'L%T |g| |rev|)
- (APPEND (REVERSE (CDR (REVERSE |l2|)))
- (CONS (|bfLetForm| |var1|
- (LIST 'NREVERSE |val1|))
- NIL))))
- (#1#
- (CONS (LIST 'L%T |g| |rev|)
- (APPEND |l2|
- (CONS (|bfLetForm| |var1|
- (LIST 'NREVERSE |var1|))
- NIL)))))))
+ (SETQ |patrev| (|bfISReverse| |var2| |var1|))
+ (SETQ |rev| (LIST 'REVERSE |rhs|))
+ (SETQ |g|
+ (INTERN (CONCAT "LETTMP#"
+ (STRINGIMAGE |$letGenVarCounter|))))
+ (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1))
+ (SETQ |l2| (|bfLET2| |patrev| |g|))
+ (COND
+ ((AND (CONSP |l2|) (ATOM (CAR |l2|)))
+ (SETQ |l2| (CONS |l2| NIL))))
+ (COND
+ ((EQ |var1| 'DOT) (CONS (LIST 'L%T |g| |rev|) |l2|))
+ ((PROGN
+ (SETQ |ISTMP#1| (|last| |l2|))
+ (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'L%T)
+ (PROGN
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (EQUAL (CAR |ISTMP#2|) |var1|)
+ (PROGN
+ (SETQ |ISTMP#3| (CDR |ISTMP#2|))
+ (AND (CONSP |ISTMP#3|)
+ (EQ (CDR |ISTMP#3|) NIL)
+ (PROGN
+ (SETQ |val1| (CAR |ISTMP#3|))
+ #0#)))))))
+ (CONS (LIST 'L%T |g| |rev|)
+ (APPEND (REVERSE (CDR (REVERSE |l2|)))
+ (CONS (|bfLetForm| |var1|
+ (LIST 'NREVERSE |val1|))
+ NIL))))
+ (#1#
+ (CONS (LIST 'L%T |g| |rev|)
+ (APPEND |l2|
+ (CONS (|bfLetForm| |var1|
+ (LIST 'NREVERSE |var1|))
+ NIL))))))
((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'EQUAL)
(PROGN
(SETQ |ISTMP#1| (CDR |lhs|))
@@ -895,12 +865,11 @@
(PROGN (SETQ |var1| (CAR |ISTMP#1|)) #0#))))
(LIST 'COND (LIST (LIST 'EQUAL |var1| |rhs|) |var1|)))
(#1#
- (PROGN
- (SETQ |isPred|
- (COND
- (|$inDefIS| (|bfIS1| |rhs| |lhs|))
- (#1# (|bfIS| |rhs| |lhs|))))
- (LIST 'COND (LIST |isPred| |rhs|))))))))
+ (SETQ |isPred|
+ (COND
+ (|$inDefIS| (|bfIS1| |rhs| |lhs|))
+ (#1# (|bfIS| |rhs| |lhs|))))
+ (LIST 'COND (LIST |isPred| |rhs|)))))))
(DEFUN |bfLET| (|lhs| |rhs|)
(PROG (|$letGenVarCounter|)
@@ -916,25 +885,22 @@
((AND (EQ |acc| 'CAR) (EQCAR |expr| 'REVERSE))
(LIST 'CAR (CONS 'LAST (CDR |expr|))))
(#0='T
- (PROGN
- (SETQ |funs|
- '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR
- CDAAR CDDAR CDADR CDDDR))
- (SETQ |p| (|bfPosition| (CAR |expr|) |funs|))
- (COND
- ((EQUAL |p| (- 1)) (LIST |acc| |expr|))
- (#0#
- (PROGN
- (SETQ |funsA|
- '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR
- CAAADR CAADDR CADAAR CADDAR CADADR CADDDR))
- (SETQ |funsR|
- '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR
- CDAADR CDADDR CDDAAR CDDDAR CDDADR CDDDDR))
- (COND
- ((EQ |acc| 'CAR)
- (CONS (ELT |funsA| |p|) (CDR |expr|)))
- ('T (CONS (ELT |funsR| |p|) (CDR |expr|)))))))))))))
+ (SETQ |funs|
+ '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR
+ CDAAR CDDAR CDADR CDDDR))
+ (SETQ |p| (|bfPosition| (CAR |expr|) |funs|))
+ (COND
+ ((EQUAL |p| (- 1)) (LIST |acc| |expr|))
+ (#0#
+ (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))
@@ -966,15 +932,9 @@
((AND (CONSP |x|) (EQ (CAR |x|) 'CONS))
(COND
((NULL (CADDR |x|)) (LIST 'CONS (CADR |x|) |a|))
- (#0='T
- (PROGN
- (SETQ |y| (|bfISReverse| (CADDR |x|) NIL))
- (RPLACA (CDDR |y|) (LIST 'CONS (CADR |x|) |a|))
- |y|))))
- (#0#
- (PROGN
- (|bpSpecificErrorHere| "Error in bfISReverse")
- (|bpTrap|)))))))
+ (#0='T (SETQ |y| (|bfISReverse| (CADDR |x|) NIL))
+ (RPLACA (CDDR |y|) (LIST 'CONS (CADR |x|) |a|)) |y|)))
+ (#0# (|bpSpecificErrorHere| "Error in bfISReverse") (|bpTrap|))))))
(DEFUN |bfIS1| (|lhs| |rhs|)
(PROG (|l2| |rev| |patrev| |cls| |b1| |a1| |b| |g| |l| |d| |ISTMP#2|
@@ -1003,10 +963,9 @@
(SETQ |ISTMP#2| (CDR |ISTMP#1|))
(AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL)
(PROGN (SETQ |d| (CAR |ISTMP#2|)) #0#))))))
- (PROGN
- (SETQ |l| (|bfLET| |c| |lhs|))
- (|bfAND| (LIST (|bfIS1| |lhs| |d|)
- (|bfMKPROGN| (LIST |l| ''T))))))
+ (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|))
@@ -1014,13 +973,11 @@
(PROGN (SETQ |a| (CAR |ISTMP#1|)) #0#))))
(LIST 'EQUAL |lhs| |a|))
((CONSP |lhs|)
- (PROGN
- (SETQ |g|
- (INTERN (CONCAT "ISTMP#"
- (STRINGIMAGE |$isGenVarCounter|))))
- (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1))
- (|bfMKPROGN|
- (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|)))))
+ (SETQ |g|
+ (INTERN (CONCAT "ISTMP#"
+ (STRINGIMAGE |$isGenVarCounter|))))
+ (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1))
+ (|bfMKPROGN| (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|))))
((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'CONS)
(PROGN
(SETQ |ISTMP#1| (CDR |rhs|))
@@ -1046,26 +1003,24 @@
((EQ |b| 'DOT)
(|bfAND| (LIST (LIST 'CONSP |lhs|)
(|bfIS1| (LIST 'CAR |lhs|) |a|))))
- (#1#
- (PROGN
- (SETQ |a1| (|bfIS1| (LIST 'CAR |lhs|) |a|))
- (SETQ |b1| (|bfIS1| (LIST 'CDR |lhs|) |b|))
- (COND
- ((AND (CONSP |a1|) (EQ (CAR |a1|) 'PROGN)
- (PROGN
- (SETQ |ISTMP#1| (CDR |a1|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |c| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (EQ (CDR |ISTMP#2|) NIL)
- (EQUAL (CAR |ISTMP#2|) ''T)))))
- (CONSP |b1|) (EQ (CAR |b1|) 'PROGN)
- (PROGN (SETQ |cls| (CDR |b1|)) #0#))
- (|bfAND| (LIST (LIST 'CONSP |lhs|)
- (|bfMKPROGN| (CONS |c| |cls|)))))
- (#1# (|bfAND| (LIST (LIST 'CONSP |lhs|) |a1| |b1|))))))))
+ (#1# (SETQ |a1| (|bfIS1| (LIST 'CAR |lhs|) |a|))
+ (SETQ |b1| (|bfIS1| (LIST 'CDR |lhs|) |b|))
+ (COND
+ ((AND (CONSP |a1|) (EQ (CAR |a1|) 'PROGN)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |a1|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |c| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (EQ (CDR |ISTMP#2|) NIL)
+ (EQUAL (CAR |ISTMP#2|) ''T)))))
+ (CONSP |b1|) (EQ (CAR |b1|) 'PROGN)
+ (PROGN (SETQ |cls| (CDR |b1|)) #0#))
+ (|bfAND| (LIST (LIST 'CONSP |lhs|)
+ (|bfMKPROGN| (CONS |c| |cls|)))))
+ (#1# (|bfAND| (LIST (LIST 'CONSP |lhs|) |a1| |b1|)))))))
((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'APPEND)
(PROGN
(SETQ |ISTMP#1| (CDR |rhs|))
@@ -1075,37 +1030,34 @@
(SETQ |ISTMP#2| (CDR |ISTMP#1|))
(AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL)
(PROGN (SETQ |b| (CAR |ISTMP#2|)) #0#))))))
- (PROGN
- (SETQ |patrev| (|bfISReverse| |b| |a|))
- (SETQ |g|
- (INTERN (CONCAT "ISTMP#"
- (STRINGIMAGE |$isGenVarCounter|))))
- (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1))
- (SETQ |rev|
- (|bfAND| (LIST (LIST 'CONSP |lhs|)
- (LIST 'PROGN
- (LIST 'L%T |g|
- (LIST 'REVERSE |lhs|))
- ''T))))
- (SETQ |l2| (|bfIS1| |g| |patrev|))
- (COND
- ((AND (CONSP |l2|) (ATOM (CAR |l2|)))
- (SETQ |l2| (CONS |l2| NIL))))
- (COND
- ((EQ |a| 'DOT) (|bfAND| (CONS |rev| |l2|)))
- (#1#
- (|bfAND| (CONS |rev|
- (APPEND |l2|
- (CONS
- (LIST 'PROGN
- (|bfLetForm| |a|
- (LIST 'NREVERSE |a|))
- ''T)
- NIL))))))))
- (#1#
- (PROGN
- (|bpSpecificErrorHere| "bad IS code is generated")
- (|bpTrap|)))))))
+ (SETQ |patrev| (|bfISReverse| |b| |a|))
+ (SETQ |g|
+ (INTERN (CONCAT "ISTMP#"
+ (STRINGIMAGE |$isGenVarCounter|))))
+ (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1))
+ (SETQ |rev|
+ (|bfAND| (LIST (LIST 'CONSP |lhs|)
+ (LIST 'PROGN
+ (LIST 'L%T |g|
+ (LIST 'REVERSE |lhs|))
+ ''T))))
+ (SETQ |l2| (|bfIS1| |g| |patrev|))
+ (COND
+ ((AND (CONSP |l2|) (ATOM (CAR |l2|)))
+ (SETQ |l2| (CONS |l2| NIL))))
+ (COND
+ ((EQ |a| 'DOT) (|bfAND| (CONS |rev| |l2|)))
+ (#1#
+ (|bfAND| (CONS |rev|
+ (APPEND |l2|
+ (CONS
+ (LIST 'PROGN
+ (|bfLetForm| |a|
+ (LIST 'NREVERSE |a|))
+ ''T)
+ NIL)))))))
+ (#1# (|bpSpecificErrorHere| "bad IS code is generated")
+ (|bpTrap|))))))
(DEFUN |bfApplication| (|bfop| |bfarg|)
(COND
@@ -1328,14 +1280,12 @@
(RETURN
(COND
(|$bfClamming|
- (PROGN
- (SETQ |LETTMP#1|
- (|shoeComp|
- (CAR (|bfDef1| (LIST |op| |args| |body|)))))
- (SETQ |op1| (CADR . #0=(|LETTMP#1|)))
- (SETQ |arg1| (CADDR . #0#))
- (SETQ |body1| (CDDDR . #0#))
- (|bfCompHash| |op1| |arg1| |body1|)))
+ (SETQ |LETTMP#1|
+ (|shoeComp|
+ (CAR (|bfDef1| (LIST |op| |args| |body|)))))
+ (SETQ |op1| (CADR . #0=(|LETTMP#1|)))
+ (SETQ |arg1| (CADDR . #0#)) (SETQ |body1| (CDDDR . #0#))
+ (|bfCompHash| |op1| |arg1| |body1|))
('T
(|bfTuple|
(LET ((|bfVar#101| NIL)
@@ -1439,21 +1389,19 @@
(AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL)
(PROGN (SETQ |b| (CAR |ISTMP#1|)) #0#))))
(LIST T 'QUOTE |b| |body|))
- (#1='T
- (PROGN
- (SETQ |g| (|bfGenSymbol|))
- (COND
- ((ATOM |y|) (LIST NIL NIL |g| |body|))
- (#1#
- (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|)))))))))))))
+ (#1='T (SETQ |g| (|bfGenSymbol|))
+ (COND
+ ((ATOM |y|) (LIST NIL NIL |g| |body|))
+ (#1#
+ (CASE (CAR |y|)
+ (|%DefaultValue|
+ (LET ((|p| (CADR |y|)) (|v| (CADDR |y|)))
+ (LIST NIL NIL (LIST '&OPTIONAL (LIST |p| |v|))
+ |body|)))
+ (T (LIST NIL NIL |g|
+ (|bfMKPROGN|
+ (LIST (|bfLET| (|compFluidize| |y|) |g|)
+ |body|))))))))))))
(DEFUN |shoeCompTran| (|x|)
(PROG (|$dollarVars| |$locVars| |$fluidVars| |fvs| |fl| |fvars|
@@ -1503,41 +1451,36 @@
(RETURN
(COND
((ATOM |body|) NIL)
- (#0='T
- (PROGN
- (SETQ |op| (CAR |body|))
- (SETQ |args| (CDR |body|))
- (COND
- ((MEMBER |op| '(RETURN RETURN-FROM)) T)
- ((MEMBER |op| '(LET PROG LOOP BLOCK DECLARE LAMBDA)) NIL)
- ((LET ((|bfVar#105| NIL) (|bfVar#104| |body|) (|t| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#104|)
- (PROGN (SETQ |t| (CAR |bfVar#104|)) NIL))
- (RETURN |bfVar#105|))
- ('T
- (PROGN
- (SETQ |bfVar#105| (|needsPROG| |t|))
- (COND (|bfVar#105| (RETURN |bfVar#105|))))))
- (SETQ |bfVar#104| (CDR |bfVar#104|))))
- T)
- (#0# NIL))))))))
+ (#0='T (SETQ |op| (CAR |body|)) (SETQ |args| (CDR |body|))
+ (COND
+ ((MEMBER |op| '(RETURN RETURN-FROM)) T)
+ ((MEMBER |op| '(LET PROG LOOP BLOCK DECLARE LAMBDA)) NIL)
+ ((LET ((|bfVar#105| NIL) (|bfVar#104| |body|) (|t| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#104|)
+ (PROGN (SETQ |t| (CAR |bfVar#104|)) NIL))
+ (RETURN |bfVar#105|))
+ ('T
+ (PROGN
+ (SETQ |bfVar#105| (|needsPROG| |t|))
+ (COND (|bfVar#105| (RETURN |bfVar#105|))))))
+ (SETQ |bfVar#104| (CDR |bfVar#104|))))
+ T)
+ (#0# NIL)))))))
(DEFUN |shoePROG| (|v| |b|)
(PROG (|blist| |blast| |LETTMP#1|)
(RETURN
(COND
((NULL |b|) (LIST (LIST 'PROG |v|)))
- ('T
- (PROGN
- (SETQ |LETTMP#1| (REVERSE |b|))
- (SETQ |blast| (CAR |LETTMP#1|))
- (SETQ |blist| (NREVERSE (CDR |LETTMP#1|)))
- (LIST (CONS 'PROG
- (CONS |v|
- (APPEND |blist|
- (CONS (LIST 'RETURN |blast|) NIL)))))))))))
+ ('T (SETQ |LETTMP#1| (REVERSE |b|))
+ (SETQ |blast| (CAR |LETTMP#1|))
+ (SETQ |blist| (NREVERSE (CDR |LETTMP#1|)))
+ (LIST (CONS 'PROG
+ (CONS |v|
+ (APPEND |blist|
+ (CONS (LIST 'RETURN |blast|) NIL))))))))))
(DEFUN |shoeFluids| (|x|)
(COND
@@ -1581,83 +1524,70 @@
((MEMQ |x| |$dollarVars|) |$dollarVars|)
(#0='T (CONS |x| |$dollarVars|)))))
(#0# NIL)))
- (#0#
- (PROGN
- (SETQ U (CAR |x|))
- (COND
- ((EQ U 'QUOTE) NIL)
- ((AND (CONSP |x|) (EQ (CAR |x|) 'L%T)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |l| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (EQ (CDR |ISTMP#2|) NIL)
- (PROGN (SETQ |r| (CAR |ISTMP#2|)) 'T))))))
- (PROGN
- (RPLACA |x| 'SETQ)
- (|shoeCompTran1| |r|)
+ (#0# (SETQ U (CAR |x|))
+ (COND
+ ((EQ U 'QUOTE) NIL)
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'L%T)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |l| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (EQ (CDR |ISTMP#2|) NIL)
+ (PROGN (SETQ |r| (CAR |ISTMP#2|)) 'T))))))
+ (RPLACA |x| 'SETQ) (|shoeCompTran1| |r|)
+ (COND
+ ((IDENTP |l|)
+ (COND
+ ((NOT (|bfBeginsDollar| |l|))
+ (SETQ |$locVars|
+ (COND
+ ((MEMQ |l| |$locVars|) |$locVars|)
+ (#0# (CONS |l| |$locVars|)))))
+ (#0#
+ (SETQ |$dollarVars|
+ (COND
+ ((MEMQ |l| |$dollarVars|) |$dollarVars|)
+ (#0# (CONS |l| |$dollarVars|)))))))
+ ((EQCAR |l| 'FLUID)
+ (SETQ |$fluidVars|
+ (COND
+ ((MEMQ (CADR |l|) |$fluidVars|) |$fluidVars|)
+ (#0# (CONS (CADR |l|) |$fluidVars|))))
+ (RPLACA (CDR |x|) (CADR |l|)))))
+ ((MEMQ U '(PROG LAMBDA)) (SETQ |newbindings| NIL)
+ (LET ((|bfVar#106| (CADR |x|)) (|y| NIL))
+ (LOOP
(COND
- ((IDENTP |l|)
+ ((OR (ATOM |bfVar#106|)
+ (PROGN (SETQ |y| (CAR |bfVar#106|)) NIL))
+ (RETURN NIL))
+ (#1='T
(COND
- ((NOT (|bfBeginsDollar| |l|))
- (SETQ |$locVars|
- (COND
- ((MEMQ |l| |$locVars|) |$locVars|)
- (#0# (CONS |l| |$locVars|)))))
- (#0#
- (SETQ |$dollarVars|
- (COND
- ((MEMQ |l| |$dollarVars|) |$dollarVars|)
- (#0# (CONS |l| |$dollarVars|)))))))
- ((EQCAR |l| 'FLUID)
- (PROGN
- (SETQ |$fluidVars|
- (COND
- ((MEMQ (CADR |l|) |$fluidVars|)
- |$fluidVars|)
- (#0# (CONS (CADR |l|) |$fluidVars|))))
- (RPLACA (CDR |x|) (CADR |l|)))))))
- ((MEMQ U '(PROG LAMBDA))
- (PROGN
- (SETQ |newbindings| NIL)
- (LET ((|bfVar#106| (CADR |x|)) (|y| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#106|)
- (PROGN (SETQ |y| (CAR |bfVar#106|)) NIL))
- (RETURN NIL))
- (#1='T
- (COND
- ((NOT (MEMQ |y| |$locVars|))
- (IDENTITY
- (PROGN
- (SETQ |$locVars| (CONS |y| |$locVars|))
- (SETQ |newbindings|
- (CONS |y| |newbindings|))))))))
- (SETQ |bfVar#106| (CDR |bfVar#106|))))
- (SETQ |res| (|shoeCompTran1| (CDDR |x|)))
- (SETQ |$locVars|
- (LET ((|bfVar#108| NIL) (|bfVar#107| |$locVars|)
- (|y| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#107|)
- (PROGN
- (SETQ |y| (CAR |bfVar#107|))
- NIL))
- (RETURN (NREVERSE |bfVar#108|)))
- (#1#
- (AND (NOT (MEMQ |y| |newbindings|))
- (SETQ |bfVar#108|
- (CONS |y| |bfVar#108|)))))
- (SETQ |bfVar#107| (CDR |bfVar#107|)))))))
- (#0#
- (PROGN
- (|shoeCompTran1| (CAR |x|))
- (|shoeCompTran1| (CDR |x|)))))))))))
+ ((NOT (MEMQ |y| |$locVars|))
+ (IDENTITY
+ (PROGN
+ (SETQ |$locVars| (CONS |y| |$locVars|))
+ (SETQ |newbindings|
+ (CONS |y| |newbindings|))))))))
+ (SETQ |bfVar#106| (CDR |bfVar#106|))))
+ (SETQ |res| (|shoeCompTran1| (CDDR |x|)))
+ (SETQ |$locVars|
+ (LET ((|bfVar#108| NIL) (|bfVar#107| |$locVars|)
+ (|y| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#107|)
+ (PROGN (SETQ |y| (CAR |bfVar#107|)) NIL))
+ (RETURN (NREVERSE |bfVar#108|)))
+ (#1#
+ (AND (NOT (MEMQ |y| |newbindings|))
+ (SETQ |bfVar#108| (CONS |y| |bfVar#108|)))))
+ (SETQ |bfVar#107| (CDR |bfVar#107|))))))
+ (#0# (|shoeCompTran1| (CAR |x|))
+ (|shoeCompTran1| (CDR |x|)))))))))
(DEFUN |bfTagged| (|a| |b|)
(DECLARE (SPECIAL |$typings| |$op|))
@@ -1668,10 +1598,8 @@
((EQ |b| 'FLUID) (|bfLET| (|compFluid| |a|) NIL))
((EQ |b| '|fluid|) (|bfLET| (|compFluid| |a|) NIL))
((EQ |b| '|local|) (|bfLET| (|compFluid| |a|) NIL))
- (#0='T
- (PROGN
- (SETQ |$typings| (CONS (LIST 'TYPE |b| |a|) |$typings|))
- |a|))))
+ (#0='T (SETQ |$typings| (CONS (LIST 'TYPE |b| |a|) |$typings|))
+ |a|)))
(#0# (LIST 'THE |b| |a|))))
(DEFUN |bfAssign| (|l| |r|)
@@ -1725,12 +1653,11 @@
((EQCAR |c| 'COND)
(CONS 'COND (CONS (CONS |a| |b1|) (CDR |c|))))
('T
- (PROGN
- (SETQ |c1|
- (COND
- ((EQCAR |c| 'PROGN) (CDR |c|))
- (#0# (LIST |c|))))
- (LIST 'COND (CONS |a| |b1|) (CONS ''T |c1|)))))))))
+ (SETQ |c1|
+ (COND
+ ((EQCAR |c| 'PROGN) (CDR |c|))
+ (#0# (LIST |c|))))
+ (LIST 'COND (CONS |a| |b1|) (CONS ''T |c1|))))))))
(DEFUN |bfExit| (|a| |b|)
(LIST 'COND (LIST |a| (LIST 'IDENTITY |b|))))
@@ -1759,27 +1686,34 @@
(RETURN
(COND
((NULL |x|) NIL)
- (#0='T
- (PROGN
- (SETQ |f| (CAR |x|))
- (COND
- ((ATOM |f|) (COND ((CDR |x|) NIL) ('T (LIST |f|))))
- ((EQCAR |f| 'PROGN)
- (COND
- ((CDR |x|)
- (LET ((|bfVar#111| NIL) (|bfVar#110| (CDR |f|))
- (|i| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#110|)
- (PROGN (SETQ |i| (CAR |bfVar#110|)) NIL))
- (RETURN (NREVERSE |bfVar#111|)))
- ('T
- (AND (NOT (ATOM |i|))
- (SETQ |bfVar#111| (CONS |i| |bfVar#111|)))))
- (SETQ |bfVar#110| (CDR |bfVar#110|)))))
- (#0# (CDR |f|))))
- (#0# (LIST |f|)))))))))
+ (#0='T (SETQ |f| (CAR |x|))
+ (COND
+ ((ATOM |f|) (COND ((CDR |x|) NIL) ('T (LIST |f|))))
+ ((EQCAR |f| 'PROGN)
+ (COND
+ ((CDR |x|)
+ (LET ((|bfVar#111| NIL) (|bfVar#110| (CDR |f|))
+ (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#110|)
+ (PROGN (SETQ |i| (CAR |bfVar#110|)) NIL))
+ (RETURN (NREVERSE |bfVar#111|)))
+ ('T
+ (AND (NOT (ATOM |i|))
+ (SETQ |bfVar#111| (CONS |i| |bfVar#111|)))))
+ (SETQ |bfVar#110| (CDR |bfVar#110|)))))
+ (#0# (CDR |f|))))
+ (#0# (LIST |f|))))))))
+
+(DEFUN |bfWashCONDBranchBody| (|x|)
+ (PROG (|y|)
+ (RETURN
+ (COND
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN)
+ (PROGN (SETQ |y| (CDR |x|)) 'T))
+ |y|)
+ ('T (LIST |x|))))))
(DEFUN |bfSequence| (|l|)
(PROG (|f| |aft| |before| |no| |transform| |b| |ISTMP#5| |ISTMP#4|
@@ -1788,72 +1722,73 @@
(COND
((NULL |l|) NIL)
(#0='T
- (PROGN
- (SETQ |transform|
- (LET ((|bfVar#113| NIL) (|bfVar#112| |l|) (|x| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#112|)
- (PROGN (SETQ |x| (CAR |bfVar#112|)) NIL)
- (NOT (AND (CONSP |x|) (EQ (CAR |x|) 'COND)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
- (EQ (CDR |ISTMP#1|) NIL)
- (PROGN
- (SETQ |ISTMP#2|
- (CAR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (PROGN
- (SETQ |a|
- (CAR |ISTMP#2|))
- (SETQ |ISTMP#3|
- (CDR |ISTMP#2|))
- (AND (CONSP |ISTMP#3|)
- (EQ (CDR |ISTMP#3|) NIL)
- (PROGN
- (SETQ |ISTMP#4|
- (CAR |ISTMP#3|))
- (AND (CONSP |ISTMP#4|)
- (EQ (CAR |ISTMP#4|)
- 'IDENTITY)
- (PROGN
- (SETQ |ISTMP#5|
- (CDR |ISTMP#4|))
- (AND
- (CONSP |ISTMP#5|)
- (EQ
- (CDR |ISTMP#5|)
- NIL)
- (PROGN
- (SETQ |b|
- (CAR |ISTMP#5|))
- 'T))))))))))))))
- (RETURN (NREVERSE |bfVar#113|)))
- ('T
- (SETQ |bfVar#113|
- (CONS (LIST |a| |b|) |bfVar#113|))))
- (SETQ |bfVar#112| (CDR |bfVar#112|)))))
- (SETQ |no| (LENGTH |transform|))
- (SETQ |before| (|bfTake| |no| |l|))
- (SETQ |aft| (|bfDrop| |no| |l|))
- (COND
- ((NULL |before|)
- (COND
- ((NULL (CDR |l|))
- (PROGN
- (SETQ |f| (CAR |l|))
+ (SETQ |transform|
+ (LET ((|bfVar#113| NIL) (|bfVar#112| |l|) (|x| NIL))
+ (LOOP
(COND
- ((EQCAR |f| 'PROGN) (|bfSequence| (CDR |f|)))
- ('T |f|))))
- (#0#
- (|bfMKPROGN|
- (LIST (CAR |l|) (|bfSequence| (CDR |l|)))))))
- ((NULL |aft|) (CONS 'COND |transform|))
- (#0#
- (CONS 'COND
- (APPEND |transform|
- (CONS (LIST ''T (|bfSequence| |aft|)) NIL)))))))))))
+ ((OR (ATOM |bfVar#112|)
+ (PROGN (SETQ |x| (CAR |bfVar#112|)) NIL)
+ (NOT (AND (CONSP |x|) (EQ (CAR |x|) 'COND)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (EQ (CDR |ISTMP#1|) NIL)
+ (PROGN
+ (SETQ |ISTMP#2|
+ (CAR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (PROGN
+ (SETQ |a| (CAR |ISTMP#2|))
+ (SETQ |ISTMP#3|
+ (CDR |ISTMP#2|))
+ (AND (CONSP |ISTMP#3|)
+ (EQ (CDR |ISTMP#3|) NIL)
+ (PROGN
+ (SETQ |ISTMP#4|
+ (CAR |ISTMP#3|))
+ (AND (CONSP |ISTMP#4|)
+ (EQ (CAR |ISTMP#4|)
+ 'IDENTITY)
+ (PROGN
+ (SETQ |ISTMP#5|
+ (CDR |ISTMP#4|))
+ (AND
+ (CONSP |ISTMP#5|)
+ (EQ (CDR |ISTMP#5|)
+ NIL)
+ (PROGN
+ (SETQ |b|
+ (CAR |ISTMP#5|))
+ #1='T))))))))))))))
+ (RETURN (NREVERSE |bfVar#113|)))
+ ('T
+ (SETQ |bfVar#113|
+ (CONS (CONS |a|
+ (|bfWashCONDBranchBody| |b|))
+ |bfVar#113|))))
+ (SETQ |bfVar#112| (CDR |bfVar#112|)))))
+ (SETQ |no| (LENGTH |transform|))
+ (SETQ |before| (|bfTake| |no| |l|))
+ (SETQ |aft| (|bfDrop| |no| |l|))
+ (COND
+ ((NULL |before|)
+ (COND
+ ((AND (CONSP |l|) (EQ (CDR |l|) NIL)
+ (PROGN (SETQ |f| (CAR |l|)) #1#))
+ (COND
+ ((AND (CONSP |f|) (EQ (CAR |f|) 'PROGN))
+ (|bfSequence| (CDR |f|)))
+ (#0# |f|)))
+ (#0#
+ (|bfMKPROGN| (LIST (CAR |l|) (|bfSequence| (CDR |l|)))))))
+ ((NULL |aft|) (CONS 'COND |transform|))
+ (#0#
+ (CONS 'COND
+ (APPEND |transform|
+ (CONS (CONS ''T
+ (|bfWashCONDBranchBody|
+ (|bfSequence| |aft|)))
+ NIL))))))))))
(DEFUN |bfWhere| (|context| |expr|)
(PROG (|a| |nondefs| |defs| |opassoc| |LETTMP#1|)
@@ -2133,19 +2068,17 @@
(COND
((SETQ |t'|
(CDR (ASSOC (|coreSymbol| |t|) |$NativeTypeTable|)))
- (PROGN
- (SETQ |t'|
- (COND
- ((|%hasFeature| :SBCL)
- (|bfColonColon| 'SB-ALIEN |t'|))
- ((|%hasFeature| :CLISP)
- (|bfColonColon| 'FFI |t'|))
- (#0='T |t'|)))
- (COND
- ((AND (EQ |t| '|string|) (|%hasFeature| :SBCL))
- (LIST |t'| :EXTERNAL-FORMAT :ASCII :ELEMENT-TYPE
- 'BASE-CHAR))
- (#0# |t'|))))
+ (SETQ |t'|
+ (COND
+ ((|%hasFeature| :SBCL)
+ (|bfColonColon| 'SB-ALIEN |t'|))
+ ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI |t'|))
+ (#0='T |t'|)))
+ (COND
+ ((AND (EQ |t| '|string|) (|%hasFeature| :SBCL))
+ (LIST |t'| :EXTERNAL-FORMAT :ASCII :ELEMENT-TYPE
+ 'BASE-CHAR))
+ (#0# |t'|)))
((MEMBER |t| '(|byte| |uint8|))
(COND
((|%hasFeature| :SBCL)
@@ -2236,21 +2169,17 @@
((EQ |t| '|string|) (|nativeType| |t|))
((OR (ATOM |t|) (NOT (EQL (LENGTH |t|) 2)))
(|coreError| "invalid argument type for a native function"))
- (#0='T
- (PROGN
- (SETQ |m| (CAR |t|))
- (SETQ |c| (CAADR . #1=(|t|)))
- (SETQ |t'| (CADADR . #1#))
- (COND
- ((NOT (MEMBER |m| '(|readonly| |writeonly| |readwrite|)))
- (|coreError|
- "missing modifier for argument type for a native function"))
- ((NOT (MEMBER |c| '(|buffer| |pointer|)))
- (|coreError|
- "expect 'buffer' or 'pointer' type instance"))
- ((NOT (MEMBER |t'| |$NativeSimpleDataTypes|))
- (|coreError| "expected simple native data type"))
- (#0# (|nativeType| (CADR |t|))))))))))
+ (#0='T (SETQ |m| (CAR |t|)) (SETQ |c| (CAADR . #1=(|t|)))
+ (SETQ |t'| (CADADR . #1#))
+ (COND
+ ((NOT (MEMBER |m| '(|readonly| |writeonly| |readwrite|)))
+ (|coreError|
+ "missing modifier for argument type for a native function"))
+ ((NOT (MEMBER |c| '(|buffer| |pointer|)))
+ (|coreError| "expect 'buffer' or 'pointer' type instance"))
+ ((NOT (MEMBER |t'| |$NativeSimpleDataTypes|))
+ (|coreError| "expected simple native data type"))
+ (#0# (|nativeType| (CADR |t|)))))))))
(DEFUN |needsStableReference?| (|t|)
(PROG (|m|)
@@ -2268,19 +2197,17 @@
((|%hasFeature| :SBCL)
(COND
((NOT (|needsStableReference?| |t|)) |a|)
- (#0='T
- (PROGN
- (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"
- (SYMBOL-NAME |c|)))))))))
+ (#0='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"
+ (SYMBOL-NAME |c|))))))))
(#0#
(|fatalError|
"don't know how to coerce argument for native type"))))))
@@ -2317,91 +2244,91 @@
(SETQ |bfVar#128| (CDR |bfVar#128|))))
(LIST (LIST 'DEFENTRY |op| |argtypes|
(LIST |rettype| (SYMBOL-NAME |op'|)))))
- (#1='T
- (PROGN
- (SETQ |cop| (CONCAT (SYMBOL-NAME |op'|) "_stub"))
- (SETQ |cargs|
- (LET ((|bfVar#136| NIL)
- (|bfVar#135| (- (LENGTH |s|) 1)) (|i| 0))
- (LOOP
- (COND
- ((> |i| |bfVar#135|)
- (RETURN (NREVERSE |bfVar#136|)))
- (#0#
- (SETQ |bfVar#136|
- (CONS (|genGCLnativeTranslation,mkCArgName|
- |i|)
- |bfVar#136|))))
- (SETQ |i| (+ |i| 1)))))
- (SETQ |ccode|
- (LET ((|bfVar#132| "")
- (|bfVar#134|
- (CONS (|genGCLnativeTranslation,gclTypeInC|
- |t|)
- (CONS " "
- (CONS |cop|
- (CONS "("
- (APPEND
- (LET
- ((|bfVar#130| NIL) (|x| |s|)
- (|a| |cargs|))
- (LOOP
- (COND
- ((OR (ATOM |x|)
- (ATOM |a|))
- (RETURN
- (NREVERSE |bfVar#130|)))
- (#0#
- (SETQ |bfVar#130|
- (CONS
- (|genGCLnativeTranslation,cparm|
- |x| |a|)
- |bfVar#130|))))
- (SETQ |x| (CDR |x|))
- (SETQ |a| (CDR |a|))))
- (CONS ") { "
- (CONS
- (COND
- ((NOT (EQ |t| '|void|))
- "return ")
- (#1# '||))
- (CONS (SYMBOL-NAME |op'|)
- (CONS "("
- (APPEND
- (LET
- ((|bfVar#131| NIL)
- (|x| |s|) (|a| |cargs|))
- (LOOP
- (COND
- ((OR (ATOM |x|)
- (ATOM |a|))
- (RETURN
- (NREVERSE
- |bfVar#131|)))
- (#0#
- (SETQ |bfVar#131|
- (CONS
- (|genGCLnativeTranslation,gclArgsInC|
- |x| |a|)
- |bfVar#131|))))
- (SETQ |x| (CDR |x|))
- (SETQ |a| (CDR |a|))))
- (CONS "); }" NIL))))))))))))
- (|bfVar#133| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#134|)
- (PROGN
- (SETQ |bfVar#133| (CAR |bfVar#134|))
- NIL))
- (RETURN |bfVar#132|))
- (#0#
- (SETQ |bfVar#132|
- (CONCAT |bfVar#132| |bfVar#133|))))
- (SETQ |bfVar#134| (CDR |bfVar#134|)))))
- (LIST (LIST 'CLINES |ccode|)
- (LIST 'DEFENTRY |op| |argtypes|
- (LIST |rettype| |cop|))))))))))
+ (#1='T (SETQ |cop| (CONCAT (SYMBOL-NAME |op'|) "_stub"))
+ (SETQ |cargs|
+ (LET ((|bfVar#136| NIL)
+ (|bfVar#135| (- (LENGTH |s|) 1)) (|i| 0))
+ (LOOP
+ (COND
+ ((> |i| |bfVar#135|)
+ (RETURN (NREVERSE |bfVar#136|)))
+ (#0#
+ (SETQ |bfVar#136|
+ (CONS (|genGCLnativeTranslation,mkCArgName|
+ |i|)
+ |bfVar#136|))))
+ (SETQ |i| (+ |i| 1)))))
+ (SETQ |ccode|
+ (LET ((|bfVar#132| "")
+ (|bfVar#134|
+ (CONS (|genGCLnativeTranslation,gclTypeInC|
+ |t|)
+ (CONS " "
+ (CONS |cop|
+ (CONS "("
+ (APPEND
+ (LET
+ ((|bfVar#130| NIL) (|x| |s|)
+ (|a| |cargs|))
+ (LOOP
+ (COND
+ ((OR (ATOM |x|)
+ (ATOM |a|))
+ (RETURN
+ (NREVERSE
+ |bfVar#130|)))
+ (#0#
+ (SETQ |bfVar#130|
+ (CONS
+ (|genGCLnativeTranslation,cparm|
+ |x| |a|)
+ |bfVar#130|))))
+ (SETQ |x| (CDR |x|))
+ (SETQ |a| (CDR |a|))))
+ (CONS ") { "
+ (CONS
+ (COND
+ ((NOT (EQ |t| '|void|))
+ "return ")
+ (#1# '||))
+ (CONS (SYMBOL-NAME |op'|)
+ (CONS "("
+ (APPEND
+ (LET
+ ((|bfVar#131| NIL)
+ (|x| |s|)
+ (|a| |cargs|))
+ (LOOP
+ (COND
+ ((OR (ATOM |x|)
+ (ATOM |a|))
+ (RETURN
+ (NREVERSE
+ |bfVar#131|)))
+ (#0#
+ (SETQ |bfVar#131|
+ (CONS
+ (|genGCLnativeTranslation,gclArgsInC|
+ |x| |a|)
+ |bfVar#131|))))
+ (SETQ |x| (CDR |x|))
+ (SETQ |a| (CDR |a|))))
+ (CONS "); }" NIL))))))))))))
+ (|bfVar#133| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#134|)
+ (PROGN
+ (SETQ |bfVar#133| (CAR |bfVar#134|))
+ NIL))
+ (RETURN |bfVar#132|))
+ (#0#
+ (SETQ |bfVar#132|
+ (CONCAT |bfVar#132| |bfVar#133|))))
+ (SETQ |bfVar#134| (CDR |bfVar#134|)))))
+ (LIST (LIST 'CLINES |ccode|)
+ (LIST 'DEFENTRY |op| |argtypes|
+ (LIST |rettype| |cop|)))))))))
(DEFUN |genGCLnativeTranslation,mkCArgName| (|i|)
(CONCAT "x" (STRINGIMAGE |i|)))
@@ -2438,18 +2365,15 @@
(COND
((MEMBER |x| |$NativeSimpleDataTypes|) |a|)
((EQ |x| '|string|) |a|)
- (#0='T
- (PROGN
- (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"))
- (#0# (|coreError| "unknown argument type")))))))))
+ (#0='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"))
+ (#0# (|coreError| "unknown argument type"))))))))
(DEFUN |genGCLnativeTranslation,gclArgsInC| (|x| |a|)
(CONCAT (|genGCLnativeTranslation,gclArgInC| (CAR |x|) (CAR |a|))
@@ -2530,26 +2454,23 @@
(RETURN
(COND
((|isSimpleNativeType| |x|) "")
- (#0='T
- (PROGN
- (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")
- (#0# "->vector.self.b8")))
- ((EQ |y| '|int|) "->vector.self.fix")
- ((EQ |y| '|float|) "->vector.self.sf")
- ((EQ |y| '|double|) "->vector.self.df")
- (#0#
- (|coreError|
- "unknown argument to buffer type constructor"))))
- ((EQ |c| '|pointer|) '||)
- (#0# (|coreError| "unknown type constructor")))))))))
+ (#0='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")
+ (#0# "->vector.self.b8")))
+ ((EQ |y| '|int|) "->vector.self.fix")
+ ((EQ |y| '|float|) "->vector.self.sf")
+ ((EQ |y| '|double|) "->vector.self.df")
+ (#0#
+ (|coreError|
+ "unknown argument to buffer type constructor"))))
+ ((EQ |c| '|pointer|) '||)
+ (#0# (|coreError| "unknown type constructor"))))))))
(DEFUN |genCLISPnativeTranslation| (|op| |s| |t| |op'|)
(PROG (|forwardingFun| |ISTMP#2| |p| |fixups| |q| |call| |localPairs|
@@ -2636,123 +2557,117 @@
((NULL |unstableArgs|)
(LIST 'DEFUN |op| |parms| (CONS |n| |parms|)))
(#1='T
- (PROGN
- (SETQ |localPairs|
- (LET ((|bfVar#156| NIL)
- (|bfVar#155| |unstableArgs|)
- (|bfVar#154| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#155|)
- (PROGN
- (SETQ |bfVar#154|
- (CAR |bfVar#155|))
- NIL))
- (RETURN (NREVERSE |bfVar#156|)))
- (#0#
- (AND (CONSP |bfVar#154|)
+ (SETQ |localPairs|
+ (LET ((|bfVar#156| NIL)
+ (|bfVar#155| |unstableArgs|)
+ (|bfVar#154| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#155|)
+ (PROGN
+ (SETQ |bfVar#154|
+ (CAR |bfVar#155|))
+ NIL))
+ (RETURN (NREVERSE |bfVar#156|)))
+ (#0#
+ (AND (CONSP |bfVar#154|)
+ (PROGN
+ (SETQ |a| (CAR |bfVar#154|))
+ (SETQ |ISTMP#1| (CDR |bfVar#154|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |x| (CAR |ISTMP#1|))
+ (SETQ |y| (CDR |ISTMP#1|))
+ #2='T)))
+ (SETQ |bfVar#156|
+ (CONS
+ (CONS |a|
+ (CONS |x|
+ (CONS |y| (GENSYM "loc"))))
+ |bfVar#156|)))))
+ (SETQ |bfVar#155| (CDR |bfVar#155|)))))
+ (SETQ |call|
+ (CONS |n|
+ (LET ((|bfVar#158| NIL)
+ (|bfVar#157| |parms|) (|p| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#157|)
(PROGN
- (SETQ |a| (CAR |bfVar#154|))
- (SETQ |ISTMP#1|
- (CDR |bfVar#154|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |x| (CAR |ISTMP#1|))
- (SETQ |y| (CDR |ISTMP#1|))
- #2='T)))
- (SETQ |bfVar#156|
- (CONS
- (CONS |a|
- (CONS |x|
- (CONS |y| (GENSYM "loc"))))
- |bfVar#156|)))))
- (SETQ |bfVar#155| (CDR |bfVar#155|)))))
- (SETQ |call|
- (CONS |n|
- (LET ((|bfVar#158| NIL)
- (|bfVar#157| |parms|) (|p| NIL))
+ (SETQ |p| (CAR |bfVar#157|))
+ NIL))
+ (RETURN (NREVERSE |bfVar#158|)))
+ (#0#
+ (SETQ |bfVar#158|
+ (CONS
+ (|genCLISPnativeTranslation,actualArg|
+ |p| |localPairs|)
+ |bfVar#158|))))
+ (SETQ |bfVar#157| (CDR |bfVar#157|))))))
+ (SETQ |call|
+ (PROGN
+ (SETQ |fixups|
+ (LET ((|bfVar#160| NIL)
+ (|bfVar#159| |localPairs|)
+ (|p| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#157|)
+ ((OR (ATOM |bfVar#159|)
(PROGN
- (SETQ |p| (CAR |bfVar#157|))
+ (SETQ |p| (CAR |bfVar#159|))
NIL))
- (RETURN (NREVERSE |bfVar#158|)))
+ (RETURN (NREVERSE |bfVar#160|)))
(#0#
- (SETQ |bfVar#158|
- (CONS
- (|genCLISPnativeTranslation,actualArg|
- |p| |localPairs|)
- |bfVar#158|))))
- (SETQ |bfVar#157| (CDR |bfVar#157|))))))
- (SETQ |call|
- (PROGN
- (SETQ |fixups|
- (LET ((|bfVar#160| NIL)
- (|bfVar#159| |localPairs|)
- (|p| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#159|)
- (PROGN
- (SETQ |p| (CAR |bfVar#159|))
- NIL))
- (RETURN
- (NREVERSE |bfVar#160|)))
- (#0#
- (AND
- (NOT
- (NULL
- (SETQ |q|
- (|genCLISPnativeTranslation,copyBack|
- |p|))))
- (SETQ |bfVar#160|
- (CONS |q| |bfVar#160|)))))
- (SETQ |bfVar#159|
- (CDR |bfVar#159|)))))
- (COND
- ((NULL |fixups|) (LIST |call|))
- (#1#
- (LIST (CONS 'PROG1
- (CONS |call| |fixups|)))))))
- (LET ((|bfVar#162| |localPairs|) (|bfVar#161| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#162|)
- (PROGN
- (SETQ |bfVar#161| (CAR |bfVar#162|))
- NIL))
- (RETURN NIL))
- (#0#
- (AND (CONSP |bfVar#161|)
- (PROGN
- (SETQ |p| (CAR |bfVar#161|))
- (SETQ |ISTMP#1| (CDR |bfVar#161|))
- (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|))
- #2#)))))
- (SETQ |call|
- (LIST
- (CONS
- (|bfColonColon| 'FFI
- 'WITH-FOREIGN-OBJECT)
- (CONS
- (LIST |a|
- (LIST 'FUNCALL
- (LIST 'INTERN "getCLISPType"
- "BOOTTRAN")
- |p|)
- |p|)
- |call|)))))))
- (SETQ |bfVar#162| (CDR |bfVar#162|))))
- (CONS 'DEFUN (CONS |op| (CONS |parms| |call|)))))))
+ (AND
+ (NOT
+ (NULL
+ (SETQ |q|
+ (|genCLISPnativeTranslation,copyBack|
+ |p|))))
+ (SETQ |bfVar#160|
+ (CONS |q| |bfVar#160|)))))
+ (SETQ |bfVar#159| (CDR |bfVar#159|)))))
+ (COND
+ ((NULL |fixups|) (LIST |call|))
+ (#1#
+ (LIST (CONS 'PROG1 (CONS |call| |fixups|)))))))
+ (LET ((|bfVar#162| |localPairs|) (|bfVar#161| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#162|)
+ (PROGN
+ (SETQ |bfVar#161| (CAR |bfVar#162|))
+ NIL))
+ (RETURN NIL))
+ (#0#
+ (AND (CONSP |bfVar#161|)
+ (PROGN
+ (SETQ |p| (CAR |bfVar#161|))
+ (SETQ |ISTMP#1| (CDR |bfVar#161|))
+ (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|))
+ #2#)))))
+ (SETQ |call|
+ (LIST
+ (CONS
+ (|bfColonColon| 'FFI
+ 'WITH-FOREIGN-OBJECT)
+ (CONS
+ (LIST |a|
+ (LIST 'FUNCALL
+ (LIST 'INTERN "getCLISPType"
+ "BOOTTRAN")
+ |p|)
+ |p|)
+ |call|)))))))
+ (SETQ |bfVar#162| (CDR |bfVar#162|))))
+ (CONS 'DEFUN (CONS |op| (CONS |parms| |call|))))))
(SETQ |$foreignsDefsForCLisp|
(CONS |foreignDecl| |$foreignsDefsForCLisp|))
(LIST |forwardingFun|)))))
@@ -2888,20 +2803,18 @@
#0#)))))))
(|coreError| "invalid function type"))
(#1='T
- (PROGN
- (COND
- ((AND (NOT (NULL |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'|))
- (#1#
- (|fatalError|
- "import declaration not implemented for this Lisp")))))))))
+ (COND
+ ((AND (NOT (NULL |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'|))
+ (#1#
+ (|fatalError|
+ "import declaration not implemented for this Lisp"))))))))
diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp
index 08964695..6146ddc7 100644
--- a/src/boot/strap/includer.clisp
+++ b/src/boot/strap/includer.clisp
@@ -93,24 +93,20 @@
(RETURN
(COND
((|bStreamNull| |stream|) (LIST NIL (LIST '|nullstream|)))
- ('T
- (PROGN
- (SETQ |a| (CAAR |stream|))
- (COND
- ((AND (NOT (< (LENGTH |a|) 8))
- (EQUAL (SUBSTRING |a| 0 8) ")package"))
- (|shoePackageStartsAt| (CONS (CAAR |stream|) |lines|)
- |sz| |name| (CDR |stream|)))
- ((< (LENGTH |a|) |sz|)
- (|shoePackageStartsAt| |lines| |sz| |name|
- (CDR |stream|)))
- ((AND (EQUAL (SUBSTRING |a| 0 |sz|) |name|)
- (< |sz| (LENGTH |a|))
- (NOT (|shoeIdChar| (ELT |a| |sz|))))
- (LIST |lines| |stream|))
- ('T
- (|shoePackageStartsAt| |lines| |sz| |name|
- (CDR |stream|))))))))))
+ ('T (SETQ |a| (CAAR |stream|))
+ (COND
+ ((AND (NOT (< (LENGTH |a|) 8))
+ (EQUAL (SUBSTRING |a| 0 8) ")package"))
+ (|shoePackageStartsAt| (CONS (CAAR |stream|) |lines|) |sz|
+ |name| (CDR |stream|)))
+ ((< (LENGTH |a|) |sz|)
+ (|shoePackageStartsAt| |lines| |sz| |name| (CDR |stream|)))
+ ((AND (EQUAL (SUBSTRING |a| 0 |sz|) |name|)
+ (< |sz| (LENGTH |a|))
+ (NOT (|shoeIdChar| (ELT |a| |sz|))))
+ (LIST |lines| |stream|))
+ ('T
+ (|shoePackageStartsAt| |lines| |sz| |name| (CDR |stream|)))))))))
(DEFUN |shoeFindLines| (|fn| |name| |a|)
(PROG (|b| |lines| |LETTMP#1|)
@@ -140,16 +136,15 @@
(COND
((OR (NULL |x|) (EQCAR |x| '|nullstream|)) T)
('T
- (PROGN
- (LOOP
- (COND
- ((NOT (EQCAR |x| '|nonnullstream|)) (RETURN NIL))
- ('T
- (PROGN
- (SETQ |st| (APPLY (CADR |x|) (CDDR |x|)))
- (RPLACA |x| (CAR |st|))
- (RPLACD |x| (CDR |st|))))))
- (EQCAR |x| '|nullstream|)))))))
+ (LOOP
+ (COND
+ ((NOT (EQCAR |x| '|nonnullstream|)) (RETURN NIL))
+ ('T
+ (PROGN
+ (SETQ |st| (APPLY (CADR |x|) (CDDR |x|)))
+ (RPLACA |x| (CAR |st|))
+ (RPLACD |x| (CDR |st|))))))
+ (EQCAR |x| '|nullstream|))))))
(DEFUN |bMap| (|f| |x|) (|bDelay| #'|bMap1| (LIST |f| |x|)))
@@ -171,16 +166,12 @@
(PROGN
(SETQ |a| (|shoeInputFile| |fn|))
(COND
- ((NULL |a|)
- (PROGN
- (|shoeConsole| (CONCAT |fn| " NOT FOUND"))
- |$bStreamNil|))
- ('T
- (PROGN
- (|shoeConsole| (CONCAT "READING " |fn|))
- (|shoeInclude|
- (|bAddLineNumber| (|bMap| |f| (|bRgen| |a|))
- (|bIgen| 0))))))))))
+ ((NULL |a|) (|shoeConsole| (CONCAT |fn| " NOT FOUND"))
+ |$bStreamNil|)
+ ('T (|shoeConsole| (CONCAT "READING " |fn|))
+ (|shoeInclude|
+ (|bAddLineNumber| (|bMap| |f| (|bRgen| |a|))
+ (|bIgen| 0)))))))))
(DEFUN |bDelay| (|f| |x|) (CONS '|nonnullstream| (CONS |f| |x|)))
@@ -201,10 +192,8 @@
(RETURN
(COND
((|bStreamNull| |s|) (LIST '|nullstream|))
- ('T
- (PROGN
- (SETQ |h| (APPLY |f| (LIST |s|)))
- (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|)))))))))
+ ('T (SETQ |h| (APPLY |f| (LIST |s|)))
+ (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|))))))))
(DEFUN |bRgen| (|s|) (|bDelay| #'|bRgen1| (LIST |s|)))
@@ -255,21 +244,19 @@
(RETURN
(COND
((< (LENGTH |whole|) (LENGTH |prefix|)) NIL)
- ('T
- (PROGN
- (SETQ |good| T)
- (LET ((|bfVar#1| (- (LENGTH |prefix|) 1)) (|i| 0) (|j| 0))
- (LOOP
- (COND
- ((OR (> |i| |bfVar#1|) (NOT |good|)) (RETURN NIL))
- ('T
- (SETQ |good|
- (EQUAL (ELT |prefix| |i|) (ELT |whole| |j|)))))
- (SETQ |i| (+ |i| 1))
- (SETQ |j| (+ |j| 1))))
- (COND
- (|good| (SUBSTRING |whole| (LENGTH |prefix|) NIL))
- ('T |good|))))))))
+ ('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|
+ (EQUAL (ELT |prefix| |i|) (ELT |whole| |j|)))))
+ (SETQ |i| (+ |i| 1))
+ (SETQ |j| (+ |j| 1))))
+ (COND
+ (|good| (SUBSTRING |whole| (LENGTH |prefix|) NIL))
+ ('T |good|)))))))
(DEFUN |shoePlainLine?| (|s|)
(COND
@@ -312,14 +299,12 @@
(SETQ |n| (STRPOSL " " |x| 0 T))
(COND
((NULL |n|) NIL)
- (#0='T
- (PROGN
- (SETQ |n1| (STRPOSL " " |x| |n| NIL))
- (COND
- ((NULL |n1|) (LIST (SUBSTRING |x| |n| NIL) ""))
- (#0#
- (LIST (SUBSTRING |x| |n| (- |n1| |n|))
- (SUBSTRING |x| |n1| NIL)))))))))))
+ (#0='T (SETQ |n1| (STRPOSL " " |x| |n| NIL))
+ (COND
+ ((NULL |n1|) (LIST (SUBSTRING |x| |n| NIL) ""))
+ (#0#
+ (LIST (SUBSTRING |x| |n| (- |n1| |n|))
+ (SUBSTRING |x| |n1| NIL))))))))))
(DEFUN |shoeFileName| (|x|)
(PROG (|c| |a|)
@@ -328,12 +313,10 @@
(SETQ |a| (|shoeBiteOff| |x|))
(COND
((NULL |a|) "")
- (#0='T
- (PROGN
- (SETQ |c| (|shoeBiteOff| (CADR |a|)))
- (COND
- ((NULL |c|) (CAR |a|))
- (#0# (CONCAT (CAR |a|) "." (CAR |c|)))))))))))
+ (#0='T (SETQ |c| (|shoeBiteOff| (CADR |a|)))
+ (COND
+ ((NULL |c|) (CAR |a|))
+ (#0# (CONCAT (CAR |a|) "." (CAR |c|))))))))))
(DEFUN |shoeFnFileName| (|x|)
(PROG (|c| |a|)
@@ -342,12 +325,10 @@
(SETQ |a| (|shoeBiteOff| |x|))
(COND
((NULL |a|) (LIST "" ""))
- (#0='T
- (PROGN
- (SETQ |c| (|shoeFileName| (CADR |a|)))
- (COND
- ((NULL |c|) (LIST (CAR |a|) ""))
- (#0# (LIST (CAR |a|) |c|))))))))))
+ (#0='T (SETQ |c| (|shoeFileName| (CADR |a|)))
+ (COND
+ ((NULL |c|) (LIST (CAR |a|) ""))
+ (#0# (LIST (CAR |a|) |c|)))))))))
(DEFUN |shoeFunctionFileInput| (|bfVar#2|)
(PROG (|fn| |fun|)
@@ -368,17 +349,13 @@
(RETURN
(COND
((|bStreamNull| |s|) |s|)
- (#0='T
- (PROGN
- (SETQ |h| (CAR |s|))
- (SETQ |t| (CDR |s|))
- (SETQ |string| (CAR |h|))
- (COND
- ((SETQ |command| (|shoeFin?| |string|)) |$bStreamNil|)
- ((SETQ |command| (|shoeIf?| |string|))
- (|shoeThen| (LIST T) (LIST (STTOMC |command|)) |t|))
- (#0#
- (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|))))))))))
+ (#0='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|))
+ (#0# (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|)))))))))
(DEFUN |shoeSimpleLine| (|h|)
(PROG (|command| |string|)
@@ -399,10 +376,10 @@
(|shoeFileInput| (|shoeFileName| |command|)))
((SETQ |command| (|shoePackage?| |string|)) (LIST |h|))
((SETQ |command| (|shoeSay?| |string|))
- (PROGN (|shoeConsole| |command|) NIL))
- ((SETQ |command| (|shoeEval?| |string|))
- (PROGN (STTOMC |command|) NIL))
- ('T (PROGN (|shoeLineSyntaxError| |h|) NIL)))))))
+ (|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|)))
@@ -412,50 +389,44 @@
(RETURN
(COND
((|bPremStreamNull| |s|) |s|)
- (#0='T
- (PROGN
- (SETQ |h| (CAR |s|))
- (SETQ |t| (CDR |s|))
- (SETQ |string| (CAR |h|))
- (COND
- ((SETQ |command| (|shoeFin?| |string|))
- (|bPremStreamNil| |h|))
- (#0#
- (PROGN
- (SETQ |keep1| (CAR |keep|))
- (SETQ |b1| (CAR |b|))
- (COND
- ((SETQ |command| (|shoeIf?| |string|))
- (COND
- ((AND |keep1| |b1|)
- (|shoeThen| (CONS T |keep|)
- (CONS (STTOMC |command|) |b|) |t|))
- (#0#
- (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
- ((SETQ |command| (|shoeElseIf?| |string|))
- (COND
- ((AND |keep1| (NOT |b1|))
- (|shoeThen| (CONS T (CDR |keep|))
- (CONS (STTOMC |command|) (CDR |b|)) |t|))
- (#0#
- (|shoeThen| (CONS NIL (CDR |keep|))
- (CONS NIL (CDR |b|)) |t|))))
- ((SETQ |command| (|shoeElse?| |string|))
- (COND
- ((AND |keep1| (NOT |b1|))
- (|shoeElse| (CONS T (CDR |keep|))
- (CONS T (CDR |b|)) |t|))
- (#0#
- (|shoeElse| (CONS NIL (CDR |keep|))
- (CONS NIL (CDR |b|)) |t|))))
- ((SETQ |command| (|shoeEndIf?| |string|))
- (COND
- ((NULL (CDR |b|)) (|shoeInclude| |t|))
- (#0# (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
- ((AND |keep1| |b1|)
- (|bAppend| (|shoeSimpleLine| |h|)
- (|shoeThen| |keep| |b| |t|)))
- (#0# (|shoeThen| |keep| |b| |t|))))))))))))
+ (#0='T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
+ (SETQ |string| (CAR |h|))
+ (COND
+ ((SETQ |command| (|shoeFin?| |string|))
+ (|bPremStreamNil| |h|))
+ (#0# (SETQ |keep1| (CAR |keep|)) (SETQ |b1| (CAR |b|))
+ (COND
+ ((SETQ |command| (|shoeIf?| |string|))
+ (COND
+ ((AND |keep1| |b1|)
+ (|shoeThen| (CONS T |keep|)
+ (CONS (STTOMC |command|) |b|) |t|))
+ (#0#
+ (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
+ ((SETQ |command| (|shoeElseIf?| |string|))
+ (COND
+ ((AND |keep1| (NOT |b1|))
+ (|shoeThen| (CONS T (CDR |keep|))
+ (CONS (STTOMC |command|) (CDR |b|)) |t|))
+ (#0#
+ (|shoeThen| (CONS NIL (CDR |keep|))
+ (CONS NIL (CDR |b|)) |t|))))
+ ((SETQ |command| (|shoeElse?| |string|))
+ (COND
+ ((AND |keep1| (NOT |b1|))
+ (|shoeElse| (CONS T (CDR |keep|)) (CONS T (CDR |b|))
+ |t|))
+ (#0#
+ (|shoeElse| (CONS NIL (CDR |keep|))
+ (CONS NIL (CDR |b|)) |t|))))
+ ((SETQ |command| (|shoeEndIf?| |string|))
+ (COND
+ ((NULL (CDR |b|)) (|shoeInclude| |t|))
+ (#0# (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
+ ((AND |keep1| |b1|)
+ (|bAppend| (|shoeSimpleLine| |h|)
+ (|shoeThen| |keep| |b| |t|)))
+ (#0# (|shoeThen| |keep| |b| |t|))))))))))
(DEFUN |shoeElse| (|keep| |b| |s|)
(|bDelay| #'|shoeElse1| (LIST |keep| |b| |s|)))
@@ -465,34 +436,28 @@
(RETURN
(COND
((|bPremStreamNull| |s|) |s|)
- (#0='T
- (PROGN
- (SETQ |h| (CAR |s|))
- (SETQ |t| (CDR |s|))
- (SETQ |string| (CAR |h|))
- (COND
- ((SETQ |command| (|shoeFin?| |string|))
- (|bPremStreamNil| |h|))
- (#0#
- (PROGN
- (SETQ |b1| (CAR |b|))
- (SETQ |keep1| (CAR |keep|))
- (COND
- ((SETQ |command| (|shoeIf?| |string|))
- (COND
- ((AND |keep1| |b1|)
- (|shoeThen| (CONS T |keep|)
- (CONS (STTOMC |command|) |b|) |t|))
- (#0#
- (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
- ((SETQ |command| (|shoeEndIf?| |string|))
- (COND
- ((NULL (CDR |b|)) (|shoeInclude| |t|))
- (#0# (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
- ((AND |keep1| |b1|)
- (|bAppend| (|shoeSimpleLine| |h|)
- (|shoeElse| |keep| |b| |t|)))
- (#0# (|shoeElse| |keep| |b| |t|))))))))))))
+ (#0='T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
+ (SETQ |string| (CAR |h|))
+ (COND
+ ((SETQ |command| (|shoeFin?| |string|))
+ (|bPremStreamNil| |h|))
+ (#0# (SETQ |b1| (CAR |b|)) (SETQ |keep1| (CAR |keep|))
+ (COND
+ ((SETQ |command| (|shoeIf?| |string|))
+ (COND
+ ((AND |keep1| |b1|)
+ (|shoeThen| (CONS T |keep|)
+ (CONS (STTOMC |command|) |b|) |t|))
+ (#0#
+ (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
+ ((SETQ |command| (|shoeEndIf?| |string|))
+ (COND
+ ((NULL (CDR |b|)) (|shoeInclude| |t|))
+ (#0# (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
+ ((AND |keep1| |b1|)
+ (|bAppend| (|shoeSimpleLine| |h|)
+ (|shoeElse| |keep| |b| |t|)))
+ (#0# (|shoeElse| |keep| |b| |t|))))))))))
(DEFUN |shoeLineSyntaxError| (|h|)
(PROGN
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index 36bece77..15e77276 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -35,10 +35,10 @@
(COND
((AND (< 0 |$bpParenCount|) (EQCAR |$stok| 'KEY))
(COND
- ((EQ |$ttok| 'SETTAB)
- (PROGN (SETQ |$bpCount| (+ |$bpCount| 1)) (|bpNext|)))
- ((EQ |$ttok| 'BACKTAB)
- (PROGN (SETQ |$bpCount| (- |$bpCount| 1)) (|bpNext|)))
+ ((EQ |$ttok| 'SETTAB) (SETQ |$bpCount| (+ |$bpCount| 1))
+ (|bpNext|))
+ ((EQ |$ttok| 'BACKTAB) (SETQ |$bpCount| (- |$bpCount| 1))
+ (|bpNext|))
((EQ |$ttok| 'BACKSET) (|bpNext|))
(#0='T T)))
(#0# T))))
@@ -119,14 +119,13 @@
(COND
((EQL |$bpCount| 0) T)
(#0='T
- (PROGN
- (SETQ |$inputStream|
- (APPEND (|bpAddTokens| |$bpCount|)
- |$inputStream|))
- (|bpFirstToken|)
- (COND
- ((EQL |$bpParenCount| 0) (PROGN (|bpCancel|) T))
- (#0# T))))))
+ (SETQ |$inputStream|
+ (APPEND (|bpAddTokens| |$bpCount|)
+ |$inputStream|))
+ (|bpFirstToken|)
+ (COND
+ ((EQL |$bpParenCount| 0) (|bpCancel|) T)
+ (#0# T)))))
((|bpEqPeek| 'CPAREN) (|bpPush| (|bfTuple| NIL))
(SETQ |$bpParenCount| (- |$bpParenCount| 1))
(|bpNextToken|) T)
@@ -244,13 +243,10 @@
(DECLARE (SPECIAL |$stack|))
(RETURN
(COND
- ((APPLY |f| NIL)
- (PROGN
- (SETQ |a| |$stack|)
- (SETQ |$stack| NIL)
- (LOOP (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) ('T 0)))
- (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|))
- (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))))
+ ((APPLY |f| NIL) (SETQ |a| |$stack|) (SETQ |$stack| NIL)
+ (LOOP (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) ('T 0)))
+ (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|))
+ (|bpPush| (CONS (|bpPop2|) (|bpPop1|))))
('T NIL)))))
(DEFUN |bpAnyNo| (|s|)
@@ -380,61 +376,45 @@
((|bpEqPeek| 'BACKTAB)
(COND
((EQL |n| 0) T)
- (#0='T
- (PROGN
- (|bpNextToken|)
- (SETQ |$bpCount| (- |$bpCount| 1))
- (|bpMoveTo| (- |n| 1))))))
+ (#0='T (|bpNextToken|) (SETQ |$bpCount| (- |$bpCount| 1))
+ (|bpMoveTo| (- |n| 1)))))
((|bpEqPeek| 'BACKSET)
- (COND
- ((EQL |n| 0) T)
- (#0# (PROGN (|bpNextToken|) (|bpMoveTo| |n|)))))
- ((|bpEqPeek| 'SETTAB)
- (PROGN (|bpNextToken|) (|bpMoveTo| (+ |n| 1))))
- ((|bpEqPeek| 'OPAREN)
- (PROGN
- (|bpNextToken|)
- (SETQ |$bpParenCount| (+ |$bpParenCount| 1))
- (|bpMoveTo| |n|)))
- ((|bpEqPeek| 'CPAREN)
- (PROGN
- (|bpNextToken|)
- (SETQ |$bpParenCount| (- |$bpParenCount| 1))
- (|bpMoveTo| |n|)))
- (#0# (PROGN (|bpNextToken|) (|bpMoveTo| |n|)))))
+ (COND ((EQL |n| 0) T) (#0# (|bpNextToken|) (|bpMoveTo| |n|))))
+ ((|bpEqPeek| 'SETTAB) (|bpNextToken|) (|bpMoveTo| (+ |n| 1)))
+ ((|bpEqPeek| 'OPAREN) (|bpNextToken|)
+ (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) (|bpMoveTo| |n|))
+ ((|bpEqPeek| 'CPAREN) (|bpNextToken|)
+ (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpMoveTo| |n|))
+ (#0# (|bpNextToken|) (|bpMoveTo| |n|))))
(DEFUN |bpQualifiedName| ()
(DECLARE (SPECIAL |$stok|))
(COND
- ((|bpEqPeek| 'COLON-COLON)
- (PROGN
- (|bpNext|)
- (AND (EQCAR |$stok| 'ID) (|bpPushId|) (|bpNext|)
- (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|))))))
+ ((|bpEqPeek| 'COLON-COLON) (|bpNext|)
+ (AND (EQCAR |$stok| 'ID) (|bpPushId|) (|bpNext|)
+ (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|)))))
('T NIL)))
(DEFUN |bpName| ()
(DECLARE (SPECIAL |$stok|))
(COND
- ((EQCAR |$stok| 'ID)
- (PROGN (|bpPushId|) (|bpNext|) (|bpAnyNo| #'|bpQualifiedName|)))
+ ((EQCAR |$stok| 'ID) (|bpPushId|) (|bpNext|)
+ (|bpAnyNo| #'|bpQualifiedName|))
('T NIL)))
(DEFUN |bpConstTok| ()
(DECLARE (SPECIAL |$ttok| |$stok|))
(COND
- ((MEMQ (|shoeTokType| |$stok|) '(INTEGER FLOAT))
- (PROGN (|bpPush| |$ttok|) (|bpNext|)))
+ ((MEMQ (|shoeTokType| |$stok|) '(INTEGER FLOAT)) (|bpPush| |$ttok|)
+ (|bpNext|))
((EQCAR |$stok| 'LISP)
(AND (|bpPush| (|%Lisp| |$ttok|)) (|bpNext|)))
((EQCAR |$stok| 'LISPEXP) (AND (|bpPush| |$ttok|) (|bpNext|)))
((EQCAR |$stok| 'LINE)
(AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|)))
- ((|bpEqPeek| 'QUOTE)
- (PROGN
- (|bpNext|)
- (AND (OR (|bpSexp|) (|bpTrap|))
- (|bpPush| (|bfSymbol| (|bpPop1|))))))
+ ((|bpEqPeek| 'QUOTE) (|bpNext|)
+ (AND (OR (|bpSexp|) (|bpTrap|))
+ (|bpPush| (|bfSymbol| (|bpPop1|)))))
('T (|bpString|))))
(DEFUN |bpExportItemTail| ()
@@ -447,19 +427,15 @@
(RETURN
(COND
((|bpEqPeek| 'STRUCTURE) (|bpStruct|))
- (#0='T
- (PROGN
- (SETQ |a| (|bpState|))
- (COND
- ((|bpName|)
- (COND
- ((|bpEqPeek| 'COLON)
- (PROGN
- (|bpRestore| |a|)
- (OR (|bpSignature|) (|bpTrap|))
- (OR (|bpExportItemTail|) T)))
- (#0# (PROGN (|bpRestore| |a|) (|bpTypeAliasDefition|)))))
- (#0# NIL))))))))
+ (#0='T (SETQ |a| (|bpState|))
+ (COND
+ ((|bpName|)
+ (COND
+ ((|bpEqPeek| 'COLON) (|bpRestore| |a|)
+ (OR (|bpSignature|) (|bpTrap|))
+ (OR (|bpExportItemTail|) T))
+ (#0# (|bpRestore| |a|) (|bpTypeAliasDefition|))))
+ (#0# NIL)))))))
(DEFUN |bpExportItemList| () (|bpListAndRecover| #'|bpExportItem|))
@@ -481,20 +457,15 @@
(PROG (|a|)
(RETURN
(COND
- ((|bpEqKey| 'IMPORT)
- (PROGN
- (SETQ |a| (|bpState|))
- (OR (|bpName|) (|bpTrap|))
- (COND
- ((|bpEqPeek| 'COLON)
- (PROGN
- (|bpRestore| |a|)
- (AND (OR (|bpSignature|) (|bpTrap|))
- (OR (|bpEqKey| 'FOR) (|bpTrap|))
- (OR (|bpName|) (|bpTrap|))
- (|bpPush|
- (|%ImportSignature| (|bpPop1|) (|bpPop1|))))))
- (#0='T (|bpPush| (|%Import| (|bpPop1|)))))))
+ ((|bpEqKey| 'IMPORT) (SETQ |a| (|bpState|))
+ (OR (|bpName|) (|bpTrap|))
+ (COND
+ ((|bpEqPeek| 'COLON) (|bpRestore| |a|)
+ (AND (OR (|bpSignature|) (|bpTrap|))
+ (OR (|bpEqKey| 'FOR) (|bpTrap|))
+ (OR (|bpName|) (|bpTrap|))
+ (|bpPush| (|%ImportSignature| (|bpPop1|) (|bpPop1|)))))
+ (#0='T (|bpPush| (|%Import| (|bpPop1|))))))
(#0# NIL)))))
(DEFUN |bpNamespace| ()
@@ -512,10 +483,9 @@
(DEFUN |bpSimpleMapping| ()
(COND
((|bpApplication|)
- (PROGN
- (AND (|bpEqKey| 'ARROW) (OR (|bpApplication|) (|bpTrap|))
- (|bpPush| (|%Mapping| (|bpPop1|) (|bfUntuple| (|bpPop1|)))))
- T))
+ (AND (|bpEqKey| 'ARROW) (OR (|bpApplication|) (|bpTrap|))
+ (|bpPush| (|%Mapping| (|bpPop1|) (|bfUntuple| (|bpPop1|)))))
+ T)
('T NIL)))
(DEFUN |bpArgtypeList| () (|bpTuple| #'|bpApplication|))
@@ -564,11 +534,10 @@
(RETURN
(COND
((AND (EQCAR |$stok| 'KEY) (NOT (|bpExceptions|)))
- (PROGN
- (SETQ |a| (GET |$ttok| 'SHOEINF))
- (COND
- ((NULL |a|) (AND (|bpPush| |$ttok|) (|bpNext|)))
- (#0='T (AND (|bpPush| |a|) (|bpNext|))))))
+ (SETQ |a| (GET |$ttok| 'SHOEINF))
+ (COND
+ ((NULL |a|) (AND (|bpPush| |$ttok|) (|bpNext|)))
+ (#0='T (AND (|bpPush| |a|) (|bpNext|)))))
(#0# NIL)))))
(DEFUN |bpAnyId| ()
@@ -878,12 +847,12 @@
(COND
((|bpExit|)
(COND
- ((|bpEqPeek| 'DEF) (PROGN (|bpRestore| |a|) (|bpDef|)))
- ((|bpEqPeek| 'TDEF)
- (PROGN (|bpRestore| |a|) (|bpTypeAliasDefition|)))
- ((|bpEqPeek| 'MDEF) (PROGN (|bpRestore| |a|) (|bpMdef|)))
+ ((|bpEqPeek| 'DEF) (|bpRestore| |a|) (|bpDef|))
+ ((|bpEqPeek| 'TDEF) (|bpRestore| |a|)
+ (|bpTypeAliasDefition|))
+ ((|bpEqPeek| 'MDEF) (|bpRestore| |a|) (|bpMdef|))
(#0='T T)))
- (#0# (PROGN (|bpRestore| |a|) NIL)))))))
+ (#0# (|bpRestore| |a|) NIL))))))
(DEFUN |bpStoreName| ()
(DECLARE (SPECIAL |$typings| |$wheredefs| |$op| |$stack|))
diff --git a/src/boot/strap/scanner.clisp b/src/boot/strap/scanner.clisp
index 5590d0ca..21722a2a 100644
--- a/src/boot/strap/scanner.clisp
+++ b/src/boot/strap/scanner.clisp
@@ -50,12 +50,11 @@
(COND
((NULL |$n|) T)
((EQUAL (QENUM |$ln| |$n|) |shoeTAB|)
- (PROGN
- (SETQ |a| (MAKE-FULL-CVEC (- 7 (REM |$n| 8)) " "))
- (SETF (ELT |$ln| |$n|) (ELT " " 0))
- (SETQ |$ln| (CONCAT |a| |$ln|))
- (SETQ |s1| (CONS (CONS |$ln| (CDR |$f|)) |$r|))
- (|shoeNextLine| |s1|)))
+ (SETQ |a| (MAKE-FULL-CVEC (- 7 (REM |$n| 8)) " "))
+ (SETF (ELT |$ln| |$n|) (ELT " " 0))
+ (SETQ |$ln| (CONCAT |a| |$ln|))
+ (SETQ |s1| (CONS (CONS |$ln| (CDR |$f|)) |$r|))
+ (|shoeNextLine| |s1|))
('T T)))))))
(DEFUN |shoeLineToks| (|s|)
@@ -74,41 +73,34 @@
(COND
((NOT (|shoeNextLine| |s|)) (CONS NIL NIL))
((NULL |$n|) (|shoeLineToks| |$r|))
- (#0='T
- (PROGN
- (SETQ |fst| (QENUM |$ln| 0))
- (COND
- ((EQL |fst| |shoeCLOSEPAREN|)
+ (#0='T (SETQ |fst| (QENUM |$ln| 0))
+ (COND
+ ((EQL |fst| |shoeCLOSEPAREN|)
+ (COND
+ ((SETQ |command| (|shoeLine?| |$ln|))
+ (SETQ |dq|
+ (|dqUnit|
+ (|shoeConstructToken| |$ln| |$linepos|
+ (|shoeLeafLine| |command|) 0)))
+ (CONS (LIST |dq|) |$r|))
+ ((SETQ |command| (|shoeLisp?| |$ln|))
+ (|shoeLispToken| |$r| |command|))
+ ((SETQ |command| (|shoePackage?| |$ln|))
+ (SETQ |a| (CONCAT "(IN-PACKAGE " |command| ")"))
+ (SETQ |dq|
+ (|dqUnit|
+ (|shoeConstructToken| |$ln| |$linepos|
+ (|shoeLeafLisp| |a|) 0)))
+ (CONS (LIST |dq|) |$r|))
+ (#0# (|shoeLineToks| |$r|))))
+ (#0# (SETQ |toks| NIL)
+ (LOOP
(COND
- ((SETQ |command| (|shoeLine?| |$ln|))
- (PROGN
- (SETQ |dq|
- (|dqUnit|
- (|shoeConstructToken| |$ln| |$linepos|
- (|shoeLeafLine| |command|) 0)))
- (CONS (LIST |dq|) |$r|)))
- ((SETQ |command| (|shoeLisp?| |$ln|))
- (|shoeLispToken| |$r| |command|))
- ((SETQ |command| (|shoePackage?| |$ln|))
- (PROGN
- (SETQ |a| (CONCAT "(IN-PACKAGE " |command| ")"))
- (SETQ |dq|
- (|dqUnit|
- (|shoeConstructToken| |$ln| |$linepos|
- (|shoeLeafLisp| |a|) 0)))
- (CONS (LIST |dq|) |$r|)))
- (#0# (|shoeLineToks| |$r|))))
- (#0#
- (PROGN
- (SETQ |toks| NIL)
- (LOOP
- (COND
- ((NOT (< |$n| |$sz|)) (RETURN NIL))
- ('T
- (SETQ |toks| (|dqAppend| |toks| (|shoeToken|))))))
- (COND
- ((NULL |toks|) (|shoeLineToks| |$r|))
- (#0# (CONS (LIST |toks|) |$r|)))))))))))))
+ ((NOT (< |$n| |$sz|)) (RETURN NIL))
+ ('T (SETQ |toks| (|dqAppend| |toks| (|shoeToken|))))))
+ (COND
+ ((NULL |toks|) (|shoeLineToks| |$r|))
+ (#0# (CONS (LIST |toks|) |$r|)))))))))))
(DEFUN |shoeLispToken| (|s| |string|)
(PROG (|dq| |st| |r| |LETTMP#1| |linepos| |ln|)
@@ -140,30 +132,25 @@
((NOT (|shoeNextLine| |s|)) (CONS |s| |string|))
((NULL |$n|) (|shoeAccumulateLines| |$r| |string|))
((EQL (LENGTH |$ln|) 0) (|shoeAccumulateLines| |$r| |string|))
- (#0='T
- (PROGN
- (SETQ |fst| (QENUM |$ln| 0))
- (COND
- ((EQL |fst| |shoeCLOSEPAREN|)
- (PROGN
- (SETQ |command| (|shoeLisp?| |$ln|))
- (COND
- ((AND |command| (< 0 (LENGTH |command|)))
- (COND
- ((EQL (QENUM |command| 0) (QENUM ";" 0))
- (|shoeAccumulateLines| |$r| |string|))
- (#0#
- (PROGN
- (SETQ |a| (STRPOS ";" |command| 0 NIL))
- (COND
- (|a| (|shoeAccumulateLines| |$r|
- (CONCAT |string|
- (SUBSTRING |command| 0 (- |a| 1)))))
- (#0#
- (|shoeAccumulateLines| |$r|
- (CONCAT |string| |command|))))))))
- (#0# (|shoeAccumulateLines| |$r| |string|)))))
- (#0# (CONS |s| |string|)))))))))
+ (#0='T (SETQ |fst| (QENUM |$ln| 0))
+ (COND
+ ((EQL |fst| |shoeCLOSEPAREN|)
+ (SETQ |command| (|shoeLisp?| |$ln|))
+ (COND
+ ((AND |command| (< 0 (LENGTH |command|)))
+ (COND
+ ((EQL (QENUM |command| 0) (QENUM ";" 0))
+ (|shoeAccumulateLines| |$r| |string|))
+ (#0# (SETQ |a| (STRPOS ";" |command| 0 NIL))
+ (COND
+ (|a| (|shoeAccumulateLines| |$r|
+ (CONCAT |string|
+ (SUBSTRING |command| 0 (- |a| 1)))))
+ (#0#
+ (|shoeAccumulateLines| |$r|
+ (CONCAT |string| |command|)))))))
+ (#0# (|shoeAccumulateLines| |$r| |string|))))
+ (#0# (CONS |s| |string|))))))))
(DEFUN |shoeCloser| (|t|)
(MEMBER (|shoeKeyWord| |t|) '(CPAREN CBRACK)))
@@ -180,18 +167,16 @@
(SETQ |ch| (ELT |$ln| |$n|))
(SETQ |b|
(COND
- ((|shoeStartsComment|) (PROGN (|shoeComment|) NIL))
- ((|shoeStartsNegComment|)
- (PROGN (|shoeNegComment|) NIL))
+ ((|shoeStartsComment|) (|shoeComment|) NIL)
+ ((|shoeStartsNegComment|) (|shoeNegComment|) NIL)
((EQUAL |c| |shoeLispESCAPE|) (|shoeLispEscape|))
((|shoePunctuation| |c|) (|shoePunct|))
((|shoeStartsId| |ch|) (|shoeWord| NIL))
- ((EQUAL |c| |shoeSPACE|) (PROGN (|shoeSpace|) NIL))
+ ((EQUAL |c| |shoeSPACE|) (|shoeSpace|) NIL)
((EQUAL |c| |shoeSTRINGCHAR|) (|shoeString|))
((|shoeDigit| |ch|) (|shoeNumber|))
((EQUAL |c| |shoeESCAPE|) (|shoeEscape|))
- ((EQUAL |c| |shoeTAB|)
- (PROGN (SETQ |$n| (+ |$n| 1)) NIL))
+ ((EQUAL |c| |shoeTAB|) (SETQ |$n| (+ |$n| 1)) NIL)
(#0='T (|shoeError|))))
(COND
((NULL |b|) NIL)
@@ -243,19 +228,14 @@
('T (SETQ |a| (|shoeReadLispString| |$ln| |$n|))
(COND
((NULL |a|)
- (PROGN
- (|SoftShoeError| (CONS |$linepos| |$n|)
- "lisp escape error")
- (|shoeLeafError| (ELT |$ln| |$n|))))
- (#0='T
- (PROGN
- (SETQ |exp| (CAR |a|))
- (SETQ |n| (CADR |a|))
- (COND
- ((NULL |n|)
- (PROGN (SETQ |$n| |$sz|) (|shoeLeafLispExp| |exp|)))
- (#0#
- (PROGN (SETQ |$n| |n|) (|shoeLeafLispExp| |exp|)))))))))))))
+ (|SoftShoeError| (CONS |$linepos| |$n|)
+ "lisp escape error")
+ (|shoeLeafError| (ELT |$ln| |$n|)))
+ (#0='T (SETQ |exp| (CAR |a|)) (SETQ |n| (CADR |a|))
+ (COND
+ ((NULL |n|) (SETQ |$n| |$sz|)
+ (|shoeLeafLispExp| |exp|))
+ (#0# (SETQ |$n| |n|) (|shoeLeafLispExp| |exp|)))))))))))
(DEFUN |shoeEscape| ()
(PROG (|a|)
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index 4b5ae83a..dfb850cb 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -28,59 +28,58 @@
((NULL |$currentModuleName|)
(|coreError| "current module has no name"))
(#0='T
- (PROGN
- (SETQ |init|
- (CONS 'DEFUN
- (CONS (INTERN (CONCAT |$currentModuleName|
- '|InitCLispFFI|))
- (CONS NIL
- (CONS
- (LIST 'MAPC
- (LIST 'FUNCTION 'FMAKUNBOUND)
- (LIST 'QUOTE
- (LET
- ((|bfVar#2| NIL)
- (|bfVar#1|
- |$foreignsDefsForCLisp|)
- (|d| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#1|)
- (PROGN
- (SETQ |d|
- (CAR |bfVar#1|))
- NIL))
- (RETURN
- (NREVERSE |bfVar#2|)))
- (#1='T
- (SETQ |bfVar#2|
- (CONS (CADR |d|)
- |bfVar#2|))))
- (SETQ |bfVar#1|
- (CDR |bfVar#1|))))))
+ (SETQ |init|
+ (CONS 'DEFUN
+ (CONS (INTERN (CONCAT |$currentModuleName|
+ '|InitCLispFFI|))
+ (CONS NIL
+ (CONS
+ (LIST 'MAPC
+ (LIST 'FUNCTION 'FMAKUNBOUND)
+ (LIST 'QUOTE
(LET
- ((|bfVar#4| NIL)
- (|bfVar#3|
+ ((|bfVar#2| NIL)
+ (|bfVar#1|
|$foreignsDefsForCLisp|)
(|d| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#3|)
+ ((OR (ATOM |bfVar#1|)
(PROGN
(SETQ |d|
- (CAR |bfVar#3|))
+ (CAR |bfVar#1|))
NIL))
(RETURN
- (NREVERSE |bfVar#4|)))
- (#1#
- (SETQ |bfVar#4|
- (CONS
- (LIST 'EVAL
- (LIST 'QUOTE |d|))
- |bfVar#4|))))
- (SETQ |bfVar#3|
- (CDR |bfVar#3|)))))))))
- (REALLYPRETTYPRINT |init| |stream|)))))
+ (NREVERSE |bfVar#2|)))
+ (#1='T
+ (SETQ |bfVar#2|
+ (CONS (CADR |d|)
+ |bfVar#2|))))
+ (SETQ |bfVar#1|
+ (CDR |bfVar#1|))))))
+ (LET
+ ((|bfVar#4| NIL)
+ (|bfVar#3|
+ |$foreignsDefsForCLisp|)
+ (|d| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#3|)
+ (PROGN
+ (SETQ |d|
+ (CAR |bfVar#3|))
+ NIL))
+ (RETURN
+ (NREVERSE |bfVar#4|)))
+ (#1#
+ (SETQ |bfVar#4|
+ (CONS
+ (LIST 'EVAL
+ (LIST 'QUOTE |d|))
+ |bfVar#4|))))
+ (SETQ |bfVar#3|
+ (CDR |bfVar#3|)))))))))
+ (REALLYPRETTYPRINT |init| |stream|))))
(#0# NIL)))))
(DEFUN |genOptimizeOptions| (|stream|)
@@ -146,23 +145,21 @@
(DECLARE (SPECIAL |$GenVarCounter|))
(COND
((NULL |a|) (|shoeNotFound| |fn|))
- ('T
- (PROGN
- (SETQ |$GenVarCounter| 0)
- (|shoeOpenOutputFile| |stream| |outfn|
- (PROGN
- (|genOptimizeOptions| |stream|)
- (LET ((|bfVar#5| |lines|) (|line| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#5|)
- (PROGN (SETQ |line| (CAR |bfVar#5|)) NIL))
- (RETURN NIL))
- ('T (|shoeFileLine| |line| |stream|)))
- (SETQ |bfVar#5| (CDR |bfVar#5|))))
- (|shoeFileTrees| (|shoeTransformStream| |a|) |stream|)
- (|genModuleFinalization| |stream|)))
- |outfn|))))
+ ('T (SETQ |$GenVarCounter| 0)
+ (|shoeOpenOutputFile| |stream| |outfn|
+ (PROGN
+ (|genOptimizeOptions| |stream|)
+ (LET ((|bfVar#5| |lines|) (|line| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#5|)
+ (PROGN (SETQ |line| (CAR |bfVar#5|)) NIL))
+ (RETURN NIL))
+ ('T (|shoeFileLine| |line| |stream|)))
+ (SETQ |bfVar#5| (CDR |bfVar#5|))))
+ (|shoeFileTrees| (|shoeTransformStream| |a|) |stream|)
+ (|genModuleFinalization| |stream|)))
+ |outfn|)))
(DEFUN BOOTTOCLC (|fn| |out|)
(PROG (|result| |callingPackage|)
@@ -189,27 +186,25 @@
(DECLARE (SPECIAL |$GenVarCounter|))
(COND
((NULL |a|) (|shoeNotFound| |fn|))
- ('T
- (PROGN
- (SETQ |$GenVarCounter| 0)
- (|shoeOpenOutputFile| |stream| |outfn|
- (PROGN
- (|genOptimizeOptions| |stream|)
- (LET ((|bfVar#6| |lines|) (|line| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#6|)
- (PROGN (SETQ |line| (CAR |bfVar#6|)) NIL))
- (RETURN NIL))
- ('T (|shoeFileLine| |line| |stream|)))
- (SETQ |bfVar#6| (CDR |bfVar#6|))))
- (|shoeFileTrees|
- (|shoeTransformToFile| |stream|
- (|shoeInclude|
- (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0))))
- |stream|)
- (|genModuleFinalization| |stream|)))
- |outfn|))))
+ ('T (SETQ |$GenVarCounter| 0)
+ (|shoeOpenOutputFile| |stream| |outfn|
+ (PROGN
+ (|genOptimizeOptions| |stream|)
+ (LET ((|bfVar#6| |lines|) (|line| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#6|)
+ (PROGN (SETQ |line| (CAR |bfVar#6|)) NIL))
+ (RETURN NIL))
+ ('T (|shoeFileLine| |line| |stream|)))
+ (SETQ |bfVar#6| (CDR |bfVar#6|))))
+ (|shoeFileTrees|
+ (|shoeTransformToFile| |stream|
+ (|shoeInclude|
+ (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0))))
+ |stream|)
+ (|genModuleFinalization| |stream|)))
+ |outfn|)))
(DECLAIM (FTYPE (FUNCTION (|%String|) |%Thing|) BOOTTOMC))
@@ -230,10 +225,8 @@
(DEFUN |shoeMc| (|a| |fn|)
(COND
((NULL |a|) (|shoeNotFound| |fn|))
- ('T
- (PROGN
- (|shoePCompileTrees| (|shoeTransformStream| |a|))
- (|shoeConsole| (CONCAT |fn| " COMPILED AND LOADED"))))))
+ ('T (|shoePCompileTrees| (|shoeTransformStream| |a|))
+ (|shoeConsole| (CONCAT |fn| " COMPILED AND LOADED")))))
(DEFUN EVAL-BOOT-FILE (|fn|)
(PROG (|outfn| |infn| |b|)
@@ -322,11 +315,10 @@
(COND
((|bStreamNull| |a|) NIL)
('T
- (PROGN
- (SETQ |fn|
- (|stripm| (CAR |a|) *PACKAGE*
- (FIND-PACKAGE "BOOTTRAN")))
- (EVAL |fn|)))))
+ (SETQ |fn|
+ (|stripm| (CAR |a|) *PACKAGE*
+ (FIND-PACKAGE "BOOTTRAN")))
+ (EVAL |fn|))))
(|setCurrentPackage| |callingPackage|)
|result|))))
@@ -409,12 +401,10 @@
(RETURN
(COND
((|bStreamNull| |s|) (LIST '|nullstream|))
- ('T
- (PROGN
- (SETQ |dq| (CAR |s|))
- (|shoeFileLines| (|shoeDQlines| |dq|) |fn|)
- (|bAppend| (|shoeParseTrees| |dq|)
- (|bFileNext| |fn| (CDR |s|)))))))))
+ ('T (SETQ |dq| (CAR |s|))
+ (|shoeFileLines| (|shoeDQlines| |dq|) |fn|)
+ (|bAppend| (|shoeParseTrees| |dq|)
+ (|bFileNext| |fn| (CDR |s|))))))))
(DEFUN |shoeParseTrees| (|dq|)
(PROG (|toklist|)
@@ -524,9 +514,9 @@
(SETQ |found| (CATCH 'TRAPPOINT (|bpOutItem|)))
(COND
((EQ |found| 'TRAPPED) NIL)
- ((NOT (|bStreamNull| |$inputStream|))
- (PROGN (|bpGeneralErrorHere|) NIL))
- ((NULL |$stack|) (PROGN (|bpGeneralErrorHere|) NIL))
+ ((NOT (|bStreamNull| |$inputStream|)) (|bpGeneralErrorHere|)
+ NIL)
+ ((NULL |$stack|) (|bpGeneralErrorHere|) NIL)
('T (CAR |$stack|)))))))
(DEFUN |genDeclaration| (|n| |t|)
@@ -544,16 +534,13 @@
(PROGN
(SETQ |argTypes| (CAR |ISTMP#2|))
'T))))))
- (PROGN
- (COND
- ((|bfTupleP| |argTypes|)
- (SETQ |argTypes| (CDR |argTypes|))))
- (COND
- ((AND (NOT (NULL |argTypes|)) (SYMBOLP |argTypes|))
- (SETQ |argTypes| (LIST |argTypes|))))
- (LIST 'DECLAIM
- (LIST 'FTYPE (LIST 'FUNCTION |argTypes| |valType|)
- |n|))))
+ (COND
+ ((|bfTupleP| |argTypes|) (SETQ |argTypes| (CDR |argTypes|))))
+ (COND
+ ((AND (NOT (NULL |argTypes|)) (SYMBOLP |argTypes|))
+ (SETQ |argTypes| (LIST |argTypes|))))
+ (LIST 'DECLAIM
+ (LIST 'FTYPE (LIST 'FUNCTION |argTypes| |valType|) |n|)))
('T (LIST 'DECLAIM (LIST 'TYPE |t| |n|)))))))
(DEFUN |translateSignatureDeclaration| (|d|)
@@ -758,21 +745,17 @@
(RETURN
(COND
((NULL |a|) (|shoeNotFound| |fn|))
- ('T
- (PROGN
- (SETQ |$lispWordTable| (MAKE-HASHTABLE 'EQ))
- (DO-SYMBOLS (|i| (FIND-PACKAGE 'LISP))
- (HPUT |$lispWordTable| |i| T))
- (SETQ |$bootDefined| (MAKE-HASHTABLE 'EQ))
- (SETQ |$bootUsed| (MAKE-HASHTABLE 'EQ))
- (SETQ |$bootDefinedTwice| NIL)
- (SETQ |$GenVarCounter| 0)
- (SETQ |$bfClamming| NIL)
- (|shoeDefUse| (|shoeTransformStream| |a|))
- (SETQ |out| (CONCAT |fn| ".defuse"))
- (|shoeOpenOutputFile| |stream| |out|
- (|shoeReport| |stream|))
- |out|))))))
+ ('T (SETQ |$lispWordTable| (MAKE-HASHTABLE 'EQ))
+ (DO-SYMBOLS (|i| (FIND-PACKAGE 'LISP))
+ (HPUT |$lispWordTable| |i| T))
+ (SETQ |$bootDefined| (MAKE-HASHTABLE 'EQ))
+ (SETQ |$bootUsed| (MAKE-HASHTABLE 'EQ))
+ (SETQ |$bootDefinedTwice| NIL) (SETQ |$GenVarCounter| 0)
+ (SETQ |$bfClamming| NIL)
+ (|shoeDefUse| (|shoeTransformStream| |a|))
+ (SETQ |out| (CONCAT |fn| ".defuse"))
+ (|shoeOpenOutputFile| |stream| |out| (|shoeReport| |stream|))
+ |out|)))))
(DEFUN |shoeReport| (|stream|)
(PROG (|b| |a|)
@@ -960,19 +943,17 @@
(SETQ |a| (CAR |ISTMP#1|))
(SETQ |b| (CDR |ISTMP#1|))
#1#))))
- (PROGN
- (SETQ |LETTMP#1| (|defSeparate| |a|))
- (SETQ |dol| (CAR |LETTMP#1|))
- (SETQ |ndol| (CADR |LETTMP#1|))
- (LET ((|bfVar#20| |dol|) (|i| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#20|)
- (PROGN (SETQ |i| (CAR |bfVar#20|)) NIL))
- (RETURN NIL))
- (#2='T (HPUT |$bootDefined| |i| T)))
- (SETQ |bfVar#20| (CDR |bfVar#20|))))
- (|defuse1| (APPEND |ndol| |e|) |b|)))
+ (SETQ |LETTMP#1| (|defSeparate| |a|))
+ (SETQ |dol| (CAR |LETTMP#1|)) (SETQ |ndol| (CADR |LETTMP#1|))
+ (LET ((|bfVar#20| |dol|) (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#20|)
+ (PROGN (SETQ |i| (CAR |bfVar#20|)) NIL))
+ (RETURN NIL))
+ (#2='T (HPUT |$bootDefined| |i| T)))
+ (SETQ |bfVar#20| (CDR |bfVar#20|))))
+ (|defuse1| (APPEND |ndol| |e|) |b|))
((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE)
(PROGN (SETQ |a| (CDR |y|)) #1#))
NIL)
@@ -994,15 +975,12 @@
(RETURN
(COND
((NULL |x|) (LIST NIL NIL))
- (#0='T
- (PROGN
- (SETQ |f| (CAR |x|))
- (SETQ |LETTMP#1| (|defSeparate| (CDR |x|)))
- (SETQ |x1| (CAR |LETTMP#1|))
- (SETQ |x2| (CADR |LETTMP#1|))
- (COND
- ((|bfBeginsDollar| |f|) (LIST (CONS |f| |x1|) |x2|))
- (#0# (LIST |x1| (CONS |f| |x2|))))))))))
+ (#0='T (SETQ |f| (CAR |x|))
+ (SETQ |LETTMP#1| (|defSeparate| (CDR |x|)))
+ (SETQ |x1| (CAR |LETTMP#1|)) (SETQ |x2| (CADR |LETTMP#1|))
+ (COND
+ ((|bfBeginsDollar| |f|) (LIST (CONS |f| |x1|) |x2|))
+ (#0# (LIST |x1| (CONS |f| |x2|)))))))))
(DEFUN |unfluidlist| (|x|)
(PROG (|y| |ISTMP#1|)
@@ -1123,26 +1101,25 @@
(PROGN
(SETQ |lines| (|shoeFindLines| |fn| |name| |a|))
(COND
- (|lines| (PROGN
- (SETQ |filename|
+ (|lines| (SETQ |filename|
+ (COND
+ ((< 8 (LENGTH |name|))
+ (SUBSTRING |name| 0 8))
+ ('T |name|)))
+ (SETQ |filename|
+ (CONCAT "/tmp/" |filename| ".boot"))
+ (|shoeOpenOutputFile| |stream| |filename|
+ (LET ((|bfVar#24| |lines|) (|line| NIL))
+ (LOOP
(COND
- ((< 8 (LENGTH |name|))
- (SUBSTRING |name| 0 8))
- ('T |name|)))
- (SETQ |filename|
- (CONCAT "/tmp/" |filename| ".boot"))
- (|shoeOpenOutputFile| |stream| |filename|
- (LET ((|bfVar#24| |lines|) (|line| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#24|)
- (PROGN
- (SETQ |line| (CAR |bfVar#24|))
- NIL))
- (RETURN NIL))
- ('T (|shoeFileLine| |line| |stream|)))
- (SETQ |bfVar#24| (CDR |bfVar#24|)))))
- T))
+ ((OR (ATOM |bfVar#24|)
+ (PROGN
+ (SETQ |line| (CAR |bfVar#24|))
+ NIL))
+ (RETURN NIL))
+ ('T (|shoeFileLine| |line| |stream|)))
+ (SETQ |bfVar#24| (CDR |bfVar#24|)))))
+ T)
('T NIL))))))
(DEFUN |shoeTransform2| (|str|)
@@ -1255,19 +1232,13 @@
(SETQ |a| (READ-LINE))
(COND
((EQL (LENGTH |a|) 0)
- (PROGN
- (WRITE-LINE "Boot Loop; to exit type ] ")
- (BOOTLOOP)))
- (#0='T
- (PROGN
- (SETQ |b| (|shoePrefix?| ")console" |a|))
- (COND
- (|b| (PROGN
- (SETQ |stream| *TERMINAL-IO*)
- (PSTTOMC (|bRgen| |stream|))
- (BOOTLOOP)))
- ((EQUAL (ELT |a| 0) (ELT "]" 0)) NIL)
- (#0# (PROGN (PSTTOMC (LIST |a|)) (BOOTLOOP)))))))))))
+ (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTLOOP))
+ (#0='T (SETQ |b| (|shoePrefix?| ")console" |a|))
+ (COND
+ (|b| (SETQ |stream| *TERMINAL-IO*)
+ (PSTTOMC (|bRgen| |stream|)) (BOOTLOOP))
+ ((EQUAL (ELT |a| 0) (ELT "]" 0)) NIL)
+ (#0# (PSTTOMC (LIST |a|)) (BOOTLOOP)))))))))
(DEFUN BOOTPO ()
(PROG (|stream| |b| |a|)
@@ -1276,17 +1247,13 @@
(SETQ |a| (READ-LINE))
(COND
((EQL (LENGTH |a|) 0)
- (PROGN (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTPO)))
- (#0='T
- (PROGN
- (SETQ |b| (|shoePrefix?| ")console" |a|))
- (COND
- (|b| (PROGN
- (SETQ |stream| *TERMINAL-IO*)
- (PSTOUT (|bRgen| |stream|))
- (BOOTPO)))
- ((EQUAL (ELT |a| 0) (ELT "]" 0)) NIL)
- (#0# (PROGN (PSTOUT (LIST |a|)) (BOOTPO)))))))))))
+ (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTPO))
+ (#0='T (SETQ |b| (|shoePrefix?| ")console" |a|))
+ (COND
+ (|b| (SETQ |stream| *TERMINAL-IO*)
+ (PSTOUT (|bRgen| |stream|)) (BOOTPO))
+ ((EQUAL (ELT |a| 0) (ELT "]" 0)) NIL)
+ (#0# (PSTOUT (LIST |a|)) (BOOTPO)))))))))
(DEFUN PSTOUT (|string|)
(PROG (|result| |callingPackage|)
@@ -1334,12 +1301,10 @@
(COND
((NOT (EQL (|errorCount|) 0)) NIL)
(|intFile|
- (PROGN
- (SETQ |objFile|
- (|compileLispHandler| |progname| |options|
- |intFile|))
- (DELETE-FILE |intFile|)
- |objFile|))
+ (SETQ |objFile|
+ (|compileLispHandler| |progname| |options|
+ |intFile|))
+ (DELETE-FILE |intFile|) |objFile|)
('T NIL))))))
(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-02 19:49:28 +0000