(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
: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
(defun vector-push-extend (new-element
vector
&optional
- (extension (1+ (length vector))))
+ (extension nil extension-p))
#!+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."
+ "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))
projects / sbcl.git / blobdiff