X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=f4791de328b9286691cd81e53bc5f820a9dc82c3;hb=a8161e77843ee18a99ec30dd57f796264dfac05a;hp=c061ddbeee15bda10e4bba872bfbfb04d9ca3c3b;hpb=1bfc464c657a8f4ad24ef612f76a38d8f6f1bbad;p=sbcl.git

diff --git a/src/code/array.lisp b/src/code/array.lisp
index c061ddb..f4791de 100644
--- 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,23 +49,28 @@
 (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?"))
 
 ;;;; MAKE-ARRAY
 
 (eval-when (:compile-toplevel :execute)
   (sb!xc:defmacro pick-vector-type (type &rest specs)
-    `(cond ,@(mapcar #'(lambda (spec)
-			 `(,(if (eq (car spec) t)
-				t
-				`(subtypep ,type ',(car spec)))
-			   ,@(cdr spec)))
+    `(cond ,@(mapcar (lambda (spec)
+		       `(,(if (eq (car spec) t)
+			      t
+			      `(subtypep ,type ',(car spec)))
+			 ,@(cdr spec)))
 		     specs))))
 
 ;;; These functions are used in the implementation of MAKE-ARRAY for
@@ -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
@@ -492,20 +509,20 @@
   "Return the type of the elements of the array"
   (let ((widetag (widetag-of array)))
     (macrolet ((pick-element-type (&rest stuff)
-		 `(cond ,@(mapcar #'(lambda (stuff)
-				      (cons
-				       (let ((item (car stuff)))
-					 (cond ((eq item t)
-						t)
-					       ((listp item)
-						(cons 'or
-						      (mapcar (lambda (x)
-								`(= widetag ,x))
-							      item)))
-					       (t
-						`(= widetag ,item))))
-				       (cdr stuff)))
-						   stuff))))
+		 `(cond ,@(mapcar (lambda (stuff)
+				    (cons
+				     (let ((item (car stuff)))
+				       (cond ((eq item t)
+					      t)
+					     ((listp item)
+					      (cons 'or
+						    (mapcar (lambda (x)
+							      `(= widetag ,x))
+							    item)))
+					     (t
+					      `(= widetag ,item))))
+				     (cdr stuff)))
+				  stuff))))
       ;; FIXME: The data here are redundant with
       ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
       (pick-element-type
@@ -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
@@ -930,9 +947,9 @@
 
 (defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
   (declare (fixnum offset))
-  (let ((limits (mapcar #'(lambda (x y)
-			    (declare (fixnum x y))
-			    (1- (the fixnum (min x y))))
+  (let ((limits (mapcar (lambda (x y)
+			  (declare (fixnum x y))
+			  (1- (the fixnum (min x y))))
 			old-dims new-dims)))
     (macrolet ((bump-index-list (index limits)
 		 `(do ((subscripts ,index (cdr subscripts))