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 (if (macro/special-guard-fun-p def
)
69 (error (ecase (car (%fun-name def
))
70 (:macro
"~S names a macro.")
71 (:special
"~S names a special operator."))
75 (defun coerce-to-fun (object)
76 ;; (Unlike the other COERCE-TO-FOOs, this one isn't inline, because
77 ;; it's so big and because optimizing away the outer ETYPECASE
78 ;; doesn't seem to buy us that much anyway.)
82 (coerce-symbol-to-fun object
))
90 (error 'simple-type-error
92 :expected-type
'(or symbol
93 ;; KLUDGE: ANSI wants us to
94 ;; return a TYPE-ERROR here, and
95 ;; a TYPE-ERROR is supposed to
96 ;; describe the expected type,
97 ;; but it's not obvious how to
98 ;; describe the coerceable cons
99 ;; types, so we punt and just say
100 ;; CONS. -- WHN 20000503
102 :format-control
"~S can't be coerced to a function."
103 :format-arguments
(list object
)))))))
105 (defun coerce-to-list (object)
108 (vector-to-list* object
)
109 (sequence-to-list object
)))
111 (defun coerce-to-vector (object output-type-spec
)
113 (list (list-to-vector* object output-type-spec
))
114 (vector (vector-to-vector* object output-type-spec
))))
116 ;;; old working version
117 (defun coerce (object output-type-spec
)
118 "Coerce the Object to an object of type Output-Type-Spec."
119 (declare (explicit-check))
120 (flet ((coerce-error ()
121 (declare (optimize allow-non-returning-tail-call
))
122 (error 'simple-type-error
123 :format-control
"~S can't be converted to type ~
124 ~/sb!impl:print-type-specifier/."
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
))