mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
246 lines
11 KiB
Common Lisp
246 lines
11 KiB
Common Lisp
;;;; 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.
|
|
|
|
(with-test (:name (coerce complex :numeric-types))
|
|
(labels ((function/optimized (type rationalp)
|
|
(checked-compile `(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)) #C(1.1s0 0s0) 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))) #C(1.1s0 0s0) 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)
|
|
|
|
))
|
|
|
|
(with-test (:name :coerce-symbol-to-fun)
|
|
(flet ((coerce-it (x)
|
|
(handler-case (sb-kernel:coerce-symbol-to-fun x)
|
|
(simple-error (c) (simple-condition-format-control c)))))
|
|
(assert (string= (coerce-it 'defun) "~S names a macro."))
|
|
(assert (string= (coerce-it 'progn) "~S names a special operator."))
|
|
(let ((foo (gensym)))
|
|
(eval `(defmacro ,foo () 5))
|
|
(setf (sb-int:info :function :kind foo) :function)
|
|
(assert (string= (coerce-it foo) "~S names a macro.")))
|
|
(let ((foo (gensym)))
|
|
(eval `(defun ,foo () 5))
|
|
(setf (sb-int:info :function :kind foo) :macro)
|
|
(assert (functionp (coerce-it foo))))))
|
|
|
|
(with-test (:name :no-coerce-macro-to-function)
|
|
;; When compiled, we actually just pass the FDEFN-FUN
|
|
;; of the FDEFN of AND even though AND is a standard macro
|
|
;; (making this particularly stupid).
|
|
;; But at least it's generally an improvement
|
|
;; to fail earlier than later in many cases.
|
|
(multiple-value-bind (fun failure-p warnings)
|
|
(checked-compile '(lambda (z)
|
|
(locally (declare (notinline sort))
|
|
(sort () z :key 'and)))
|
|
:allow-warnings t)
|
|
(declare (ignore failure-p))
|
|
(assert (= 1 (length warnings)))
|
|
(assert-error (funcall fun))))
|
|
|
|
(with-test (:name :coerce-float-to-float)
|
|
(checked-compile-and-assert
|
|
()
|
|
'(lambda (f)
|
|
(coerce f 'float))
|
|
((10) 10.0)
|
|
((1/2) 0.5)
|
|
((30d0) 30d0)))
|
|
|
|
(with-test (:name :no-coerce-to-values-type)
|
|
(multiple-value-bind (fun warnp errorp)
|
|
(checked-compile '(lambda (x) (coerce (list x) '(values list)))
|
|
:allow-warnings t)
|
|
(assert (and warnp errorp))
|
|
(assert-error (funcall fun 1))))
|
|
|
|
;; lp#1929614
|
|
(with-test (:name :no-coerce-to-union-of-array)
|
|
(let ((fun
|
|
(checked-compile '(lambda (x)
|
|
(declare (optimize speed)) ; want to see notes
|
|
;; safety doesn't matter now (in terms of getting
|
|
;; the transform to try to run), but it used to matter,
|
|
;; so keep it in.
|
|
(declare (optimize (safety 0)))
|
|
(coerce x '(or (array (signed-byte 8) (*))
|
|
(array (unsigned-byte 8) (*))))))))
|
|
(assert-error (funcall fun '(1 2 1)))))
|
|
|
|
(with-test (:name :coerce-array)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a)
|
|
(coerce a 'array))
|
|
((#(1)) #(1) :test #'equalp)))
|
|
|
|
(with-test (:name :coerce-vector-no-warnings)
|
|
(checked-compile '(lambda (x)
|
|
(typecase x
|
|
(vector 1)
|
|
(t
|
|
(coerce x '(vector t))))))
|
|
(checked-compile '(lambda (x)
|
|
(typecase x
|
|
((vector t) 1)
|
|
(t
|
|
(coerce x '(vector t)))))))
|
|
|
|
(with-test (:name :coerce-object-type)
|
|
(assert-type
|
|
(lambda (x y)
|
|
(coerce (the float x) y))
|
|
(or float (complex float)))
|
|
(assert-type
|
|
(lambda (x y)
|
|
(coerce (the array x) y))
|
|
(or array sequence character))
|
|
(assert-type
|
|
(lambda (y)
|
|
(coerce "ab" y))
|
|
(or cons (simple-array * (2)) sb-kernel:extended-sequence))
|
|
(assert-type
|
|
(lambda (x y)
|
|
(coerce (the function x) y))
|
|
(or list (simple-array * (*)) function sb-kernel:extended-sequence))
|
|
(assert-type
|
|
(lambda (x y)
|
|
(coerce (the (and symbol (not null)) x) y))
|
|
(or (and symbol (not null)) function character))
|
|
(assert-type
|
|
(lambda (x y)
|
|
(coerce (the symbol x) y))
|
|
(or symbol (simple-array * (0)) sb-kernel:extended-sequence function character))
|
|
(assert-type
|
|
(lambda (x y)
|
|
(coerce (the (not single-float) x) y))
|
|
t))
|
|
|
|
(with-test (:name :coerce-constructed-type)
|
|
(assert-type
|
|
(lambda (x n)
|
|
(coerce x `(vector ,n)))
|
|
vector)
|
|
(assert-type
|
|
(lambda (x n)
|
|
(coerce (the list x) `(vector ,n)))
|
|
(simple-array * (*)))
|
|
(assert-type
|
|
(lambda (x n)
|
|
(coerce n (if x 'single-float 'double-float)))
|
|
float)
|
|
(assert-type
|
|
(lambda (n e)
|
|
(coerce n `(simple-array ,e (* *))))
|
|
(simple-array * (* *)))
|
|
(assert-type
|
|
(lambda (n e)
|
|
(coerce n `(array ,e (*))))
|
|
vector))
|
|
|
|
(with-test (:name :coerce-excluded-types)
|
|
(assert-type
|
|
(lambda (x y)
|
|
(coerce (the (not real) x) y))
|
|
(not real))
|
|
(assert-type
|
|
(lambda (x y)
|
|
(coerce (the (not fixnum) x) y))
|
|
(not fixnum)))
|
|
|
|
(with-test (:name :numbero-to-list-error)
|
|
(assert-error (coerce (opaque-identity 1)
|
|
(opaque-identity 'list))
|
|
type-error))
|