(in-package "SB!IMPL")
-(file-comment
- "$Header$")
-
#!-sb-fluid
(declaim (inline fill-pointer array-has-fill-pointer-p adjustable-array-p
array-displacement))
\f
;;;; miscellaneous accessor functions
-;;; These functions are needed by the interpreter, 'cause the compiler inlines
-;;; them.
+;;; These functions are only needed by the interpreter, 'cause the
+;;; compiler inlines them.
(macrolet ((def-frob (name)
`(progn
(defun ,name (array)
(fixnum index))
(%check-bound array bound index))
-;;; The guts of the WITH-ARRAY-DATA macro. Note that this function is
-;;; only called if we have an array header or an error, so it doesn't
-;;; have to be too tense.
(defun %with-array-data (array start end)
- (declare (array array) (type index start) (type (or index null) end))
- ;; FIXME: The VALUES declaration here is correct, but as of SBCL
- ;; 0.6.6, the corresponding runtime assertion is implemented
- ;; horribly inefficiently, with a full call to %TYPEP for every
- ;; call to this function. As a quick fix, I commented it out,
- ;; but the proper fix would be to fix up type checking.
- ;;
- ;; A simpler test case for the optimization bug is
- ;; (DEFUN FOO (X)
- ;; (DECLARE (TYPE INDEXOID X))
- ;; (THE (VALUES INDEXOID)
- ;; (VALUES X)))
- ;; which also compiles to a full call to %TYPEP.
- #+nil (declare (values (simple-array * (*)) index index index))
- (let* ((size (array-total-size array))
- (end (cond (end
- (unless (<= end size)
- (error "End ~D is greater than total size ~D."
- end size))
- end)
- (t size))))
- (when (> start end)
- (error "Start ~D is greater than end ~D." start end))
- (do ((data array (%array-data-vector data))
- (cumulative-offset 0
- (+ cumulative-offset
- (%array-displacement data))))
- ((not (array-header-p data))
- (values (the (simple-array * (*)) data)
- (the index (+ cumulative-offset start))
- (the index (+ cumulative-offset end))
- (the index cumulative-offset)))
- (declare (type index cumulative-offset)))))
+ (%with-array-data-macro array start end :fail-inline? t))
+
+;;; It'd waste space to expand copies of error handling in every
+;;; inline %WITH-ARRAY-DATA, so we have them call this function
+;;; instead. This is just a wrapper which is known never to return.
+(defun failed-%with-array-data (array start end)
+ (declare (notinline %with-array-data))
+ (%with-array-data array start end)
+ (error "internal error: shouldn't be here with valid parameters"))
\f
;;;; MAKE-ARRAY
(eval-when (:compile-toplevel :execute)
- (sb!xc:defmacro pick-type (type &rest specs)
+ (sb!xc:defmacro pick-vector-type (type &rest specs)
`(cond ,@(mapcar #'(lambda (spec)
`(,(if (eq (car spec) t)
- t
- `(subtypep ,type ',(car spec)))
+ t
+ `(subtypep ,type ',(car spec)))
,@(cdr spec)))
specs))))
;;; These functions are used in the implementation of MAKE-ARRAY for
;;; complex arrays. There are lots of transforms to simplify
-;;; MAKE-ARRAY is transformed away for various easy cases, but not for
-;;; all reasonable cases, so e.g. as of sbcl-0.6.6 we still make full
-;;; calls to MAKE-ARRAY for any non-simple array. Thus, there's some
-;;; value to making this somewhat efficient, at least not doing full
-;;; calls to SUBTYPEP in the easy cases.
-(defun %vector-type-code (type)
+;;; MAKE-ARRAY for various easy cases, but not for all reasonable
+;;; cases, so e.g. as of sbcl-0.6.6 we still make full calls to
+;;; MAKE-ARRAY for any non-simple array. Thus, there's some value to
+;;; making this somewhat efficient, at least not doing full calls to
+;;; SUBTYPEP in the easy cases.
+(defun %vector-widetag-and-n-bits (type)
(case type
;; Pick off some easy common cases.
;;
;; on smarter compiler transforms which do the calculation once
;; and for all in any reasonable user programs.)
((t)
- (values #.sb!vm:simple-vector-type #.sb!vm:word-bits))
- ((character base-char)
- (values #.sb!vm:simple-string-type #.sb!vm:byte-bits))
+ (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))
+ ((character base-char standard-char)
+ (values #.sb!vm:simple-string-widetag #.sb!vm:byte-bits))
((bit)
- (values #.sb!vm:simple-bit-vector-type 1))
+ (values #.sb!vm:simple-bit-vector-widetag 1))
;; OK, we have to wade into SUBTYPEPing after all.
(t
- (pick-type type
- (base-char (values #.sb!vm:simple-string-type #.sb!vm:byte-bits))
- (bit (values #.sb!vm:simple-bit-vector-type 1))
+ ;; FIXME: The data here are redundant with
+ ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
+ (pick-vector-type type
+ (base-char (values #.sb!vm:simple-string-widetag #.sb!vm:byte-bits))
+ (bit (values #.sb!vm:simple-bit-vector-widetag 1))
((unsigned-byte 2)
- (values #.sb!vm:simple-array-unsigned-byte-2-type 2))
+ (values #.sb!vm:simple-array-unsigned-byte-2-widetag 2))
((unsigned-byte 4)
- (values #.sb!vm:simple-array-unsigned-byte-4-type 4))
+ (values #.sb!vm:simple-array-unsigned-byte-4-widetag 4))
((unsigned-byte 8)
- (values #.sb!vm:simple-array-unsigned-byte-8-type 8))
+ (values #.sb!vm:simple-array-unsigned-byte-8-widetag 8))
((unsigned-byte 16)
- (values #.sb!vm:simple-array-unsigned-byte-16-type 16))
+ (values #.sb!vm:simple-array-unsigned-byte-16-widetag 16))
((unsigned-byte 32)
- (values #.sb!vm:simple-array-unsigned-byte-32-type 32))
+ (values #.sb!vm:simple-array-unsigned-byte-32-widetag 32))
((signed-byte 8)
- (values #.sb!vm:simple-array-signed-byte-8-type 8))
+ (values #.sb!vm:simple-array-signed-byte-8-widetag 8))
((signed-byte 16)
- (values #.sb!vm:simple-array-signed-byte-16-type 16))
+ (values #.sb!vm:simple-array-signed-byte-16-widetag 16))
((signed-byte 30)
- (values #.sb!vm:simple-array-signed-byte-30-type 32))
+ (values #.sb!vm:simple-array-signed-byte-30-widetag 32))
((signed-byte 32)
- (values #.sb!vm:simple-array-signed-byte-32-type 32))
- (single-float (values #.sb!vm:simple-array-single-float-type 32))
- (double-float (values #.sb!vm:simple-array-double-float-type 64))
+ (values #.sb!vm:simple-array-signed-byte-32-widetag 32))
+ (single-float (values #.sb!vm:simple-array-single-float-widetag 32))
+ (double-float (values #.sb!vm:simple-array-double-float-widetag 64))
#!+long-float
(long-float
- (values #.sb!vm:simple-array-long-float-type #!+x86 96 #!+sparc 128))
+ (values #.sb!vm:simple-array-long-float-widetag
+ #!+x86 96 #!+sparc 128))
((complex single-float)
- (values #.sb!vm:simple-array-complex-single-float-type 64))
+ (values #.sb!vm:simple-array-complex-single-float-widetag 64))
((complex double-float)
- (values #.sb!vm:simple-array-complex-double-float-type 128))
+ (values #.sb!vm:simple-array-complex-double-float-widetag 128))
#!+long-float
((complex long-float)
- (values #.sb!vm:simple-array-complex-long-float-type
+ (values #.sb!vm:simple-array-complex-long-float-widetag
#!+x86 192
#!+sparc 256))
- (t (values #.sb!vm:simple-vector-type #.sb!vm:word-bits))))))
-(defun %complex-vector-type-code (type)
+ (t (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))))))
+(defun %complex-vector-widetag (type)
(case type
;; Pick off some easy common cases.
((t)
- #.sb!vm:complex-vector-type)
+ #.sb!vm:complex-vector-widetag)
((character base-char)
- #.sb!vm:complex-string-type)
+ #.sb!vm:complex-string-widetag)
((bit)
- #.sb!vm:complex-bit-vector-type)
+ #.sb!vm:complex-bit-vector-widetag)
;; OK, we have to wade into SUBTYPEPing after all.
(t
- (pick-type type
- (base-char #.sb!vm:complex-string-type)
- (bit #.sb!vm:complex-bit-vector-type)
- (t #.sb!vm:complex-vector-type)))))
+ (pick-vector-type type
+ (base-char #.sb!vm:complex-string-widetag)
+ (bit #.sb!vm:complex-bit-vector-widetag)
+ (t #.sb!vm:complex-vector-widetag)))))
(defun make-array (dimensions &key
(element-type t)
(initial-element nil initial-element-p)
initial-contents adjustable fill-pointer
displaced-to displaced-index-offset)
- #!+sb-doc
- "Creates an array of the specified Dimensions. See manual for details."
(let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
(array-rank (length (the list dimensions)))
(simple (and (null fill-pointer)
(null displaced-to))))
(declare (fixnum array-rank))
(when (and displaced-index-offset (null displaced-to))
- (error "Can't specify :displaced-index-offset without :displaced-to"))
+ (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
(if (and simple (= array-rank 1))
;; Its a (simple-array * (*))
- (multiple-value-bind (type bits) (%vector-type-code element-type)
+ (multiple-value-bind (type n-bits)
+ (%vector-widetag-and-n-bits element-type)
(declare (type (unsigned-byte 8) type)
- (type (integer 1 256) bits))
+ (type (integer 1 256) n-bits))
(let* ((length (car dimensions))
(array (allocate-vector
type
length
- (ceiling (* (if (= type sb!vm:simple-string-type)
+ (ceiling (* (if (= type sb!vm:simple-string-widetag)
(1+ length)
length)
- bits)
- sb!vm:word-bits))))
+ 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 "Cannot specify both :initial-element and ~
- :initial-contents"))
+ (error "can't specify both :INITIAL-ELEMENT and ~
+ :INITIAL-CONTENTS"))
(unless (= length (length initial-contents))
- (error "~D elements in the initial-contents, but the ~
- vector length is ~D."
+ (error "There are ~D elements in the :INITIAL-CONTENTS, but ~
+ the vector length is ~D."
(length initial-contents)
length))
(replace array initial-contents))
initial-contents initial-element initial-element-p)))
(array (make-array-header
(cond ((= array-rank 1)
- (%complex-vector-type-code element-type))
- (simple sb!vm:simple-array-type)
- (t sb!vm:complex-array-type))
+ (%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)
(unless (and (fixnump fill-pointer)
(>= fill-pointer 0)
(<= fill-pointer length))
- (error "Invalid fill-pointer ~D"
+ (error "invalid fill-pointer ~D"
fill-pointer))
fill-pointer))))
(setf (%array-fill-pointer-p array) t))
(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"))
+ (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))
(incf axis)))
array))))
-;;; 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 initial-contents.
+;;; 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
+;;; 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)
- (error "Cannot supply both :initial-contents and :initial-element to
- either make-array or adjust-array."))
+ (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
(incf index))
(t
(unless (typep contents 'sequence)
- (error "Malformed :INITIAL-CONTENTS. ~S is not a ~
+ (error "malformed :INITIAL-CONTENTS: ~S is not a ~
sequence, but ~D more layer~:P needed."
contents
(- (length dimensions) axis)))
(unless (= (length contents) (car dims))
- (error "Malformed :INITIAL-CONTENTS. Dimension of ~
+ (error "malformed :INITIAL-CONTENTS: Dimension of ~
axis ~D is ~D, but ~S is ~D long."
axis (car dims) contents (length contents)))
(if (listp contents)
\f
;;;; accessor/setter functions
+(eval-when (:compile-toplevel :execute)
+ (defparameter *specialized-array-element-types*
+ '(t
+ character
+ bit
+ (unsigned-byte 2)
+ (unsigned-byte 4)
+ (unsigned-byte 8)
+ (unsigned-byte 16)
+ (unsigned-byte 32)
+ (signed-byte 8)
+ (signed-byte 16)
+ (signed-byte 30)
+ (signed-byte 32)
+ single-float
+ double-float
+ #!+long-float long-float
+ (complex single-float)
+ (complex double-float)
+ #!+long-float (complex long-float))))
+
(defun hairy-data-vector-ref (array index)
(with-array-data ((vector array) (index index) (end))
(declare (ignore end) (optimize (safety 3)))
- (macrolet ((dispatch (&rest stuff)
- `(etypecase vector
- ,@(mapcar #'(lambda (type)
- (let ((atype `(simple-array ,type (*))))
- `(,atype
- (data-vector-ref (the ,atype vector)
- index))))
- stuff))))
- (dispatch
- t
- bit
- character
- (unsigned-byte 2)
- (unsigned-byte 4)
- (unsigned-byte 8)
- (unsigned-byte 16)
- (unsigned-byte 32)
- (signed-byte 8)
- (signed-byte 16)
- (signed-byte 30)
- (signed-byte 32)
- single-float
- double-float
- #!+long-float long-float
- (complex single-float)
- (complex double-float)
- #!+long-float (complex long-float)))))
+ (etypecase vector .
+ #.(mapcar (lambda (type)
+ (let ((atype `(simple-array ,type (*))))
+ `(,atype
+ (data-vector-ref (the ,atype vector)
+ index))))
+ *specialized-array-element-types*))))
(defun hairy-data-vector-set (array index new-value)
(with-array-data ((vector array) (index index) (end))
(declare (ignore end) (optimize (safety 3)))
- (macrolet ((dispatch (&rest stuff)
- `(etypecase vector
- ,@(mapcar #'(lambda (type)
- (let ((atype `(simple-array ,type (*))))
- `(,atype
- (data-vector-set (the ,atype vector)
- index
- (the ,type
- new-value)))))
- stuff))))
- (dispatch
- t
- bit
- character
- (unsigned-byte 2)
- (unsigned-byte 4)
- (unsigned-byte 8)
- (unsigned-byte 16)
- (unsigned-byte 32)
- (signed-byte 8)
- (signed-byte 16)
- (signed-byte 30)
- (signed-byte 32)
- single-float
- double-float
- #!+long-float long-float
- (complex single-float)
- (complex double-float)
- #!+long-float (complex long-float)))))
+ (etypecase vector .
+ #.(mapcar (lambda (type)
+ (let ((atype `(simple-array ,type (*))))
+ `(,atype
+ (data-vector-set (the ,atype vector)
+ index
+ (the ,type
+ new-value)))))
+ *specialized-array-element-types*))))
(defun %array-row-major-index (array subscripts
&optional (invalid-index-error-p t))
(list subscripts))
(let ((rank (array-rank array)))
(unless (= rank (length subscripts))
- (error "Wrong number of subscripts, ~D, for array of rank ~D"
+ (error "wrong number of subscripts, ~D, for array of rank ~D"
(length subscripts) rank))
(if (array-header-p array)
(do ((subs (nreverse subscripts) (cdr subs))
(declare (fixnum index dim))
(unless (< -1 index dim)
(if invalid-index-error-p
- (error "Invalid index ~D~[~;~:; on axis ~:*~D~] in ~S"
+ (error "invalid index ~D~[~;~:; on axis ~:*~D~] in ~S"
index axis array)
(return-from %array-row-major-index nil)))
(incf result (* chunk-size index))
(let ((index (first subscripts)))
(unless (< -1 index (length (the (simple-array * (*)) array)))
(if invalid-index-error-p
- (error "Invalid index ~D in ~S" index array)
+ (error "invalid index ~D in ~S" index array)
(return-from %array-row-major-index nil)))
index))))
(defun array-in-bounds-p (array &rest subscripts)
#!+sb-doc
- "Returns 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
- "Returns 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)
(defun row-major-aref (array index)
#!+sb-doc
- "Returns the element of array corressponding to the row-major index. This is
+ "Return the element of array corressponding to the row-major index. This is
SETF'able."
(declare (optimize (safety 1)))
(row-major-aref array index))
(defun svref (simple-vector index)
#!+sb-doc
- "Returns the Index'th element of the given Simple-Vector."
+ "Return the INDEX'th element of the given Simple-Vector."
(declare (optimize (safety 1)))
(aref simple-vector index))
(defun bit (bit-array &rest subscripts)
#!+sb-doc
- "Returns the bit from the Bit-Array at the specified Subscripts."
+ "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
(declare (type (array bit) bit-array) (optimize (safety 1)))
(row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
(defun sbit (simple-bit-array &rest subscripts)
#!+sb-doc
- "Returns the bit from the Simple-Bit-Array at the specified Subscripts."
+ "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
(declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
(row-major-aref simple-bit-array
(%array-row-major-index simple-bit-array subscripts)))
(defun array-element-type (array)
#!+sb-doc
- "Returns the type of the elements of the array"
+ "Return the type of the elements of the array"
(let ((type (get-type array)))
(macrolet ((pick-element-type (&rest stuff)
`(cond ,@(mapcar #'(lambda (stuff)
`(= type ,item))))
(cdr stuff)))
stuff))))
+ ;; FIXME: The data here are redundant with
+ ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
(pick-element-type
- ((sb!vm:simple-string-type sb!vm:complex-string-type) 'base-char)
- ((sb!vm:simple-bit-vector-type sb!vm:complex-bit-vector-type) 'bit)
- (sb!vm:simple-vector-type t)
- (sb!vm:simple-array-unsigned-byte-2-type '(unsigned-byte 2))
- (sb!vm:simple-array-unsigned-byte-4-type '(unsigned-byte 4))
- (sb!vm:simple-array-unsigned-byte-8-type '(unsigned-byte 8))
- (sb!vm:simple-array-unsigned-byte-16-type '(unsigned-byte 16))
- (sb!vm:simple-array-unsigned-byte-32-type '(unsigned-byte 32))
- (sb!vm:simple-array-signed-byte-8-type '(signed-byte 8))
- (sb!vm:simple-array-signed-byte-16-type '(signed-byte 16))
- (sb!vm:simple-array-signed-byte-30-type '(signed-byte 30))
- (sb!vm:simple-array-signed-byte-32-type '(signed-byte 32))
- (sb!vm:simple-array-single-float-type 'single-float)
- (sb!vm:simple-array-double-float-type 'double-float)
+ ((sb!vm:simple-string-widetag sb!vm:complex-string-widetag) 'base-char)
+ ((sb!vm:simple-bit-vector-widetag
+ sb!vm:complex-bit-vector-widetag) 'bit)
+ (sb!vm:simple-vector-widetag t)
+ (sb!vm:simple-array-unsigned-byte-2-widetag '(unsigned-byte 2))
+ (sb!vm:simple-array-unsigned-byte-4-widetag '(unsigned-byte 4))
+ (sb!vm:simple-array-unsigned-byte-8-widetag '(unsigned-byte 8))
+ (sb!vm:simple-array-unsigned-byte-16-widetag '(unsigned-byte 16))
+ (sb!vm:simple-array-unsigned-byte-32-widetag '(unsigned-byte 32))
+ (sb!vm:simple-array-signed-byte-8-widetag '(signed-byte 8))
+ (sb!vm:simple-array-signed-byte-16-widetag '(signed-byte 16))
+ (sb!vm:simple-array-signed-byte-30-widetag '(signed-byte 30))
+ (sb!vm:simple-array-signed-byte-32-widetag '(signed-byte 32))
+ (sb!vm:simple-array-single-float-widetag 'single-float)
+ (sb!vm:simple-array-double-float-widetag 'double-float)
#!+long-float
- (sb!vm:simple-array-long-float-type 'long-float)
- (sb!vm:simple-array-complex-single-float-type '(complex single-float))
- (sb!vm:simple-array-complex-double-float-type '(complex double-float))
+ (sb!vm:simple-array-long-float-widetag 'long-float)
+ (sb!vm:simple-array-complex-single-float-widetag
+ '(complex single-float))
+ (sb!vm:simple-array-complex-double-float-widetag
+ '(complex double-float))
#!+long-float
- (sb!vm:simple-array-complex-long-float-type '(complex long-float))
- ((sb!vm:simple-array-type sb!vm:complex-vector-type
- sb!vm:complex-array-type)
+ (sb!vm:simple-array-complex-long-float-widetag '(complex long-float))
+ ((sb!vm:simple-array-widetag
+ sb!vm:complex-vector-widetag
+ sb!vm:complex-array-widetag)
(with-array-data ((array array) (start) (end))
(declare (ignore start end))
(array-element-type array)))
(defun array-rank (array)
#!+sb-doc
- "Returns the number of dimensions of the Array."
+ "Return the number of dimensions of ARRAY."
(if (array-header-p array)
(%array-rank array)
1))
(defun array-dimension (array axis-number)
#!+sb-doc
- "Returns length of dimension Axis-Number of the Array."
+ "Return the length of dimension AXIS-NUMBER of ARRAY."
(declare (array array) (type index axis-number))
(cond ((not (array-header-p array))
(unless (= axis-number 0)
(error "Vector axis is not zero: ~S" axis-number))
(length (the (simple-array * (*)) array)))
((>= axis-number (%array-rank array))
- (error "~D is too big; ~S only has ~D dimension~:P"
+ (error "~D is too big; ~S only has ~D dimension~:P."
axis-number array (%array-rank array)))
(t
(%array-dimension array axis-number))))
(defun array-dimensions (array)
#!+sb-doc
- "Returns a list whose elements are the dimensions of the array"
+ "Return a list whose elements are the dimensions of the array"
(declare (array array))
(if (array-header-p array)
(do ((results nil (cons (array-dimension array index) results))
(defun array-total-size (array)
#!+sb-doc
- "Returns the total number of elements in the Array."
+ "Return the total number of elements in the Array."
(declare (array array))
(if (array-header-p array)
(%array-available-elements array)
(defun array-displacement (array)
#!+sb-doc
- "Returns values of :displaced-to and :displaced-index-offset options to
- make-array, or the defaults nil and 0 if not a displaced array."
- (declare (array array))
- (values (%array-data-vector array) (%array-displacement array)))
+ "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
+ options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
+ (declare (type array array))
+ (if (and (array-header-p array) ; if unsimple and
+ (%array-displaced-p array)) ; displaced
+ (values (%array-data-vector array) (%array-displacement array))
+ (values nil 0)))
(defun adjustable-array-p (array)
#!+sb-doc
- "Returns T if (adjust-array array...) would return an array identical
+ "Return T if (ADJUST-ARRAY ARRAY...) would return an array identical
to the argument, this happens for complex arrays."
(declare (array array))
(not (typep array 'simple-array)))
(defun array-has-fill-pointer-p (array)
#!+sb-doc
- "Returns T if the given Array has a fill pointer, or Nil otherwise."
+ "Return T if the given ARRAY has a fill pointer, or NIL otherwise."
(declare (array array))
(and (array-header-p array) (%array-fill-pointer-p array)))
(defun fill-pointer (vector)
#!+sb-doc
- "Returns the Fill-Pointer of the given Vector."
+ "Return the FILL-POINTER of the given VECTOR."
(declare (vector vector))
(if (and (array-header-p vector) (%array-fill-pointer-p vector))
(%array-fill-pointer vector)
(error 'simple-type-error
:datum vector
:expected-type '(and vector (satisfies array-has-fill-pointer-p))
- :format-control
- "~S is not an array with a fill-pointer."
+ :format-control "~S is not an array with a fill pointer."
:format-arguments (list vector))))
(defun %set-fill-pointer (vector new)
(declare (vector vector) (fixnum new))
(if (and (array-header-p vector) (%array-fill-pointer-p vector))
(if (> new (%array-available-elements vector))
- (error "New fill pointer, ~S, is larger than the length of the vector."
- new)
+ (error
+ "The new fill pointer, ~S, is larger than the length of the vector."
+ new)
(setf (%array-fill-pointer vector) new))
(error 'simple-type-error
:datum vector
:expected-type '(and vector (satisfies array-has-fill-pointer-p))
- :format-control "~S is not an array with a fill-pointer."
+ :format-control "~S is not an array with a fill pointer."
:format-arguments (list vector))))
+;;; FIXME: It'd probably make sense to use a MACROLET to share the
+;;; guts of VECTOR-PUSH between VECTOR-PUSH-EXTEND. Such a macro
+;;; should probably be based on the VECTOR-PUSH-EXTEND code (which is
+;;; new ca. sbcl-0.7.0) rather than the VECTOR-PUSH code (which dates
+;;; back to CMU CL).
(defun vector-push (new-el array)
#!+sb-doc
- "Attempts to set the element of Array designated by the fill pointer
- to New-El and increment fill pointer by one. If the fill pointer is
- too large, Nil is returned, otherwise the index of the pushed element is
+ "Attempt to set the element of ARRAY designated by its fill pointer
+ to NEW-EL, and increment the fill pointer by one. If the fill pointer is
+ too large, NIL is returned, otherwise the index of the pushed element is
returned."
(declare (vector array))
(let ((fill-pointer (fill-pointer array)))
(setf (%array-fill-pointer array) (1+ fill-pointer))
fill-pointer))))
-(defun vector-push-extend (new-el array &optional
- (extension (if (zerop (length array))
- 1
- (length array))))
- #!+sb-doc
- "Like Vector-Push except that if the fill pointer gets too large, the
- Array is extended rather than Nil being returned."
- (declare (vector array) (fixnum extension))
- (let ((fill-pointer (fill-pointer array)))
+(defun vector-push-extend (new-element
+ vector
+ &optional
+ (extension (1+ (length vector))))
+ (declare (vector vector) (fixnum extension))
+ (let ((fill-pointer (fill-pointer vector)))
(declare (fixnum fill-pointer))
- (when (= fill-pointer (%array-available-elements array))
- (adjust-array array (+ fill-pointer extension)))
- (setf (aref array fill-pointer) new-el)
- (setf (%array-fill-pointer array) (1+ fill-pointer))
+ (when (= fill-pointer (%array-available-elements vector))
+ (adjust-array vector (+ fill-pointer extension)))
+ (setf (aref vector fill-pointer) new-element)
+ (setf (%array-fill-pointer vector) (1+ fill-pointer))
fill-pointer))
(defun vector-pop (array)
#!+sb-doc
- "Attempts to decrease the fill-pointer by 1 and return the element
- pointer to by the new fill pointer. If the original value of the fill
- pointer is 0, an error occurs."
+ "Decrease the fill pointer by 1 and return the element pointed to by the
+ new fill pointer."
(declare (vector array))
(let ((fill-pointer (fill-pointer array)))
(declare (fixnum fill-pointer))
(if (zerop fill-pointer)
- (error "Nothing left to pop.")
+ (error "There is nothing left to pop.")
(aref array
(setf (%array-fill-pointer array)
(1- fill-pointer))))))
initial-contents fill-pointer
displaced-to displaced-index-offset)
#!+sb-doc
- "Adjusts the Array's dimensions to the given Dimensions and stuff."
+ "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
(let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
(cond ((/= (the fixnum (length (the list dimensions)))
(the fixnum (array-rank array)))
- (error "Number of dimensions not equal to rank of array."))
+ (error "The number of dimensions not equal to rank of array."))
((not (subtypep element-type (array-element-type array)))
- (error "New element type, ~S, is incompatible with old."
+ (error "The new element type, ~S, is incompatible with old type."
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
- ;; Array former contents replaced by initial-contents.
+ ;; array former contents replaced by INITIAL-CONTENTS
(if (or initial-element-p displaced-to)
- (error "Initial contents may not be specified with ~
- the :initial-element or :displaced-to option."))
+ (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
fill-pointer)
0 dimensions nil)
(if (array-header-p array)
- ;; Simple multidimensional or single dimensional array.
+ ;; simple multidimensional or single dimensional array
(make-array dimensions
:element-type element-type
:initial-contents initial-contents)
array-data))))
(displaced-to
- ;; No initial-contents supplied is already established.
+ ;; We already established that no INITIAL-CONTENTS was supplied.
(when initial-element
- (error "The :initial-element option may not be specified ~
- with :displaced-to."))
+ (error "The :INITIAL-ELEMENT option may not be specified ~
+ with :DISPLACED-TO."))
(unless (subtypep element-type (array-element-type displaced-to))
- (error "One can't displace an array of type ~S into another of ~
- type ~S."
+ (error "can't displace an array of type ~S into another of ~
+ type ~S"
element-type (array-element-type displaced-to)))
(let ((displacement (or displaced-index-offset 0))
(array-size (apply #'* dimensions)))
(declare (fixnum displacement array-size))
(if (< (the fixnum (array-total-size displaced-to))
(the fixnum (+ displacement array-size)))
- (error "The :displaced-to array is too small."))
+ (error "The :DISPLACED-TO array is too small."))
(if (adjustable-array-p array)
;; None of the original contents appear in adjusted array.
(set-array-header array displaced-to array-size
(get-new-fill-pointer array array-size
fill-pointer)
displacement dimensions t)
- ;; Simple multidimensional or single dimensional array.
+ ;; simple multidimensional or single dimensional array
(make-array dimensions
:element-type element-type
:displaced-to displaced-to
(cond ((not fill-pointer)
(when (array-has-fill-pointer-p old-array)
(when (> (%array-fill-pointer old-array) new-array-size)
- (error "Cannot adjust-array an array (~S) to a size (~S) that is ~
- smaller than its fill pointer (~S)."
+ (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~
+ smaller than its fill pointer (~S)"
old-array new-array-size (fill-pointer old-array)))
(%array-fill-pointer old-array)))
((not (array-has-fill-pointer-p old-array))
- (error "Cannot supply a non-NIL value (~S) for :fill-pointer ~
- in adjust-array unless the array (~S) was originally ~
- created with a fill pointer."
- fill-pointer
- old-array))
+ (error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~
+ in ADJUST-ARRAY unless the array (~S) was originally ~
+ created with a fill pointer"
+ fill-pointer
+ old-array))
((numberp fill-pointer)
(when (> fill-pointer new-array-size)
- (error "Cannot supply a value for :fill-pointer (~S) that is larger ~
- than the new length of the vector (~S)."
+ (error "can't supply a value for :FILL-POINTER (~S) that is larger ~
+ than the new length of the vector (~S)"
fill-pointer new-array-size))
fill-pointer)
((eq fill-pointer t)
new-array-size)
(t
- (error "Bogus value for :fill-pointer in adjust-array: ~S"
+ (error "bogus value for :FILL-POINTER in ADJUST-ARRAY: ~S"
fill-pointer))))
-(defun shrink-vector (vector new-size)
- #!+sb-doc
- "Destructively alters the Vector, changing its length to New-Size, which
- must be less than or equal to its current size."
+;;; Destructively alter VECTOR, changing its length to NEW-LENGTH,
+;;; which must be less than or equal to its current length.
+(defun shrink-vector (vector new-length)
(declare (vector vector))
(unless (array-header-p vector)
(macrolet ((frob (name &rest things)
`(etypecase ,name
- ,@(mapcar #'(lambda (thing)
- `(,(car thing)
- (fill (truly-the ,(car thing) ,name)
- ,(cadr thing)
- :start new-size)))
+ ,@(mapcar (lambda (thing)
+ (destructuring-bind (type-spec fill-value)
+ thing
+ `(,type-spec
+ (fill (truly-the ,type-spec ,name)
+ ,fill-value
+ :start new-length))))
things))))
+ ;; FIXME: The associations between vector types and initial
+ ;; values here are redundant with
+ ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
(frob vector
(simple-vector 0)
- (simple-base-string #.default-init-char)
+ (simple-base-string #.*default-init-char-form*)
(simple-bit-vector 0)
((simple-array (unsigned-byte 2) (*)) 0)
((simple-array (unsigned-byte 4) (*)) 0)
(coerce 0 '(complex long-float))))))
;; Only arrays have fill-pointers, but vectors have their length
;; parameter in the same place.
- (setf (%array-fill-pointer vector) new-size)
+ (setf (%array-fill-pointer vector) new-length)
vector)
+;;; Fill in array header with the provided information, and return the array.
(defun set-array-header (array data length fill-pointer displacement dimensions
&optional displacedp)
- #!+sb-doc
- "Fills in array header with provided information. Returns array."
(setf (%array-data-vector array) data)
(setf (%array-available-elements array) length)
(cond (fill-pointer
\f
;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
-;;; Make a temporary to be used when old-data and new-data are EQ.
+;;; a temporary to be used when OLD-DATA and NEW-DATA are EQ.
;;; KLUDGE: Boy, DYNAMIC-EXTENT would be nice.
(defvar *zap-array-data-temp* (make-array 1000 :initial-element t))
(make-array length :initial-element t)))
(when initial-element-p
(unless (typep initial-element element-type)
- (error "~S cannot be used to initialize an array of type ~S."
+ (error "~S can't be used to initialize an array of type ~S."
initial-element element-type))
(fill (the simple-vector *zap-array-data-temp*) initial-element
:end length))
*zap-array-data-temp*)
-;;; This does the grinding work for ADJUST-ARRAY. It zaps the data from the
-;;; Old-Data in an arrangement specified by the Old-Dims to the New-Data in an
-;;; arrangement specified by the New-Dims. Offset is a displaced offset to be
-;;; added to computed indexes of Old-Data. New-Length, Element-Type,
-;;; Initial-Element, and Initial-Element-P are used when Old-Data and New-Data
-;;; are EQ; in this case, a temporary must be used and filled appropriately.
-;;; When Old-Data and New-Data are not EQ, New-Data has already been filled
-;;; with any specified initial-element.
+;;; This does the grinding work for ADJUST-ARRAY. It zaps the data
+;;; from the OLD-DATA in an arrangement specified by the OLD-DIMS to
+;;; the NEW-DATA in an arrangement specified by the NEW-DIMS. OFFSET
+;;; is a displaced offset to be added to computed indices of OLD-DATA.
+;;; NEW-LENGTH, ELEMENT-TYPE, INITIAL-ELEMENT, and INITIAL-ELEMENT-P
+;;; are used when OLD-DATA and NEW-DATA are EQ; in this case, a
+;;; temporary must be used and filled appropriately. When OLD-DATA and
+;;; NEW-DATA are not EQ, NEW-DATA has already been filled with any
+;;; specified initial-element.
(defun zap-array-data (old-data old-dims offset new-data new-dims new-length
element-type initial-element initial-element-p)
(declare (list old-dims new-dims))
offset)))))))
;;; Figure out the row-major-order index of an array reference from a
-;;; list of subscripts and a list of dimensions. This is for internal calls
-;;; only, and the subscripts and dim-list variables are assumed to be reversed
-;;; from what the user supplied.
+;;; list of subscripts and a list of dimensions. This is for internal
+;;; calls only, and the subscripts and dim-list variables are assumed
+;;; to be reversed from what the user supplied.
(defun row-major-index-from-dims (rev-subscripts rev-dim-list)
(do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
(rev-dim-list rev-dim-list (cdr rev-dim-list))
(t
(unless (bit-array-same-dimensions-p bit-array-1
result-bit-array)
- (error "~S and ~S do not have the same dimensions."
+ (error "~S and ~S don't have the same dimensions."
bit-array-1 result-bit-array))
result-bit-array)))
(declare (type (array bit) bit-array-1 bit-array-2)
(type (or (array bit) (member t nil)) result-bit-array))
(unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
- (error "~S and ~S do not have the same dimensions."
+ (error "~S and ~S don't have the same dimensions."
bit-array-1 bit-array-2))
(let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
(if (and (simple-bit-vector-p bit-array-1)
projects / sbcl.git / blobdiff