From f67bbd42bcfacd8b75c2e69aa9eba1c0dc24f324 Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Sun, 13 Jul 2014 01:50:14 +0400
Subject: [PATCH] COERCE: report the original type in case of errors.

The expanded type isn't really helpful.
---
 src/lsp/predlib.lsp | 90 ++++++++++++++++++++++-----------------------
 1 file changed, 45 insertions(+), 45 deletions(-)

diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp
index 85a4ce02b..dc8358ad4 100644
--- a/src/lsp/predlib.lsp
+++ b/src/lsp/predlib.lsp
@@ -673,9 +673,6 @@ Returns T if X belongs to TYPE; NIL otherwise."
 ;;			COERCE
 ;;************************************************************
 
-(defun error-coerce (object type)
-  (error "Cannot coerce ~S to type ~S." object type))
-
 (defun coerce (object type &aux aux)
   "Args: (x type)
 Coerces X to an object of the specified type, if possible.  Signals an error
@@ -683,48 +680,51 @@ if not possible."
   (when (typep object type)
     ;; Just return as it is.
     (return-from coerce object))
-  (setq type (expand-deftype type))
-  (cond ((atom type)
-	 (case type
-	   ((T) object)
-	   (LIST
-	    (do ((io (make-seq-iterator object) (seq-iterator-next object io))
-	         (l nil (cons (seq-iterator-ref object io) l)))
-	        ((null io) l)))
-	   ((CHARACTER BASE-CHAR) (character object))
-	   (FLOAT (float object))
-	   (SINGLE-FLOAT (float object 0.0F0))
-	   (SHORT-FLOAT (float object 0.0S0))
-	   (DOUBLE-FLOAT (float object 0.0D0))
-	   (LONG-FLOAT (float object 0.0L0))
-	   (COMPLEX (complex (realpart object) (imagpart object)))
-	   (FUNCTION (coerce-to-function object))
-	   ((VECTOR SIMPLE-VECTOR #+unicode SIMPLE-BASE-STRING SIMPLE-STRING #+unicode BASE-STRING STRING BIT-VECTOR SIMPLE-BIT-VECTOR)
-	    (concatenate type object))
-	   (t
-	    (if (or (listp object) (vectorp object))
-		(concatenate type object)
-		(error-coerce object type)))))
-	((eq (setq aux (first type)) 'COMPLEX)
-	 (if type
-	     (complex (coerce (realpart object) (second type))
-		      (coerce (imagpart object) (second type)))
-	     (complex (realpart object) (imagpart object))))
-	((member aux '(SINGLE-FLOAT SHORT-FLOAT DOUBLE-FLOAT LONG-FLOAT FLOAT))
-	 (setq aux (coerce object aux))
-	 (unless (typep aux type)
-	   (error-coerce object type))
-	 aux)
-	((eq aux 'AND)
-	 (dolist (type (rest type))
-	   (setq aux (coerce aux type)))
-	 (unless (typep aux type)
-	   (error-coerce object type))
-	 aux)
-	((or (listp object) (vectorp object))
-	 (concatenate type object))
-	(t
-	 (error-coerce object type))))
+  (flet ((fail ()
+           (error "Cannot coerce ~S to type ~S." object type)))
+    (let ((type (expand-deftype type)))
+      (cond ((atom type)
+             (case type
+               ((T) object)
+               (LIST
+                (do ((io (make-seq-iterator object) (seq-iterator-next object io))
+                     (l nil (cons (seq-iterator-ref object io) l)))
+                    ((null io) l)))
+               ((CHARACTER BASE-CHAR) (character object))
+               (FLOAT (float object))
+               (SINGLE-FLOAT (float object 0.0F0))
+               (SHORT-FLOAT (float object 0.0S0))
+               (DOUBLE-FLOAT (float object 0.0D0))
+               (LONG-FLOAT (float object 0.0L0))
+               (COMPLEX (complex (realpart object) (imagpart object)))
+               (FUNCTION (coerce-to-function object))
+               ((VECTOR SIMPLE-VECTOR #+unicode SIMPLE-BASE-STRING SIMPLE-STRING
+                        #+unicode BASE-STRING STRING BIT-VECTOR SIMPLE-BIT-VECTOR)
+                (concatenate type object))
+               (t
+                (if (or (listp object) (vectorp object))
+                    (concatenate type object)
+                    (fail)))))
+            ((eq (setq aux (first type)) 'COMPLEX)
+             (if type
+                 (complex (coerce (realpart object) (second type))
+                          (coerce (imagpart object) (second type)))
+                 (complex (realpart object) (imagpart object))))
+            ((member aux '(SINGLE-FLOAT SHORT-FLOAT DOUBLE-FLOAT LONG-FLOAT FLOAT))
+             (setq aux (coerce object aux))
+             (unless (typep aux type)
+               (fail))
+             aux)
+            ((eq aux 'AND)
+             (dolist (type (rest type))
+               (setq aux (coerce aux type)))
+             (unless (typep aux type)
+               (fail))
+             aux)
+            ((or (listp object) (vectorp object))
+             (concatenate type object))
+            (t
+             (fail))))))
 
 ;;************************************************************
 ;;			SUBTYPEP