1.0.4.39: get rid of hardcoded mutex and spinlock slot indexes

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

diff --git a/src/code/array.lisp b/src/code/array.lisp
index d1e06bb..6296eb4 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -149,6 +149,11 @@
     (declare (fixnum array-rank))
     (when (and displaced-index-offset (null displaced-to))
       (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
+    (when (and displaced-to
+               (arrayp displaced-to)
+               (not (equal (array-element-type displaced-to)
+                           (upgraded-array-element-type element-type))))
+      (error "Array element type of :DISPLACED-TO array does not match specified element type"))
     (if (and simple (= array-rank 1))
         ;; it's a (SIMPLE-ARRAY * (*))
         (multiple-value-bind (type n-bits)
@@ -306,29 +311,6 @@ of specialized arrays is supported."
            (fill-data-vector data dimensions initial-contents)))
     data))
 
-(defun fill-data-vector (vector dimensions initial-contents)
-  (let ((index 0))
-    (labels ((frob (axis dims contents)
-               (cond ((null dims)
-                      (setf (aref vector index) contents)
-                      (incf index))
-                     (t
-                      (unless (typep contents 'sequence)
-                        (error "malformed :INITIAL-CONTENTS: ~S is not a ~
-                                sequence, but ~W more layer~:P needed."
-                               contents
-                               (- (length dimensions) axis)))
-                      (unless (= (length contents) (car dims))
-                        (error "malformed :INITIAL-CONTENTS: Dimension of ~
-                                axis ~W is ~W, but ~S is ~W long."
-                               axis (car dims) contents (length contents)))
-                      (if (listp contents)
-                          (dolist (content contents)
-                            (frob (1+ axis) (cdr dims) content))
-                          (dotimes (i (length contents))
-                            (frob (1+ axis) (cdr dims) (aref contents i))))))))
-      (frob 0 dimensions initial-contents))))
-
 (defun vector (&rest objects)
   #!+sb-doc
   "Construct a SIMPLE-VECTOR from the given objects."
@@ -764,7 +746,11 @@ of specialized arrays is supported."
            (error "The number of dimensions not equal to rank of array."))
           ((not (subtypep element-type (array-element-type array)))
            (error "The new element type, ~S, is incompatible with old type."
-                  element-type)))
+                  element-type))
+          ((and fill-pointer (not (array-has-fill-pointer-p array)))
+           (error 'type-error
+                  :datum array
+                  :expected-type '(satisfies array-has-fill-pointer-p))))
     (let ((array-rank (length (the list dimensions))))
       (declare (fixnum array-rank))
       (unless (= array-rank 1)
@@ -944,11 +930,13 @@ of specialized arrays is supported."
 
 (defun shrink-vector (vector new-length)
   (declare (vector vector))
-  (cond ((eq (length vector) new-length)
-         vector)
-        ((array-has-fill-pointer-p vector)
-         (setf (%array-fill-pointer vector) new-length))
-        (t (subseq vector 0 new-length))))
+  (cond
+    ((eq (length vector) new-length)
+     vector)
+    ((array-has-fill-pointer-p vector)
+     (setf (%array-fill-pointer vector) new-length)
+     vector)
+    (t (subseq vector 0 new-length))))
 
 ;;; Fill in array header with the provided information, and return the array.
 (defun set-array-header (array data length fill-pointer displacement dimensions
@@ -973,7 +961,13 @@ of specialized arrays is supported."
 ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
 
 ;;; a temporary to be used when OLD-DATA and NEW-DATA are EQ.
-;;; KLUDGE: Boy, DYNAMIC-EXTENT would be nice.
+;;; KLUDGE: Boy, DYNAMIC-EXTENT would be nice. This is rebound
+;;; to length zero array in each new thread.
+;;;
+;;; DX is probably a bad idea, because a with a big array it would
+;;; be fairly easy to blow the stack.
+;;;
+;;; Rebound per thread.
 (defvar *zap-array-data-temp* (make-array 1000 :initial-element t))
 
 (defun zap-array-data-temp (length element-type initial-element