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
&optional explicit-check
)
15 `(defun ,name
(object type
)
16 (declare (type ,src-type object
))
17 ,@(when explicit-check
`((declare (explicit-check))))
18 (do* ((index 0 (1+ index
))
19 (length (length object
))
22 ((>= index length
) result
)
23 (declare (fixnum length index
))
24 (declare (type vector result
))
25 (setf (,access result index
)
27 (list '(pop in-object
))
28 (vector '(aref in-object index
))
29 (sequence '(elt in-object index
))))))))
31 (def list-to-vector
* (make-sequence type length
) aref list t
)
33 (def vector-to-vector
* (make-sequence type length
) aref vector t
)
35 (def sequence-to-vector
* (make-sequence type length
) aref sequence
))
37 (defun vector-to-list* (object)
38 (declare (type vector object
))
39 (dx-let ((result (list nil
)))
40 (let ((splice result
))
41 (do-vector-data (elt object
(cdr result
))
42 (let ((cell (list elt
)))
43 (setf (cdr splice
) cell splice cell
))))))
45 (defun sequence-to-list (sequence)
46 (declare (type sequence sequence
))
47 (dx-let ((result (list nil
)))
48 (let ((splice result
))
49 (sb!sequence
:dosequence
(elt sequence
(cdr result
))
50 (let ((cell (list elt
)))
51 (setf (cdr splice
) cell splice cell
))))))
53 ;;; These are used both by the full DEFUN function and by various
54 ;;; optimization transforms in the constant-OUTPUT-TYPE-SPEC case.
56 ;;; Most of them are INLINE so that they can be optimized when the
57 ;;; argument type is known. It might be better to do this with
58 ;;; DEFTRANSFORMs, though.
59 (declaim (inline coerce-to-list
))
60 (declaim (inline coerce-to-vector
))
62 (defun coerce-symbol-to-fun (symbol)
63 ;; FIXME? I would think to use SYMBOL-FUNCTION here which does not strip off
64 ;; encapsulations. But Stas wrote FDEFINITION so ...
65 ;; [Also note, we won't encapsulate a macro or special-form, so this
66 ;; introspective technique to decide what kind something is works either way]
67 (let ((def (fdefinition symbol
)))
68 (declare (notinline macro
/special-guard-fun-p
)) ; not performance-critical
69 (if (macro/special-guard-fun-p def
)
70 (error (ecase (car (%fun-name def
))
71 (:macro
"~S names a macro.")
72 (:special
"~S names a special operator."))
76 (defun coerce-to-fun (object)
77 ;; (Unlike the other COERCE-TO-FOOs, this one isn't inline, because
78 ;; it's so big and because optimizing away the outer ETYPECASE
79 ;; doesn't seem to buy us that much anyway.)
83 (coerce-symbol-to-fun object
))
91 (error 'simple-type-error
93 :expected-type
'(or symbol
94 ;; KLUDGE: ANSI wants us to
95 ;; return a TYPE-ERROR here, and
96 ;; a TYPE-ERROR is supposed to
97 ;; describe the expected type,
98 ;; but it's not obvious how to
99 ;; describe the coerceable cons
100 ;; types, so we punt and just say
101 ;; CONS. -- WHN 20000503
103 :format-control
"~S can't be coerced to a function."
104 :format-arguments
(list object
)))))))
106 (defun coerce-to-list (object)
109 (vector-to-list* object
)
110 (sequence-to-list object
)))
112 (defun coerce-to-vector (object output-type-spec
)
114 (list (list-to-vector* object output-type-spec
))
115 (vector (vector-to-vector* object output-type-spec
))))
117 ;;; old working version
118 (defun coerce (object output-type-spec
)
120 "Coerce the Object to an object of type Output-Type-Spec."
121 (declare (explicit-check))
122 (flet ((coerce-error ()
123 (declare (optimize allow-non-returning-tail-call
))
124 (error 'simple-type-error
125 :format-control
"~S can't be converted to type ~
126 ~/sb!impl:print-type-specifier/."
127 :format-arguments
(list object output-type-spec
)
129 :expected-type output-type-spec
)))
130 (let ((type (specifier-type output-type-spec
)))
132 ((%%typep object type
)
134 ((eq type
*empty-type
*)
136 ((type= type
(specifier-type 'character
))
140 ((csubtypep type
(specifier-type 'single-float
))
141 (let ((res (%single-float object
)))
142 (unless (typep res output-type-spec
)
145 ((csubtypep type
(specifier-type 'double-float
))
146 (let ((res (%double-float object
)))
147 (unless (typep res output-type-spec
)
151 ((csubtypep type
(specifier-type 'long-float
))
152 (let ((res (%long-float object
)))
153 (unless (typep res output-type-spec
)
156 ((csubtypep type
(specifier-type 'float
))
157 (let ((res (%single-float object
)))
158 (unless (typep res output-type-spec
)
164 ((csubtypep type
(specifier-type '(complex single-float
)))
165 (complex (%single-float
(realpart object
))
166 (%single-float
(imagpart object
))))
167 ((csubtypep type
(specifier-type '(complex double-float
)))
168 (complex (%double-float
(realpart object
))
169 (%double-float
(imagpart object
))))
171 ((csubtypep type
(specifier-type '(complex long-float
)))
172 (complex (%long-float
(realpart object
))
173 (%long-float
(imagpart object
))))
174 ((csubtypep type
(specifier-type '(complex float
)))
175 (complex (%single-float
(realpart object
))
176 (%single-float
(imagpart object
))))
177 ((and (typep object
'rational
) ; TODO jmoringe unreachable?
178 (csubtypep type
(specifier-type '(complex float
))))
179 ;; Perhaps somewhat surprisingly, ANSI specifies
180 ;; that (COERCE FOO 'FLOAT) is a SINGLE-FLOAT,
181 ;; not dispatching on
182 ;; *READ-DEFAULT-FLOAT-FORMAT*. By analogy, we
183 ;; do the same for complex numbers. -- CSR,
185 (complex (%single-float object
)))
186 ((csubtypep type
(specifier-type 'complex
))
190 ;; If RES has the wrong type, that means that rule of
191 ;; canonical representation for complex rationals was
192 ;; invoked. According to the Hyperspec, (coerce 7/2
193 ;; 'complex) returns 7/2. Thus, if the object was a
194 ;; rational, there is no error here.
195 (unless (or (typep res output-type-spec
)
199 ((csubtypep type
(specifier-type 'list
))
202 ((type= type
(specifier-type 'list
))
203 (vector-to-list* object
))
204 ((type= type
(specifier-type 'null
))
205 (if (= (length object
) 0)
207 (sequence-type-length-mismatch-error type
210 (multiple-value-bind (min exactp
)
211 (sb!kernel
::cons-type-length-info type
)
212 (let ((length (length object
)))
214 (unless (= length min
)
215 (sequence-type-length-mismatch-error type length
))
216 (unless (>= length min
)
217 (sequence-type-length-mismatch-error type length
)))
218 (vector-to-list* object
))))
219 (t (sequence-type-too-hairy (type-specifier type
))))
220 (if (sequencep object
)
222 ((type= type
(specifier-type 'list
))
223 (sb!sequence
:make-sequence-like
224 nil
(length object
) :initial-contents object
))
225 ((type= type
(specifier-type 'null
))
226 (if (= (length object
) 0)
228 (sequence-type-length-mismatch-error type
231 (multiple-value-bind (min exactp
)
232 (sb!kernel
::cons-type-length-info type
)
233 (let ((length (length object
)))
235 (unless (= length min
)
236 (sequence-type-length-mismatch-error type length
))
237 (unless (>= length min
)
238 (sequence-type-length-mismatch-error type length
)))
239 (sb!sequence
:make-sequence-like
240 nil length
:initial-contents object
))))
241 (t (sequence-type-too-hairy (type-specifier type
))))
243 ((csubtypep type
(specifier-type 'vector
))
245 ;; FOO-TO-VECTOR* go through MAKE-SEQUENCE, so length
246 ;; errors are caught there. -- CSR, 2002-10-18
247 (list (list-to-vector* object output-type-spec
))
248 (vector (vector-to-vector* object output-type-spec
))
249 (sequence (sequence-to-vector* object output-type-spec
))
252 ((and (csubtypep type
(specifier-type 'sequence
))
253 (find-class output-type-spec nil
))
254 (let ((prototype (sb!mop
:class-prototype
255 (sb!pcl
:ensure-class-finalized
256 (find-class output-type-spec
)))))
257 (sb!sequence
:make-sequence-like
258 prototype
(length object
) :initial-contents object
)))
259 ((csubtypep type
(specifier-type 'function
))
260 (coerce-to-fun object
))