diff options
| -rw-r--r-- | module/language/tree-il/primitives.scm | 38 | ||||
| -rw-r--r-- | 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 c3cd8c67a..bac3136e3 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 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" |