Commit e8616faa authored by wlott's avatar wlott
Browse files

Fixed coerce to use subtypep to analyze the output type spec instead of

checking for magic symbols.
parent 51987841
...@@ -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.17 1994/02/05 11:41:36 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.18 1994/02/10 22:39:13 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -798,85 +798,51 @@ ...@@ -798,85 +798,51 @@
(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."
(let ((output-type-spec (type-expand output-type-spec))) (let ((type (specifier-type output-type-spec)))
(cond (cond
((typep object output-type-spec) ((%typep object output-type-spec)
object) object)
((eq output-type-spec 'character) ((csubtypep type (specifier-type 'character))
(character object)) (character object))
((eq output-type-spec 'function) ((csubtypep type (specifier-type 'function))
(eval `#',object)) (eval `#',object))
((numberp object) ((numberp object)
(cond (cond
((subtypep output-type-spec 'single-float) ((csubtypep type (specifier-type 'single-float))
(%single-float object)) (%single-float object))
((subtypep output-type-spec 'double-float) ((csubtypep type (specifier-type 'double-float))
(%double-float object)) (%double-float object))
((subtypep output-type-spec 'complex) ((csubtypep type (specifier-type 'complex))
(complex object)) (complex object))
(t (t
(error "~S can't be converted to type ~S." object output-type-spec)))) (error "~S can't be converted to type ~S."
(t object output-type-spec))))
((csubtypep type (specifier-type 'list))
(if (vectorp object)
(vector-to-list* object)
(error "~S can't be converted to type ~S."
object output-type-spec)))
((csubtypep type (specifier-type 'string))
(typecase object (typecase object
(list (list (list-to-string* object))
(case (type-specifier-atom output-type-spec) (string (string-to-simple-string* object))
((simple-string string simple-base-string base-string) (vector (vector-to-string* object))
(list-to-string* object)) (t
((simple-bit-vector bit-vector) (list-to-bit-vector* object)) (error "~S can't be converted to type ~S." object output-type-spec))))
((simple-vector vector array simple-array) ((csubtypep type (specifier-type 'bit-vector))
(list-to-vector* object output-type-spec)) (typecase object
(t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (list (list-to-bit-vector* object))
(simple-string (vector (vector-to-bit-vector* object))
(case (type-specifier-atom output-type-spec) (t
(list (vector-to-list* object)) (error "~S can't be converted to type ~S." object output-type-spec))))
;; Can't coerce a string to a bit-vector! ((csubtypep type (specifier-type 'vector))
((simple-vector vector array simple-array) (typecase object
(vector-to-vector* object output-type-spec)) (list (list-to-vector* object output-type-spec))
(t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (vector (vector-to-vector* object output-type-spec))
(simple-bit-vector (t
(case (type-specifier-atom output-type-spec) (error "~S can't be converted to type ~S." object output-type-spec))))
(list (vector-to-list* object)) (t
;; Can't coerce a bit-vector to a string! (error "~S can't be converted to type ~S." object output-type-spec)))))
((simple-vector vector array simple-array)
(vector-to-vector* object output-type-spec))
(t (error "Can't coerce ~S to type ~S." object output-type-spec))))
(simple-vector
(case (type-specifier-atom output-type-spec)
(list (vector-to-list* object))
((simple-string string simple-base-string base-string)
(vector-to-string* object))
((simple-bit-vector bit-vector) (vector-to-bit-vector* object))
((vector array simple-array)
(vector-to-vector* object output-type-spec))
(t (error "Can't coerce ~S to type ~S." object output-type-spec))))
(string
(case (type-specifier-atom output-type-spec)
(list (vector-to-list* object))
((simple-string simple-base-string)
(string-to-simple-string* object))
;; Can't coerce a string to a bit-vector!
((simple-vector vector simple-array array)
(vector-to-vector* object output-type-spec))
(t (error "Can't coerce ~S to type ~S." object output-type-spec))))
(bit-vector
(case (type-specifier-atom output-type-spec)
(list (vector-to-list* object))
;; Can't coerce a bit-vector to a string!
(simple-bit-vector (bit-vector-to-simple-bit-vector* object))
((simple-vector vector array simple-array)
(vector-to-vector* object output-type-spec))
(t (error "Can't coerce ~S to type ~S." object output-type-spec))))
(vector
(case (type-specifier-atom output-type-spec)
(list (vector-to-list* object))
((simple-string string base-string simple-base-string)
(vector-to-string* object))
((simple-bit-vector bit-vector) (vector-to-bit-vector* object))
((simple-vector vector array simple-array)
(vector-to-vector* object output-type-spec))
(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