\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
;;; 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.
+;;; 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-type-code (type)
(case type
;; Pick off some easy common cases.
(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)
(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."
+ "Returns 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)
(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)))
(defun vector-push-extend (new-element
vector
&optional
- (extension (1+ (length vector))))
+ (extension nil extension-p))
#!+sb-doc
- "Like Vector-Push except that if the fill pointer gets too large, the
- Vector is extended rather than Nil being returned."
+ "This is like VECTOR-PUSH except that if the fill pointer gets too
+ large, VECTOR is extended to allow the push to work."
+ (declare (type vector vector))
+ (let ((old-fill-pointer (fill-pointer vector)))
+ (declare (type index old-fill-pointer))
+ (when (= old-fill-pointer (%array-available-elements vector))
+ (adjust-array vector (+ old-fill-pointer
+ (if extension-p
+ (the (integer 1 #.most-positive-fixnum)
+ extension)
+ (1+ old-fill-pointer)))))
+ (setf (%array-fill-pointer vector)
+ (1+ old-fill-pointer))
+ ;; Wrapping the type test and the AREF in the same WITH-ARRAY-DATA
+ ;; saves some time.
+ (with-array-data ((v vector) (i old-fill-pointer) (end)
+ :force-inline t)
+ (declare (ignore end) (optimize (safety 0)))
+ (if (simple-vector-p v) ; if common special case
+ (setf (aref v i) new-element)
+ (setf (aref v i) new-element)))
+ old-fill-pointer))
+
+(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))
(defun vector-pop (array)
#!+sb-doc
- "Attempts to decrease the fill-pointer by 1 and return the element
+ "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."
(declare (vector array))
(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 ~
+ (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
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."))
((numberp fill-pointer)
(when (> fill-pointer new-array-size)
(error "can't supply a value for :FILL-POINTER (~S) that is larger ~
- than the new length of the vector (~S)."
+ than the new length of the vector (~S)"
fill-pointer new-array-size))
fill-pointer)
((eq fill-pointer t)
(error "bogus value for :FILL-POINTER in ADJUST-ARRAY: ~S"
fill-pointer))))
+;;; 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)
- #!+sb-doc
- "Destructively alter VECTOR, changing its length to NEW-LENGTH, which
- must be less than or equal to its current length."
(declare (vector vector))
(unless (array-header-p vector)
(macrolet ((frob (name &rest things)
(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))
: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))
projects / sbcl.git / blobdiff