[Sbcl-commits] CVS: sbcl/src/compiler array-tran.lisp,1.38,1.39

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1:/tmp/cvs-serv26868/src/compiler

Modified Files:
	array-tran.lisp 
Log Message:
0.7.10.11:
	A couple of array fixes
	... make DESCRIBE work on rank-0 arrays (Lutz Euler sbcl-devel
		2002-12-03)
	... make DEFTRANSFORM MAKE-ARRAY warn (or style-warn) in the 
		various appropriate cases:
	* default :INITIAL-ELEMENT not compatible with :ELEMENT-TYPE
	* provided :INITIAL-ELEMENT not compatible with :ELEMENT-TYPE
	* provided :INITIAL-ELEMENT not compatible with
		(UPGRADED-ARRAY-ELEMENT-TYPE ELEMENT-TYPE)


Index: array-tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/array-tran.lisp,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -d -r1.38 -r1.39
--- array-tran.lisp	4 Dec 2002 15:23:02 -0000	1.38
+++ array-tran.lisp	5 Dec 2002 10:44:44 -0000	1.39
@@ -278,37 +278,41 @@
 	 (saetp (find-if (lambda (saetp)
 			   (csubtypep eltype-type (saetp-ctype saetp)))
 			 *specialized-array-element-type-properties*))
-	 (creation-form `(make-array dims :element-type ',eltype
-			             ,@(when fill-pointer
-				         '(:fill-pointer fill-pointer))
-			             ,@(when adjustable
-				         '(:adjustable adjustable)))))
+	 (creation-form `(make-array dims
+			  :element-type ',(type-specifier (saetp-ctype saetp))
+			  ,@(when fill-pointer
+				  '(:fill-pointer fill-pointer))
+			  ,@(when adjustable
+				  '(:adjustable adjustable)))))
 
     (unless saetp
       (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype))
 
-    (cond ((or (null initial-element)
-	       (and (constant-continuation-p initial-element)
-		    (eql (continuation-value initial-element)
-			 (saetp-initial-element-default saetp))))
-	   (unless (csubtypep (ctype-of (saetp-initial-element-default saetp))
-			      eltype-type)
-	     ;; This situation arises e.g. in (MAKE-ARRAY 4
-	     ;; :ELEMENT-TYPE '(INTEGER 1 5)) ANSI's definition of
-	     ;; MAKE-ARRAY says "If INITIAL-ELEMENT is not supplied,
-	     ;; the consequences of later reading an uninitialized
-	     ;; element of new-array are undefined," so this could be
-	     ;; legal code as long as the user plans to write before
-	     ;; he reads, and if he doesn't we're free to do anything
-	     ;; we like. But in case the user doesn't know to write
-	     ;; elements before he reads elements (or to read manuals
-	     ;; before he writes code:-), we'll signal a STYLE-WARNING
-	     ;; in case he didn't realize this.
-	     (compiler-style-warn "The default initial element ~S is not a ~S."
-				  (saetp-initial-element-default saetp)
-				  eltype))
+    (cond ((and (constant-continuation-p initial-element)
+		(eql (continuation-value initial-element)
+		     (saetp-initial-element-default saetp)))
 	   creation-form)
 	  (t
+	   ;; error checking for target, disabled on the host because
+	   ;; (CTYPE-OF #\Null) is not possible.
+	   #-sb-xc-host
+	   (when (constant-continuation-p initial-element)
+	     (let ((value (continuation-value initial-element)))
+	       (cond
+		 ((not (csubtypep (ctype-of value)
+				  (saetp-ctype saetp)))
+		  ;; this case will cause an error at runtime, so we'd
+		  ;; better WARN about it now.
+		  (compiler-warn "~@<~S is not a ~S (which is the ~
+                                 UPGRADED-ARRAY-ELEMENT-TYPE of ~S).~@:>"
+				 value
+				 (type-specifier (saetp-ctype saetp))
+				 eltype))
+		 ((not (csubtypep (ctype-of value) eltype-type))
+		  ;; this case will not cause an error at runtime, but
+		  ;; it's still worth STYLE-WARNing about.
+		  (compiler-style-warn "~S is not a ~S."
+				       value eltype)))))
 	   `(let ((array ,creation-form))
 	     (multiple-value-bind (vector)
 		 (%data-vector-and-index array 0)
@@ -339,7 +343,22 @@
     (unless saetp
       (give-up-ir1-transform
        "cannot open-code creation of ~S" result-type-spec))
-
+    #-sb-xc-host
+    (unless (csubtypep (ctype-of (saetp-initial-element-default saetp))
+		       eltype-type)
+      ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
+      ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
+      ;; INITIAL-ELEMENT is not supplied, the consequences of later
+      ;; reading an uninitialized element of new-array are undefined,"
+      ;; so this could be legal code as long as the user plans to
+      ;; write before he reads, and if he doesn't we're free to do
+      ;; anything we like. But in case the user doesn't know to write
+      ;; elements before he reads elements (or to read manuals before
+      ;; he writes code:-), we'll signal a STYLE-WARNING in case he
+      ;; didn't realize this.
+      (compiler-style-warn "The default initial element ~S is not a ~S."
+			   (saetp-initial-element-default saetp)
+			   eltype))
     (let* ((n-bits-per-element (saetp-n-bits saetp))
 	   (typecode (saetp-typecode saetp))
 	   (n-pad-elements (saetp-n-pad-elements saetp))