0.7.9.1:

[sbcl.git] / src / code / array.lisp

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 8adb473..f4791de 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -19,18 +19,18 @@
 
 ;;; These functions are only needed by the interpreter, 'cause the
 ;;; compiler inlines them.
-(macrolet ((def-frob (name)
+(macrolet ((def (name)
             `(progn
                (defun ,name (array)
                  (,name array))
                (defun (setf ,name) (value array)
                  (setf (,name array) value)))))
-  (def-frob %array-fill-pointer)
-  (def-frob %array-fill-pointer-p)
-  (def-frob %array-available-elements)
-  (def-frob %array-data-vector)
-  (def-frob %array-displacement)
-  (def-frob %array-displaced-p))
+  (def %array-fill-pointer)
+  (def %array-fill-pointer-p)
+  (def %array-available-elements)
+  (def %array-data-vector)
+  (def %array-displacement)
+  (def %array-displaced-p))
 
 (defun %array-rank (array)
   (%array-rank array))
@@ -49,13 +49,18 @@
 (defun %with-array-data (array start end)
   (%with-array-data-macro array start end :fail-inline? t))
 
+(defun %data-vector-and-index (array index)
+  (if (array-header-p array)
+      (%with-array-data array index nil)
+      (values array index)))
+
 ;;; It'd waste space to expand copies of error handling in every
 ;;; inline %WITH-ARRAY-DATA, so we have them call this function
 ;;; instead. This is just a wrapper which is known never to return.
 (defun failed-%with-array-data (array start end)
   (declare (notinline %with-array-data))
   (%with-array-data array start end)
-  (error "internal error: shouldn't be here with valid parameters"))
+  (bug "called FAILED-%WITH-ARRAY-DATA with valid array parameters?"))
 \f
 ;;;; MAKE-ARRAY
 
@@ -319,7 +324,7 @@
     
 (defun hairy-data-vector-ref (array index)
   (with-array-data ((vector array) (index index) (end))
-    (declare (ignore end) (optimize (safety 3)))
+    (declare (ignore end))
     (etypecase vector .
               #.(mapcar (lambda (type)
                           (let ((atype `(simple-array ,type (*))))
@@ -328,9 +333,15 @@
                                                index))))
                         *specialized-array-element-types*))))
 
+;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
+;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function
+;;; definition is needed for the compiler to use in constant folding.)
+(defun data-vector-ref (array index)
+  (hairy-data-vector-ref array index))
+
 (defun hairy-data-vector-set (array index new-value)
   (with-array-data ((vector array) (index index) (end))
-    (declare (ignore end) (optimize (safety 3)))
+    (declare (ignore end))
     (etypecase vector .
               #.(mapcar (lambda (type)
                           (let ((atype `(simple-array ,type (*))))
@@ -338,7 +349,13 @@
                               (data-vector-set (the ,atype vector)
                                                index
                                                (the ,type
-                                                 new-value)))))
+                                                 new-value))
+                              ;; For specialized arrays, the return
+                              ;; from data-vector-set would have to
+                              ;; be reboxed to be a (Lisp) return
+                              ;; value; instead, we use the
+                              ;; already-boxed value as the return.
+                              new-value)))
                         *specialized-array-element-types*))))
 
 (defun %array-row-major-index (array subscripts
@@ -539,7 +556,7 @@
          (declare (ignore start end))
          (array-element-type array)))
        (t
-       (error "~S is not an array." array))))))
+       (error 'type-error :datum array :expected-type 'array))))))
 
 (defun array-rank (array)
   #!+sb-doc