From: stassats <sta...@us...> - 2014-04-27 12:00:57
|
The branch "master" has been updated in SBCL: via d69b224577bef30c8676a45c5b7e176486342783 (commit) from 2ea1111db2af14bdc4ccebf4d5e2cf81f4e22183 (commit) - Log ----------------------------------------------------------------- commit d69b224577bef30c8676a45c5b7e176486342783 Author: Stas Boukarev <sta...@gm...> Date: Sun Apr 27 15:55:33 2014 +0400 Fix the COERCE transform for complexes. It got some corner cases wrong. Based on the patch by Jan Moringen. --- src/code/coerce.lisp | 2 +- src/compiler/typetran.lisp | 38 +++++++++-------- tests/coerce.pure.lisp | 102 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 123 insertions(+), 19 deletions(-) diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index c75c2e3..d4f212d 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -177,7 +177,7 @@ ((csubtypep type (specifier-type '(complex float))) (complex (%single-float (realpart object)) (%single-float (imagpart object)))) - ((and (typep object 'rational) + ((and (typep object 'rational) ; TODO jmoringe unreachable? (csubtypep type (specifier-type '(complex float)))) ;; Perhaps somewhat surprisingly, ANSI specifies ;; that (COERCE FOO 'FLOAT) is a SINGLE-FLOAT, diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index a6327ed..840a4dc 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -731,24 +731,26 @@ ((csubtypep tspec (specifier-type 'float)) `(the ,tval (%single-float x))) ((csubtypep tspec (specifier-type 'complex)) - (let ((part-type (cond ((numeric-type-p tspec) - (numeric-type-format tspec)) - ((csubtypep tspec (specifier-type '(complex float))) - 'float) - (t - t)))) - `(cond ,@(and (eq part-type t) - `(((typep x 'rational) - x))) - (t - (the ,tval - (cond ((not (typep x 'complex)) - (complex (coerce x ',part-type))) - ((typep x ',tval) - x) - (t - (complex (coerce (realpart x) ',part-type) - (coerce (imagpart x) ',part-type))))))))) + (multiple-value-bind (part-type result-type) + (cond ((and (numeric-type-p tspec) + (numeric-type-format tspec))) ; specific FLOAT type + ((csubtypep tspec (specifier-type '(complex float))) + ;; unspecific FLOAT type + 'float) + ((csubtypep tspec (specifier-type '(complex rational))) + (values 'rational `(or ,tval rational))) + (t + (values t `(or ,tval rational)))) + (let ((result-type (or result-type tval))) + `(cond + ((not (typep x 'complex)) + (the ,result-type (complex (coerce x ',part-type)))) + ((typep x ',tval) + x) + (t ; X is COMPLEX, but not of the requested type + (the ,result-type + (complex (coerce (realpart x) ',part-type) + (coerce (imagpart x) ',part-type)))))))) ;; Special case STRING and SIMPLE-STRING as they are union types ;; in SBCL. ((member tval '(string simple-string)) diff --git a/tests/coerce.pure.lisp b/tests/coerce.pure.lisp new file mode 100644 index 0000000..fd57331 --- /dev/null +++ b/tests/coerce.pure.lisp @@ -0,0 +1,102 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package "CL-USER") + +(with-test (:name (coerce complex :numeric-types)) + (labels ((function/optimized (type rationalp) + (compile nil `(lambda (input) + (ignore-errors + (the ,(if rationalp + `(or ,type rational) + type) + (coerce input ',type)))))) + (function/unoptimized (type) + (lambda (input) + (ignore-errors (coerce input type)))) + (check-result (kind input result type rationalp expected) + (unless (eql result expected) + (error "~@<~S ~Sing ~S to type ~S produced ~S, not ~S.~@:>" + kind 'coerce input type result expected)) + (when expected + (if rationalp + (assert (typep result `(or ,type rational))) + (assert (typep result type))))) + (test-case (input type expected &optional rationalp) + (let ((result/optimized + (funcall (function/optimized type rationalp) input)) + (result/unoptimized + (funcall (function/unoptimized type) input))) + (check-result :optimized input result/optimized type rationalp expected) + (check-result :unoptmized input result/unoptimized type rationalp expected)))) + + (test-case 1 'complex 1 t) + (test-case 1 '(complex real) 1 t) + (test-case 1 '(complex (real 1)) 1 t) + (test-case 1 '(complex rational) 1 t) + (test-case 1 '(complex (rational 1)) 1 t) + (test-case 1 '(complex (or (rational -3 -2) (rational 1))) 1 t) + (test-case 1 '(complex float) #C(1.0e0 0.0e0)) + (test-case 1 '(complex double-float) #C(1.0d0 0.0d0)) + (test-case 1 '(complex single-float) #C(1.0f0 0.0f0)) + (test-case 1 '(complex integer) 1 t) + (test-case 1 '(complex (or (real 1) (integer -1 0))) 1 t) + + (test-case -2 'complex -2 t) + (test-case -2 '(complex real) -2 t) + (test-case -2 '(complex (real 1)) -2 t) + (test-case -2 '(complex rational) -2 t) + (test-case -2 '(complex (rational 1)) -2 t) + (test-case -2 '(complex (or (rational -3 -2) (rational 1))) -2 t) + (test-case -2 '(complex float) #C(-2.0e0 0.0e0)) + (test-case -2 '(complex double-float) #C(-2.0d0 0.0d0)) + (test-case -2 '(complex single-float) #C(-2.0f0 0.0f0)) + (test-case -2 '(complex integer) -2 t) + (test-case -2 '(complex (or (real 1) (integer -1 0))) -2 t) + + (test-case 1.1s0 'complex #C(1.1s0 .0s0) t) + (test-case 1.1s0 '(complex real) #C(1.1s0 .0s0) t) + (test-case 1.1s0 '(complex (real 1)) nil t) + (test-case 1.1s0 '(complex rational) nil t) + (test-case 1.1s0 '(complex (rational 1)) nil t) + (test-case 1.1s0 '(complex (or (rational -3 -2) (rational 1))) nil t) + (test-case 1.1s0 '(complex float) #C(1.1s0 .0s0)) + (test-case 1.1s0 '(complex double-float) (coerce #C(1.1s0 .0s0) '(complex double-float))) + (test-case 1.1s0 '(complex single-float) #C(1.1s0 .0s0)) + (test-case 1.1s0 '(complex integer) nil t) + (test-case 1.1s0 '(complex (or (real 1) (integer -1 0))) nil t) + + (test-case 1/2 'complex 1/2 t) + (test-case 1/2 '(complex real) 1/2 t) + (test-case 1/2 '(complex (real 1)) 1/2 t) + (test-case 1/2 '(complex rational) 1/2 t) + (test-case 1/2 '(complex (rational 1)) 1/2 t) + (test-case 1/2 '(complex (or (rational -3 -2) (rational 1))) 1/2 t) + (test-case 1/2 '(complex float) #C(.5e0 0.0e0)) + (test-case 1/2 '(complex double-float) #C(.5d0 0.0d0)) + (test-case 1/2 '(complex single-float) #C(.5f0 0.0f0)) + (test-case 1/2 '(complex integer) 1/2 t) + (test-case 1/2 '(complex (or (real 1) (integer -1 0))) 1/2 t) + + ;; TODO fails with vanilla COERCE (i.e. without source transform) + ;; (test-case #C(1/2 .5e0) 'complex #C(1/2 .5e0) t) + ;; (test-case #C(1/2 .5e0) '(complex real) #C(1/2 .5e0) t) + ;; (test-case #C(1/2 .5e0) '(complex (real 1)) nil t) + ;; (test-case #C(1/2 .5e0) '(complex rational) nil t) + ;; (test-case #C(1/2 .5e0) '(complex (rational 1)) nil t) + ;; (test-case #C(1/2 .5e0) '(complex (or (rational -3 -2) (rational 1))) nil t) + ;; (test-case #C(1/2 .5e0) '(complex float) #C(.5e0 .5e0)) + ;; (test-case #C(1/2 .5e0) '(complex double-float) #C(.5d0 .5d0)) + ;; (test-case #C(1/2 .5e0) '(complex single-float) #C(.5f0 .5f0)) + ;; (test-case #C(1/2 .5e0) '(complex integer) nil t) + ;; (test-case #C(1/2 .5e0) '(complex (or (real 1) (integer -1 0))) nil t) + + )) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |