Fixup sequences, simplify some code, rewrite conditionals whose predicates are sequences.

diff --git a/src/sf/object.scm b/src/sf/object.scm
index e8bf9f27e55a75c9bff00b5ab77e0374460da6c0..bfc6440a0ba112d559b50bed175cf8fbb180dcfc 100644 (file)
--- a/src/sf/object.scm
+++ b/src/sf/object.scm
@@ -215,7 +215,7 @@ USA.
 (define-simple-type open-block      #f                 (block variables values actions))
 (define-simple-type procedure       #f                 (block name required optional rest body))
 (define-simple-type quotation       #f                 (block expression))
-(define-simple-type sequence        #f                 (actions))
+(define-simple-type sequence        sequence/%make     (actions))
 (define-simple-type the-environment #f                 (block))
 
 ;;; Helpers for expressions
@@ -444,11 +444,9 @@ USA.
                          #f
                          (procedure/body operator))
                         new-operand-list))))
-              (if (null? other-operands)
-                  result-body
-                  (sequence/make
-                   (and expression (object/scode expression))
-                   (append other-operands (list result-body))))))))
+              (sequence/make
+               (and expression (object/scode expression))
+               (append other-operands (list result-body)))))))
        (else
         (combination/%make (and expression (object/scode expression)) block operator operands))))
 
@@ -528,9 +526,7 @@ USA.
 
        ;; If the consequent and alternative are the same, just make a sequence.
        ((expressions/equal? consequent alternative)
-        (if (expression/effect-free? predicate)
-            consequent
-            (sequence/make scode (list predicate consequent))))
+        (sequence/make scode (list predicate consequent)))
 
        (else
         (conditional/%make scode predicate consequent alternative))))
@@ -549,6 +545,30 @@ USA.
        (else
         (disjunction/%make scode predicate alternative))))
 
