Commit e4297f35 authored by wlott's avatar wlott
Browse files

Fixed coerce to call type-expand so that people can coerce to deftypes.

parent 1b56c58e
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.15 1993/11/02 16:12:54 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.16 1994/02/04 15:25:43 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -798,82 +798,85 @@ ...@@ -798,82 +798,85 @@
(defun coerce (object output-type-spec) (defun coerce (object output-type-spec)
"Coerces the Object to an object of type Output-Type-Spec." "Coerces the Object to an object of type Output-Type-Spec."
(cond (let ((output-type-spec (type-expand output-type-spec)))
((typep object output-type-spec) (cond
object) ((typep object output-type-spec)
((eq output-type-spec 'character) object)
(character object)) ((eq output-type-spec 'character)
((eq output-type-spec 'function) (character object))
(eval `#',object)) ((eq output-type-spec 'function)
((numberp object) (eval `#',object))
(case output-type-spec ((numberp object)
((short-float single-float float) (case output-type-spec
(%single-float object)) ((short-float single-float float)
((double-float long-float) (%single-float object))
(%double-float object)) ((double-float long-float)
(complex (%double-float object))
(complex object)) (complex
(t (complex object))
(error "~S can't be converted to type ~S." object output-type-spec)))) (t
(t (error "~S can't be converted to type ~S." object output-type-spec))))
(typecase object (t
(list (typecase object
(case (type-specifier-atom output-type-spec) (list
((simple-string string simple-base-string base-string) (case (type-specifier-atom output-type-spec)
(list-to-string* object)) ((simple-string string simple-base-string base-string)
((simple-bit-vector bit-vector) (list-to-bit-vector* object)) (list-to-string* object))
((simple-vector vector array simple-array) ((simple-bit-vector bit-vector) (list-to-bit-vector* object))
(list-to-vector* object output-type-spec)) ((simple-vector vector array simple-array)
(t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (list-to-vector* object output-type-spec))
(simple-string (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
(case (type-specifier-atom output-type-spec) (simple-string
(list (vector-to-list* object)) (case (type-specifier-atom output-type-spec)
;; Can't coerce a string to a bit-vector! (list (vector-to-list* object))
((simple-vector vector array simple-array) ;; Can't coerce a string to a bit-vector!
(vector-to-vector* object output-type-spec)) ((simple-vector vector array simple-array)
(t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (vector-to-vector* object output-type-spec))
(simple-bit-vector (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
(case (type-specifier-atom output-type-spec) (simple-bit-vector
(list (vector-to-list* object)) (case (type-specifier-atom output-type-spec)
;; Can't coerce a bit-vector to a string! (list (vector-to-list* object))
((simple-vector vector array simple-array) ;; Can't coerce a bit-vector to a string!
(vector-to-vector* object output-type-spec)) ((simple-vector vector array simple-array)
(t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (vector-to-vector* object output-type-spec))
(simple-vector (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
(case (type-specifier-atom output-type-spec) (simple-vector
(list (vector-to-list* object)) (case (type-specifier-atom output-type-spec)
((simple-string string simple-base-string base-string) (list (vector-to-list* object))
((simple-string string simple-base-string base-string)
(vector-to-string* object)) (vector-to-string* object))
((simple-bit-vector bit-vector) (vector-to-bit-vector* object)) ((simple-bit-vector bit-vector) (vector-to-bit-vector* object))
((vector array simple-array) (vector-to-vector* object output-type-spec)) ((vector array simple-array)
(t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (vector-to-vector* object output-type-spec))
(string (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
(case (type-specifier-atom output-type-spec) (string
(list (vector-to-list* object)) (case (type-specifier-atom output-type-spec)
((simple-string simple-base-string) (list (vector-to-list* object))
(string-to-simple-string* object)) ((simple-string simple-base-string)
;; Can't coerce a string to a bit-vector! (string-to-simple-string* object))
((simple-vector vector simple-array array) ;; Can't coerce a string to a bit-vector!
(vector-to-vector* object output-type-spec)) ((simple-vector vector simple-array array)
(t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (vector-to-vector* object output-type-spec))
(bit-vector (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
(case (type-specifier-atom output-type-spec) (bit-vector
(list (vector-to-list* object)) (case (type-specifier-atom output-type-spec)
;; Can't coerce a bit-vector to a string! (list (vector-to-list* object))
(simple-bit-vector (bit-vector-to-simple-bit-vector* object)) ;; Can't coerce a bit-vector to a string!
((simple-vector vector array simple-array) (simple-bit-vector (bit-vector-to-simple-bit-vector* object))
(vector-to-vector* object output-type-spec)) ((simple-vector vector array simple-array)
(t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (vector-to-vector* object output-type-spec))
(vector (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
(case (type-specifier-atom output-type-spec) (vector
(list (vector-to-list* object)) (case (type-specifier-atom output-type-spec)
((simple-string string base-string simple-base-string) (list (vector-to-list* object))
(vector-to-string* object)) ((simple-string string base-string simple-base-string)
((simple-bit-vector bit-vector) (vector-to-bit-vector* object)) (vector-to-string* object))
((simple-vector vector array simple-array) ((simple-bit-vector bit-vector) (vector-to-bit-vector* object))
(vector-to-vector* object output-type-spec)) ((simple-vector vector array simple-array)
(t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (vector-to-vector* object output-type-spec))
(t (error "~S is an inappropriate type of object for coerce." object)))))) (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
(t
(error "~S is an inappropriate type of object for coerce." object)))))))
;;; Internal Frobs: ;;; Internal Frobs:
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment