[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-34-g75a5de1

[Mark H Weaver]

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=75a5de18a0e6e34963cf0f5e0e20f528222e06af

The branch, stable-2.0 has been updated
       via  75a5de18a0e6e34963cf0f5e0e20f528222e06af (commit)
      from  bcf87e35e17741c279b755b0804776cdc8ee5828 (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 75a5de18a0e6e34963cf0f5e0e20f528222e06af
Author: Mark H Weaver <address@hidden>
Date:   Mon Oct 8 11:56:10 2012 -0400

    Simplify calls to 'eqv?' when one argument is an immediate constant.
    
    * module/language/tree-il/primitives.scm (maybe-simplify-to-eq): New
      helper procedure shared by expanders for 'eqv?' and 'equal?'.
      (*primitive-expand-table*): Add expansion rule for 'eqv?'.
    
    * test-suite/tests/tree-il.test ("primitives"): Add tests.

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

Summary of changes:
 module/language/tree-il/primitives.scm |   38 +++++++++--------
 test-suite/tests/tree-il.test          |   74 +++++++++++++++++++++++---------
 2 files changed, 73 insertions(+), 39 deletions(-)

diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index c3cd8c6..bac3136 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -490,24 +490,26 @@
 (define-primitive-expander f64vector-set! (vec i x)
   (bytevector-ieee-double-native-set! vec (* i 8) x))
 
-(hashq-set! *primitive-expand-table*
-            'equal?
-            (case-lambda
-              ((src a b)
-               ;; Simplify cases where either A or B is constant.
-               (define (maybe-simplify a b)
-                 (and (const? a)
-                      (let ((v (const-exp a)))
-                        (and (or (memq v '(#f #t () #nil))
-                                 (symbol? v)
-                                 (and (integer? v)
-                                      (exact? v)
-                                      (<= v most-positive-fixnum)
-                                      (>= v most-negative-fixnum)))
-                             (make-application src (make-primitive-ref #f 'eq?)
-                                               (list a b))))))
-               (or (maybe-simplify a b) (maybe-simplify b a)))
-              (else #f)))
+;; Appropriate for use with either 'eqv?' or 'equal?'.
+(define maybe-simplify-to-eq
+  (case-lambda
+    ((src a b)
+     ;; Simplify cases where either A or B is constant.
+     (define (maybe-simplify a b)
+       (and (const? a)
+            (let ((v (const-exp a)))
+              (and (or (memq v '(#f #t () #nil))
+                       (symbol? v)
+                       (and (integer? v)
+                            (exact? v)
+                            (<= most-negative-fixnum v most-positive-fixnum)))
+                   (make-application src (make-primitive-ref #f 'eq?)
+                                     (list a b))))))
+     (or (maybe-simplify a b) (maybe-simplify b a)))
+    (else #f)))
+
+(hashq-set! *primitive-expand-table* 'eqv?   maybe-simplify-to-eq)
+(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
 
 (hashq-set! *primitive-expand-table*
             'dynamic-wind
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 008eb83..1df72e8 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -86,33 +86,65 @@
 
 (with-test-prefix "primitives"
 
-  (pass-if-primitives-resolved
-   (apply (primitive equal?) (const #f) (toplevel x))
-   (apply (primitive eq?) (const #f) (toplevel x)))
+  (with-test-prefix "eqv?"
 
-  (pass-if-primitives-resolved
-   (apply (primitive equal?) (const ()) (toplevel x))
-   (apply (primitive eq?) (const ()) (toplevel x)))
+    (pass-if-primitives-resolved
+        (apply (primitive eqv?) (const #f) (toplevel x))
+      (apply (primitive eq?) (const #f) (toplevel x)))
 
-  (pass-if-primitives-resolved
-   (apply (primitive equal?) (const #t) (lexical x y))
-   (apply (primitive eq?) (const #t) (lexical x y)))
+    (pass-if-primitives-resolved
+        (apply (primitive eqv?) (const ()) (toplevel x))
+      (apply (primitive eq?) (const ()) (toplevel x)))
 
-  (pass-if-primitives-resolved
-   (apply (primitive equal?) (const this-is-a-symbol) (toplevel x))
-   (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
+    (pass-if-primitives-resolved
+        (apply (primitive eqv?) (const #t) (lexical x y))
+      (apply (primitive eq?) (const #t) (lexical x y)))
 
-  (pass-if-primitives-resolved
-   (apply (primitive equal?) (const 42) (toplevel x))
-   (apply (primitive eq?) (const 42) (toplevel x)))
+    (pass-if-primitives-resolved
+        (apply (primitive eqv?) (const this-is-a-symbol) (toplevel x))
+      (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
 
-  (pass-if-primitives-resolved
-   (apply (primitive equal?) (const 42.0) (toplevel x))
-   (apply (primitive equal?) (const 42.0) (toplevel x)))
+    (pass-if-primitives-resolved
+        (apply (primitive eqv?) (const 42) (toplevel x))
+      (apply (primitive eq?) (const 42) (toplevel x)))
 
-  (pass-if-primitives-resolved
-   (apply (primitive equal?) (const #nil) (toplevel x))
-   (apply (primitive eq?) (const #nil) (toplevel x))))
+    (pass-if-primitives-resolved
+        (apply (primitive eqv?) (const 42.0) (toplevel x))
+      (apply (primitive eqv?) (const 42.0) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (apply (primitive eqv?) (const #nil) (toplevel x))
+      (apply (primitive eq?) (const #nil) (toplevel x))))
+
+  (with-test-prefix "equal?"
+
+    (pass-if-primitives-resolved
+        (apply (primitive equal?) (const #f) (toplevel x))
+      (apply (primitive eq?) (const #f) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (apply (primitive equal?) (const ()) (toplevel x))
+      (apply (primitive eq?) (const ()) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (apply (primitive equal?) (const #t) (lexical x y))
+      (apply (primitive eq?) (const #t) (lexical x y)))
+
+    (pass-if-primitives-resolved
+        (apply (primitive equal?) (const this-is-a-symbol) (toplevel x))
+      (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (apply (primitive equal?) (const 42) (toplevel x))
+      (apply (primitive eq?) (const 42) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (apply (primitive equal?) (const 42.0) (toplevel x))
+      (apply (primitive equal?) (const 42.0) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (apply (primitive equal?) (const #nil) (toplevel x))
+      (apply (primitive eq?) (const #nil) (toplevel x)))))
 
 
 (with-test-prefix "tree-il->scheme"


hooks/post-receive
-- 
GNU Guile