(bit #.sb!vm:complex-bit-vector-widetag)
(t #.sb!vm:complex-vector-widetag)))))
+(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))
+ (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)
(initial-element nil initial-element-p)
(declare (type (unsigned-byte 8) type)
(type (integer 0 256) n-bits))
(let* ((length (car dimensions))
- (array (allocate-vector
- type
- length
- (ceiling
- (* (if (or (= type sb!vm:simple-base-string-widetag)
- #!+sb-unicode
- (= type
- sb!vm:simple-character-string-widetag))
- (1+ length)
- length)
- n-bits)
- sb!vm:n-word-bits))))
+ (array (allocate-vector-with-widetag type length n-bits)))
(declare (type index length))
(when initial-element-p
(fill array initial-element))
(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
;;; 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))
(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)
(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
+ ;; inside REPLACE.
(replace new-data old-data
+ :end1 new-length
:start2 old-start :end2 old-end))
(t (setf new-data
(shrink-vector old-data new-length))))
(> 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))