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")
17 (macrolet ((def-frob (name result access src-type &optional typep)
18 `(defun ,name (object ,@(if typep '(type) ()))
19 (do* ((index 0 (1+ index))
20 (length (length (the ,(ecase src-type
26 ((= index length) result)
27 (declare (fixnum length index))
28 (setf (,access result index)
30 (:list '(pop in-object))
31 (:vector '(aref in-object index))))))))
33 (def-frob list-to-simple-string* (make-string length) schar :list)
35 (def-frob list-to-bit-vector* (make-array length :element-type '(mod 2))
38 (def-frob list-to-vector* (make-sequence-of-type type length)
41 (def-frob vector-to-vector* (make-sequence-of-type type length)
44 (def-frob vector-to-simple-string* (make-string length) schar :vector)
46 (def-frob vector-to-bit-vector* (make-array length :element-type '(mod 2))
49 (defun vector-to-list* (object)
50 (let ((result (list nil))
51 (length (length object)))
52 (declare (fixnum length))
53 (do ((index 0 (1+ index))
54 (splice result (cdr splice)))
55 ((= index length) (cdr result))
56 (declare (fixnum index))
57 (rplacd splice (list (aref object index))))))
59 (defun string-to-simple-string* (object)
60 (if (simple-string-p object)
62 (with-array-data ((data object)
64 (end (length object)))
65 (declare (simple-string data))
66 (subseq data start end))))
68 (defun bit-vector-to-simple-bit-vector* (object)
69 (if (simple-bit-vector-p object)
71 (with-array-data ((data object)
73 (end (length object)))
74 (declare (simple-bit-vector data))
75 (subseq data start end))))
77 (defvar *offending-datum*); FIXME: Remove after debugging COERCE.
79 ;;; These are used both by the full DEFUN function and by various
80 ;;; optimization transforms in the constant-OUTPUT-TYPE-SPEC case.
82 ;;; Most of them are INLINE so that they can be optimized when the
83 ;;; argument type is known. It might be better to do this with
84 ;;; DEFTRANSFORMs, though.
85 (declaim (inline coerce-to-list))
86 (declaim (inline coerce-to-simple-string coerce-to-bit-vector coerce-to-vector))
87 (defun coerce-to-function (object)
88 ;; (Unlike the other COERCE-TO-FOOs, this one isn't inline, because
89 ;; it's so big and because optimizing away the outer ETYPECASE
90 ;; doesn't seem to buy us that much anyway.)
93 ;; ANSI lets us return ordinary errors (non-TYPE-ERRORs) here.
94 (cond ((macro-function object)
95 (error "~S names a macro." object))
96 ((special-operator-p object)
97 (error "~S is a special operator." object))
98 (t (fdefinition object))))
102 (fdefinition object))
103 ((lambda instance-lambda)
104 ;; FIXME: If we go to a compiler-only implementation, this can
105 ;; become COMPILE instead of EVAL, which seems nicer to me.
106 (eval `(function ,object)))
108 (error 'simple-type-error
110 :expected-type '(or symbol
111 ;; KLUDGE: ANSI wants us to
112 ;; return a TYPE-ERROR here, and
113 ;; a TYPE-ERROR is supposed to
114 ;; describe the expected type,
115 ;; but it's not obvious how to
116 ;; describe the coerceable cons
117 ;; types, so we punt and just say
118 ;; CONS. -- WHN 20000503
120 :format-control "~S can't be coerced to a function."
121 :format-arguments (list object)))))))
122 (defun coerce-to-list (object)
124 (vector (vector-to-list* object))))
125 (defun coerce-to-simple-string (object)
127 (list (list-to-simple-string* object))
128 (string (string-to-simple-string* object))
129 (vector (vector-to-simple-string* object))))
130 (defun coerce-to-bit-vector (object)
132 (list (list-to-bit-vector* object))
133 (vector (vector-to-bit-vector* object))))
134 (defun coerce-to-vector (object output-type-spec)
136 (list (list-to-vector* object output-type-spec))
137 (vector (vector-to-vector* object output-type-spec))))
139 ;;; old working version
140 (defun coerce (object output-type-spec)
142 "Coerces the Object to an object of type Output-Type-Spec."
143 (flet ((coerce-error ()
144 (/show0 "entering COERCE-ERROR")
145 (error 'simple-type-error
146 :format-control "~S can't be converted to type ~S."
147 :format-arguments (list object output-type-spec)))
148 (check-result (result)
150 (check-type-var result output-type-spec)
152 (let ((type (specifier-type output-type-spec)))
154 ((%typep object output-type-spec)
156 ((eq type *empty-type*)
158 ((csubtypep type (specifier-type 'character))
160 ((csubtypep type (specifier-type 'function))
162 (when (and (or (symbolp object)
164 (= (length object) 2)
165 (eq (car object) 'setf)))
166 (not (fboundp object)))
167 (error 'simple-type-error
169 :expected-type '(satisfies fboundp)
170 :format-control "~S isn't fbound."
171 :format-arguments (list object)))
173 (when (and (symbolp object)
174 (sb!xc:macro-function object))
175 (error 'simple-type-error
177 :expected-type '(not (satisfies sb!xc:macro-function))
178 :format-control "~S is a macro."
179 :format-arguments (list object)))
181 (when (and (symbolp object)
182 (special-operator-p object))
183 (error 'simple-type-error
185 :expected-type '(not (satisfies special-operator-p))
186 :format-control "~S is a special operator."
187 :format-arguments (list object)))
192 ((csubtypep type (specifier-type 'single-float))
193 (%single-float object))
194 ((csubtypep type (specifier-type 'double-float))
195 (%double-float object))
197 ((csubtypep type (specifier-type 'long-float))
198 (%long-float object))
199 ((csubtypep type (specifier-type 'float))
200 (%single-float object))
201 ((csubtypep type (specifier-type '(complex single-float)))
202 (complex (%single-float (realpart object))
203 (%single-float (imagpart object))))
204 ((csubtypep type (specifier-type '(complex double-float)))
205 (complex (%double-float (realpart object))
206 (%double-float (imagpart object))))
208 ((csubtypep type (specifier-type '(complex long-float)))
209 (complex (%long-float (realpart object))
210 (%long-float (imagpart object))))
211 ((csubtypep type (specifier-type 'complex))
215 ;; If RES has the wrong type, that means that rule of canonical
216 ;; representation for complex rationals was invoked. According to
217 ;; the Hyperspec, (coerce 7/2 'complex) returns 7/2. Thus, if the
218 ;; object was a rational, there is no error here.
219 (unless (or (typep res output-type-spec) (rationalp object))
222 ((csubtypep type (specifier-type 'list))
224 (vector-to-list* object)
226 ((csubtypep type (specifier-type 'string))
229 (list (list-to-simple-string* object))
230 (string (string-to-simple-string* object))
231 (vector (vector-to-simple-string* object))
234 ((csubtypep type (specifier-type 'bit-vector))
237 (list (list-to-bit-vector* object))
238 (vector (vector-to-bit-vector* object))
241 ((csubtypep type (specifier-type 'vector))
244 (list (list-to-vector* object output-type-spec))
245 (vector (vector-to-vector* object output-type-spec))
251 ;;; new version, which seems as though it should be better, but which
252 ;;; does not yet work
254 (defun coerce (object output-type-spec)
256 "Coerces the Object to an object of type Output-Type-Spec."
257 (flet ((coerce-error ()
258 (error 'simple-type-error
259 :format-control "~S can't be converted to type ~S."
260 :format-arguments (list object output-type-spec)))
261 (check-result (result)
263 (check-type-var result output-type-spec)
265 (let ((type (specifier-type output-type-spec)))
267 ((%typep object output-type-spec)
269 ((eq type *empty-type*)
271 ((csubtypep type (specifier-type 'character))
273 ((csubtypep type (specifier-type 'function))
274 (coerce-to-function object))
278 ((csubtypep type (specifier-type 'single-float))
279 (%single-float object))
280 ((csubtypep type (specifier-type 'double-float))
281 (%double-float object))
283 ((csubtypep type (specifier-type 'long-float))
284 (%long-float object))
285 ((csubtypep type (specifier-type 'float))
286 (%single-float object))
287 ((csubtypep type (specifier-type '(complex single-float)))
288 (complex (%single-float (realpart object))
289 (%single-float (imagpart object))))
290 ((csubtypep type (specifier-type '(complex double-float)))
291 (complex (%double-float (realpart object))
292 (%double-float (imagpart object))))
294 ((csubtypep type (specifier-type '(complex long-float)))
295 (complex (%long-float (realpart object))
296 (%long-float (imagpart object))))
297 ((csubtypep type (specifier-type 'complex))
301 ;; If RES has the wrong type, that means that rule of
302 ;; canonical representation for complex rationals was
303 ;; invoked. According to the ANSI spec, (COERCE 7/2
304 ;; 'COMPLEX) returns 7/2. Thus, if the object was a
305 ;; rational, there is no error here.
306 (unless (or (typep res output-type-spec) (rationalp object))
309 ((csubtypep type (specifier-type 'list))
310 (coerce-to-list object))
311 ((csubtypep type (specifier-type 'string))
312 (check-result (coerce-to-simple-string object)))
313 ((csubtypep type (specifier-type 'bit-vector))
314 (check-result (coerce-to-bit-vector object)))
315 ((csubtypep type (specifier-type 'vector))
316 (check-result (coerce-to-vector object output-type-spec)))