1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
12 (in-package "CL-USER")
14 (with-test (:name
(coerce complex
:numeric-types
))
15 (labels ((function/optimized
(type rationalp
)
16 (compile nil
`(lambda (input)
21 (coerce input
',type
))))))
22 (function/unoptimized
(type)
24 (ignore-errors (coerce input type
))))
25 (check-result (kind input result type rationalp expected
)
26 (unless (eql result expected
)
27 (error "~@<~S ~Sing ~S to type ~S produced ~S, not ~S.~@:>"
28 kind
'coerce input type result expected
))
31 (assert (typep result
`(or ,type rational
)))
32 (assert (typep result type
)))))
33 (test-case (input type expected
&optional rationalp
)
34 (let ((result/optimized
35 (funcall (function/optimized type rationalp
) input
))
37 (funcall (function/unoptimized type
) input
)))
38 (check-result :optimized input result
/optimized type rationalp expected
)
39 (check-result :unoptmized input result
/unoptimized type rationalp expected
))))
41 (test-case 1 'complex
1 t
)
42 (test-case 1 '(complex real
) 1 t
)
43 (test-case 1 '(complex (real 1)) 1 t
)
44 (test-case 1 '(complex rational
) 1 t
)
45 (test-case 1 '(complex (rational 1)) 1 t
)
46 (test-case 1 '(complex (or (rational -
3 -
2) (rational 1))) 1 t
)
47 (test-case 1 '(complex float
) #C
(1.0e0
0.0e0
))
48 (test-case 1 '(complex double-float
) #C
(1.0d0
0.0d0
))
49 (test-case 1 '(complex single-float
) #C
(1.0f0
0.0f0
))
50 (test-case 1 '(complex integer
) 1 t
)
51 (test-case 1 '(complex (or (real 1) (integer -
1 0))) 1 t
)
53 (test-case -
2 'complex -
2 t
)
54 (test-case -
2 '(complex real
) -
2 t
)
55 (test-case -
2 '(complex (real 1)) -
2 t
)
56 (test-case -
2 '(complex rational
) -
2 t
)
57 (test-case -
2 '(complex (rational 1)) -
2 t
)
58 (test-case -
2 '(complex (or (rational -
3 -
2) (rational 1))) -
2 t
)
59 (test-case -
2 '(complex float
) #C
(-2.0e0
0.0e0
))
60 (test-case -
2 '(complex double-float
) #C
(-2.0d0
0.0d0
))
61 (test-case -
2 '(complex single-float
) #C
(-2.0f0
0.0f0
))
62 (test-case -
2 '(complex integer
) -
2 t
)
63 (test-case -
2 '(complex (or (real 1) (integer -
1 0))) -
2 t
)
65 (test-case 1.1s0
'complex
#C
(1.1s0
.0s0
) t
)
66 (test-case 1.1s0
'(complex real
) #C
(1.1s0
.0s0
) t
)
67 (test-case 1.1s0
'(complex (real 1)) nil t
)
68 (test-case 1.1s0
'(complex rational
) nil t
)
69 (test-case 1.1s0
'(complex (rational 1)) nil t
)
70 (test-case 1.1s0
'(complex (or (rational -
3 -
2) (rational 1))) nil t
)
71 (test-case 1.1s0
'(complex float
) #C
(1.1s0
.0s0
))
72 (test-case 1.1s0
'(complex double-float
) (coerce #C
(1.1s0
.0s0
) '(complex double-float
)))
73 (test-case 1.1s0
'(complex single-float
) #C
(1.1s0
.0s0
))
74 (test-case 1.1s0
'(complex integer
) nil t
)
75 (test-case 1.1s0
'(complex (or (real 1) (integer -
1 0))) nil t
)
77 (test-case 1/2 'complex
1/2 t
)
78 (test-case 1/2 '(complex real
) 1/2 t
)
79 (test-case 1/2 '(complex (real 1)) 1/2 t
)
80 (test-case 1/2 '(complex rational
) 1/2 t
)
81 (test-case 1/2 '(complex (rational 1)) 1/2 t
)
82 (test-case 1/2 '(complex (or (rational -
3 -
2) (rational 1))) 1/2 t
)
83 (test-case 1/2 '(complex float
) #C
(.5e0
0.0e0
))
84 (test-case 1/2 '(complex double-float
) #C
(.5d0
0.0d0
))
85 (test-case 1/2 '(complex single-float
) #C
(.5f0
0.0f0
))
86 (test-case 1/2 '(complex integer
) 1/2 t
)
87 (test-case 1/2 '(complex (or (real 1) (integer -
1 0))) 1/2 t
)
89 ;; TODO fails with vanilla COERCE (i.e. without source transform)
90 ;; (test-case #C(1/2 .5e0) 'complex #C(1/2 .5e0) t)
91 ;; (test-case #C(1/2 .5e0) '(complex real) #C(1/2 .5e0) t)
92 ;; (test-case #C(1/2 .5e0) '(complex (real 1)) nil t)
93 ;; (test-case #C(1/2 .5e0) '(complex rational) nil t)
94 ;; (test-case #C(1/2 .5e0) '(complex (rational 1)) nil t)
95 ;; (test-case #C(1/2 .5e0) '(complex (or (rational -3 -2) (rational 1))) nil t)
96 ;; (test-case #C(1/2 .5e0) '(complex float) #C(.5e0 .5e0))
97 ;; (test-case #C(1/2 .5e0) '(complex double-float) #C(.5d0 .5d0))
98 ;; (test-case #C(1/2 .5e0) '(complex single-float) #C(.5f0 .5f0))
99 ;; (test-case #C(1/2 .5e0) '(complex integer) nil t)
100 ;; (test-case #C(1/2 .5e0) '(complex (or (real 1) (integer -1 0))) nil t)
104 (with-test (:name
:coerce-symbol-to-fun
)
105 (flet ((coerce-it (x)
106 (handler-case (sb-kernel:coerce-symbol-to-fun x
)
107 (simple-error (c) (simple-condition-format-control c
)))))
108 (assert (string= (coerce-it 'defun
) "~S names a macro."))
109 (assert (string= (coerce-it 'progn
) "~S names a special operator."))
110 (let ((foo (gensym)))
111 (eval `(defmacro ,foo
() 5))
112 (setf (sb-int:info
:function
:kind foo
) :function
)
113 (assert (string= (coerce-it foo
) "~S names a macro.")))
114 (let ((foo (gensym)))
115 (eval `(defun ,foo
() 5))
116 (setf (sb-int:info
:function
:kind foo
) :macro
)
117 (assert (functionp (coerce-it foo
))))))
119 (with-test (:name
:no-coerce-macro-to-function
)
120 ;; When compiled, we actually just pass the FDEFN-FUN
121 ;; of the FDEFN of AND even though AND is a standard macro
122 ;; (making this particular stupid).
123 ;; But at least it's generally an improvement
124 ;; to fail earlier than later in many cases.
125 (locally (declare (notinline sort
))
126 (assert-error (sort () #'< :key
'and
))))
