0.pre7.20:

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

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 4f03dfc..e5647cd 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -17,8 +17,8 @@
 \f
 ;;;; miscellaneous accessor functions
 
 \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)
 (macrolet ((def-frob (name)
             `(progn
                (defun ,name (array)

@@ -46,43 +46,16 @@
           (fixnum index))
   (%check-bound array bound index))
 
           (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)
 (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
 
 \f
 ;;;; MAKE-ARRAY
 

@@ -97,11 +70,11 @@
 
 ;;; These functions are used in the implementation of MAKE-ARRAY for
 ;;; complex arrays. There are lots of transforms to simplify
 
 ;;; 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.
 (defun %vector-type-code (type)
   (case type
     ;; Pick off some easy common cases.

@@ -175,8 +148,6 @@
                              (initial-element nil initial-element-p)
                              initial-contents adjustable fill-pointer
                              displaced-to displaced-index-offset)
                              (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)
   (let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
         (array-rank (length (the list dimensions)))
         (simple (and (null fill-pointer)

@@ -561,14 +532,14 @@
 
 (defun array-rank (array)
   #!+sb-doc
 
 (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
   (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)
   (declare (array array) (type index axis-number))
   (cond ((not (array-header-p array))
         (unless (= axis-number 0)

@@ -582,7 +553,7 @@
 
 (defun array-dimensions (array)
   #!+sb-doc
 
 (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))
   (declare (array array))
   (if (array-header-p array)
       (do ((results nil (cons (array-dimension array index) results))

@@ -592,7 +563,7 @@
 
 (defun array-total-size (array)
   #!+sb-doc
 
 (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)
   (declare (array array))
   (if (array-header-p array)
       (%array-available-elements array)

@@ -600,14 +571,17 @@
 
 (defun array-displacement (array)
   #!+sb-doc
 
 (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
 
 (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)))
    to the argument, this happens for complex arrays."
   (declare (array array))
   (not (typep array 'simple-array)))

@@ -616,41 +590,46 @@
 
 (defun array-has-fill-pointer-p (array)
   #!+sb-doc
 
 (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
   (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))
   (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))
             :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))
        (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))))
 
             :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
 (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)))
    returned."
   (declare (vector array))
   (let ((fill-pointer (fill-pointer array)))

@@ -665,10 +644,35 @@
 (defun vector-push-extend (new-element
                           vector
                           &optional
 (defun vector-push-extend (new-element
                           vector
                           &optional

-                          (extension (1+ (length vector))))
+                          (extension nil extension-p))

   #!+sb-doc
   #!+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))
   (declare (vector vector) (fixnum extension))
   (let ((fill-pointer (fill-pointer vector)))
     (declare (fixnum fill-pointer))

@@ -680,7 +684,7 @@
 
 (defun vector-pop (array)
   #!+sb-doc
 
 (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))
    pointer to by the new fill pointer. If the original value of the fill
    pointer is 0, an error occurs."
   (declare (vector array))

@@ -713,9 +717,9 @@
       (when (and fill-pointer (> array-rank 1))
        (error "Multidimensional arrays can't have fill pointers."))
       (cond (initial-contents
       (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)
             (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
                 the :INITIAL-ELEMENT or :DISPLACED-TO option."))
             (let* ((array-size (apply #'* dimensions))
                    (array-data (data-vector-from-inits

@@ -728,13 +732,13 @@
                                                       fill-pointer)
                                 0 dimensions nil)
                   (if (array-header-p array)
                                                       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
                       (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."))
             (when initial-element
               (error "The :INITIAL-ELEMENT option may not be specified ~
                      with :DISPLACED-TO."))

@@ -825,7 +829,7 @@
        ((numberp fill-pointer)
         (when (> fill-pointer new-array-size)
           (error "can't supply a value for :FILL-POINTER (~S) that is larger ~
        ((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)
                  fill-pointer new-array-size))
         fill-pointer)
        ((eq fill-pointer t)

@@ -834,10 +838,9 @@
         (error "bogus value for :FILL-POINTER in ADJUST-ARRAY: ~S"
                fill-pointer))))
 
         (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)
 (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)
   (declare (vector vector))
   (unless (array-header-p vector)
     (macrolet ((frob (name &rest things)

@@ -877,10 +880,9 @@
   (setf (%array-fill-pointer vector) new-length)
   vector)
 
   (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)
 (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
   (setf (%array-data-vector array) data)
   (setf (%array-available-elements array) length)
   (cond (fill-pointer

@@ -900,7 +902,7 @@
 \f
 ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
 
 \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))
 
 ;;; KLUDGE: Boy, DYNAMIC-EXTENT would be nice.
 (defvar *zap-array-data-temp* (make-array 1000 :initial-element t))
 

@@ -918,14 +920,15 @@
          :end length))
   *zap-array-data-temp*)
 
          :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))
 (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))

@@ -963,9 +966,9 @@
                       offset)))))))
 
 ;;; Figure out the row-major-order index of an array reference from a
                       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))
 (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))