1.0.21.14: fix CHECK-FASL-HEADER buglet
[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 (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                                               (:sequence 'sequence))
21                                            object)))
22                       (result ,result)
23                       (in-object object))
24                      ((= index length) result)
25                   (declare (fixnum length index))
26                   (setf (,access result index)
27                         ,(ecase src-type
28                            (:list '(pop in-object))
29                            (:vector '(aref in-object index))
30                            (:sequence '(elt in-object index))))))))
31
32   (def list-to-vector* (make-sequence type length)
33     aref :list t)
34
35   (def vector-to-vector* (make-sequence type length)
36     aref :vector t)
37
38   (def sequence-to-vector* (make-sequence type length)
39     aref :sequence t))
40
41 (defun vector-to-list* (object)
42   (let ((result (list nil))
43         (length (length object)))
44     (declare (fixnum length))
45     (do ((index 0 (1+ index))
46          (splice result (cdr splice)))
47         ((= index length) (cdr result))
48       (declare (fixnum index))
49       (rplacd splice (list (aref object index))))))
50
51 (defvar *offending-datum*); FIXME: Remove after debugging COERCE.
52
53 ;;; These are used both by the full DEFUN function and by various
54 ;;; optimization transforms in the constant-OUTPUT-TYPE-SPEC case.
55 ;;;
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))
61 (defun coerce-to-fun (object)
62   ;; (Unlike the other COERCE-TO-FOOs, this one isn't inline, because
63   ;; it's so big and because optimizing away the outer ETYPECASE
64   ;; doesn't seem to buy us that much anyway.)
65   (etypecase object
66     (symbol
67      ;; ANSI lets us return ordinary errors (non-TYPE-ERRORs) here.
68      (cond ((macro-function object)
69             (error "~S names a macro." object))
70            ((special-operator-p object)
71             (error "~S is a special operator." object))
72            (t (fdefinition object))))
73     (list
74      (case (first object)
75        ((setf)
76         (fdefinition object))
77        ((lambda)
78         ;; FIXME: If we go to a compiler-only implementation, this can
79         ;; become COMPILE instead of EVAL, which seems nicer to me.
80         (eval `(function ,object)))
81        ((instance-lambda)
82         (deprecation-warning 'instance-lambda 'lambda)
83         (eval `(function ,object)))
84        (t
85         (error 'simple-type-error
86                :datum object
87                :expected-type '(or symbol
88                                    ;; KLUDGE: ANSI wants us to
89                                    ;; return a TYPE-ERROR here, and
90                                    ;; a TYPE-ERROR is supposed to
91                                    ;; describe the expected type,
92                                    ;; but it's not obvious how to
93                                    ;; describe the coerceable cons
94                                    ;; types, so we punt and just say
95                                    ;; CONS. -- WHN 20000503
96                                    cons)
97                :format-control "~S can't be coerced to a function."
98                :format-arguments (list object)))))))
99
100 (defun coerce-to-list (object)
101   (etypecase object
102     (vector (vector-to-list* object))))
103
104 (defun coerce-to-vector (object output-type-spec)
105   (etypecase object
106     (list (list-to-vector* object output-type-spec))
107     (vector (vector-to-vector* object output-type-spec))))
108
109 ;;; old working version
110 (defun coerce (object output-type-spec)
111   #!+sb-doc
112   "Coerce the Object to an object of type Output-Type-Spec."
113   (flet ((coerce-error ()
114            (/show0 "entering COERCE-ERROR")
115            (error 'simple-type-error
116                   :format-control "~S can't be converted to type ~S."
117                   :format-arguments (list object output-type-spec)
118                   :datum object
119                   :expected-type output-type-spec)))
120     (let ((type (specifier-type output-type-spec)))
121       (cond
122         ((%typep object output-type-spec)
123          object)
124         ((eq type *empty-type*)
125          (coerce-error))
126         ((csubtypep type (specifier-type 'character))
127          (character object))
128         ((numberp object)
129          (cond
130            ((csubtypep type (specifier-type 'single-float))
131             (let ((res (%single-float object)))
132               (unless (typep res output-type-spec)
133                 (coerce-error))
134               res))
135            ((csubtypep type (specifier-type 'double-float))
136             (let ((res (%double-float object)))
137               (unless (typep res output-type-spec)
138                 (coerce-error))
139               res))
140            #!+long-float
141            ((csubtypep type (specifier-type 'long-float))
142             (let ((res (%long-float object)))
143               (unless (typep res output-type-spec)
144                 (coerce-error))
145               res))
146            ((csubtypep type (specifier-type 'float))
147             (let ((res (%single-float object)))
148               (unless (typep res output-type-spec)
149                 (coerce-error))
150               res))
151            (t
152             (let ((res
153                    (cond
154                      ((csubtypep type (specifier-type '(complex single-float)))
155                       (complex (%single-float (realpart object))
156                                (%single-float (imagpart object))))
157                      ((csubtypep type (specifier-type '(complex double-float)))
158                       (complex (%double-float (realpart object))
159                                (%double-float (imagpart object))))
160                      #!+long-float
161                      ((csubtypep type (specifier-type '(complex long-float)))
162                       (complex (%long-float (realpart object))
163                                (%long-float (imagpart object))))
164                      ((csubtypep type (specifier-type '(complex float)))
165                       (complex (%single-float (realpart object))
166                                (%single-float (imagpart object))))
167                      ((and (typep object 'rational)
168                            (csubtypep type (specifier-type '(complex float))))
169                       ;; Perhaps somewhat surprisingly, ANSI specifies
170                       ;; that (COERCE FOO 'FLOAT) is a SINGLE-FLOAT,
171                       ;; not dispatching on
172                       ;; *READ-DEFAULT-FLOAT-FORMAT*.  By analogy, we
173                       ;; do the same for complex numbers. -- CSR,
174                       ;; 2002-08-06
175                       (complex (%single-float object)))
176                      ((csubtypep type (specifier-type 'complex))
177                       (complex object))
178                      (t
179                       (coerce-error)))))
180               ;; If RES has the wrong type, that means that rule of
181               ;; canonical representation for complex rationals was
182               ;; invoked. According to the Hyperspec, (coerce 7/2
183               ;; 'complex) returns 7/2. Thus, if the object was a
184               ;; rational, there is no error here.
185               (unless (or (typep res output-type-spec)
186                           (rationalp object))
187                 (coerce-error))
188               res))))
189         ((csubtypep type (specifier-type 'list))
190          (if (vectorp object)
191              (cond
192                ((type= type (specifier-type 'list))
193                 (vector-to-list* object))
194                ((type= type (specifier-type 'null))
195                 (if (= (length object) 0)
196                     'nil
197                     (sequence-type-length-mismatch-error type
198                                                          (length object))))
199                ((cons-type-p type)
200                 (multiple-value-bind (min exactp)
201                     (sb!kernel::cons-type-length-info type)
202                   (let ((length (length object)))
203                     (if exactp
204                         (unless (= length min)
205                           (sequence-type-length-mismatch-error type length))
206                         (unless (>= length min)
207                           (sequence-type-length-mismatch-error type length)))
208                     (vector-to-list* object))))
209                (t (sequence-type-too-hairy (type-specifier type))))
210              (if (sequencep object)
211                  (cond
212                    ((type= type (specifier-type 'list))
213                     (sb!sequence:make-sequence-like
214                      nil (length object) :initial-contents object))
215                    ((type= type (specifier-type 'null))
216                     (if (= (length object) 0)
217                         'nil
218                         (sequence-type-length-mismatch-error type
219                                                              (length object))))
220                    ((cons-type-p type)
221                     (multiple-value-bind (min exactp)
222                         (sb!kernel::cons-type-length-info type)
223                       (let ((length (length object)))
224                         (if exactp
225                             (unless (= length min)
226                               (sequence-type-length-mismatch-error type length))
227                             (unless (>= length min)
228                               (sequence-type-length-mismatch-error type length)))
229                         (sb!sequence:make-sequence-like
230                          nil length :initial-contents object))))
231                    (t (sequence-type-too-hairy (type-specifier type))))
232                  (coerce-error))))
233         ((csubtypep type (specifier-type 'vector))
234          (typecase object
235            ;; FOO-TO-VECTOR* go through MAKE-SEQUENCE, so length
236            ;; errors are caught there. -- CSR, 2002-10-18
237            (list (list-to-vector* object output-type-spec))
238            (vector (vector-to-vector* object output-type-spec))
239            (sequence (sequence-to-vector* object output-type-spec))
240            (t
241             (coerce-error))))
242         ((and (csubtypep type (specifier-type 'sequence))
243               (find-class output-type-spec nil))
244          (let ((class (find-class output-type-spec)))
245            (sb!sequence:make-sequence-like
246             (sb!mop:class-prototype class)
247             (length object) :initial-contents object)))
248         ((csubtypep type (specifier-type 'function))
249          (when (and (legal-fun-name-p object)
250                     (not (fboundp object)))
251            (error 'simple-type-error
252                   :datum object
253                   ;; FIXME: SATISFIES FBOUNDP is a kinda bizarre broken
254                   ;; type specifier, since the set of values it describes
255                   ;; isn't in general constant in time. Maybe we could
256                   ;; find a better way of expressing this error? (Maybe
257                   ;; with the UNDEFINED-FUNCTION condition?)
258                   :expected-type '(satisfies fboundp)
259                :format-control "~S isn't fbound."
260                :format-arguments (list object)))
261          (when (and (symbolp object)
262                     (sb!xc:macro-function object))
263            (error 'simple-type-error
264                   :datum object
265                   :expected-type '(not (satisfies sb!xc:macro-function))
266                   :format-control "~S is a macro."
267                   :format-arguments (list object)))
268          (when (and (symbolp object)
269                     (special-operator-p object))
270            (error 'simple-type-error
271                   :datum object
272                   :expected-type '(not (satisfies special-operator-p))
273                   :format-control "~S is a special operator."
274                   :format-arguments (list object)))
275          (eval `#',object))
276         (t
277          (coerce-error))))))
278
279 ;;; new version, which seems as though it should be better, but which
280 ;;; does not yet work
281 #+nil
282 (defun coerce (object output-type-spec)
283   #!+sb-doc
284   "Coerces the Object to an object of type Output-Type-Spec."
285   (flet ((coerce-error ()
286            (error 'simple-type-error
287                   :format-control "~S can't be converted to type ~S."
288                   :format-arguments (list object output-type-spec)))
289          (check-result (result)
290            #!+high-security (aver (typep result output-type-spec))
291            result))
292     (let ((type (specifier-type output-type-spec)))
293       (cond
294         ((%typep object output-type-spec)
295          object)
296         ((eq type *empty-type*)
297          (coerce-error))
298         ((csubtypep type (specifier-type 'character))
299          (character object))
300         ((csubtypep type (specifier-type 'function))
301          (coerce-to-fun object))
302         ((numberp object)
303          (let ((res
304                 (cond
305                   ((csubtypep type (specifier-type 'single-float))
306                    (%single-float object))
307                   ((csubtypep type (specifier-type 'double-float))
308                    (%double-float object))
309                   #!+long-float
310                   ((csubtypep type (specifier-type 'long-float))
311                    (%long-float object))
312                   ((csubtypep type (specifier-type 'float))
313                    (%single-float object))
314                   ((csubtypep type (specifier-type '(complex single-float)))
315                    (complex (%single-float (realpart object))
316                             (%single-float (imagpart object))))
317                   ((csubtypep type (specifier-type '(complex double-float)))
318                    (complex (%double-float (realpart object))
319                             (%double-float (imagpart object))))
320                   #!+long-float
321                   ((csubtypep type (specifier-type '(complex long-float)))
322                    (complex (%long-float (realpart object))
323                             (%long-float (imagpart object))))
324                   ((csubtypep type (specifier-type 'complex))
325                    (complex object))
326                   (t
327                    (coerce-error)))))
328            ;; If RES has the wrong type, that means that rule of
329            ;; canonical representation for complex rationals was
330            ;; invoked. According to the ANSI spec, (COERCE 7/2
331            ;; 'COMPLEX) returns 7/2. Thus, if the object was a
332            ;; rational, there is no error here.
333            (unless (or (typep res output-type-spec) (rationalp object))
334              (coerce-error))
335            res))
336         ((csubtypep type (specifier-type 'list))
337          (coerce-to-list object))
338         ((csubtypep type (specifier-type 'string))
339          (check-result (coerce-to-simple-string object)))
340         ((csubtypep type (specifier-type 'bit-vector))
341          (check-result (coerce-to-bit-vector object)))
342         ((csubtypep type (specifier-type 'vector))
343          (check-result (coerce-to-vector object output-type-spec)))
344         (t
345          (coerce-error))))))