Move EXPRESSION/UNSPECIFIC?, add EXPRESSION/PURE-TRUE? and EXPRESSION/PURE-FALSE?

diff --git a/src/sf/analyze.scm b/src/sf/analyze.scm
index 9ea6cf02f42c775e3134fd50cfd88960c61002f4..c1ce65b0156234e528e7548fe5e89a649cd3fa28 100644 (file)
--- a/src/sf/analyze.scm
+++ b/src/sf/analyze.scm
@@ -611,4 +611,156 @@ USA.
     (expression/never-false? (last (sequence/actions expression)))))
 
 (define-method/never-false? 'THE-ENVIRONMENT true-procedure)
+\f
+;;; EXPRESSION/PURE-FALSE?
+
+;; True iff all paths through expression end in returning
+;; exactly #F or unspecified, and no path has side effects.
+;; Expression is observationally equivalent to #F.
+(define (expression/pure-false? expression)
+  ((expression/method pure-false?-dispatch-vector expression) expression))
+
+(define pure-false?-dispatch-vector
+  (expression/make-dispatch-vector))
+
+(define define-method/pure-false?
+  (expression/make-method-definer pure-false?-dispatch-vector))
+
+(define-method/pure-false? 'ACCESS false-procedure)
+
+(define-method/pure-false? 'ASSIGNMENT false-procedure)
+
+(define-method/pure-false? 'COMBINATION
+  (lambda (expression)
+    (cond ((expression/call-to-not? expression)
+          (expression/pure-true? (first (combination/operands expression))))
+         ((procedure? (combination/operator expression))
+          (and (for-all? (combination/operands expression) expression/effect-free?)
+               (expression/pure-false? (procedure/body (combination/operator expression)))))
+         (else #f))))
+
+(define-method/pure-false? 'CONDITIONAL
+  (lambda (expression)
+    (and (expression/effect-free? (conditional/predicate expression))
+        (or (expression/always-false? (conditional/predicate expression))
+            (expression/pure-false? (conditional/consequent expression)))
+        (or (expression/never-false? (conditional/predicate expression))
+            (expression/pure-false? (conditional/alternative expression))))))
+
+(define-method/pure-false? 'CONSTANT
+  (lambda (expression)
+    (or (not (constant/value expression))
+       (and (eq? (constant/value expression) unspecific)
+            (noisy-test sf:enable-true-unspecific? "Treating unspecific as pure false.")))))
+
+(define-method/pure-false? 'DECLARATION
+  (lambda (expression)
+    (expression/pure-false?
+     (declaration/expression expression))))
+
+(define-method/pure-false? 'DELAY false-procedure)
+
+(define-method/pure-false? 'DISJUNCTION
+  (lambda (expression)
+    (and (expression/pure-false? (disjunction/predicate expression))
+        (expression/pure-false? (disjunction/alternative expression)))))
+
+;; Could be smarter
+(define-method/pure-false? 'OPEN-BLOCK false-procedure)
+
+(define-method/pure-false? 'PROCEDURE false-procedure)
+
+(define-method/pure-false? 'QUOTATION false-procedure)
+
+(define-method/pure-false? 'REFERENCE false-procedure)
+
+(define-method/pure-false? 'SEQUENCE
+  (lambda (expression)
+    (and (for-all? (except-last-pair (sequence/actions expression)) 
+                  expression/effect-free?) ;; unlikely
+        (expression/pure-false? (last (sequence/actions expression))))))
+
+(define-method/pure-false? 'THE-ENVIRONMENT false-procedure)
+\f
+;;; EXPRESSION/PURE-TRUE?
+;;
+;; True iff all paths through expression end in returning
+;; exactly #T or unspecified, and no path has side effects.
+;; Expression is observationally equivalent to #T.
+(declare (integrate-operator expression/pure-true?))
+(define (expression/pure-true? expression)
+  ((expression/method pure-true?-dispatch-vector expression) expression))
+
+(define pure-true?-dispatch-vector
+  (expression/make-dispatch-vector))
+
+(define define-method/pure-true?
+  (expression/make-method-definer pure-true?-dispatch-vector))
+
+(define-method/pure-true? 'ACCESS false-procedure)
+
+(define-method/pure-true? 'ASSIGNMENT false-procedure)
+
+(define-method/pure-true? 'COMBINATION
+  (lambda (expression)
+    (cond ((expression/call-to-not? expression)
+          (expression/pure-false? (first (combination/operands expression))))
+         ((procedure? (combination/operator expression))
+          (and (for-all? (combination/operands expression) expression/effect-free?)
+               (expression/pure-true? (procedure/body (combination/operator expression)))))
+         (else #f))))
+
+(define-method/pure-true? 'CONDITIONAL
+  (lambda (expression)
+    (and (expression/effect-free? (conditional/predicate expression))
+        (or (expression/always-false? (conditional/predicate expression))
+            (expression/pure-true? (conditional/consequent expression)))
+        (or (expression/never-false? (conditional/predicate expression))
+            (expression/pure-true? (conditional/alternative expression))))))
+
+(define-method/pure-true? 'CONSTANT
+  (lambda (expression)
+    (or (eq? (constant/value expression) #t)
+       (and (eq? (constant/value expression) unspecific)
+            (noisy-test sf:enable-true-unspecific? "Treating unspecific as pure true.")))))
+
+(define-method/pure-true? 'DECLARATION
+  (lambda (expression)
+    (expression/pure-true? (declaration/expression expression))))
+
+(define-method/pure-true? 'DELAY false-procedure)
+
+(define-method/pure-true? 'DISJUNCTION
+  (lambda (expression)
+    (and (expression/effect-free? (disjunction/predicate expression))
+        (expression/boolean? (disjunction/predicate expression))
+        (expression/pure-true? (disjunction/alternative expression)))))
+
+(define-method/pure-true? 'OPEN-BLOCK false-procedure)
+
+(define-method/pure-true? 'PROCEDURE false-procedure)
+
+(define-method/pure-true? 'QUOTATION false-procedure)
+
+(define-method/pure-true? 'REFERENCE false-procedure)
+
+(define-method/pure-true? 'SEQUENCE
+  (lambda (expression)
+    (and (for-all? (except-last-pair (sequence/actions expression)) 
+                  expression/effect-free?)
+        (expression/pure-true? (last (sequence/actions expression))))))
+
+(define-method/pure-true? 'THE-ENVIRONMENT false-procedure)
+\f
+;; If true, then expression/unspecific? will return #t on
+;; unspecific which will enable certain operations to treat
+;; the value as something more convenient.  For example, a
+;; conditional might just treat an unspecific as #F to enable
+;; folding.
+(define sf:enable-true-unspecific? #t)
+
+(define (expression/unspecific? expression)
+  (and (constant? expression)
+       (eq? (constant/value expression) unspecific)
+       (noisy-test sf:enable-true-unspecific? "Enable true unspecific")))
 

diff --git a/src/sf/object.scm b/src/sf/object.scm
index b020cbf79f5a4a4ec2896c96fe1d9e14d0e1cafe..fad3cd1fb51694713cafe45237acc33567d989fd 100644 (file)
--- a/src/sf/object.scm
+++ b/src/sf/object.scm
@@ -326,18 +326,6 @@ USA.
   (and (constant? expression)
        (eq? (constant/value expression) value)))
 
-;; If true, then expression/unspecific? will return #t on
-;; unspecific which will enable certain operations to treat
-;; the value as something more convenient.  For example, a
-;; conditional might just treat an unspecific as #F to enable
-;; folding.
-(define sf:enable-true-unspecific? #t)
-
-(define (expression/unspecific? expression)
-  (and (constant? expression)
-       (eq? (constant/value expression) unspecific)
-       (noisy-test sf:enable-true-unspecific? "Enable true unspecific")))
-
 (define-integrable (global-ref/make name)
   (access/make #f
               (constant/make #f system-global-environment)

diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg
index f768e4a512d25f357de12a8b27fcb2924f0b875f..12b0489978e561f4a2b142ce93da47739a31898e 100644 (file)
--- a/src/sf/sf.pkg
+++ b/src/sf/sf.pkg
@@ -46,8 +46,7 @@ USA.
          sf:enable-disjunction-distribution?
          sf:enable-disjunction-simplification?
          sf:enable-distribute-primitives?
-         sf:enable-elide-conditional-canonicalization?
-         sf:enable-true-unspecific?))
+         sf:enable-elide-conditional-canonicalization?))
 
 (define-package (scode-optimizer global-imports)
   (files "gimprt")
@@ -155,7 +154,11 @@ USA.
          expression/free-variable?
          expression/free-variables
          expression/never-false?
-         sf:maximum-duplicate-expression-size))
+         expression/pure-false?
+         expression/pure-true?
+         expression/unspecific?
+         sf:maximum-duplicate-expression-size
+         sf:enable-true-unspecific?))
 
 (define-package (scode-optimizer change-type)
   (files "chtype")