X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=b5e399977a0716d0c8fd8f0f162126ff141c9b48;hb=11aa29a68039d6fb3cf41d67352a6b263b1094b6;hp=79e7545bd9a29f26a4d1f33c79ea1fe4243e49da;hpb=e32906fedb6a32b0b237e542ce93e5187c88c4ee;p=sbcl.git

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 79e7545..b5e3999 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -133,20 +133,27 @@
        (bit #.sb!vm:complex-bit-vector-widetag)
        (t #.sb!vm:complex-vector-widetag)))))
 
-(defun allocate-vector-with-widetag (widetag length n-bits)
+(defglobal %%simple-array-n-bits%% (make-array (1+ sb!vm:widetag-mask)))
+#.(loop for info across sb!vm:*specialized-array-element-type-properties*
+        collect `(setf (aref %%simple-array-n-bits%% ,(sb!vm:saetp-typecode info))
+                       ,(sb!vm:saetp-n-bits info)) into forms
+        finally (return `(progn ,@forms)))
+
+(defun allocate-vector-with-widetag (widetag length &optional n-bits)
   (declare (type (unsigned-byte 8) widetag)
-           (type index length)
-           (type (integer 0 256) n-bits))
-  (allocate-vector widetag length
-                   (ceiling
-                    (* (if (or (= widetag sb!vm:simple-base-string-widetag)
-                               #!+sb-unicode
-                               (= widetag
-                                  sb!vm:simple-character-string-widetag))
-                           (1+ length)
-                           length)
-                       n-bits)
-                    sb!vm:n-word-bits)))
+           (type index length))
+  (let ((n-bits (or n-bits (aref %%simple-array-n-bits%% widetag))))
+    (declare (type (integer 0 256) n-bits))
+    (allocate-vector widetag length
+                     (ceiling
+                      (* (if (or (= widetag sb!vm:simple-base-string-widetag)
+                                 #!+sb-unicode
+                                 (= widetag
+                                    sb!vm:simple-character-string-widetag))
+                             (1+ length)
+                             length)
+                         n-bits)
+                      sb!vm:n-word-bits))))
 
 (defun make-array (dimensions &key
                               (element-type t)
@@ -193,7 +200,7 @@
         (let* ((total-size (reduce #'* dimensions))
                (data (or displaced-to
                          (data-vector-from-inits
-                          dimensions total-size element-type
+                          dimensions total-size element-type nil
                           initial-contents initial-contents-p
                           initial-element initial-element-p)))
                (array (make-array-header
@@ -293,24 +300,22 @@ of specialized arrays is supported."
 ;;; specified array characteristics. Dimensions is only used to pass
 ;;; to FILL-DATA-VECTOR for error checking on the structure of
 ;;; initial-contents.
-(defun data-vector-from-inits (dimensions total-size element-type
+(defun data-vector-from-inits (dimensions total-size
+                               element-type widetag
                                initial-contents initial-contents-p
                                initial-element initial-element-p)
-  (when (and initial-contents-p initial-element-p)
-    (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to
+  (when initial-element-p
+    (when initial-contents-p
+      (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to
             either MAKE-ARRAY or ADJUST-ARRAY."))
-  (let ((data (if initial-element-p
-                  (make-array total-size
-                              :element-type element-type
-                              :initial-element initial-element)
-                  (make-array total-size
-                              :element-type element-type))))
+    (unless (typep initial-element element-type)
+      (error "~S cannot be used to initialize an array of type ~S."
+             initial-element element-type)))
+  (let ((data (if widetag
+                  (allocate-vector-with-widetag widetag total-size)
+                  (make-array total-size :element-type element-type))))
     (cond (initial-element-p
-           (unless (simple-vector-p data)
-             (unless (typep initial-element element-type)
-               (error "~S cannot be used to initialize an array of type ~S."
-                      initial-element element-type))
-             (fill (the vector data) initial-element)))
+           (fill (the vector data) initial-element))
           (initial-contents-p
            (fill-data-vector data dimensions initial-contents)))
     data))
@@ -904,11 +909,11 @@ of specialized arrays is supported."
       (cond (initial-contents-p
              ;; array former contents replaced by INITIAL-CONTENTS
              (if (or initial-element-p displaced-to)
-                 (error "INITIAL-CONTENTS may not be specified with ~
+                 (error ":INITIAL-CONTENTS may not be specified with ~
                          the :INITIAL-ELEMENT or :DISPLACED-TO option."))
              (let* ((array-size (apply #'* dimensions))
                     (array-data (data-vector-from-inits
-                                 dimensions array-size element-type
+                                 dimensions array-size element-type nil
                                  initial-contents initial-contents-p
                                  initial-element initial-element-p)))
                (if (adjustable-array-p array)
@@ -962,6 +967,7 @@ of specialized arrays is supported."
                         (setf new-data
                               (data-vector-from-inits
                                dimensions new-length element-type
+                               (widetag-of old-data)
                                initial-contents initial-contents-p
                                initial-element initial-element-p))
                         ;; Provide :END1 to avoid full call to LENGTH
@@ -989,7 +995,8 @@ of specialized arrays is supported."
                                          (> new-length old-length))
                                      (data-vector-from-inits
                                       dimensions new-length
-                                      element-type () nil
+                                      element-type
+                                      (widetag-of old-data) () nil
                                       initial-element initial-element-p)
                                      old-data)))
                    (if (or (zerop old-length) (zerop new-length))