0.6.11.37:
[sbcl.git] / src / code / coerce.lisp
1 ;;;; COERCE and related code
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!IMPL")
13
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
18                                               (:list 'list)
19                                               (:vector 'vector))
20                                            object)))
21                       (result ,result)
22                       (in-object object))
23                      ((= index length) result)
24                   (declare (fixnum length index))
25                   (setf (,access result index)
26                         ,(ecase src-type
27                            (:list '(pop in-object))
28                            (:vector '(aref in-object index))))))))
29
30   (def-frob list-to-simple-string* (make-string length) schar :list)
31
32   (def-frob list-to-bit-vector* (make-array length :element-type '(mod 2))
33     sbit :list)
34
35   (def-frob list-to-vector* (make-sequence-of-type type length)
36     aref :list t)
37
38   (def-frob vector-to-vector* (make-sequence-of-type type length)
39     aref :vector t)
40
41   (def-frob vector-to-simple-string* (make-string length) schar :vector)
42
43   (def-frob vector-to-bit-vector* (make-array length :element-type '(mod 2))
44     sbit :vector))
45
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))))))
55
56 (defun string-to-simple-string* (object)
57   (if (simple-string-p object)
58       object
59       (with-array-data ((data object)
60                         (start)
61                         (end (length object)))
62         (declare (simple-string data))
63         (subseq data start end))))
64
65 (defun bit-vector-to-simple-bit-vector* (object)
66   (if (simple-bit-vector-p object)
67       object
68       (with-array-data ((data object)
69                         (start)
70                         (end (length object)))
71         (declare (simple-bit-vector data))
72         (subseq data start end))))
73
74 (defvar *offending-datum*); FIXME: Remove after debugging COERCE.
75
76 ;;; These are used both by the full DEFUN function and by various
77 ;;; optimization transforms in the constant-OUTPUT-TYPE-SPEC case.
78 ;;;
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.)
88   (etypecase object
89     (symbol
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))))
96     (list
97      (case (first object)
98        ((setf)
99         (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)))
104        (t
105         (error 'simple-type-error
106                :datum object
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
116                                    cons)
117                :format-control "~S can't be coerced to a function."
118                :format-arguments (list object)))))))
119 (defun coerce-to-list (object)
120   (etypecase object
121     (vector (vector-to-list* object))))
122 (defun coerce-to-simple-string (object)
123   (etypecase 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)
128   (etypecase object
129     (list (list-to-bit-vector* object))
130     (vector (vector-to-bit-vector* object))))
131 (defun coerce-to-vector (object output-type-spec)
132   (etypecase object
133     (list (list-to-vector* object output-type-spec))
134     (vector (vector-to-vector* object output-type-spec))))
135
136 ;;; old working version
137 (defun coerce (object output-type-spec)
138   #!+sb-doc
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))
147            result))
148     (let ((type (specifier-type output-type-spec)))
149       (cond
150         ((%typep object output-type-spec)
151          object)
152         ((eq type *empty-type*)
153          (coerce-error))
154         ((csubtypep type (specifier-type 'character))
155          (character object))
156         ((csubtypep type (specifier-type 'function))
157          #!+high-security
158          (when (and (or (symbolp object)
159                         (and (listp object)
160                              (= (length object) 2)
161                              (eq (car object) 'setf)))
162                     (not (fboundp object)))
163            (error 'simple-type-error
164                   :datum object
165                   :expected-type '(satisfies fboundp)
166                :format-control "~S isn't fbound."
167                :format-arguments (list object)))
168          #!+high-security
169          (when (and (symbolp object)
170                     (sb!xc:macro-function object))
171            (error 'simple-type-error
172                   :datum object
173                   :expected-type '(not (satisfies sb!xc:macro-function))
174                   :format-control "~S is a macro."
175                   :format-arguments (list object)))
176          #!+high-security
177          (when (and (symbolp object)
178                     (special-operator-p object))
179            (error 'simple-type-error
180                   :datum object
181                   :expected-type '(not (satisfies special-operator-p))
182                   :format-control "~S is a special operator."
183                   :format-arguments (list object)))
184          (eval `#',object))
185         ((numberp object)
186          (let ((res
187                 (cond
188                   ((csubtypep type (specifier-type 'single-float))
189                    (%single-float object))
190                   ((csubtypep type (specifier-type 'double-float))
191                    (%double-float object))
192                   #!+long-float
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))))
203                   #!+long-float
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))
208                    (complex object))
209                   (t
210                    (coerce-error)))))
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))
216              (coerce-error))
217            res))
218         ((csubtypep type (specifier-type 'list))
219          (if (vectorp object)
220              (vector-to-list* object)
221              (coerce-error)))
222         ((csubtypep type (specifier-type 'string))
223          (check-result
224           (typecase object
225             (list (list-to-simple-string* object))
226             (string (string-to-simple-string* object))
227             (vector (vector-to-simple-string* object))
228             (t
229              (coerce-error)))))
230         ((csubtypep type (specifier-type 'bit-vector))
231          (check-result
232           (typecase object
233             (list (list-to-bit-vector* object))
234             (vector (vector-to-bit-vector* object))
235             (t
236              (coerce-error)))))
237         ((csubtypep type (specifier-type 'vector))
238          (check-result
239           (typecase object
240             (list (list-to-vector* object output-type-spec))
241             (vector (vector-to-vector* object output-type-spec))
242             (t
243              (coerce-error)))))
244         (t
245          (coerce-error))))))
246
247 ;;; new version, which seems as though it should be better, but which
248 ;;; does not yet work
249 #+nil
250 (defun coerce (object output-type-spec)
251   #!+sb-doc
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))
259            result))
260     (let ((type (specifier-type output-type-spec)))
261       (cond
262         ((%typep object output-type-spec)
263          object)
264         ((eq type *empty-type*)
265          (coerce-error))
266         ((csubtypep type (specifier-type 'character))
267          (character object))
268         ((csubtypep type (specifier-type 'function))
269          (coerce-to-function object))
270         ((numberp object)
271          (let ((res
272                 (cond
273                   ((csubtypep type (specifier-type 'single-float))
274                    (%single-float object))
275                   ((csubtypep type (specifier-type 'double-float))
276                    (%double-float object))
277                   #!+long-float
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))))
288                   #!+long-float
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))
293                    (complex object))
294                   (t
295                    (coerce-error)))))
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))
302              (coerce-error))
303            res))
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)))
312         (t
313          (coerce-error))))))