* boot/ast.boot (bfAlternative): New. Move single assignment in

	pattern matching to the body of the branch.
	(bfSequence): Use it.

4 files changed, 59 insertions, 26 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 11a82c82..de9f95f4 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,11 @@
 2009-09-03  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
+	* boot/ast.boot (bfAlternative): New.  Move single assignment in
+	pattern matching to the body of the branch.
+	(bfSequence): Use it.
+
+2009-09-03  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
 	* boot/ast.boot: More cleanup.
 
 2009-09-02  Gabriel Dos Reis  <gdr@cs.tamu.edu>
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 1fdeceb7..f455cc3b 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -980,9 +980,14 @@ bfWashCONDBranchBody x ==
   x is ["PROGN",:y] => y
   [x]
 
+bfAlternative(a,b) ==
+  a is ["AND",:conds,["PROGN",stmt,='T]] =>
+    [["AND",:conds], :bfWashCONDBranchBody bfMKPROGN [stmt,b]]
+  [a,:bfWashCONDBranchBody b]
+
 bfSequence l ==
       null l=> NIL
-      transform:= [[a,:bfWashCONDBranchBody b] for x in l while
+      transform:= [bfAlternative(a,b) for x in l while
               x is ["COND",[a,["IDENTITY",b]]]]
       no:=#transform
       before:= bfTake(no,l)
@@ -993,7 +998,7 @@ bfSequence l ==
                    f
               bfMKPROGN [first l,bfSequence rest l]
       null aft => ["COND",:transform]
-      ["COND",:transform,['T,:bfWashCONDBranchBody bfSequence aft]]
+      ["COND",:transform,bfAlternative('T,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 cc73c41e..cf2067e7 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -210,9 +210,8 @@
       (COND
         ((NULL |x|)
          (COND
-           ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE)
-                 (PROGN (SETQ |a| (CDR |y|)) T))
-            (LIST '&REST (CONS 'QUOTE |a|)))
+           ((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|)))))))
 
@@ -282,8 +281,8 @@
                      (PROGN
                        (SETQ |ISTMP#2| (CDR |ISTMP#1|))
                        (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL)
-                            (PROGN (SETQ |a| (CAR |ISTMP#2|)) T)))))
-              (PROGN (SETQ |l1| (CDR |l|)) T))
+                            (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|))))))))
 
@@ -1014,8 +1013,8 @@
                                (AND (CONSP |ISTMP#2|)
                                     (EQ (CDR |ISTMP#2|) NIL)
                                     (EQ (CAR |ISTMP#2|) 'T)))))
-                      (CONSP |b1|) (EQ (CAR |b1|) 'PROGN)
-                      (PROGN (SETQ |cls| (CDR |b1|)) 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|)))))))
@@ -1704,11 +1703,40 @@
   (PROG (|y|)
     (RETURN
       (COND
-        ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN)
-              (PROGN (SETQ |y| (CDR |x|)) T))
+        ((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|)
+                                      (EQ (CDR |ISTMP#5|) NIL)
+                                      (EQ (CAR |ISTMP#5|) 'T)))))))
+                     (PROGN (SETQ |conds| (CDR |ISTMP#2|)) T)
+                     (PROGN (SETQ |conds| (NREVERSE |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|)
@@ -1757,8 +1785,7 @@
                                                        T))))))))))))))
                         (RETURN (NREVERSE |bfVar#113|)))
                        (T (SETQ |bfVar#113|
-                                (CONS (CONS |a|
-                                       (|bfWashCONDBranchBody| |b|))
+                                (CONS (|bfAlternative| |a| |b|)
                                       |bfVar#113|))))
                      (SETQ |bfVar#112| (CDR |bfVar#112|)))))
            (SETQ |no| (LENGTH |transform|))
@@ -1767,8 +1794,8 @@
            (COND
              ((NULL |before|)
               (COND
-                ((AND (CONSP |l|) (EQ (CDR |l|) NIL)
-                      (PROGN (SETQ |f| (CAR |l|)) T))
+                ((AND (CONSP |l|) (EQ (CDR |l|) NIL))
+                 (SETQ |f| (CAR |l|))
                  (COND
                    ((AND (CONSP |f|) (EQ (CAR |f|) 'PROGN))
                     (|bfSequence| (CDR |f|)))
@@ -1778,9 +1805,8 @@
              ((NULL |aft|) (CONS 'COND |transform|))
              (T (CONS 'COND
                       (APPEND |transform|
-                              (CONS (CONS 'T
-                                     (|bfWashCONDBranchBody|
-                                      (|bfSequence| |aft|)))
+                              (CONS (|bfAlternative| 'T
+                                     (|bfSequence| |aft|))
                                     NIL))))))))))
 
 (DEFUN |bfWhere| (|context| |expr|)
@@ -1884,8 +1910,7 @@
   (PROG (|a| |f|)
     (RETURN
       (COND
-        ((AND (CONSP |x|) (EQ (CDR |x|) NIL)
-              (PROGN (SETQ |f| (CAR |x|)) T))
+        ((AND (CONSP |x|) (EQ (CDR |x|) NIL)) (SETQ |f| (CAR |x|))
          (LIST 'DEFCONSTANT |f| (LIST 'LIST (LIST 'QUOTE |f|))))
         (T (SETQ |a|
                  (LET ((|bfVar#117| NIL) (|bfVar#116| (CDR |x|))
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index c243fe0c..bb464915 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -579,8 +579,7 @@
     (RETURN
       (COND
         ((ATOM |b|) (LIST |b|))
-        ((AND (CONSP |b|) (EQ (CAR |b|) 'TUPLE)
-              (PROGN (SETQ |xs| (CDR |b|)) T))
+        ((AND (CONSP |b|) (EQ (CAR |b|) 'TUPLE)) (SETQ |xs| (CDR |b|))
          (|coreError| "invalid AST"))
         (T (CASE (CAR |b|)
              (|%Signature|
@@ -947,11 +946,9 @@
                (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|)) T))
+        ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE)) (SETQ |a| (CDR |y|))
          NIL)
-        ((AND (CONSP |y|) (EQ (CAR |y|) '+LINE)
-              (PROGN (SETQ |a| (CDR |y|)) T))
+        ((AND (CONSP |y|) (EQ (CAR |y|) '+LINE)) (SETQ |a| (CDR |y|))
          NIL)
         (T (LET ((|bfVar#21| |y|) (|i| NIL))
              (LOOP