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

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 5224134..14eb3de 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