X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=b71f70d86f343582e40045e5ffee2d085ebc1e73;hb=cae594ffb04c80cfa70abce4a6a35a9ba5a27e8c;hp=d2eafd110a6b1979d505b74547907f44815767c0;hpb=11b8fcf55c80cb2686fb49663fa4d96f9b152ce4;p=sbcl.git

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index d2eafd1..b71f70d 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -35,7 +35,11 @@
     ;; array type.
     (if (array-type-p type)
 	(array-type-specialized-element-type type)
-	*universal-type*)))
+	;; KLUDGE: there is no good answer here, but at least
+	;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
+	;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
+	;; 2002-08-21
+	*wild-type*)))
 
 ;;; The ``new-value'' for array setters must fit in the array, and the
 ;;; return type is going to be the same as the new-value for SETF
@@ -47,6 +51,11 @@
 				(array-type-specialized-element-type type))))
   (continuation-type new-value))
 
+(defun assert-array-complex (array)
+  (assert-continuation-type array
+			    (make-array-type :complexp t
+					     :element-type *wild-type*)))
+
 ;;; Return true if ARG is NIL, or is a constant-continuation whose
 ;;; value is NIL, false otherwise.
 (defun unsupplied-or-nil (arg)
@@ -117,23 +126,42 @@
   (let ((simple (and (unsupplied-or-nil adjustable)
 		     (unsupplied-or-nil displaced-to)
 		     (unsupplied-or-nil fill-pointer))))
-    (specifier-type
-     `(,(if simple 'simple-array 'array)
-       ,(cond ((not element-type) t)
-	      ((constant-continuation-p element-type)
-	       (continuation-value element-type))
-	      (t
-	       '*))
-       ,(cond ((not simple)
-	       '*)
-	      ((constant-continuation-p dims)
-	       (let ((val (continuation-value dims)))
-		 (if (listp val) val (list val))))
-	      ((csubtypep (continuation-type dims)
-			  (specifier-type 'integer))
-	       '(*))
-	      (t
-	       '*))))))
+    (or (careful-specifier-type
+         `(,(if simple 'simple-array 'array)
+            ,(cond ((not element-type) t)
+                   ((constant-continuation-p element-type)
+                    (continuation-value element-type))
+                   (t
+                    '*))
+            ,(cond ((not simple)
+                    '*)
+                   ((constant-continuation-p dims)
+                    (let ((val (continuation-value dims)))
+                      (if (listp val) val (list val))))
+                   ((csubtypep (continuation-type dims)
+                               (specifier-type 'integer))
+                    '(*))
+                   (t
+                    '*))))
+        (specifier-type 'array))))
+
+;;; Complex array operations should assert that their array argument
+;;; is complex.  In SBCL, vectors with fill-pointers are complex.
+(defoptimizer (fill-pointer derive-type) ((vector))
+  (assert-array-complex vector))
+(defoptimizer (%set-fill-pointer derive-type) ((vector index))
+  (declare (ignorable index))
+  (assert-array-complex vector))
+
+(defoptimizer (vector-push derive-type) ((object vector))
+  (declare (ignorable object))
+  (assert-array-complex vector))
+(defoptimizer (vector-push-extend derive-type)
+    ((object vector &optional index))
+  (declare (ignorable object index))
+  (assert-array-complex vector))
+(defoptimizer (vector-pop derive-type) ((vector))
+  (assert-array-complex vector))
 
 ;;;; constructors
 
@@ -240,7 +268,7 @@
 			 "ELEMENT-TYPE is not constant."))
 		       (t
 			(continuation-value element-type))))
-	 (eltype-type (specifier-type eltype))
+	 (eltype-type (ir1-transform-specifier-type eltype))
 	 (saetp (find-if (lambda (saetp)
 			   (csubtypep eltype-type (saetp-ctype saetp)))
 			 *specialized-array-element-type-properties*))
@@ -252,7 +280,7 @@
 
     (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)
@@ -280,7 +308,7 @@
 		 (%data-vector-and-index array 0)
 	       (fill vector initial-element))
 	     array)))))
-			 
+
 ;;; The integer type restriction on the length ensures that it will be
 ;;; a vector. The lack of :ADJUSTABLE, :FILL-POINTER, and
 ;;; :DISPLACED-TO keywords ensures that it will be simple; the lack of
@@ -298,7 +326,7 @@
 		  (continuation-value length)
 		  '*))
 	 (result-type-spec `(simple-array ,eltype (,len)))
-	 (eltype-type (specifier-type eltype))
+	 (eltype-type (ir1-transform-specifier-type eltype))
 	 (saetp (find-if (lambda (saetp)
 			   (csubtypep eltype-type (saetp-ctype saetp)))
 			 *specialized-array-element-type-properties*)))