mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 12:20:20 +02:00
Code Activity

More robust reduction of equal? and eqv?

Browse source 
* module/language/tree-il/primitives.scm (expand-eq): Just expand out to
  binary comparisons.  Also expand eq?, which was missing.  Leave
  strength reduction to peval.
  (character-comparison-expander): Move down, as it depends on <, <=,
  and so on.
* module/language/tree-il/peval.scm (peval): Robustly reduce equal? and
  eqv?.
* test-suite/tests/peval.test ("partial evaluation"): Expect fixnum
  comparison to reduce to eq?.
  ("eqv?", "equal?"): A new battery of tests.
* test-suite/tests/tree-il.test ("primitives"): Remove reduction tests.
This commit is contained in:
Andy Wingo 2020-05-13 15:51:58 +02:00
parent 498428fbef
commit 7df3f3414b
4 changed files with 125 additions and 119 deletions
Download patch file Download diff file Expand all files Collapse all files

62
test-suite/tests/peval.test
View file

@ -642,11 +642,11 @@
((3 2 1) 'a)
(else 'b))
(let (key) (_) ((toplevel foo))
(if (if (primcall eqv? (lexical key _) (const 3))
(if (if (primcall eq? (lexical key _) (const 3))
(const #t)
(if (primcall eqv? (lexical key _) (const 2))
(if (primcall eq? (lexical key _) (const 2))
(const #t)
(primcall eqv? (lexical key _) (const 1))))
(primcall eq? (lexical key _) (const 1))))
(const a)
(const b))))
@ -1441,3 +1441,59 @@
(call (lexical add1 _)
(const 1)
(const 2))))))))
(with-test-prefix "eqv?"
(pass-if-peval (eqv? x #f)
(primcall eq? (toplevel x) (const #f)))
(pass-if-peval (eqv? x '())
(primcall eq? (toplevel x) (const ())))
(pass-if-peval (eqv? x #t)
(primcall eq? (toplevel x) (const #t)))
(pass-if-peval (eqv? x 'sym)
(primcall eq? (toplevel x) (const sym)))
(pass-if-peval (eqv? x 42)
(primcall eq? (toplevel x) (const 42)))
(pass-if-peval (eqv? x #\a)
(primcall eq? (toplevel x) (const #\a)))
(pass-if-peval (eqv? x 42.0)
(primcall eqv? (toplevel x) (const '42.0)))
(pass-if-peval (eqv? x #nil)
(primcall eq? (toplevel x) (const #nil)))
(pass-if-peval (eqv? x '(a . b))
(primcall eq? (toplevel x) (const (a . b)))))
(with-test-prefix "equal?"
(pass-if-peval (equal? x #f)
(primcall eq? (toplevel x) (const #f)))
(pass-if-peval (equal? x '())
(primcall eq? (toplevel x) (const ())))
(pass-if-peval (equal? x #t)
(primcall eq? (toplevel x) (const #t)))
(pass-if-peval (equal? x 'sym)
(primcall eq? (toplevel x) (const sym)))
(pass-if-peval (equal? x 42)
(primcall eq? (toplevel x) (const 42)))
(pass-if-peval (equal? x #\a)
(primcall eq? (toplevel x) (const #\a)))
(pass-if-peval (equal? x 42.0)
(primcall eqv? (toplevel x) (const '42.0)))
(pass-if-peval (equal? x #nil)
(primcall eq? (toplevel x) (const #nil)))
(pass-if-peval (equal? x '(a . b))
(primcall equal? (toplevel x) (const (a . b)))))

60
test-suite/tests/tree-il.test
View file

@ -56,66 +56,6 @@
(with-test-prefix "primitives"
(with-test-prefix "eqv?"
(pass-if-primitives-resolved
(primcall eqv? (toplevel x) (const #f))
(primcall eq? (const #f) (toplevel x)))
(pass-if-primitives-resolved
(primcall eqv? (toplevel x) (const ()))
(primcall eq? (const ()) (toplevel x)))
(pass-if-primitives-resolved
(primcall eqv? (const #t) (lexical x y))
(primcall eq? (const #t) (lexical x y)))
(pass-if-primitives-resolved
(primcall eqv? (const this-is-a-symbol) (toplevel x))
(primcall eq? (const this-is-a-symbol) (toplevel x)))
(pass-if-primitives-resolved
(primcall eqv? (const 42) (toplevel x))
(primcall eq? (const 42) (toplevel x)))
(pass-if-primitives-resolved
(primcall eqv? (const 42.0) (toplevel x))
(primcall eqv? (const 42.0) (toplevel x)))
(pass-if-primitives-resolved
(primcall eqv? (const #nil) (toplevel x))
(primcall eq? (const #nil) (toplevel x))))
(with-test-prefix "equal?"
(pass-if-primitives-resolved
(primcall equal? (toplevel x) (const #f))
(primcall eq? (const #f) (toplevel x)))
(pass-if-primitives-resolved
(primcall equal? (toplevel x) (const ()))
(primcall eq? (const ()) (toplevel x)))
(pass-if-primitives-resolved
(primcall equal? (const #t) (lexical x y))
(primcall eq? (const #t) (lexical x y)))
(pass-if-primitives-resolved
(primcall equal? (const this-is-a-symbol) (toplevel x))
(primcall eq? (const this-is-a-symbol) (toplevel x)))
(pass-if-primitives-resolved
(primcall equal? (const 42) (toplevel x))
(primcall eq? (const 42) (toplevel x)))
(pass-if-primitives-resolved
(primcall equal? (const 42.0) (toplevel x))
(primcall equal? (const 42.0) (toplevel x)))
(pass-if-primitives-resolved
(primcall equal? (const #nil) (toplevel x))
(primcall eq? (const #nil) (toplevel x))))
(with-test-prefix "error"
(pass-if-primitives-resolved
(primcall error (const "message"))