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