X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=d8d04e90ddf3d3eb5c491034d120bcec596667ee;hb=4bc9a2b01540f3a7cbf4499b4689b292fe406139;hp=10f81e883ae23d96808f8f03de745428f6c207ca;hpb=e43ebe3057bd62a58987b22f53c386ca7f5740f8;p=sbcl.git

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 10f81e8..d8d04e9 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -51,7 +51,9 @@
 
 (defun %data-vector-and-index (array index)
   (if (array-header-p array)
-      (%with-array-data array index nil)
+      (multiple-value-bind (vector index)
+          (%with-array-data array index nil)
+        (values vector index))
       (values array index)))
 
 ;;; It'd waste space to expand copies of error handling in every
@@ -63,7 +65,6 @@
   (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)
@@ -99,6 +100,7 @@
      ;; FIXME: The data here are redundant with
      ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
      (pick-vector-type type
+       (nil (values #.sb!vm:simple-array-nil-widetag 0))
        (base-char (values #.sb!vm:simple-string-widetag #.sb!vm:n-byte-bits))
        (bit (values #.sb!vm:simple-bit-vector-widetag 1))
        ((unsigned-byte 2)
@@ -165,11 +167,11 @@
     (when (and displaced-index-offset (null displaced-to))
       (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
     (if (and simple (= array-rank 1))
-	;; Its a (simple-array * (*))
+	;; it's a (SIMPLE-ARRAY * (*))
 	(multiple-value-bind (type n-bits)
 	    (%vector-widetag-and-n-bits element-type)
 	  (declare (type (unsigned-byte 8) type)
-		   (type (integer 1 256) n-bits))
+		   (type (integer 0 256) n-bits))
 	  (let* ((length (car dimensions))
 		 (array (allocate-vector
 			 type
@@ -193,7 +195,7 @@
 		       length))
 	      (replace array initial-contents))
 	    array))
-	;; It's either a complex array or a multidimensional array.
+	;; it's either a complex array or a multidimensional array.
 	(let* ((total-size (reduce #'* dimensions))
 	       (data (or displaced-to
 			 (data-vector-from-inits
@@ -244,7 +246,7 @@
 	      (setf (%array-dimension array axis) dim)
 	      (incf axis)))
 	  array))))
-	
+
 ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the
 ;;; specified array characteristics. Dimensions is only used to pass
 ;;; to FILL-DATA-VECTOR for error checking on the structure of
@@ -320,7 +322,8 @@
       #!+long-float long-float
       (complex single-float)
       (complex double-float)
-      #!+long-float (complex long-float))))
+      #!+long-float (complex long-float)
+      nil)))
     
 (defun hairy-data-vector-ref (array index)
   (with-array-data ((vector array) (index index) (end))
@@ -375,8 +378,8 @@
 	  (declare (list subs) (fixnum axis chunk-size result))
 	  (let ((index (car subs))
 		(dim (%array-dimension array axis)))
-	    (declare (fixnum index dim))
-	    (unless (< -1 index dim)
+	    (declare (fixnum dim))
+	    (unless (and (fixnump index) (< -1 index dim))
 	      (if invalid-index-error-p
 		  (error 'simple-type-error
 			 :format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S"
@@ -384,11 +387,11 @@
 			 :datum index
 			 :expected-type `(integer 0 (,dim)))
 		  (return-from %array-row-major-index nil)))
-	    (incf result (* chunk-size index))
+	    (incf result (* chunk-size (the fixnum index)))
 	    (setf chunk-size (* chunk-size dim))))
 	(let ((index (first subscripts))
 	      (length (length (the (simple-array * (*)) array))))
-	  (unless (< -1 index length)
+	  (unless (and (fixnump index) (< -1 index length))
 	    (if invalid-index-error-p
 		;; FIXME: perhaps this should share a format-string
 		;; with INVALID-ARRAY-INDEX-ERROR or
@@ -403,7 +406,7 @@
 
 (defun array-in-bounds-p (array &rest subscripts)
   #!+sb-doc
-  "Return T if the Subscipts are in bounds for the Array, Nil otherwise."
+  "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise."
   (if (%array-row-major-index array subscripts nil)
       t))
 
@@ -412,7 +415,7 @@
 
 (defun aref (array &rest subscripts)
   #!+sb-doc
-  "Return the element of the Array specified by the Subscripts."
+  "Return the element of the ARRAY specified by the SUBSCRIPTS."
   (row-major-aref array (%array-row-major-index array subscripts)))
 
 (defun %aset (array &rest stuff)
@@ -436,6 +439,13 @@
 ;;;  ZOO
 ;;; But that doesn't seem to be what happens in CMU CL.
 ;;;
+;;; KLUDGE: this is probably because ANSI, in its wisdom (CLHS
+;;; 5.1.2.5) requires implementations to support
+;;;   (SETF (APPLY #'AREF ...) ...)
+;;; [and also #'BIT and #'SBIT].  Yes, this is terrifying, and it's
+;;; also terrifying that this sequence of definitions causes it to
+;;; work.
+;;;
 ;;; Also, it would be nice to make DESCRIBE FOO tell whether a symbol
 ;;; has a setf expansion and/or a setf function defined.
 
@@ -537,6 +547,7 @@
       ;; FIXME: The data here are redundant with
       ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
       (pick-element-type
+       (sb!vm:simple-array-nil-widetag nil)
        ((sb!vm:simple-string-widetag sb!vm:complex-string-widetag) 'base-char)
        ((sb!vm:simple-bit-vector-widetag
 	 sb!vm:complex-bit-vector-widetag) 'bit)
@@ -855,6 +866,8 @@
   (unless (array-header-p vector)
     (macrolet ((frob (name &rest things)
 		 `(etypecase ,name
+		    ((simple-array nil (*)) (error 'cell-error
+					     :name 'nil-array-element))
 		    ,@(mapcar (lambda (thing)
 				(destructuring-bind (type-spec fill-value)
 				    thing