X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=e5647cdda008b61ed34093f48a2b19eaeeedbc5f;hb=b5703d98da9ebfd688c87e14862ab4e26dc94d14;hp=f3ee81bc8a0044266f69c43bda6de6181792328b;hpb=3bd7a97d1b11a2b0aee086ef211cae807f3dfc35;p=sbcl.git

diff --git a/src/code/array.lisp b/src/code/array.lisp
index f3ee81b..e5647cd 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -46,42 +46,16 @@
 	   (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"))
 
 ;;;; MAKE-ARRAY
 
@@ -646,6 +620,11 @@
 	     :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
@@ -665,10 +644,35 @@
 (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))