\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 (except when DEFTRANSFORM
-;;; %WITH-ARRAY-DATA takes over)
(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
;; and for all in any reasonable user programs.)
((t)
(values #.sb!vm:simple-vector-type #.sb!vm:word-bits))
- ((character base-char)
+ ((character base-char standard-char)
(values #.sb!vm:simple-string-type #.sb!vm:byte-bits))
((bit)
(values #.sb!vm:simple-bit-vector-type 1))
;; OK, we have to wade into SUBTYPEPing after all.
(t
- (pick-type type
+ ;; FIXME: The data here are redundant with
+ ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
+ (pick-vector-type type
(base-char (values #.sb!vm:simple-string-type #.sb!vm:byte-bits))
(bit (values #.sb!vm:simple-bit-vector-type 1))
((unsigned-byte 2)
#.sb!vm:complex-bit-vector-type)
;; OK, we have to wade into SUBTYPEPing after all.
(t
- (pick-type type
+ (pick-vector-type type
(base-char #.sb!vm:complex-string-type)
(bit #.sb!vm:complex-bit-vector-type)
(t #.sb!vm:complex-vector-type)))))
(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)
(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)
(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)))
: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
"Attempt to set the element of ARRAY designated by its fill pointer
vector
&optional
(extension (1+ (length vector))))
- #!+sb-doc
- "This is like Vector-Push except that if the fill pointer gets too
- large, the Vector is extended rather than Nil being returned."
(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
- 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))
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 "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)
`(etypecase ,name
- ,@(mapcar #'(lambda (thing)
- `(,(car thing)
- (fill (truly-the ,(car thing) ,name)
- ,(cadr thing)
- :start new-length)))
+ ,@(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)
(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
projects / sbcl.git / blobdiff