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) (define-module (language cps specialize-numbers)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language cps) #:use-module (language cps)
#:use-module (language cps intmap) #:use-module (language cps intmap)
#:use-module (language cps intset) #: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) (lambda (type min max)
(and (eqv? type &exact-integer) (and (eqv? type &exact-integer)
(<= 0 min max #xffffffffffffffff)))))) (<= 0 min max #xffffffffffffffff))))))
(define (f64-operand? var) (define (f64-operands? vara varb)
(call-with-values (lambda () (let-values (((typea mina maxa) (lookup-pre-type types label vara))
(lookup-pre-type types label var)) ((typeb minb maxb) (lookup-pre-type types label varb)))
(lambda (type min max) (and (zero? (logand (logior typea typeb) (lognot &real)))
(and (eqv? type &flonum))))) (or (eqv? typea &flonum)
(eqv? typeb &flonum)))))
(match cont (match cont
(($ $kfun) (($ $kfun)
(let ((types (infer-types cps label))) (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))))) ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b)))))
(values (values
(cond (cond
((or (f64-operand? a) (f64-operand? b)) ((f64-operands? a b)
(with-cps cps (with-cps cps
(let$ body (specialize-f64-comparison k kt src op a b)) (let$ body (specialize-f64-comparison k kt src op a b))
(setk label ($kargs names vars ,body)))) (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 'ash ash floor)
(test-ash-variant 'round-ash round-ash round)) (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))))