* boot/ast.boot (bfCase): Don't introduce temporary for scrutinee

	when it is already reduced.

1 files changed, 87 insertions, 94 deletions

diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index 593ad5cb..056fe0ec 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -557,16 +557,12 @@
         ('T (LIST 'DECLAIM (LIST 'TYPE |t| |n|)))))))
 
 (DEFUN |translateSignatureDeclaration| (|d|)
-  (PROG (|bfVar#10| |bfVar#9|)
-    (RETURN
-      (PROGN
-        (SETQ |bfVar#9| |d|)
-        (SETQ |bfVar#10| (CDR |bfVar#9|))
-        (CASE (CAR |bfVar#9|)
-          (|%Signature|
-              (LET ((|n| (CAR |bfVar#10|)) (|t| (CADR |bfVar#10|)))
-                (|genDeclaration| |n| |t|)))
-          (T (|coreError| "signature expected")))))))
+  (LET ((|bfVar#9| (CDR |d|)))
+    (CASE (CAR |d|)
+      (|%Signature|
+          (LET ((|n| (CAR |bfVar#9|)) (|t| (CADR |bfVar#9|)))
+            (|genDeclaration| |n| |t|)))
+      (T (|coreError| "signature expected")))))
 
 (DEFUN |translateToplevelExpression| (|expr|)
   (PROG (|expr'|)
@@ -576,17 +572,17 @@
         (SETQ |expr'|
               (CDR (CDR (|shoeCompTran|
                             (LIST 'LAMBDA (LIST '|x|) |expr|)))))
-        (LET ((|bfVar#11| |expr'|) (|t| NIL))
+        (LET ((|bfVar#10| |expr'|) (|t| NIL))
           (LOOP
             (COND
-              ((OR (ATOM |bfVar#11|)
-                   (PROGN (SETQ |t| (CAR |bfVar#11|)) NIL))
+              ((OR (ATOM |bfVar#10|)
+                   (PROGN (SETQ |t| (CAR |bfVar#10|)) NIL))
                (RETURN NIL))
               ('T
                (COND
                  ((AND (CONSP |t|) (EQ (CAR |t|) 'DECLARE))
                   (IDENTITY (RPLACA |t| 'DECLAIM))))))
-            (SETQ |bfVar#11| (CDR |bfVar#11|))))
+            (SETQ |bfVar#10| (CDR |bfVar#10|))))
         (SETQ |expr'|
               (COND
                 ((< 1 (LENGTH |expr'|)) (CONS 'PROGN |expr'|))
@@ -599,8 +595,7 @@
   (COND (|export?| |d|) ('T |d|)))
 
 (DEFUN |translateToplevel| (|b| |export?|)
-  (PROG (|lhs| |t| |ISTMP#2| |n| |ISTMP#1| |sig| |bfVar#17| |bfVar#16|
-               |xs|)
+  (PROG (|lhs| |t| |ISTMP#2| |n| |ISTMP#1| |sig| |xs|)
     (DECLARE (SPECIAL |$activeNamespace| |$InteractiveMode|
                       |$foreignsDefsForCLisp| |$currentModuleName|))
     (RETURN
@@ -608,50 +603,48 @@
         ((ATOM |b|) (LIST |b|))
         ((AND (CONSP |b|) (EQ (CAR |b|) 'TUPLE)
               (PROGN (SETQ |xs| (CDR |b|)) #0='T))
-         (LET ((|bfVar#13| NIL) (|bfVar#12| |xs|) (|x| NIL))
+         (LET ((|bfVar#12| NIL) (|bfVar#11| |xs|) (|x| NIL))
            (LOOP
              (COND
-               ((OR (ATOM |bfVar#12|)
-                    (PROGN (SETQ |x| (CAR |bfVar#12|)) NIL))
-                (RETURN (NREVERSE |bfVar#13|)))
+               ((OR (ATOM |bfVar#11|)
+                    (PROGN (SETQ |x| (CAR |bfVar#11|)) NIL))
+                (RETURN (NREVERSE |bfVar#12|)))
                (#1='T
-                (SETQ |bfVar#13|
+                (SETQ |bfVar#12|
                       (CONS (|maybeExportDecl| |x| |export?|)
-                            |bfVar#13|))))
-             (SETQ |bfVar#12| (CDR |bfVar#12|)))))
+                            |bfVar#12|))))
+             (SETQ |bfVar#11| (CDR |bfVar#11|)))))
         (#2='T
-         (PROGN
-           (SETQ |bfVar#16| |b|)
-           (SETQ |bfVar#17| (CDR |bfVar#16|))
-           (CASE (CAR |bfVar#16|)
+         (LET ((|bfVar#15| (CDR |b|)))
+           (CASE (CAR |b|)
              (|%Signature|
-                 (LET ((|op| (CAR |bfVar#17|)) (|t| (CADR |bfVar#17|)))
+                 (LET ((|op| (CAR |bfVar#15|)) (|t| (CADR |bfVar#15|)))
                    (LIST (|maybeExportDecl| (|genDeclaration| |op| |t|)
                              |export?|))))
              (|%Module|
-                 (LET ((|m| (CAR |bfVar#17|)) (|ds| (CADR |bfVar#17|)))
+                 (LET ((|m| (CAR |bfVar#15|)) (|ds| (CADR |bfVar#15|)))
                    (PROGN
                      (SETQ |$currentModuleName| |m|)
                      (SETQ |$foreignsDefsForCLisp| NIL)
                      (CONS (LIST 'PROVIDE (STRING |m|))
-                           (LET ((|bfVar#15| NIL) (|bfVar#14| |ds|)
+                           (LET ((|bfVar#14| NIL) (|bfVar#13| |ds|)
                                  (|d| NIL))
                              (LOOP
                                (COND
-                                 ((OR (ATOM |bfVar#14|)
+                                 ((OR (ATOM |bfVar#13|)
                                       (PROGN
-                                        (SETQ |d| (CAR |bfVar#14|))
+                                        (SETQ |d| (CAR |bfVar#13|))
                                         NIL))
-                                  (RETURN (NREVERSE |bfVar#15|)))
+                                  (RETURN (NREVERSE |bfVar#14|)))
                                  (#1#
-                                  (SETQ |bfVar#15|
+                                  (SETQ |bfVar#14|
                                         (CONS
                                          (CAR
                                           (|translateToplevel| |d| T))
-                                         |bfVar#15|))))
-                               (SETQ |bfVar#14| (CDR |bfVar#14|))))))))
+                                         |bfVar#14|))))
+                               (SETQ |bfVar#13| (CDR |bfVar#13|))))))))
              (|%Import|
-                 (LET ((|m| (CAR |bfVar#17|)))
+                 (LET ((|m| (CAR |bfVar#15|)))
                    (PROGN
                      (COND
                        ((NOT (EQUAL (|getOptionValue| '|import|)
@@ -659,17 +652,17 @@
                         (|bootImport| (STRING |m|))))
                      (LIST (LIST 'IMPORT-MODULE (STRING |m|))))))
              (|%ImportSignature|
-                 (LET ((|x| (CAR |bfVar#17|))
-                       (|sig| (CADR |bfVar#17|)))
+                 (LET ((|x| (CAR |bfVar#15|))
+                       (|sig| (CADR |bfVar#15|)))
                    (|genImportDeclaration| |x| |sig|)))
              (|%TypeAlias|
-                 (LET ((|lhs| (CAR |bfVar#17|))
-                       (|rhs| (CADR |bfVar#17|)))
+                 (LET ((|lhs| (CAR |bfVar#15|))
+                       (|rhs| (CADR |bfVar#15|)))
                    (LIST (|maybeExportDecl|
                              (|genTypeAlias| |lhs| |rhs|) |export?|))))
              (|%ConstantDefinition|
-                 (LET ((|lhs| (CAR |bfVar#17|))
-                       (|rhs| (CADR |bfVar#17|)))
+                 (LET ((|lhs| (CAR |bfVar#15|))
+                       (|rhs| (CADR |bfVar#15|)))
                    (PROGN
                      (SETQ |sig| NIL)
                      (COND
@@ -694,8 +687,8 @@
                                (LIST 'DEFCONSTANT |lhs| |rhs|)
                                |export?|)))))
              (|%Assignment|
-                 (LET ((|lhs| (CAR |bfVar#17|))
-                       (|rhs| (CADR |bfVar#17|)))
+                 (LET ((|lhs| (CAR |bfVar#15|))
+                       (|rhs| (CADR |bfVar#15|)))
                    (PROGN
                      (SETQ |sig| NIL)
                      (COND
@@ -724,7 +717,7 @@
                                   (LIST 'DEFPARAMETER |lhs| |rhs|)
                                   |export?|)))))))
              (|%Namespace|
-                 (LET ((|n| (CAR |bfVar#17|)))
+                 (LET ((|n| (CAR |bfVar#15|)))
                    (PROGN
                      (SETQ |$activeNamespace| (STRING |n|))
                      (LIST (LIST 'IN-PACKAGE (STRING |n|))))))
@@ -824,17 +817,17 @@
       (PROGN
         (|shoeFileLine| "DEFINED and not USED" |stream|)
         (SETQ |a|
-              (LET ((|bfVar#19| NIL)
-                    (|bfVar#18| (HKEYS |$bootDefined|)) (|i| NIL))
+              (LET ((|bfVar#17| NIL)
+                    (|bfVar#16| (HKEYS |$bootDefined|)) (|i| NIL))
                 (LOOP
                   (COND
-                    ((OR (ATOM |bfVar#18|)
-                         (PROGN (SETQ |i| (CAR |bfVar#18|)) NIL))
-                     (RETURN (NREVERSE |bfVar#19|)))
+                    ((OR (ATOM |bfVar#16|)
+                         (PROGN (SETQ |i| (CAR |bfVar#16|)) NIL))
+                     (RETURN (NREVERSE |bfVar#17|)))
                     (#0='T
                      (AND (NOT (GETHASH |i| |$bootUsed|))
-                          (SETQ |bfVar#19| (CONS |i| |bfVar#19|)))))
-                  (SETQ |bfVar#18| (CDR |bfVar#18|)))))
+                          (SETQ |bfVar#17| (CONS |i| |bfVar#17|)))))
+                  (SETQ |bfVar#16| (CDR |bfVar#16|)))))
         (|bootOut| (SSORT |a|) |stream|)
         (|shoeFileLine| "             " |stream|)
         (|shoeFileLine| "DEFINED TWICE" |stream|)
@@ -842,29 +835,29 @@
         (|shoeFileLine| "             " |stream|)
         (|shoeFileLine| "USED and not DEFINED" |stream|)
         (SETQ |a|
-              (LET ((|bfVar#21| NIL) (|bfVar#20| (HKEYS |$bootUsed|))
+              (LET ((|bfVar#19| NIL) (|bfVar#18| (HKEYS |$bootUsed|))
                     (|i| NIL))
                 (LOOP
                   (COND
-                    ((OR (ATOM |bfVar#20|)
-                         (PROGN (SETQ |i| (CAR |bfVar#20|)) NIL))
-                     (RETURN (NREVERSE |bfVar#21|)))
+                    ((OR (ATOM |bfVar#18|)
+                         (PROGN (SETQ |i| (CAR |bfVar#18|)) NIL))
+                     (RETURN (NREVERSE |bfVar#19|)))
                     (#0#
                      (AND (NOT (GETHASH |i| |$bootDefined|))
-                          (SETQ |bfVar#21| (CONS |i| |bfVar#21|)))))
-                  (SETQ |bfVar#20| (CDR |bfVar#20|)))))
-        (LET ((|bfVar#22| (SSORT |a|)) (|i| NIL))
+                          (SETQ |bfVar#19| (CONS |i| |bfVar#19|)))))
+                  (SETQ |bfVar#18| (CDR |bfVar#18|)))))
+        (LET ((|bfVar#20| (SSORT |a|)) (|i| NIL))
           (LOOP
             (COND
-              ((OR (ATOM |bfVar#22|)
-                   (PROGN (SETQ |i| (CAR |bfVar#22|)) NIL))
+              ((OR (ATOM |bfVar#20|)
+                   (PROGN (SETQ |i| (CAR |bfVar#20|)) NIL))
                (RETURN NIL))
               (#0#
                (PROGN
                  (SETQ |b| (CONCAT (PNAME |i|) " is used in "))
                  (|bootOutLines| (SSORT (GETHASH |i| |$bootUsed|))
                      |stream| |b|))))
-            (SETQ |bfVar#22| (CDR |bfVar#22|))))))))
+            (SETQ |bfVar#20| (CDR |bfVar#20|))))))))
 
 (DEFUN |shoeDefUse| (|s|)
   (LOOP
@@ -960,16 +953,16 @@
                    (#1# (CONS |nee| |$bootDefinedTwice|)))))
           ('T (HPUT |$bootDefined| |nee| T)))
         (|defuse1| |e| |niens|)
-        (LET ((|bfVar#23| |$used|) (|i| NIL))
+        (LET ((|bfVar#21| |$used|) (|i| NIL))
           (LOOP
             (COND
-              ((OR (ATOM |bfVar#23|)
-                   (PROGN (SETQ |i| (CAR |bfVar#23|)) NIL))
+              ((OR (ATOM |bfVar#21|)
+                   (PROGN (SETQ |i| (CAR |bfVar#21|)) NIL))
                (RETURN NIL))
               ('T
                (HPUT |$bootUsed| |i|
                      (CONS |nee| (GETHASH |i| |$bootUsed|)))))
-            (SETQ |bfVar#23| (CDR |bfVar#23|))))))))
+            (SETQ |bfVar#21| (CDR |bfVar#21|))))))))
 
 (DEFUN |defuse1| (|e| |y|)
   (PROG (|ndol| |dol| |LETTMP#1| |b| |a| |ISTMP#1|)
@@ -1007,14 +1000,14 @@
            (SETQ |LETTMP#1| (|defSeparate| |a|))
            (SETQ |dol| (CAR |LETTMP#1|))
            (SETQ |ndol| (CADR |LETTMP#1|))
-           (LET ((|bfVar#24| |dol|) (|i| NIL))
+           (LET ((|bfVar#22| |dol|) (|i| NIL))
              (LOOP
                (COND
-                 ((OR (ATOM |bfVar#24|)
-                      (PROGN (SETQ |i| (CAR |bfVar#24|)) NIL))
+                 ((OR (ATOM |bfVar#22|)
+                      (PROGN (SETQ |i| (CAR |bfVar#22|)) NIL))
                   (RETURN NIL))
                  (#2='T (HPUT |$bootDefined| |i| T)))
-               (SETQ |bfVar#24| (CDR |bfVar#24|))))
+               (SETQ |bfVar#22| (CDR |bfVar#22|))))
            (|defuse1| (APPEND |ndol| |e|) |b|)))
         ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE)
               (PROGN (SETQ |a| (CDR |y|)) #1#))
@@ -1023,14 +1016,14 @@
               (PROGN (SETQ |a| (CDR |y|)) #1#))
          NIL)
         (#0#
-         (LET ((|bfVar#25| |y|) (|i| NIL))
+         (LET ((|bfVar#23| |y|) (|i| NIL))
            (LOOP
              (COND
-               ((OR (ATOM |bfVar#25|)
-                    (PROGN (SETQ |i| (CAR |bfVar#25|)) NIL))
+               ((OR (ATOM |bfVar#23|)
+                    (PROGN (SETQ |i| (CAR |bfVar#23|)) NIL))
                 (RETURN NIL))
                (#2# (|defuse1| |e| |i|)))
-             (SETQ |bfVar#25| (CDR |bfVar#25|)))))))))
+             (SETQ |bfVar#23| (CDR |bfVar#23|)))))))))
 
 (DEFUN |defSeparate| (|x|)
   (PROG (|x2| |x1| |LETTMP#1| |f|)
@@ -1066,13 +1059,13 @@
   (GETHASH |x| |$lispWordTable|))
 
 (DEFUN |bootOut| (|l| |outfn|)
-  (LET ((|bfVar#26| |l|) (|i| NIL))
+  (LET ((|bfVar#24| |l|) (|i| NIL))
     (LOOP
       (COND
-        ((OR (ATOM |bfVar#26|) (PROGN (SETQ |i| (CAR |bfVar#26|)) NIL))
+        ((OR (ATOM |bfVar#24|) (PROGN (SETQ |i| (CAR |bfVar#24|)) NIL))
          (RETURN NIL))
         ('T (|shoeFileLine| (CONCAT "   " (PNAME |i|)) |outfn|)))
-      (SETQ |bfVar#26| (CDR |bfVar#26|)))))
+      (SETQ |bfVar#24| (CDR |bfVar#24|)))))
 
 (DEFUN CLESSP (|s1| |s2|) (NOT (SHOEGREATERP |s1| |s2|)))
 
@@ -1123,18 +1116,18 @@
       (PROGN
         (|shoeFileLine| "USED and where DEFINED" |stream|)
         (SETQ |c| (SSORT (HKEYS |$bootUsed|)))
-        (LET ((|bfVar#27| |c|) (|i| NIL))
+        (LET ((|bfVar#25| |c|) (|i| NIL))
           (LOOP
             (COND
-              ((OR (ATOM |bfVar#27|)
-                   (PROGN (SETQ |i| (CAR |bfVar#27|)) NIL))
+              ((OR (ATOM |bfVar#25|)
+                   (PROGN (SETQ |i| (CAR |bfVar#25|)) NIL))
                (RETURN NIL))
               ('T
                (PROGN
                  (SETQ |a| (CONCAT (PNAME |i|) " is used in "))
                  (|bootOutLines| (SSORT (GETHASH |i| |$bootUsed|))
                      |stream| |a|))))
-            (SETQ |bfVar#27| (CDR |bfVar#27|))))))))
+            (SETQ |bfVar#25| (CDR |bfVar#25|))))))))
 
 (DEFUN FBO (|name| |fn|) (|shoeGeneralFC| #'BO |name| |fn|))
 
@@ -1175,16 +1168,16 @@
                      (SETQ |filename|
                            (CONCAT "/tmp/" |filename| ".boot"))
                      (|shoeOpenOutputFile| |stream| |filename|
-                         (LET ((|bfVar#28| |lines|) (|line| NIL))
+                         (LET ((|bfVar#26| |lines|) (|line| NIL))
                            (LOOP
                              (COND
-                               ((OR (ATOM |bfVar#28|)
+                               ((OR (ATOM |bfVar#26|)
                                     (PROGN
-                                      (SETQ |line| (CAR |bfVar#28|))
+                                      (SETQ |line| (CAR |bfVar#26|))
                                       NIL))
                                 (RETURN NIL))
                                ('T (|shoeFileLine| |line| |stream|)))
-                             (SETQ |bfVar#28| (CDR |bfVar#28|)))))
+                             (SETQ |bfVar#26| (CDR |bfVar#26|)))))
                      T))
           ('T NIL))))))
 
@@ -1199,20 +1192,20 @@
     (RETURN
       (PROGN
         (SETQ |dq| (CAR |str|))
-        (CONS (LIST (LET ((|bfVar#30| NIL)
-                          (|bfVar#29| (|shoeDQlines| |dq|))
+        (CONS (LIST (LET ((|bfVar#28| NIL)
+                          (|bfVar#27| (|shoeDQlines| |dq|))
                           (|line| NIL))
                       (LOOP
                         (COND
-                          ((OR (ATOM |bfVar#29|)
+                          ((OR (ATOM |bfVar#27|)
                                (PROGN
-                                 (SETQ |line| (CAR |bfVar#29|))
+                                 (SETQ |line| (CAR |bfVar#27|))
                                  NIL))
-                           (RETURN (NREVERSE |bfVar#30|)))
+                           (RETURN (NREVERSE |bfVar#28|)))
                           ('T
-                           (SETQ |bfVar#30|
-                                 (CONS (CAR |line|) |bfVar#30|))))
-                        (SETQ |bfVar#29| (CDR |bfVar#29|)))))
+                           (SETQ |bfVar#28|
+                                 (CONS (CAR |line|) |bfVar#28|))))
+                        (SETQ |bfVar#27| (CDR |bfVar#27|)))))
               (CDR |str|))))))
 
 (DEFUN |stripm| (|x| |pk| |bt|)