0.8.0.24:

[sbcl.git] / src / code / coerce.lisp

diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp
index dfd208d..1d05f63 100644 (file)
--- a/src/code/coerce.lisp
+++ b/src/code/coerce.lisp
@@ -117,10 +117,7 @@
         (character object))
        ((csubtypep type (specifier-type 'function))
         #!+high-security
-        (when (and (or (symbolp object)
-                       (and (listp object)
-                            (= (length object) 2)
-                            (eq (car object) 'setf)))
+        (when (and (legal-fun-name-p object)
                    (not (fboundp object)))
           (error 'simple-type-error
                  :datum object
@@ -150,52 +147,82 @@
                  :format-arguments (list object)))
         (eval `#',object))
        ((numberp object)
-        (let ((res
-               (cond
-                 ((csubtypep type (specifier-type 'single-float))
-                  (%single-float object))
-                 ((csubtypep type (specifier-type 'double-float))
-                  (%double-float object))
-                 #!+long-float
-                 ((csubtypep type (specifier-type 'long-float))
-                  (%long-float object))
-                 ((csubtypep type (specifier-type 'float))
-                  (%single-float object))
-                 ((csubtypep type (specifier-type '(complex single-float)))
-                  (complex (%single-float (realpart object))
-                           (%single-float (imagpart object))))
-                 ((csubtypep type (specifier-type '(complex double-float)))
-                  (complex (%double-float (realpart object))
-                           (%double-float (imagpart object))))
-                 #!+long-float
-                 ((csubtypep type (specifier-type '(complex long-float)))
-                  (complex (%long-float (realpart object))
-                           (%long-float (imagpart object))))
-                 ((and (typep object 'rational)
-                       (csubtypep type (specifier-type '(complex float))))
-                  ;; Perhaps somewhat surprisingly, ANSI specifies
-                  ;; that (COERCE FOO 'FLOAT) is a SINGLE-FLOAT, not
-                  ;; dispatching on *READ-DEFAULT-FLOAT-FORMAT*.  By
-                  ;; analogy, we do the same for complex numbers. --
-                  ;; CSR, 2002-08-06
-                  (complex (%single-float object)))
-                 ((csubtypep type (specifier-type 'complex))
-                  (complex object))
-                 (t
-                  (coerce-error)))))
-          ;; If RES has the wrong type, that means that rule of canonical
-          ;; representation for complex rationals was invoked. According to
-          ;; the Hyperspec, (coerce 7/2 'complex) returns 7/2. Thus, if the
-          ;; object was a rational, there is no error here.
-          (unless (or (typep res output-type-spec) (rationalp object))
-            (coerce-error))
-          res))
+        (cond
+          ((csubtypep type (specifier-type 'single-float))
+           (let ((res (%single-float object)))
+             (unless (typep res output-type-spec)
+               (coerce-error))
+             res))
+          ((csubtypep type (specifier-type 'double-float))
+           (let ((res (%double-float object)))
+             (unless (typep res output-type-spec)
+               (coerce-error))
+             res))
+          #!+long-float
+          ((csubtypep type (specifier-type 'long-float))
+           (let ((res (%long-float object)))
+             (unless (typep res output-type-spec)
+               (coerce-error))
+             res))
+          ((csubtypep type (specifier-type 'float))
+           (let ((res (%single-float object)))
+             (unless (typep res output-type-spec)
+               (coerce-error))
+             res))
+          (t
+           (let ((res
+                  (cond
+                    ((csubtypep type (specifier-type '(complex single-float)))
+                     (complex (%single-float (realpart object))
+                              (%single-float (imagpart object))))
+                    ((csubtypep type (specifier-type '(complex double-float)))
+                     (complex (%double-float (realpart object))
+                              (%double-float (imagpart object))))
+                    #!+long-float
+                    ((csubtypep type (specifier-type '(complex long-float)))
+                     (complex (%long-float (realpart object))
+                              (%long-float (imagpart object))))
+                    ((and (typep object 'rational)
+                          (csubtypep type (specifier-type '(complex float))))
+                     ;; Perhaps somewhat surprisingly, ANSI specifies
+                     ;; that (COERCE FOO 'FLOAT) is a SINGLE-FLOAT,
+                     ;; not dispatching on
+                     ;; *READ-DEFAULT-FLOAT-FORMAT*.  By analogy, we
+                     ;; do the same for complex numbers. -- CSR,
+                     ;; 2002-08-06
+                     (complex (%single-float object)))
+                    ((csubtypep type (specifier-type 'complex))
+                     (complex object))
+                    (t
+                     (coerce-error)))))
+             ;; If RES has the wrong type, that means that rule of
+             ;; canonical representation for complex rationals was
+             ;; invoked. According to the Hyperspec, (coerce 7/2
+             ;; 'complex) returns 7/2. Thus, if the object was a
+             ;; rational, there is no error here.
+             (unless (or (typep res output-type-spec)
+                         (rationalp object))
+               (coerce-error))
+             res))))
        ((csubtypep type (specifier-type 'list))
         (if (vectorp object)
-            (vector-to-list* object)
+            (cond ((type= type (specifier-type 'list))
+                   (vector-to-list* object))
+                  ((type= type (specifier-type 'null))
+                   (if (= (length object) 0)
+                       'nil
+                       (sequence-type-length-mismatch-error type
+                                                            (length object))))
+                  ((csubtypep (specifier-type '(cons nil t)) type)
+                   (if (> (length object) 0)
+                       (vector-to-list* object)
+                       (sequence-type-length-mismatch-error type 0)))
+                  (t (sequence-type-too-hairy (type-specifier type))))
             (coerce-error)))
        ((csubtypep type (specifier-type 'vector))
         (typecase object
+          ;; FOO-TO-VECTOR* go through MAKE-SEQUENCE, so length
+          ;; errors are caught there. -- CSR, 2002-10-18
           (list (list-to-vector* object output-type-spec))
           (vector (vector-to-vector* object output-type-spec))
           (t