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