+;;; Sequence
+
+;;  Ensure that sequences are always flat.
+(define (sequence/make scode actions)
+  (define (sequence/collect-actions collected actions)
+    (fold-left (lambda (reversed action)
+                (if (sequence? action)
+                    (sequence/collect-actions reversed (sequence/actions action))
+                    (cons action reversed)))
+              collected
+              actions))
+  (let ((filtered-actions
+        (fold-left (lambda (filtered action)
+                     (if (expression/effect-free? action)
+                         (if (null? filtered)
+                             (list action)
+                             filtered)
+                         (cons action filtered)))
+                   '()
+                   (sequence/collect-actions '() actions))))
+    (if (null? (cdr filtered-actions))
+       (car filtered-actions)
+       (sequence/%make scode filtered-actions))))
+
 ;; Done specially so we can tweak the print method.
 ;; This makes debugging an awful lot easier.
 (define-structure (reference

diff --git a/src/sf/subst.scm b/src/sf/subst.scm
index 4b9714117346f51fef84eb9e908f6a1e769b0965..b9ee3a349103b2b3f372c7320bb8d03eab1460c9 100644 (file)
--- a/src/sf/subst.scm
+++ b/src/sf/subst.scm
@@ -193,19 +193,15 @@ USA.
                               alternative)
   (cond ((and (expression/never-false? integrated-predicate)
              (noisy-test sf:enable-conditional-folding? "Fold constant true conditional"))
-        (let ((integrated-consequent (integrate/expression operations environment consequent)))
-          (if (expression/effect-free? integrated-predicate)
-              integrated-consequent
-              (sequence/make (and expression (conditional/scode expression))
-                             (list integrated-predicate integrated-consequent)))))
+        (sequence/make (and expression (conditional/scode expression))
+                       (list integrated-predicate
+                             (integrate/expression operations environment consequent))))
 
        ((and (expression/always-false? integrated-predicate)
              (noisy-test sf:enable-conditional-folding? "Fold constant false conditional"))
-        (let ((integrated-alternative (integrate/expression operations environment alternative)))
-          (if (expression/effect-free? integrated-predicate)
-              integrated-alternative
-              (sequence/make (and expression (conditional/scode expression))
-                             (list integrated-predicate integrated-alternative)))))
+        (sequence/make (and expression (conditional/scode expression))
+                       (list integrated-predicate
+                             (integrate/expression operations environment alternative))))
 
        ((and (expression/call-to-not? integrated-predicate)
              (noisy-test sf:enable-conditional-inversion? "Invert conditional"))
@@ -224,6 +220,14 @@ USA.
          operations environment expression
          integrated-predicate consequent alternative))
 
+       ((sequence? integrated-predicate)
+        (sequence/make (and expression (object/scode expression))
+                       (append (except-last-pair (sequence/actions integrated-predicate))
+                               (list (integrate/conditional operations environment #f
+                                                            (last (sequence/actions integrated-predicate))
+                                                            consequent
+                                                            alternative)))))
+
        (else
         (let ((integrated-consequent (integrate/expression operations environment consequent)))
           (if (or (and (expressions/equal? integrated-predicate integrated-consequent)
@@ -234,13 +238,12 @@ USA.
                        (noisy-test sf:enable-elide-conditional-canonicalization? "Eliding conditional canonicalization")))
               (integrate/disjunction operations environment expression integrated-predicate alternative)
 
-              (let ((integrated-alternative (integrate/expression
-                                             (operations/prepare-false-branch operations integrated-predicate)
-                                             environment alternative)))
-                (conditional/make (and expression (conditional/scode expression))
-                                  integrated-predicate
-                                  integrated-consequent
-                                  integrated-alternative)))))))
+              (conditional/make (and expression (conditional/scode expression))
+                                integrated-predicate
+                                integrated-consequent
+                                (integrate/expression
+                                 (operations/prepare-false-branch operations integrated-predicate)
+                                 environment alternative)))))))
 
 (define sf:enable-rewrite-disjunction-in-conditional? #t)
 ;; If #t, move disjunctions out of the predicate if possible.
@@ -305,7 +308,7 @@ USA.
       (cond ((expression/never-false? e2)
             (if (and (expression/always-false? e3)
                      (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (1)"))
-                ;;    (if e1 (begin e2 e4) (begin e3 e5))   case 1, e2 never false, e3 always false
+                ;; (if e1 (begin e2 e4) (begin e3 e5))   case 1, e2 never false, e3 always false
                 (integrate/conditional operations environment expression
                                        e1
                                        (sequence/make #f (list e2 consequent))
@@ -313,7 +316,7 @@ USA.
                 (let ((e4 (integrate/expression context-CC environment consequent)))
                   (if (and (expression/can-duplicate? e4)
                            (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (2)"))
-                      ;;    (if e1 (begin e2 e4) (if e3 e4 e5))   case 2, e2 never false, e4 can be duplicated
+                      ;; (if e1 (begin e2 e4) (if e3 e4 e5))   case 2, e2 never false, e4 can be duplicated
                       (integrate/conditional operations environment expression
                                              e1
                                              (sequence/make #f (list e2 consequent))
@@ -327,13 +330,13 @@ USA.
             (let ((e5 (integrate/expression operations environment alternative)))
               (cond ((and (expression/never-false? e3)
                           (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (3)"))
-                     ;;    (if e1 (begin e2 e5) (begin e3 e4))   case 3, e2 always false, e3 never false
+                     ;; (if e1 (begin e2 e5) (begin e3 e4))   case 3, e2 always false, e3 never false
                      (conditional/make (and expression (object/scode expression))
                                        integrated-predicate e4a e5))
 
                     ((and (expression/can-duplicate? e5)
                           (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (4)"))
-                     ;;    (if e1 (begin e2 e5) (if e3 e4 e5))   case 4, e2 always false, e5 can be duplicated
+                     ;; (if e1 (begin e2 e5) (if e3 e4 e5))   case 4, e2 always false, e5 can be duplicated
                      (integrate/conditional operations environment expression
                                             e1
                                             (sequence/make #f (list e2 e5))
@@ -348,7 +351,7 @@ USA.
             (let ((e4 (integrate/expression operations environment consequent)))
               (if (and (expression/can-duplicate? e4)
                        (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (5)"))
-                  ;;    (if e1 (if e2 e4 e5) (begin e3 e4))   case 5, e3 never false, e4 can be duplicated
+                  ;; (if e1 (if e2 e4 e5) (begin e3 e4))   case 5, e3 never false, e4 can be duplicated
                   (integrate/conditional operations environment expression
                                          e1
                                          (conditional/make #f e2 e4 alternative)
@@ -378,7 +381,7 @@ USA.
               (if (and (expression/can-duplicate? e4)
                        (expression/can-duplicate? e5)
                        (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (7)"))
-                  ;;    (if e1 (if e2 e4 e5) (if e3 e4 e5))   case 7, e4 and e5 can be duplicated
+                  ;; (if e1 (if e2 e4 e5) (if e3 e4 e5))   case 7, e4 and e5 can be duplicated
                   (integrate/conditional operations environment expression
                                          e1
                                          (conditional/make #f e2 e4 e5)
@@ -449,12 +452,9 @@ USA.
        ((and (expression/always-false? integrated-predicate)
              (noisy-test sf:enable-disjunction-folding? "Folding constant false disjunction"))
         ;; (or <exp1> <exp2>) => (begin <exp1> <exp2>) if <exp1> is always false
-        (let ((integrated-alternative (integrate/expression operations environment alternative)))
-          (if (expression/effect-free? integrated-predicate)
-              integrated-alternative
-              (sequence/make (and expression (object/scode expression))
-                             (list integrated-predicate
-                                   integrated-alternative)))))
+        (sequence/make (and expression (object/scode expression))
+                       (list integrated-predicate
+                             (integrate/expression operations environment alternative))))
 
        ((and (conditional? integrated-predicate)
              (noisy-test sf:enable-rewrite-conditional-in-disjunction?
@@ -470,6 +470,13 @@ USA.
                                (disjunction/predicate integrated-predicate)
                                (disjunction/make #f (disjunction/alternative integrated-predicate) alternative)))
 
+       ((sequence? integrated-predicate)
+        (sequence/make (and expression (object/scode expression))
+                       (append (except-last-pair (sequence/actions integrated-predicate))
+                               (list (integrate/disjunction operations environment #f
+                                                            (last (sequence/actions integrated-predicate))
+                                                            alternative)))))
+
        (else
         (disjunction/make (and expression (object/scode expression))
                           integrated-predicate
@@ -606,10 +613,8 @@ USA.
 ;;; SEQUENCE
 (define-method/integrate 'SEQUENCE
   (lambda (operations environment expression)
-    ;; Optimize (begin (foo)) => (foo)
-    ;; Optimize (begin a b (foo) 22 (bar)) => (begin (foo) (bar))
-    (sequence/optimizing-make
-     expression
+    (sequence/make
+     (and expression (object/scode expression))
      (integrate/actions operations environment
                        (sequence/actions expression)))))
 
@@ -1181,13 +1186,6 @@ USA.
   (or (reference? expression)
       (non-side-effecting-in-sequence? expression)))
 \f
-(define (sequence/optimizing-make expression actions)
-  (let ((actions (remove-non-side-effecting actions)))
-    (if (null? (cdr actions))
-       (car actions)
-       (sequence/make (and expression (object/scode expression))
-                      actions))))
-
 (define (remove-non-side-effecting actions)
   ;; Do not remove references from sequences, because they have
   ;; meaning as declarations.  The output code generator will take

diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm
index 1b3ed162436b6c3a7e6604ec4fd44319d0ef5c78..593d1ae4515e84d9b266cf0aac766264283908ec 100644 (file)
--- a/src/sf/usiexp.scm
+++ b/src/sf/usiexp.scm
@@ -469,17 +469,13 @@ USA.
       ;; Convert (eq? <expr> #f) and (eq? #f <expr>) to (not <expr>)
       ;; Conditional inversion will remove the call to not.
       (cond ((expression/always-false? (first operands))
-            (if (expression/effect-free? (first operands))
-                (make-combination expr block (ucode-primitive not) (cdr operands))
-                (sequence/make (and expr (object/scode expr))
-                               (list (first operands)
-                                     (make-combination #f block (ucode-primitive not) (cdr operands))))))
+            (sequence/make (and expr (object/scode expr))
+                           (list (first operands)
+                                 (make-combination #f block (ucode-primitive not) (cdr operands)))))
            ((expression/always-false? (second operands))
-            (if (expression/effect-free? (second operands))
-                (make-combination expr block (ucode-primitive not) (list (car operands)))
-                (sequence/make (and expr (object/scode expr))
-                               (list (second operands)
-                                     (make-combination #f block (ucode-primitive not) (list (car operands)))))))
+            (sequence/make (and expr (object/scode expr))
+                           (list (second operands)
+                                 (make-combination #f block (ucode-primitive not) (list (car operands))))))
            (else
             (make-combination expr block (ucode-primitive eq?) operands)))
       #f))
@@ -495,15 +491,11 @@ USA.
   (if (and (pair? operands)
           (null? (cdr operands)))
       (cond ((expression/always-false? (first operands))
-            (if (expression/effect-free? (first operands))
-                (constant/make (and expr (object/scode expr)) #t)
-                (sequence/make (and expr (object/scode expr))
-                               (list (first operands) (constant/make #f #t)))))
+            (sequence/make (and expr (object/scode expr))
+                           (list (first operands) (constant/make #f #t))))
            ((expression/never-false? (first operands))
-            (if (expression/effect-free? (first operands))
-                (constant/make (and expr (object/scode expr)) #f)
-                (sequence/make (and expr (object/scode expr))
-                               (list (first operands) (constant/make #f #f)))))
+            (sequence/make (and expr (object/scode expr))
+                           (list (first operands) (constant/make #f #f))))
            (else (make-combination expr block (ucode-primitive not) operands)))
       #f))
 

diff --git a/src/sf/xform.scm b/src/sf/xform.scm
index 47519ba78e08d6b06d80fbd63c2bb8e7b8a107ec..ffcac1f84d77e24bb489b70dc06b4ae3e67b9ccf 100644 (file)
--- a/src/sf/xform.scm
+++ b/src/sf/xform.scm
@@ -182,7 +182,7 @@ USA.
       (let ((block (block/make block true '())))
        (call-with-values
            (lambda ()
-             (let ((name->variable 
+             (let ((name->variable
                     (lambda (name) (variable/make&bind! block name))))
                (values (map name->variable required)
                        (map name->variable optional)
@@ -209,7 +209,7 @@ USA.
              expression block name required optional rest
              (if (null? ignores)
                  final-body
-                 (declaration/make #f (declarations/parse block `((ignore ,@ignores))) 
+                 (declaration/make #f (declarations/parse block `((ignore ,@ignores)))
                                    final-body))))))
       (procedure/make
        expression block name required optional rest
@@ -302,7 +302,9 @@ USA.
       (quotation/make expression block expression**))))
 
 (define (transform/sequence block environment expression)
-  (sequence/make
+  ;; Don't remove references from sequences here.  We want them
+  ;; to signal ignored variables.
+  (sequence/%make
    expression
    (transform/expressions block environment (sequence-actions expression))))