1 ;;;; COERCE and related code
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 (macrolet ((def (name constructor access src-type
)
15 `(defun ,name
(object type
)
16 (declare (type ,src-type object
))
17 (do* ((index 0 (1+ index
))
18 (length (length object
))
21 ((>= index length
) result
)
22 (declare (fixnum length index
))
23 (declare (type vector result
))
24 (setf (,access result index
)
26 (list '(pop in-object
))
27 (vector '(aref in-object index
))
28 (sequence '(elt in-object index
))))))))
30 (def list-to-vector
* (make-sequence type length
) aref list
)
32 (def vector-to-vector
* (make-sequence type length
) aref vector
)
34 (def sequence-to-vector
* (make-sequence type length
) aref sequence
))
36 (defun vector-to-list* (object)
37 (declare (type vector object
))
38 (let ((result (list nil
))
39 (length (length object
)))
40 (declare (fixnum length
))
41 (do ((index 0 (1+ index
))
42 (splice result
(cdr splice
)))
43 ((>= index length
) (cdr result
))
44 (declare (fixnum index
))
45 (rplacd splice
(list (aref object index
))))))
47 (defun sequence-to-list (sequence)
48 (declare (type sequence sequence
))
49 (let* ((result (list nil
))
51 (sb!sequence
:dosequence
(i sequence
)
52 (rplacd splice
(list i
))
53 (setf splice
(cdr splice
)))
56 ;;; These are used both by the full DEFUN function and by various
57 ;;; optimization transforms in the constant-OUTPUT-TYPE-SPEC case.
59 ;;; Most of them are INLINE so that they can be optimized when the
60 ;;; argument type is known. It might be better to do this with
61 ;;; DEFTRANSFORMs, though.
62 (declaim (inline coerce-to-list
))
63 (declaim (inline coerce-to-vector
))
65 (defun coerce-symbol-to-fun (symbol)
66 ;; FIXME? I would think to use SYMBOL-FUNCTION here which does not strip off
67 ;; encapsulations. But Stas wrote FDEFINITION so ...
68 ;; [Also note, we won't encapsulate a macro or special-form, so this
69 ;; introspective technique to decide what kind something is works either way]
70 (let ((def (fdefinition symbol
)))
71 (acond ((macro/special-guard-fun-p def
)
72 (error (if (eq it
:special
)
73 "~S names a special operator." "~S names a macro.")
77 (defun coerce-to-fun (object)
78 ;; (Unlike the other COERCE-TO-FOOs, this one isn't inline, because
79 ;; it's so big and because optimizing away the outer ETYPECASE
80 ;; doesn't seem to buy us that much anyway.)
84 (coerce-symbol-to-fun object
))
92 (error 'simple-type-error
94 :expected-type
'(or symbol
95 ;; KLUDGE: ANSI wants us to
96 ;; return a TYPE-ERROR here, and
97 ;; a TYPE-ERROR is supposed to
98 ;; describe the expected type,
99 ;; but it's not obvious how to
100 ;; describe the coerceable cons
101 ;; types, so we punt and just say
102 ;; CONS. -- WHN 20000503
104 :format-control
"~S can't be coerced to a function."
105 :format-arguments
(list object
)))))))
107 (defun coerce-to-list (object)
110 (vector-to-list* object
)
111 (sequence-to-list object
)))
113 (defun coerce-to-vector (object output-type-spec
)
115 (list (list-to-vector* object output-type-spec
))
116 (vector (vector-to-vector* object output-type-spec
))))
118 ;;; old working version
119 (defun coerce (object output-type-spec
)
121 "Coerce the Object to an object of type Output-Type-Spec."
122 (flet ((coerce-error ()
123 (error 'simple-type-error
124 :format-control
"~S can't be converted to type ~S."
125 :format-arguments
(list object output-type-spec
)
127 :expected-type output-type-spec
)))
128 (let ((type (specifier-type output-type-spec
)))
130 ((%%typep object type
)
132 ((eq type
*empty-type
*)
134 ((type= type
(specifier-type 'character
))
138 ((csubtypep type
(specifier-type 'single-float
))
139 (let ((res (%single-float object
)))
140 (unless (typep res output-type-spec
)
143 ((csubtypep type
(specifier-type 'double-float
))
144 (let ((res (%double-float object
)))
145 (unless (typep res output-type-spec
)
149 ((csubtypep type
(specifier-type 'long-float
))
150 (let ((res (%long-float object
)))
151 (unless (typep res output-type-spec
)
154 ((csubtypep type
(specifier-type 'float
))
155 (let ((res (%single-float object
)))
156 (unless (typep res output-type-spec
)
162 ((csubtypep type
(specifier-type '(complex single-float
)))
163 (complex (%single-float
(realpart object
))
164 (%single-float
(imagpart object
))))
165 ((csubtypep type
(specifier-type '(complex double-float
)))
166 (complex (%double-float
(realpart object
))
167 (%double-float
(imagpart object
))))
169 ((csubtypep type
(specifier-type '(complex long-float
)))
170 (complex (%long-float
(realpart object
))
171 (%long-float
(imagpart object
))))
172 ((csubtypep type
(specifier-type '(complex float
)))
173 (complex (%single-float
(realpart object
))
174 (%single-float
(imagpart object
))))
175 ((and (typep object
'rational
) ; TODO jmoringe unreachable?
176 (csubtypep type
(specifier-type '(complex float
))))
177 ;; Perhaps somewhat surprisingly, ANSI specifies
178 ;; that (COERCE FOO 'FLOAT) is a SINGLE-FLOAT,
179 ;; not dispatching on
180 ;; *READ-DEFAULT-FLOAT-FORMAT*. By analogy, we
181 ;; do the same for complex numbers. -- CSR,
183 (complex (%single-float object
)))
184 ((csubtypep type
(specifier-type 'complex
))
188 ;; If RES has the wrong type, that means that rule of
189 ;; canonical representation for complex rationals was
190 ;; invoked. According to the Hyperspec, (coerce 7/2
191 ;; 'complex) returns 7/2. Thus, if the object was a
192 ;; rational, there is no error here.
193 (unless (or (typep res output-type-spec
)
197 ((csubtypep type
(specifier-type 'list
))
200 ((type= type
(specifier-type 'list
))
201 (vector-to-list* object
))
202 ((type= type
(specifier-type 'null
))
203 (if (= (length object
) 0)
205 (sequence-type-length-mismatch-error type
208 (multiple-value-bind (min exactp
)
209 (sb!kernel
::cons-type-length-info type
)
210 (let ((length (length object
)))
212 (unless (= length min
)
213 (sequence-type-length-mismatch-error type length
))
214 (unless (>= length min
)
215 (sequence-type-length-mismatch-error type length
)))
216 (vector-to-list* object
))))
217 (t (sequence-type-too-hairy (type-specifier type
))))
218 (if (sequencep object
)
220 ((type= type
(specifier-type 'list
))
221 (sb!sequence
:make-sequence-like
222 nil
(length object
) :initial-contents object
))
223 ((type= type
(specifier-type 'null
))
224 (if (= (length object
) 0)
226 (sequence-type-length-mismatch-error type
229 (multiple-value-bind (min exactp
)
230 (sb!kernel
::cons-type-length-info type
)
231 (let ((length (length object
)))
233 (unless (= length min
)
234 (sequence-type-length-mismatch-error type length
))
235 (unless (>= length min
)
236 (sequence-type-length-mismatch-error type length
)))
237 (sb!sequence
:make-sequence-like
238 nil length
:initial-contents object
))))
239 (t (sequence-type-too-hairy (type-specifier type
))))
241 ((csubtypep type
(specifier-type 'vector
))
243 ;; FOO-TO-VECTOR* go through MAKE-SEQUENCE, so length
244 ;; errors are caught there. -- CSR, 2002-10-18
245 (list (list-to-vector* object output-type-spec
))
246 (vector (vector-to-vector* object output-type-spec
))
247 (sequence (sequence-to-vector* object output-type-spec
))
250 ((and (csubtypep type
(specifier-type 'sequence
))
251 (find-class output-type-spec nil
))
252 (let ((prototype (sb!mop
:class-prototype
253 (sb!pcl
:ensure-class-finalized
254 (find-class output-type-spec
)))))
255 (sb!sequence
:make-sequence-like
256 prototype
(length object
) :initial-contents object
)))
257 ((csubtypep type
(specifier-type 'function
))
258 (coerce-to-fun object
))
262 ;;; new version, which seems as though it should be better, but which
263 ;;; does not yet work
265 (defun coerce (object output-type-spec
)
267 "Coerces the Object to an object of type Output-Type-Spec."
268 (flet ((coerce-error ()
269 (error 'simple-type-error
270 :format-control
"~S can't be converted to type ~S."
271 :format-arguments
(list object output-type-spec
)))
272 (check-result (result)
273 #!+high-security
(aver (typep result output-type-spec
))
275 (let ((type (specifier-type output-type-spec
)))
277 ((%%typep object type
)
279 ((eq type
*empty-type
*)
281 ((csubtypep type
(specifier-type 'character
))
283 ((csubtypep type
(specifier-type 'function
))
284 (coerce-to-fun object
))
288 ((csubtypep type
(specifier-type 'single-float
))
289 (%single-float object
))
290 ((csubtypep type
(specifier-type 'double-float
))
291 (%double-float object
))
293 ((csubtypep type
(specifier-type 'long-float
))
294 (%long-float object
))
295 ((csubtypep type
(specifier-type 'float
))
296 (%single-float object
))
297 ((csubtypep type
(specifier-type '(complex single-float
)))
298 (complex (%single-float
(realpart object
))
299 (%single-float
(imagpart object
))))
300 ((csubtypep type
(specifier-type '(complex double-float
)))
301 (complex (%double-float
(realpart object
))
302 (%double-float
(imagpart object
))))
304 ((csubtypep type
(specifier-type '(complex long-float
)))
305 (complex (%long-float
(realpart object
))
306 (%long-float
(imagpart object
))))
307 ((csubtypep type
(specifier-type 'complex
))
311 ;; If RES has the wrong type, that means that rule of
312 ;; canonical representation for complex rationals was
313 ;; invoked. According to the ANSI spec, (COERCE 7/2
314 ;; 'COMPLEX) returns 7/2. Thus, if the object was a
315 ;; rational, there is no error here.
316 (unless (or (typep res output-type-spec
) (rationalp object
))
319 ((csubtypep type
(specifier-type 'list
))
320 (coerce-to-list object
))
321 ((csubtypep type
(specifier-type 'string
))
322 (check-result (coerce-to-simple-string object
)))
323 ((csubtypep type
(specifier-type 'bit-vector
))
324 (check-result (coerce-to-bit-vector object
)))
325 ((csubtypep type
(specifier-type 'vector
))
326 (check-result (coerce-to-vector object output-type-spec
)))