;; and for all in any reasonable user programs.)
((t)
(values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))
- ((base-char standard-char character)
+ ((base-char standard-char #!-sb-unicode character)
(values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits))
+ #!+sb-unicode
+ ((character)
+ (values #.sb!vm:simple-character-string-widetag #.sb!vm:n-word-bits))
((bit)
(values #.sb!vm:simple-bit-vector-widetag 1))
;; OK, we have to wade into SUBTYPEPing after all.
;; Pick off some easy common cases.
((t)
#.sb!vm:complex-vector-widetag)
- ((base-char character)
+ ((base-char #!-sb-unicode character)
#.sb!vm:complex-base-string-widetag)
+ #!+sb-unicode
+ ((character)
+ #.sb!vm:complex-character-string-widetag)
((nil)
#.sb!vm:complex-vector-nil-widetag)
((bit)
(t
(pick-vector-type type
(nil #.sb!vm:complex-vector-nil-widetag)
+ #!-sb-unicode
(character #.sb!vm:complex-base-string-widetag)
+ #!+sb-unicode
+ (base-char #.sb!vm:complex-base-string-widetag)
+ #!+sb-unicode
+ (character #.sb!vm:complex-character-string-widetag)
(bit #.sb!vm:complex-bit-vector-widetag)
(t #.sb!vm:complex-vector-widetag)))))
(array (allocate-vector
type
length
- (ceiling (* (if (= type sb!vm:simple-base-string-widetag)
- (1+ length)
- length)
- n-bits)
- sb!vm:n-word-bits))))
+ (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))
(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)))))
+
;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the
;;; specified array characteristics. Dimensions is only used to pass
;;; to FILL-DATA-VECTOR for error checking on the structure of
sb!vm:*specialized-array-element-type-properties*)
#'> :key #'sb!vm:saetp-importance)))))
+;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
(defun %array-row-major-index (array subscripts
&optional (invalid-index-error-p t))
(declare (array array)
t))
(defun array-row-major-index (array &rest subscripts)
+ (declare (dynamic-extent subscripts))
(%array-row-major-index array subscripts))
(defun aref (array &rest subscripts)
#!+sb-doc
"Return the element of the ARRAY specified by the SUBSCRIPTS."
+ (declare (dynamic-extent subscripts))
(row-major-aref array (%array-row-major-index array subscripts)))
(defun %aset (array &rest stuff)
+ (declare (dynamic-extent stuff))
(let ((subscripts (butlast stuff))
(new-value (car (last stuff))))
(setf (row-major-aref array (%array-row-major-index array subscripts))
#!-sb-fluid (declaim (inline (setf aref)))
(defun (setf aref) (new-value array &rest subscripts)
+ (declare (dynamic-extent subscripts))
(declare (type array array))
(setf (row-major-aref array (%array-row-major-index array subscripts))
new-value))
,@(map 'list
(lambda (saetp)
`((simple-array ,(sb!vm:saetp-specifier saetp) (*))
- ,(if (eq (sb!vm:saetp-specifier saetp) 'character)
+ ,(if (or (eq (sb!vm:saetp-specifier saetp) 'character)
+ #!+sb-unicode
+ (eq (sb!vm:saetp-specifier saetp) 'base-char))
*default-init-char-form*
(sb!vm:saetp-initial-element-default saetp))))
(remove-if-not
projects / sbcl.git / blobdiff