(bug "called FAILED-%WITH-ARRAY-DATA with valid array parameters?"))
\f
;;;; MAKE-ARRAY
-(defun upgraded-array-element-type (spec &optional environment)
- #!+sb-doc
- "Return the element type that will actually be used to implement an array
- with the specifier :ELEMENT-TYPE Spec."
- (declare (ignore environment))
- (if (unknown-type-p (specifier-type spec))
- (error "undefined type: ~S" spec)
- (type-specifier (array-type-specialized-element-type
- (specifier-type `(array ,spec))))))
(eval-when (:compile-toplevel :execute)
(sb!xc:defmacro pick-vector-type (type &rest specs)
`(cond ,@(mapcar (lambda (spec)
(defun make-array (dimensions &key
(element-type t)
(initial-element nil initial-element-p)
- initial-contents adjustable fill-pointer
+ (initial-contents nil initial-contents-p)
+ adjustable fill-pointer
displaced-to displaced-index-offset)
(let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
(array-rank (length (the list dimensions)))
(declare (type index length))
(when initial-element-p
(fill array initial-element))
- (when initial-contents
- (when 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))
(data (or displaced-to
(data-vector-from-inits
dimensions total-size element-type
- initial-contents initial-element initial-element-p)))
+ initial-contents initial-contents-p
+ initial-element initial-element-p)))
(array (make-array-header
(cond ((= array-rank 1)
(%complex-vector-widetag element-type))
(setf (%array-available-elements array) total-size)
(setf (%array-data-vector array) data)
(cond (displaced-to
- (when (or initial-element-p initial-contents)
+ (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)))
;;; to FILL-DATA-VECTOR for error checking on the structure of
;;; initial-contents.
(defun data-vector-from-inits (dimensions total-size element-type
- initial-contents initial-element
- initial-element-p)
- (when (and initial-contents initial-element-p)
+ 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
either MAKE-ARRAY or ADJUST-ARRAY."))
(let ((data (if initial-element-p
(error "~S cannot be used to initialize an array of type ~S."
initial-element element-type))
(fill (the vector data) initial-element)))
- (initial-contents
+ (initial-contents-p
(fill-data-vector data dimensions initial-contents)))
data))
(let ((index (car subs))
(dim (%array-dimension array axis)))
(declare (fixnum dim))
- (unless (< -1 index dim)
+ (unless (and (fixnump index) (< -1 index dim))
(if invalid-index-error-p
(error 'simple-type-error
:format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S"
(setf chunk-size (* chunk-size dim))))
(let ((index (first subscripts))
(length (length (the (simple-array * (*)) array))))
- (unless (< -1 index length)
+ (unless (and (fixnump index) (< -1 index length))
(if invalid-index-error-p
;; FIXME: perhaps this should share a format-string
;; with INVALID-ARRAY-INDEX-ERROR or
(defun array-in-bounds-p (array &rest subscripts)
#!+sb-doc
- "Return T if the Subscipts are in bounds for the Array, Nil otherwise."
+ "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise."
(if (%array-row-major-index array subscripts nil)
t))
(defun aref (array &rest subscripts)
#!+sb-doc
- "Return the element of the Array specified by the Subscripts."
+ "Return the element of the ARRAY specified by the SUBSCRIPTS."
(row-major-aref array (%array-row-major-index array subscripts)))
(defun %aset (array &rest stuff)
"Return T if (ADJUST-ARRAY ARRAY...) would return an array identical
to the argument, this happens for complex arrays."
(declare (array array))
+ ;; Note that this appears not to be a fundamental limitation.
+ ;; non-vector SIMPLE-ARRAYs are in fact capable of being adjusted,
+ ;; but in practice we test using ADJUSTABLE-ARRAY-P in ADJUST-ARRAY.
+ ;; -- CSR, 2004-03-01.
(not (typep array 'simple-array)))
\f
;;;; fill pointer frobbing stuff
(declare (fixnum fill-pointer))
(when (= fill-pointer (%array-available-elements vector))
(adjust-array vector (+ fill-pointer extension)))
- (setf (aref vector fill-pointer) new-element)
+ ;; disable bounds checking
+ (locally (declare (optimize (safety 0)))
+ (setf (aref vector fill-pointer) new-element))
(setf (%array-fill-pointer vector) (1+ fill-pointer))
fill-pointer))
(declare (fixnum fill-pointer))
(if (zerop fill-pointer)
(error "There is nothing left to pop.")
- (aref array
- (setf (%array-fill-pointer array)
- (1- fill-pointer))))))
+ ;; disable bounds checking (and any fixnum test)
+ (locally (declare (optimize (safety 0)))
+ (aref array
+ (setf (%array-fill-pointer array)
+ (1- fill-pointer)))))))
+
\f
;;;; ADJUST-ARRAY
(defun adjust-array (array dimensions &key
(element-type (array-element-type array))
(initial-element nil initial-element-p)
- initial-contents fill-pointer
+ (initial-contents nil initial-contents-p)
+ fill-pointer
displaced-to displaced-index-offset)
#!+sb-doc
"Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
element-type)))
(let ((array-rank (length (the list dimensions))))
(declare (fixnum array-rank))
- (when (and fill-pointer (> array-rank 1))
- (error "Multidimensional arrays can't have fill pointers."))
- (cond (initial-contents
+ (unless (= array-rank 1)
+ (when fill-pointer
+ (error "Only vectors can have fill pointers.")))
+ (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 ~
(let* ((array-size (apply #'* dimensions))
(array-data (data-vector-from-inits
dimensions array-size element-type
- initial-contents initial-element
- initial-element-p)))
+ initial-contents initial-contents-p
+ initial-element initial-element-p)))
(if (adjustable-array-p array)
(set-array-header array array-data array-size
(get-new-fill-pointer array array-size
(setf new-data
(data-vector-from-inits
dimensions new-length element-type
- initial-contents initial-element
- initial-element-p))
+ initial-contents initial-contents-p
+ initial-element initial-element-p))
(replace new-data old-data
:start2 old-start :end2 old-end))
(t (setf new-data
(> new-length old-length))
(data-vector-from-inits
dimensions new-length
- element-type () initial-element
- initial-element-p)
+ element-type () nil
+ initial-element initial-element-p)
old-data)))
(if (or (zerop old-length) (zerop new-length))
(when initial-element-p (fill new-data initial-element))
new-data dimensions new-length
element-type initial-element
initial-element-p))
- (set-array-header array new-data new-length
- new-length 0 dimensions nil)))))))))
+ (if (adjustable-array-p array)
+ (set-array-header array new-data new-length
+ new-length 0 dimensions nil)
+ (let ((new-array
+ (make-array-header
+ sb!vm:simple-array-widetag array-rank)))
+ (set-array-header new-array new-data new-length
+ new-length 0 dimensions nil)))))))))))
+
(defun get-new-fill-pointer (old-array new-array-size fill-pointer)
(cond ((not fill-pointer)
(macrolet ((bump-index-list (index limits)
`(do ((subscripts ,index (cdr subscripts))
(limits ,limits (cdr limits)))
- ((null subscripts) nil)
+ ((null subscripts) :eof)
(cond ((< (the fixnum (car subscripts))
(the fixnum (car limits)))
(rplaca subscripts
(t (rplaca subscripts 0))))))
(do ((index (make-list (length old-dims) :initial-element 0)
(bump-index-list index limits)))
- ((null index))
+ ((eq index :eof))
(setf (aref new-data (row-major-index-from-dims index new-dims))
(aref old-data
(+ (the fixnum (row-major-index-from-dims index old-dims))
(defmacro def-bit-array-op (name function)
`(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
+ #!+sb-doc
,(format nil
"Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~
projects / sbcl.git / blobdiff