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.

1 files changed, 53 insertions, 21 deletions

diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 008eb83fc..1df72e848 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"