dc97323ab36962f26599e52283462f9327690ab7
[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-simple-vector (x)
132   (if (simple-vector-p x)
133       x
134       (replace (make-array (length x)) x)))
135 (defun coerce-to-vector (object output-type-spec)
136   (etypecase object
137     (list (list-to-vector* object output-type-spec))
138     (vector (vector-to-vector* object output-type-spec))))
139
140 ;;; old working version
141 (defun coerce (object output-type-spec)
142   #!+sb-doc
143   "Coerce the Object to an object of type Output-Type-Spec."
144   (flet ((coerce-error ()
145            (/show0 "entering COERCE-ERROR")
146            (error 'simple-type-error
147                   :format-control "~S can't be converted to type ~S."
148                   :format-arguments (list object output-type-spec)))
149          (check-result (result)
150            #!+high-security (aver (typep result output-type-spec))
151            result))
152     (let ((type (specifier-type output-type-spec)))
153       (cond
154         ((%typep object output-type-spec)
155          object)
156         ((eq type *empty-type*)
157          (coerce-error))
158         ((csubtypep type (specifier-type 'character))
159          (character object))
160         ((csubtypep type (specifier-type 'function))
161          #!+high-security
162          (when (and (or (symbolp object)
163                         (and (listp object)
164                              (= (length object) 2)
165                              (eq (car object) 'setf)))
166                     (not (fboundp object)))
167            (error 'simple-type-error
168                   :datum object
169                   :expected-type '(satisfies fboundp)
170                :format-control "~S isn't fbound."
171                :format-arguments (list object)))
172          #!+high-security
173          (when (and (symbolp object)
174                     (sb!xc:macro-function object))
175            (error 'simple-type-error
176                   :datum object
177                   :expected-type '(not (satisfies sb!xc:macro-function))
178                   :format-control "~S is a macro."
179                   :format-arguments (list object)))
180          #!+high-security
181          (when (and (symbolp object)
182                     (special-operator-p object))
183            (error 'simple-type-error
184                   :datum object
185                   :expected-type '(not (satisfies special-operator-p))
186                   :format-control "~S is a special operator."
187                   :format-arguments (list object)))
188          (eval `#',object))
189         ((numberp object)
190          (let ((res
191                 (cond
192                   ((csubtypep type (specifier-type 'single-float))
193                    (%single-float object))
194                   ((csubtypep type (specifier-type 'double-float))
195                    (%double-float object))
196                   #!+long-float
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))))
207                   #!+long-float
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))
212                    (complex object))
213                   (t
214                    (coerce-error)))))
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))
220              (coerce-error))
221            res))
222         ((csubtypep type (specifier-type 'list))
223          (if (vectorp object)
224              (vector-to-list* object)
225              (coerce-error)))
226         ((csubtypep type (specifier-type 'string))
227          (check-result
228           (typecase object
229             (list (list-to-simple-string* object))
230             (string (string-to-simple-string* object))
231             (vector (vector-to-simple-string* object))
232             (t
233              (coerce-error)))))
234         ((csubtypep type (specifier-type 'bit-vector))
235          (check-result
236           (typecase object
237             (list (list-to-bit-vector* object))
238             (vector (vector-to-bit-vector* object))
239             (t
240              (coerce-error)))))
241         ((csubtypep type (specifier-type 'vector))
242          (check-result
243           (typecase object
244             (list (list-to-vector* object output-type-spec))
245             (vector (vector-to-vector* object output-type-spec))
246             (t
247              (coerce-error)))))
248         (t
249          (coerce-error))))))
250
251 ;;; new version, which seems as though it should be better, but which
252 ;;; does not yet work
253 #+nil
254 (defun coerce (object output-type-spec)
255   #!+sb-doc
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)
262            #!+high-security (aver (typep result output-type-spec))
263            result))
264     (let ((type (specifier-type output-type-spec)))
265       (cond
266         ((%typep object output-type-spec)
267          object)
268         ((eq type *empty-type*)
269          (coerce-error))
270         ((csubtypep type (specifier-type 'character))
271          (character object))
272         ((csubtypep type (specifier-type 'function))
273          (coerce-to-function object))
274         ((numberp object)
275          (let ((res
276                 (cond
277                   ((csubtypep type (specifier-type 'single-float))
278                    (%single-float object))
279                   ((csubtypep type (specifier-type 'double-float))
280                    (%double-float object))
281                   #!+long-float
282                   ((csubtypep type (specifier-type 'long-float))
283                    (%long-float object))
284                   ((csubtypep type (specifier-type 'float))
285                    (%single-float object))
286                   ((csubtypep type (specifier-type '(complex single-float)))
287                    (complex (%single-float (realpart object))
288                             (%single-float (imagpart object))))
289                   ((csubtypep type (specifier-type '(complex double-float)))
290                    (complex (%double-float (realpart object))
291                             (%double-float (imagpart object))))
292                   #!+long-float
293                   ((csubtypep type (specifier-type '(complex long-float)))
294                    (complex (%long-float (realpart object))
295                             (%long-float (imagpart object))))
296                   ((csubtypep type (specifier-type 'complex))
297                    (complex object))
298                   (t
299                    (coerce-error)))))
300            ;; If RES has the wrong type, that means that rule of
301            ;; canonical representation for complex rationals was
302            ;; invoked. According to the ANSI spec, (COERCE 7/2
303            ;; 'COMPLEX) returns 7/2. Thus, if the object was a
304            ;; rational, there is no error here.
305            (unless (or (typep res output-type-spec) (rationalp object))
306              (coerce-error))
307            res))
308         ((csubtypep type (specifier-type 'list))
309          (coerce-to-list object))
310         ((csubtypep type (specifier-type 'string))
311          (check-result (coerce-to-simple-string object)))
312         ((csubtypep type (specifier-type 'bit-vector))
313          (check-result (coerce-to-bit-vector object)))
314         ((csubtypep type (specifier-type 'vector))
315          (check-result (coerce-to-vector object output-type-spec)))
316         (t
317          (coerce-error))))))