[Guile-commits] GNU Guile branch, wip-peval-predicates, updated. v2.0.5-102-g699d924

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=699d924bb85a69cce030287a58669c3fddd5eab7

The branch, wip-peval-predicates has been updated
       via  699d924bb85a69cce030287a58669c3fddd5eab7 (commit)
      from  8186d7acfcd8aa888390d89934fa4508c026613a (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 699d924bb85a69cce030287a58669c3fddd5eab7
Author: Andy Wingo <address@hidden>
Date:   Tue Apr 10 22:16:43 2012 -0700

    correctness fixes
    
    * module/language/tree-il/peval.scm (boolean-valued?): Factor out of
      peval.
      (peval): Fix negation for alternate.  Refactor a little.  Fix "and" /
      "or" folding.

-----------------------------------------------------------------------

Summary of changes:
 module/language/tree-il/peval.scm |   36 ++++++++++++++++++++----------------
 1 files changed, 20 insertions(+), 16 deletions(-)

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index e649e49..28a6bb5 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -363,6 +363,12 @@
     ;; FIXME: add more cases?
     (else #f)))
 
+(define (boolean-valued? primitive)
+  (or (negate-primitive primitive)
+      (let ((chars (symbol->string primitive)))
+        (eqv? (string-ref chars (1- (string-length chars)))
+              #\?))))
+
 (define* (peval exp #:optional (cenv (current-module)) (env vlist-null)
                 #:key
                 (operator-size-limit 40)
@@ -1207,22 +1213,25 @@ top-level bindings from ENV and return the resulting 
expression."
              (if (const-exp condition)
                  (for-tail subsequent)
                  (for-tail alternate))
-             (let ((db? (extract-facts condition '() #t)))
+             (let ((db+ (extract-facts condition '() #t))
+                   (db- (extract-facts (negate condition) '() #t)))
                (match (make-conditional
                        src
                        condition
-                       (for-cond subsequent db?)
-                       (for-cond alternate (map negate db?)))
-                 (($ <conditional> src condition
-                     ($ <const> _ #f) ($ <const> _ #t))
-                  (for-tail (negate condition)))
-                 (($ <conditional> src condition
-                     ($ <const> _ #t) ($ <const> _ #f))
-                  (for-tail (negate (negate condition))))
+                       (for-cond subsequent db+)
+                       (for-cond alternate db-))
                  (($ <conditional> src condition
-                     ($ <const> _ a) ($ <const> _ (and b (equal? a b))))
+                     ($ <const> _ a) ($ <const> _ (? (cut equal? a <>))))
                   (for-tail
                    (make-sequence #f (list condition (make-const #f a)))))
+                 (($ <conditional> src
+                     ($ <application> _
+                        ($ <primitive-ref> _ (? boolean-valued?)))
+                     ($ <const> _ (and b (? boolean?)))
+                     ($ <const> _ (? boolean?)))
+                  ;; A shortcut for (if FOO #t #f) or (if FOO #f #t) for
+                  ;; boolean-valued FOO.
+                  (if b condition (negate condition)))
                  (exp exp))))))
       (($ <application> src
           ($ <primitive-ref> _ '@call-with-values)
@@ -1355,11 +1364,6 @@ top-level bindings from ENV and return the resulting 
expression."
             (let ((args (map for-value orig-args)))
               (or (fold-constants src name args ctx)
                   (let ((exp (make-application src proc args)))
-                    (define (predicate? primitive)
-                      (or (negate-primitive primitive)
-                          (let ((chars (symbol->string primitive)))
-                            (eqv? (string-ref chars (1- (string-length chars)))
-                                  #\?))))
                     (match exp
                       ;; Three degenerate cases of (eq? X X).  Usually
                       ;; not present in source programs, but constant
@@ -1399,7 +1403,7 @@ top-level bindings from ENV and return the resulting 
expression."
                       ;; primitives, and is possible for other ones
                       ;; (like memv) in test context.
                       (($ <application> _
-                          ($ <primitive-ref> _ (? predicate?)))
+                          ($ <primitive-ref> _ (? boolean-valued?)))
                        (infer exp db))
                       (_ 
                        (if (eq? ctx 'test)


hooks/post-receive
-- 
GNU Guile