-
Notifications
You must be signed in to change notification settings - Fork 0
/
coerce.pure.lisp
132 lines (122 loc) · 7.95 KB
/
coerce.pure.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
;;;; 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)
(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)) 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)
))
(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 ()
(locally (declare (notinline sort))
(sort () #'< :key 'and)))
:allow-warnings t)
(declare (ignore failure-p))
(assert (= 1 (length warnings)))
(assert-error (funcall fun))))