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-frob (name result access src-type &optional typep)
15 `(defun ,name (object ,@(if typep '(type) ()))
16 (do* ((index 0 (1+ index))
17 (length (length (the ,(ecase src-type
23 ((= index length) result)
24 (declare (fixnum length index))
25 (setf (,access result index)
27 (:list '(pop in-object))
28 (:vector '(aref in-object index))))))))
30 (def-frob list-to-simple-string* (make-string length) schar :list)
32 (def-frob list-to-bit-vector* (make-array length :element-type '(mod 2))
35 (def-frob list-to-vector* (make-sequence-of-type type length)
38 (def-frob vector-to-vector* (make-sequence-of-type type length)
41 (def-frob vector-to-simple-string* (make-string length) schar :vector)
43 (def-frob vector-to-bit-vector* (make-array length :element-type '(mod 2))
46 (defun vector-to-list* (object)
47 (let ((result (list nil))
48 (length (length object)))
49 (declare (fixnum length))
50 (do ((index 0 (1+ index))
51 (splice result (cdr splice)))
52 ((= index length) (cdr result))
53 (declare (fixnum index))
54 (rplacd splice (list (aref object index))))))
56 (defun string-to-simple-string* (object)
57 (if (simple-string-p object)
59 (with-array-data ((data object)
61 (end (length object)))
62 (declare (simple-string data))
63 (subseq data start end))))
65 (defun bit-vector-to-simple-bit-vector* (object)
66 (if (simple-bit-vector-p object)
68 (with-array-data ((data object)
70 (end (length object)))
71 (declare (simple-bit-vector data))
72 (subseq data start end))))
74 (defvar *offending-datum*); FIXME: Remove after debugging COERCE.
76 ;;; These are used both by the full DEFUN function and by various
77 ;;; optimization transforms in the constant-OUTPUT-TYPE-SPEC case.
79 ;;; Most of them are INLINE so that they can be optimized when the
80 ;;; argument type is known. It might be better to do this with
81 ;;; DEFTRANSFORMs, though.
82 (declaim (inline coerce-to-list))
83 (declaim (inline coerce-to-simple-string coerce-to-bit-vector coerce-to-vector))
84 (defun coerce-to-function (object)
85 ;; (Unlike the other COERCE-TO-FOOs, this one isn't inline, because
86 ;; it's so big and because optimizing away the outer ETYPECASE
87 ;; doesn't seem to buy us that much anyway.)
90 ;; ANSI lets us return ordinary errors (non-TYPE-ERRORs) here.
91 (cond ((macro-function object)
92 (error "~S names a macro." object))
93 ((special-operator-p object)
94 (error "~S is a special operator." object))
95 (t (fdefinition object))))
100 ((lambda instance-lambda)
101 ;; FIXME: If we go to a compiler-only implementation, this can
102 ;; become COMPILE instead of EVAL, which seems nicer to me.
103 (eval `(function ,object)))
105 (error 'simple-type-error
107 :expected-type '(or symbol
108 ;; KLUDGE: ANSI wants us to
109 ;; return a TYPE-ERROR here, and
110 ;; a TYPE-ERROR is supposed to
111 ;; describe the expected type,
112 ;; but it's not obvious how to
113 ;; describe the coerceable cons
114 ;; types, so we punt and just say
115 ;; CONS. -- WHN 20000503
117 :format-control "~S can't be coerced to a function."
118 :format-arguments (list object)))))))
119 (defun coerce-to-list (object)
121 (vector (vector-to-list* object))))
122 (defun coerce-to-simple-string (object)
124 (list (list-to-simple-string* object))
125 (string (string-to-simple-string* object))
126 (vector (vector-to-simple-string* object))))
127 (defun coerce-to-bit-vector (object)
129 (list (list-to-bit-vector* object))
130 (vector (vector-to-bit-vector* object))))
131 (defun coerce-to-vector (object output-type-spec)
133 (list (list-to-vector* object output-type-spec))
134 (vector (vector-to-vector* object output-type-spec))))
136 ;;; old working version
137 (defun coerce (object output-type-spec)
139 "Coerce the Object to an object of type Output-Type-Spec."
140 (flet ((coerce-error ()
141 (/show0 "entering COERCE-ERROR")
142 (error 'simple-type-error
143 :format-control "~S can't be converted to type ~S."
144 :format-arguments (list object output-type-spec)))
145 (check-result (result)
146 #!+high-security (aver (typep result output-type-spec))
148 (let ((type (specifier-type output-type-spec)))
150 ((%typep object output-type-spec)
152 ((eq type *empty-type*)
154 ((csubtypep type (specifier-type 'character))
156 ((csubtypep type (specifier-type 'function))
158 (when (and (or (symbolp object)
160 (= (length object) 2)
161 (eq (car object) 'setf)))
162 (not (fboundp object)))
163 (error 'simple-type-error
165 :expected-type '(satisfies fboundp)
166 :format-control "~S isn't fbound."
167 :format-arguments (list object)))
169 (when (and (symbolp object)
170 (sb!xc:macro-function object))
171 (error 'simple-type-error
173 :expected-type '(not (satisfies sb!xc:macro-function))
174 :format-control "~S is a macro."
175 :format-arguments (list object)))
177 (when (and (symbolp object)
178 (special-operator-p object))
179 (error 'simple-type-error
181 :expected-type '(not (satisfies special-operator-p))
182 :format-control "~S is a special operator."
183 :format-arguments (list object)))
188 ((csubtypep type (specifier-type 'single-float))
189 (%single-float object))
190 ((csubtypep type (specifier-type 'double-float))
191 (%double-float object))
193 ((csubtypep type (specifier-type 'long-float))
194 (%long-float object))
195 ((csubtypep type (specifier-type 'float))
196 (%single-float object))
197 ((csubtypep type (specifier-type '(complex single-float)))
198 (complex (%single-float (realpart object))
199 (%single-float (imagpart object))))
200 ((csubtypep type (specifier-type '(complex double-float)))
201 (complex (%double-float (realpart object))
202 (%double-float (imagpart object))))
204 ((csubtypep type (specifier-type '(complex long-float)))
205 (complex (%long-float (realpart object))
206 (%long-float (imagpart object))))
207 ((csubtypep type (specifier-type 'complex))
211 ;; If RES has the wrong type, that means that rule of canonical
212 ;; representation for complex rationals was invoked. According to
213 ;; the Hyperspec, (coerce 7/2 'complex) returns 7/2. Thus, if the
214 ;; object was a rational, there is no error here.
215 (unless (or (typep res output-type-spec) (rationalp object))
218 ((csubtypep type (specifier-type 'list))
220 (vector-to-list* object)
222 ((csubtypep type (specifier-type 'string))
225 (list (list-to-simple-string* object))
226 (string (string-to-simple-string* object))
227 (vector (vector-to-simple-string* object))
230 ((csubtypep type (specifier-type 'bit-vector))
233 (list (list-to-bit-vector* object))
234 (vector (vector-to-bit-vector* object))
237 ((csubtypep type (specifier-type 'vector))
240 (list (list-to-vector* object output-type-spec))
241 (vector (vector-to-vector* object output-type-spec))
247 ;;; new version, which seems as though it should be better, but which
248 ;;; does not yet work
250 (defun coerce (object output-type-spec)
252 "Coerces the Object to an object of type Output-Type-Spec."
253 (flet ((coerce-error ()
254 (error 'simple-type-error
255 :format-control "~S can't be converted to type ~S."
256 :format-arguments (list object output-type-spec)))
257 (check-result (result)
258 #!+high-security (aver (typep result output-type-spec))
260 (let ((type (specifier-type output-type-spec)))
262 ((%typep object output-type-spec)
264 ((eq type *empty-type*)
266 ((csubtypep type (specifier-type 'character))
268 ((csubtypep type (specifier-type 'function))
269 (coerce-to-function object))
273 ((csubtypep type (specifier-type 'single-float))
274 (%single-float object))
275 ((csubtypep type (specifier-type 'double-float))
276 (%double-float object))
278 ((csubtypep type (specifier-type 'long-float))
279 (%long-float object))
280 ((csubtypep type (specifier-type 'float))
281 (%single-float object))
282 ((csubtypep type (specifier-type '(complex single-float)))
283 (complex (%single-float (realpart object))
284 (%single-float (imagpart object))))
285 ((csubtypep type (specifier-type '(complex double-float)))
286 (complex (%double-float (realpart object))
287 (%double-float (imagpart object))))
289 ((csubtypep type (specifier-type '(complex long-float)))
290 (complex (%long-float (realpart object))
291 (%long-float (imagpart object))))
292 ((csubtypep type (specifier-type 'complex))
296 ;; If RES has the wrong type, that means that rule of
297 ;; canonical representation for complex rationals was
298 ;; invoked. According to the ANSI spec, (COERCE 7/2
299 ;; 'COMPLEX) returns 7/2. Thus, if the object was a
300 ;; rational, there is no error here.
301 (unless (or (typep res output-type-spec) (rationalp object))
304 ((csubtypep type (specifier-type 'list))
305 (coerce-to-list object))
306 ((csubtypep type (specifier-type 'string))
307 (check-result (coerce-to-simple-string object)))
308 ((csubtypep type (specifier-type 'bit-vector))
309 (check-result (coerce-to-bit-vector object)))
310 ((csubtypep type (specifier-type 'vector))
311 (check-result (coerce-to-vector object output-type-spec)))