X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=a57dc9361b6336ac324f8847c1ba74153fb1e3f4;hb=83097ed630d4efdb79bd0bc91f21014f4365f008;hp=522413454797ae6c3b572f1e39f3a96c88bdb015;hpb=b86daba1860b622636d9e8f655a3f96de4d86801;p=sbcl.git

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 5224134..a57dc93 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -600,7 +600,7 @@
   (once-only ((n-array array)
               (n-svalue `(the index ,svalue))
               (n-evalue `(the (or index null) ,evalue)))
-    (let ((check-bounds (policy env (= 0 insert-array-bounds-checks))))
+    (let ((check-bounds (policy env (plusp insert-array-bounds-checks))))
       `(multiple-value-bind (,data-var
                              ,start-var
                              ,end-var
@@ -613,12 +613,12 @@
                                          `(array-total-size ,n-array)))
                               (n-end `(or ,n-evalue ,n-len)))
                              (if check-bounds
-                                 `(values ,n-array ,n-svalue ,n-end 0)
-                                 `(if (<= ,n-svalue ,n-end ,n-len)
+                                 `(if (<= 0 ,n-svalue ,n-end ,n-len)
                                       (values ,n-array ,n-svalue ,n-end 0)
                                       ,(if check-fill-pointer
                                            `(sequence-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue)
-                                           `(array-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue))))))
+                                           `(array-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue)))
+                                 `(values ,n-array ,n-svalue ,n-end 0))))
                ,(if force-inline
                     `(%with-array-data-macro ,n-array ,n-svalue ,n-evalue
                                              :check-bounds ,check-bounds
@@ -660,8 +660,10 @@
 
 (defun transform-%with-array-data/muble (array node check-fill-pointer)
   (let ((element-type (upgraded-element-type-specifier-or-give-up array))
-        (type (lvar-type array)))
+        (type (lvar-type array))
+        (check-bounds (policy node (plusp insert-array-bounds-checks))))
     (if (and (array-type-p type)
+             (not (array-type-complexp type))
              (listp (array-type-dimensions type))
              (not (null (cdr (array-type-dimensions type)))))
         ;; If it's a simple multidimensional array, then just return
@@ -671,15 +673,20 @@
         ;; users to use WITH-ARRAY-DATA and we may use it ourselves at
         ;; some point in the future for optimized libraries or
         ;; similar.
-        ;;
-        ;; FIXME: The return values here don't seem sane, and
-        ;; bounds-checks are elided!
-        `(let ((data (truly-the (simple-array ,element-type (*))
-                                (%array-data-vector array))))
-           (values data 0 (length data) 0))
+        (if check-bounds
+            `(let* ((data (truly-the (simple-array ,element-type (*))
+                                     (%array-data-vector array)))
+                    (len (length data))
+                    (real-end (or end len)))
+               (unless (<= 0 start data-end lend)
+                 (sequence-bounding-indices-bad-error array start end))
+               (values data 0 real-end 0))
+            `(let ((data (truly-the (simple-array ,element-type (*))
+                                    (%array-data-vector array))))
+               (values data 0 (or end (length data)) 0)))
         `(%with-array-data-macro array start end
                                  :check-fill-pointer ,check-fill-pointer
-                                 :check-bounds ,(policy node (< 0 insert-array-bounds-checks))
+                                 :check-bounds ,check-bounds
                                  :element-type ,element-type))))
 
 ;; It might very well be reasonable to allow general ARRAY here, I
@@ -793,19 +800,23 @@
 ;; without bloating the code. If we already know the type of the array
 ;; with sufficient precision, skip directly to DATA-VECTOR-REF.
 (deftransform aref ((array index) (t t) * :node node)
-  (let ((type (lvar-type array)))
-    (cond ((and (array-type-p type)
-                (null (array-type-complexp type))
-                (not (eql (extract-upgraded-element-type array)
-                          *wild-type*))
-                (eql (length (array-type-dimensions type)) 1))
-           `(data-vector-ref array (%check-bound array
-                                                 (array-dimension array 0)
-                                                 index)))
-          ((policy node (zerop insert-array-bounds-checks))
-           `(hairy-data-vector-ref array index))
-          (t
-           `(hairy-data-vector-ref/check-bounds array index)))))
+  (let* ((type (lvar-type array))
+         (element-ctype (extract-upgraded-element-type array)))
+    (cond
+      ((and (array-type-p type)
+            (null (array-type-complexp type))
+            (not (eql element-ctype *wild-type*))
+            (eql (length (array-type-dimensions type)) 1))
+       (let* ((declared-element-ctype (extract-declared-element-type array))
+              (bare-form
+               `(data-vector-ref array
+                 (%check-bound array (array-dimension array 0) index))))
+         (if (type= declared-element-ctype element-ctype)
+             bare-form
+             `(the ,(type-specifier declared-element-ctype) ,bare-form))))
+      ((policy node (zerop insert-array-bounds-checks))
+       `(hairy-data-vector-ref array index))
+      (t `(hairy-data-vector-ref/check-bounds array index)))))
 
 (deftransform %aset ((array index new-value) (t t t) * :node node)
   (if (policy node (zerop insert-array-bounds-checks))
@@ -816,6 +827,7 @@
 ;;; available, switch back to the normal one to give other transforms
 ;;; a stab at it.
 (macrolet ((define (name transform-to extra extra-type)
+             (declare (ignore extra-type))
              `(deftransform ,name ((array index ,@extra))
                 (let ((type (lvar-type array))
                       (element-type (extract-upgraded-element-type array)))