don't check SUBTYPEP of ELEMENT-TYPE in ADJUST-ARRAY unnecessarily

[sbcl.git] / src / code / array.lisp

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 55c172d..90b7a99 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -339,9 +339,30 @@ of specialized arrays is supported."
                        (svref ,',table-name tag)))))))
   (def !find-data-vector-setter %%data-vector-setters%%)
   (def !find-data-vector-setter/check-bounds %%data-vector-setters/check-bounds%%)
-  (def !find-data-vector-reffer %%data-vector-reffers%%)
+  ;; Used by DO-VECTOR-DATA -- which in turn appears in DOSEQUENCE expansion,
+  ;; meaning we can have post-build dependences on this.
+  (def %find-data-vector-reffer %%data-vector-reffers%%)
   (def !find-data-vector-reffer/check-bounds %%data-vector-reffers/check-bounds%%))
 
+;;; Like DOVECTOR, but more magical -- can't use this on host.
+(defmacro do-vector-data ((elt vector &optional result) &body body)
+  (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+    (with-unique-names (index vec start end ref)
+      `(with-array-data ((,vec ,vector)
+                         (,start)
+                         (,end)
+                         :check-fill-pointer t)
+         (let ((,ref (%find-data-vector-reffer ,vec)))
+           (do ((,index ,start (1+ ,index)))
+               ((>= ,index ,end)
+                (let ((,elt nil))
+                  ,@(filter-dolist-declarations decls)
+                  ,elt
+                  ,result))
+             (let ((,elt (funcall ,ref ,vec ,index)))
+               ,@decls
+               (tagbody ,@forms))))))))
+
 (macrolet ((%ref (accessor-getter extra-params)
              `(funcall (,accessor-getter array) array index ,@extra-params))
            (define (accessor-name slow-accessor-name accessor-getter
@@ -375,7 +396,7 @@ of specialized arrays is supported."
                         (declare (ignore end))
                         (,accessor-name vector index ,@extra-params)))))))
   (define hairy-data-vector-ref slow-hairy-data-vector-ref
-    !find-data-vector-reffer
+    %find-data-vector-reffer
     nil (progn))
   (define hairy-data-vector-set slow-hairy-data-vector-set
     !find-data-vector-setter
@@ -815,18 +836,17 @@ of specialized arrays is supported."
            (setf (%array-fill-pointer array) (1+ fill-pointer))
            fill-pointer))))
 
-(defun vector-push-extend (new-element
-                           vector
-                           &optional
-                           (min-extension
-                            (let ((length (length vector)))
-                              (min (1+ length)
-                                   (- array-dimension-limit length)))))
-  (declare (fixnum min-extension))
+(defun vector-push-extend (new-element vector &optional min-extension)
+  (declare (type (or null fixnum) min-extension))
   (let ((fill-pointer (fill-pointer vector)))
     (declare (fixnum fill-pointer))
     (when (= fill-pointer (%array-available-elements vector))
-      (adjust-array vector (+ fill-pointer (max 1 min-extension))))
+      (let ((min-extension
+             (or min-extension
+                 (let ((length (length vector)))
+                   (min (1+ length)
+                        (- array-dimension-limit length))))))
+        (adjust-array vector (+ fill-pointer (max 1 min-extension)))))
     ;; disable bounds checking
     (locally (declare (optimize (safety 0)))
       (setf (aref vector fill-pointer) new-element))
@@ -851,7 +871,7 @@ of specialized arrays is supported."
 ;;;; ADJUST-ARRAY
 
 (defun adjust-array (array dimensions &key
-                           (element-type (array-element-type array))
+                           (element-type (array-element-type array) element-type-p)
                            (initial-element nil initial-element-p)
                            (initial-contents nil initial-contents-p)
                            fill-pointer
@@ -864,7 +884,8 @@ of specialized arrays is supported."
     (cond ((/= (the fixnum (length (the list dimensions)))
                (the fixnum (array-rank array)))
            (error "The number of dimensions not equal to rank of array."))
-          ((not (subtypep element-type (array-element-type array)))
+          ((and element-type-p
+                (not (subtypep element-type (array-element-type array))))
            (error "The new element type, ~S, is incompatible with old type."
                   element-type))
           ((and fill-pointer (not (array-has-fill-pointer-p array)))