- ;; 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 0 256) n-bits))
- (let* ((length (car dimensions))
- (array (allocate-vector
- type
- length
- (ceiling (* (if (= type sb!vm:simple-base-string-widetag)
- (1+ length)
- length)
- n-bits)
- sb!vm:n-word-bits))))
- (declare (type index length))
- (when initial-element-p
- (fill array initial-element))
- (when initial-contents
- (when initial-element
- (error "can't specify both :INITIAL-ELEMENT and ~
- :INITIAL-CONTENTS"))
- (unless (= length (length initial-contents))
- (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
- the vector length is ~W."
- (length initial-contents)
- length))
- (replace array initial-contents))
- array))
- ;; it's either a complex array or a multidimensional array.
- (let* ((total-size (reduce #'* dimensions))
- (data (or displaced-to
- (data-vector-from-inits
- dimensions total-size element-type
- initial-contents initial-element initial-element-p)))
- (array (make-array-header
- (cond ((= array-rank 1)
- (%complex-vector-widetag element-type))
- (simple sb!vm:simple-array-widetag)
- (t sb!vm:complex-array-widetag))
- array-rank)))
- (cond (fill-pointer
- (unless (= array-rank 1)
- (error "Only vectors can have fill pointers."))
- (let ((length (car dimensions)))
- (declare (fixnum length))
- (setf (%array-fill-pointer array)
- (cond ((eq fill-pointer t)
- length)
- (t
- (unless (and (fixnump fill-pointer)
- (>= fill-pointer 0)
- (<= fill-pointer length))
- ;; FIXME: should be TYPE-ERROR?
- (error "invalid fill-pointer ~W"
- fill-pointer))
- fill-pointer))))
- (setf (%array-fill-pointer-p array) t))
- (t
- (setf (%array-fill-pointer array) total-size)
- (setf (%array-fill-pointer-p array) nil)))
- (setf (%array-available-elements array) total-size)
- (setf (%array-data-vector array) data)
- (cond (displaced-to
- (when (or initial-element-p initial-contents)
- (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
- can be specified along with :DISPLACED-TO"))
- (let ((offset (or displaced-index-offset 0)))
- (when (> (+ offset total-size)
- (array-total-size displaced-to))
- (error "~S doesn't have enough elements." displaced-to))
- (setf (%array-displacement array) offset)
- (setf (%array-displaced-p array) t)))
- (t
- (setf (%array-displaced-p array) nil)))
- (let ((axis 0))
- (dolist (dim dimensions)
- (setf (%array-dimension array axis) dim)
- (incf axis)))
- 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 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))))
+ (declare (type index length))
+ (when initial-element-p
+ (fill array initial-element))
+ (when initial-contents-p
+ (when initial-element-p
+ (error "can't specify both :INITIAL-ELEMENT and ~
+ :INITIAL-CONTENTS"))
+ (unless (= length (length initial-contents))
+ (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
+ the vector length is ~W."
+ (length initial-contents)
+ length))
+ (replace array initial-contents))
+ array))
+ ;; it's either a complex array or a multidimensional array.
+ (let* ((total-size (reduce #'* dimensions))
+ (data (or displaced-to
+ (data-vector-from-inits
+ dimensions total-size element-type
+ initial-contents initial-contents-p
+ initial-element initial-element-p)))
+ (array (make-array-header
+ (cond ((= array-rank 1)
+ (%complex-vector-widetag element-type))
+ (simple sb!vm:simple-array-widetag)
+ (t sb!vm:complex-array-widetag))
+ array-rank)))
+ (cond (fill-pointer
+ (unless (= array-rank 1)
+ (error "Only vectors can have fill pointers."))
+ (let ((length (car dimensions)))
+ (declare (fixnum length))
+ (setf (%array-fill-pointer array)
+ (cond ((eq fill-pointer t)
+ length)
+ (t
+ (unless (and (fixnump fill-pointer)
+ (>= fill-pointer 0)
+ (<= fill-pointer length))
+ ;; FIXME: should be TYPE-ERROR?
+ (error "invalid fill-pointer ~W"
+ fill-pointer))
+ fill-pointer))))
+ (setf (%array-fill-pointer-p array) t))
+ (t
+ (setf (%array-fill-pointer array) total-size)
+ (setf (%array-fill-pointer-p array) nil)))
+ (setf (%array-available-elements array) total-size)
+ (setf (%array-data-vector array) data)
+ (cond (displaced-to
+ (when (or initial-element-p initial-contents-p)
+ (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
+ can be specified along with :DISPLACED-TO"))
+ (let ((offset (or displaced-index-offset 0)))
+ (when (> (+ offset total-size)
+ (array-total-size displaced-to))
+ (error "~S doesn't have enough elements." displaced-to))
+ (setf (%array-displacement array) offset)
+ (setf (%array-displaced-p array) t)))
+ (t
+ (setf (%array-displaced-p array) nil)))
+ (let ((axis 0))
+ (dolist (dim dimensions)
+ (setf (%array-dimension array axis) dim)
+ (incf axis)))
+ array))))
+
+(defun make-static-vector (length &key
+ (element-type '(unsigned-byte 8))
+ (initial-contents nil initial-contents-p)
+ (initial-element nil initial-element-p))
+ "Allocate vector of LENGTH elements in static space. Only allocation
+of specialized arrays is supported."
+ ;; STEP 1: check inputs fully
+ ;;
+ ;; This way of doing explicit checks before the vector is allocated
+ ;; is expensive, but probably worth the trouble as once we've allocated
+ ;; the vector we have no way to get rid of it anymore...
+ (when (eq t (upgraded-array-element-type element-type))
+ (error "Static arrays of type ~S not supported."
+ element-type))
+ (when initial-contents-p
+ (when initial-element-p
+ (error "can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
+ (unless (= length (length initial-contents))
+ (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~
+ vector length is ~W."
+ (length initial-contents)
+ length))
+ (unless (every (lambda (x) (typep x element-type)) initial-contents)
+ (error ":INITIAL-CONTENTS contains elements not of type ~S."
+ element-type)))
+ (when initial-element-p
+ (unless (typep initial-element element-type)
+ (error ":INITIAL-ELEMENT ~S is not of type ~S."
+ initial-element element-type)))
+ ;; STEP 2
+ ;;
+ ;; Allocate and possibly initialize the vector.
+ (multiple-value-bind (type n-bits)
+ (sb!impl::%vector-widetag-and-n-bits element-type)
+ (let ((vector
+ (allocate-static-vector type length
+ (ceiling (* length n-bits)
+ sb!vm:n-word-bits))))
+ (cond (initial-element-p
+ (fill vector initial-element))
+ (initial-contents-p
+ (replace vector initial-contents))
+ (t
+ vector)))))