0.8.0.3:

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

diff --git a/src/code/array.lisp b/src/code/array.lisp
index f4791de..9d1045d 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -63,7 +63,15 @@
   (bug "called FAILED-%WITH-ARRAY-DATA with valid array parameters?"))
 \f
 ;;;; MAKE-ARRAY
-
+(defun upgraded-array-element-type (spec &optional environment)
+  #!+sb-doc
+  "Return the element type that will actually be used to implement an array
+   with the specifier :ELEMENT-TYPE Spec."
+  (declare (ignore environment))
+  (if (unknown-type-p (specifier-type spec))
+      (error "undefined type: ~S" spec)
+      (type-specifier (array-type-specialized-element-type
+                      (specifier-type `(array ,spec))))))
 (eval-when (:compile-toplevel :execute)
   (sb!xc:defmacro pick-vector-type (type &rest specs)
     `(cond ,@(mapcar (lambda (spec)
@@ -99,6 +107,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 +174,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 +202,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
@@ -320,7 +329,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,18 +385,29 @@
          (declare (list subs) (fixnum axis chunk-size result))
          (let ((index (car subs))
                (dim (%array-dimension array axis)))
-           (declare (fixnum index dim))
+           (declare (fixnum dim))
            (unless (< -1 index dim)
              (if invalid-index-error-p
-                 (error "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S"
-                        index axis array)
+                 (error 'simple-type-error
+                        :format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S"
+                        :format-arguments (list index axis array)
+                        :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)))
-         (unless (< -1 index (length (the (simple-array * (*)) array)))
+       (let ((index (first subscripts))
+             (length (length (the (simple-array * (*)) array))))
+         (unless (< -1 index length)
            (if invalid-index-error-p
-               (error "invalid index ~W in ~S" index array)
+               ;; FIXME: perhaps this should share a format-string
+               ;; with INVALID-ARRAY-INDEX-ERROR or
+               ;; INDEX-TOO-LARGE-ERROR?
+               (error 'simple-type-error
+                      :format-control "invalid index ~W in ~S"
+                      :format-arguments (list index array)
+                      :datum index
+                      :expected-type `(integer 0 (,length)))
                (return-from %array-row-major-index nil)))
          index))))
 
@@ -425,6 +446,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.
 
@@ -526,6 +554,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)
@@ -844,6 +873,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