Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[2fadba]: src / code / coerce.lisp Maximize Restore History

Download this file

coerce.lisp    324 lines (309 with data), 14.2 kB

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