X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=e7aec41cbdfdfc174303991c9129bf643ae7ab16;hb=902e93736a0888aa6b04dc328b1eb328423bf426;hp=724440da2ea9ff8e051571e38529e0ed4d65be5f;hpb=0051cc0532da9f68a0ba5db5c07ebee1c91ee4d8;p=sbcl.git

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 724440d..e7aec41 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -111,11 +111,10 @@
 (defoptimizer (%with-array-data derive-type) ((array start end))
   (let ((atype (continuation-type array)))
     (when (array-type-p atype)
-      (values-specifier-type
-       `(values (simple-array ,(type-specifier
-				(array-type-specialized-element-type atype))
-			      (*))
-		index index index)))))
+      (specifier-type
+       `(simple-array ,(type-specifier
+                       (array-type-specialized-element-type atype))
+                     (*))))))
 
 (defoptimizer (array-row-major-index derive-type) ((array &rest indices))
   (assert-array-rank array (length indices))
@@ -140,11 +139,12 @@
                     (continuation-value element-type))
                    (t
                     '*))
-            ,(cond ((not simple)
-                    '*)
-                   ((constant-continuation-p dims)
-                    (let ((val (continuation-value dims)))
-                      (if (listp val) val (list val))))
+            ,(cond ((constant-continuation-p dims)
+                    (let* ((val (continuation-value dims))
+			   (cdims (if (listp val) val (list val))))
+		      (if simple
+			  cdims
+			  (length cdims))))
                    ((csubtypep (continuation-type dims)
                                (specifier-type 'integer))
                     '(*))
@@ -231,7 +231,7 @@
        `(;; Erm.  Yeah.  There aren't a lot of things that make sense
 	 ;; for an initial element for (ARRAY NIL). -- CSR, 2002-03-07
 	 (nil '#:mu 0 ,sb!vm:simple-array-nil-widetag)
-	 (base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag
+	 (base-char ,(code-char 0) 8 ,sb!vm:simple-base-string-widetag
 		    ;; (SIMPLE-STRINGs are stored with an extra trailing
 		    ;; #\NULL for convenience in calling out to C.)
 		    :n-pad-elements 1)
@@ -303,8 +303,7 @@
 	   (when (constant-continuation-p initial-element)
 	     (let ((value (continuation-value initial-element)))
 	       (cond
-		 ((not (csubtypep (ctype-of value)
-				  (saetp-ctype saetp)))
+		 ((not (ctypep 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 ~
@@ -312,7 +311,7 @@
 				 value
 				 (type-specifier (saetp-ctype saetp))
 				 eltype))
-		 ((not (csubtypep (ctype-of value) eltype-type))
+		 ((not (ctypep 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."
@@ -559,14 +558,14 @@
 ;;; Primitive used to verify indices into arrays. If we can tell at
 ;;; compile-time or we are generating unsafe code, don't bother with
 ;;; the VOP.
-(deftransform %check-bound ((array dimension index))
-  (unless (constant-continuation-p dimension)
-    (give-up-ir1-transform))
-  (let ((dim (continuation-value dimension)))
-    `(the (integer 0 ,dim) index)))
-(deftransform %check-bound ((array dimension index) * *
-			    :policy (and (> speed safety) (= safety 0)))
-  'index)
+(deftransform %check-bound ((array dimension index) * * :node node)
+  (cond ((policy node (and (> speed safety) (= safety 0)))
+         'index)
+        ((not (constant-continuation-p dimension))
+         (give-up-ir1-transform))
+        (t
+         (let ((dim (continuation-value dimension)))
+           `(the (integer 0 ,dim) index)))))
 
 ;;;; WITH-ARRAY-DATA