mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Fix bug in comparison between real and complex

Browse source 
This bug was introduced by 35a9059250.

* module/language/cps/specialize-numbers.scm (specialize-operations):
  Check that both operands are real as a condition for
  specialize-f64-comparison.
* test-suite/tests/numbers.test: Add test.
This commit is contained in:
Daniel Llorens 2017-03-09 15:13:19 +01:00
parent 7cdfaaada9
commit 7de77bf7d8
2 changed files with 17 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

14
module/language/cps/specialize-numbers.scm
View file

@ -51,6 +51,7 @@
(define-module (language cps specialize-numbers)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language cps)
#:use-module (language cps intmap)
#:use-module (language cps intset)
@ -301,11 +302,12 @@ BITS indicating the significant bits needed for a variable. BITS may be
(lambda (type min max)
(and (eqv? type &exact-integer)
(<= 0 min max #xffffffffffffffff))))))
(define (f64-operand? var)
(call-with-values (lambda ()
(lookup-pre-type types label var))
(lambda (type min max)
(and (eqv? type &flonum)))))
(define (f64-operands? vara varb)
(let-values (((typea mina maxa) (lookup-pre-type types label vara))
((typeb minb maxb) (lookup-pre-type types label varb)))
(and (zero? (logand (logior typea typeb) (lognot &real)))
(or (eqv? typea &flonum)
(eqv? typeb &flonum)))))
(match cont
(($ $kfun)
(let ((types (infer-types cps label)))
@ -411,7 +413,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b)))))
(values
(cond
((or (f64-operand? a) (f64-operand? b))
((f64-operands? a b)
(with-cps cps
(let$ body (specialize-f64-comparison k kt src op a b))
(setk label ($kargs names vars ,body))))

9
test-suite/tests/numbers.test
View file

@ -5425,3 +5425,12 @@
(test-ash-variant 'ash ash floor)
(test-ash-variant 'round-ash round-ash round))
;;;
;;; regressions
;;;
(with-test-prefix/c&e "bug in unboxing f64 in 2.1.6"
(pass-if "= real and complex"
(= 1.0 (make-rectangular 1.0 0.0))))