From e8616faa3d4855bf42e0f64660492bd6a207bb0d Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Thu, 10 Feb 1994 22:39:13 +0000 Subject: [PATCH] Fixed coerce to use subtypep to analyze the output type spec instead of checking for magic symbols. --- code/seq.lisp | 104 +++++++++++++++++--------------------------------- 1 file changed, 35 insertions(+), 69 deletions(-) diff --git a/code/seq.lisp b/code/seq.lisp index 357f8fc65..51521f82f 100644 --- a/code/seq.lisp +++ b/code/seq.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (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 @@ (defun coerce (object 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 - ((typep object output-type-spec) + ((%typep object output-type-spec) object) - ((eq output-type-spec 'character) + ((csubtypep type (specifier-type 'character)) (character object)) - ((eq output-type-spec 'function) + ((csubtypep type (specifier-type 'function)) (eval `#',object)) ((numberp object) (cond - ((subtypep output-type-spec 'single-float) + ((csubtypep type (specifier-type 'single-float)) (%single-float object)) - ((subtypep output-type-spec 'double-float) + ((csubtypep type (specifier-type 'double-float)) (%double-float object)) - ((subtypep output-type-spec 'complex) + ((csubtypep type (specifier-type 'complex)) (complex object)) (t - (error "~S can't be converted to type ~S." object output-type-spec)))) - (t + (error "~S can't be converted to type ~S." + 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 - (list - (case (type-specifier-atom output-type-spec) - ((simple-string string simple-base-string base-string) - (list-to-string* object)) - ((simple-bit-vector bit-vector) (list-to-bit-vector* object)) - ((simple-vector vector array simple-array) - (list-to-vector* object output-type-spec)) - (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) - (simple-string - (case (type-specifier-atom output-type-spec) - (list (vector-to-list* object)) - ;; Can't coerce a string to a bit-vector! - ((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-bit-vector - (case (type-specifier-atom output-type-spec) - (list (vector-to-list* object)) - ;; Can't coerce a bit-vector to a string! - ((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))))))) + (list (list-to-string* object)) + (string (string-to-simple-string* object)) + (vector (vector-to-string* object)) + (t + (error "~S can't be converted to type ~S." object output-type-spec)))) + ((csubtypep type (specifier-type 'bit-vector)) + (typecase object + (list (list-to-bit-vector* object)) + (vector (vector-to-bit-vector* object)) + (t + (error "~S can't be converted to type ~S." object output-type-spec)))) + ((csubtypep type (specifier-type 'vector)) + (typecase object + (list (list-to-vector* object output-type-spec)) + (vector (vector-to-vector* object output-type-spec)) + (t + (error "~S can't be converted to type ~S." object output-type-spec)))) + (t + (error "~S can't be converted to type ~S." object output-type-spec))))) ;;; Internal Frobs: -- GitLab