X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcoerce.lisp;h=575083f15371e1279e9d9ecd7f7cc4697e845f25;hb=01044af1b8d69fc3899dc0417064c1512223223d;hp=576aba5965a36dc093ef0a295a71a9852ae10d0a;hpb=789a365f2d49a2d2774797dec5759a6e9c7e0d5a;p=sbcl.git

diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp
index 576aba5..575083f 100644
--- a/src/code/coerce.lisp
+++ b/src/code/coerce.lisp
@@ -116,11 +116,7 @@
 	((csubtypep type (specifier-type 'character))
 	 (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
@@ -132,7 +128,6 @@
 		  :expected-type '(satisfies fboundp)
 	       :format-control "~S isn't fbound."
 	       :format-arguments (list object)))
-	 #!+high-security
 	 (when (and (symbolp object)
 		    (sb!xc:macro-function object))
 	   (error 'simple-type-error
@@ -140,7 +135,6 @@
 		  :expected-type '(not (satisfies sb!xc:macro-function))
 		  :format-control "~S is a macro."
 		  :format-arguments (list object)))
-	 #!+high-security
 	 (when (and (symbolp object)
 		    (special-operator-p object))
 	   (error 'simple-type-error
@@ -150,60 +144,84 @@
 		  :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)
-	     (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))))
+	     (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))))
+	       ((cons-type-p type)
+		(multiple-value-bind (min exactp)
+		    (sb!kernel::cons-type-length-info type)
+		  (let ((length (length object)))
+		    (if exactp
+			(unless (= length min)
+			  (sequence-type-length-mismatch-error type length))
+			(unless (>= length min)
+			  (sequence-type-length-mismatch-error type length)))
+		    (vector-to-list* object))))
+	       (t (sequence-type-too-hairy (type-specifier type))))
 	     (coerce-error)))
 	((csubtypep type (specifier-type 'vector))
 	 (typecase object