array-aux.lsp 7.83 KB
Newer Older
pfdietz's avatar
pfdietz committed
1 2 3 4 5
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Tue Jan 21 05:11:31 2003
;;;; Contains: Auxiliary functions for array tests

6

pfdietz's avatar
pfdietz committed
7 8 9 10 11

(defun make-array-check-upgrading (type)
  (subtypep* type (array-element-type (make-array 0 :element-type type))))

(defun subtypep-or-unknown (subtype supertype)
12
  (multiple-value-bind* (is-subtype is-known)
pfdietz's avatar
pfdietz committed
13 14 15 16
      (subtypep subtype supertype)
    (or (not is-known) (notnot is-subtype))))

(defun make-array-with-checks (dimensions
sds's avatar
sds committed
17 18 19 20 21 22 23 24 25 26 27 28 29
                               &rest options
                               &key
                               (element-type t element-type-p)
                               (initial-contents nil initial-contents-p)
                               (initial-element nil initial-element-p)
                               (adjustable nil)
                               (fill-pointer nil)
                               (displaced-to nil)
                               (displaced-index-offset 0 dio-p)
                               &aux
                               (dimensions-list (if (listp dimensions)
                                                    dimensions
                                                  (list dimensions))))
pfdietz's avatar
pfdietz committed
30 31
  "Call MAKE-ARRAY and do sanity tests on the output."
  (declare (ignore element-type-p initial-contents initial-contents-p
sds's avatar
sds committed
32
                   initial-element initial-element-p dio-p))
33
  (let ((a (check-values (apply #'make-array dimensions options)))
sds's avatar
sds committed
34
        (rank (length dimensions-list)))
pfdietz's avatar
pfdietz committed
35
    (cond
36 37 38

     ((not (typep a 'array))
      :fail-not-array)
39 40
     ((not (typep a (find-class 'array)))
      :fail-not-array-class)
41 42 43 44 45 46 47 48 49 50
     ((not (typep a '(array *)))
      :fail-not-array2)
     ((not (typep a `(array * ,dimensions-list)))
      :fail-not-array3)
     ((not (typep a `(array * *)))
      :fail-not-array4)
     ((not (typep a `(array ,element-type)))
      :fail-not-array5)
     ((not (typep a `(array ,element-type *)))
      :fail-not-array6)
sds's avatar
sds committed
51

52
;     #-gcl
53
     ((not (typep a `(array ,element-type ,rank)))
54 55 56 57 58 59
      :fail-not-array7)

     ((not (typep a `(array ,element-type ,dimensions-list)))
      :fail-not-array8)

     ((not (typep a `(array ,element-type ,(mapcar (constantly '*)
sds's avatar
sds committed
60
                                                   dimensions-list))))
61 62
      :fail-not-array9)

63
     ((loop for i from 0 below (min 10 rank)
sds's avatar
sds committed
64 65 66 67 68 69
            thereis
            (let ((x (append (subseq dimensions-list 0 i)
                             (list '*)
                             (subseq dimensions-list (1+ i)))))
              (or (not (typep a `(array * ,x)))
                  (not (typep a `(array ,element-type ,x))))))
70 71
      :fail-not-array10)

72
     ((not (check-values (arrayp a))) :fail-not-arrayp)
pfdietz's avatar
pfdietz committed
73

74
     ((and ;; (eq t element-type)
sds's avatar
sds committed
75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101
           (not adjustable)
           (not fill-pointer)
           (not displaced-to)
           (cond
            ((not (typep a 'simple-array))
             :fail-not-simple-array)
            ((not (typep a '(simple-array *)))
             :fail-not-simple-array2)
            ((not (typep a `(simple-array * ,dimensions-list)))
             :fail-not-simple-array3)
            ((not (typep a `(simple-array * *)))
             :fail-not-simple-array4)
            ((not (typep a `(simple-array ,element-type)))
             :fail-not-simple-array5)
            ((not (typep a `(simple-array ,element-type *)))
             :fail-not-simple-array6)
            #-gcl
            ((not (typep a `(simple-array ,element-type
                                          ,rank)))
             :fail-not-array7)
            ((not (typep a `(simple-array ,element-type ,dimensions-list)))
             :fail-not-simple-array8)
            ((not (typep a `(simple-array ,element-type
                                          ,(mapcar (constantly '*)
                                                   dimensions-list))))
             :fail-not-simple-array9)
            )))
pfdietz's avatar
pfdietz committed
102 103

     ;; If the array is a vector, check that...
sds's avatar
sds committed
104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131
     ((and (eql rank 1)
           (cond
            ;; ...It's in type vector
            ((not (typep a 'vector))
             :fail-not-vector)
            ;; ...If the element type is a subtype of BIT, then it's a
            ;; bit vector...
            ((and (subtypep 'bit element-type)
                  (subtypep element-type 'bit)
                  (or (not (bit-vector-p a))
                      (not (typep a 'bit-vector))))
             :fail-not-bit-vector)
            ;; ...If not adjustable, fill pointered, or displaced,
            ;; then it's a simple vector or simple bit vector
            ;; (if the element-type is appropriate)
            ((and (not adjustable)
                  (not fill-pointer)
                  (not displaced-to)
                  (cond
                   ((and (eq t element-type)
                         (or (not (simple-vector-p a))
                             (not (typep a 'simple-vector))))
                    :fail-not-simple-vector)
                   ((and (subtypep 'bit element-type)
                         (subtypep element-type 'bit)
                         (or (not (simple-bit-vector-p a))
                             (not (typep a 'simple-bit-vector))))
                    :fail-not-simple-bit-vector) ))) )))
pfdietz's avatar
pfdietz committed
132 133 134 135 136 137

     ;; The dimensions of the array must be initialized properly
     ((not (equal (array-dimensions a) dimensions-list))
      :fail-array-dimensions)

     ;; The rank of the array must equal the number of dimensions
138
     ((not (equal (array-rank a) rank))
pfdietz's avatar
pfdietz committed
139 140 141 142
      :fail-array-rank)

     ;; Arrays other than vectors cannot have fill pointers
     ((and (not (equal (array-rank a) 1))
sds's avatar
sds committed
143
           (array-has-fill-pointer-p a))
pfdietz's avatar
pfdietz committed
144 145 146 147 148 149 150 151 152
      :fail-non-vector-fill-pointer)

     ;; The actual element type must be a supertype of the element-type
     ;; argument
     ((not (subtypep-or-unknown element-type (array-element-type a)))
      :failed-array-element-type)

     ;; If :adjustable is given, the array must be adjustable.
     ((and adjustable
sds's avatar
sds committed
153 154
           (not (check-values (adjustable-array-p a)))
           :fail-adjustable))
pfdietz's avatar
pfdietz committed
155 156 157

     ;; If :fill-pointer is given, the array must have a fill pointer
     ((and fill-pointer
sds's avatar
sds committed
158 159
           (not (check-values (array-has-fill-pointer-p a)))
           :fail-has-fill-pointer))
pfdietz's avatar
pfdietz committed
160 161 162

     ;; If the fill pointer is given as an integer, it must be the value
     ;; of the fill pointer of the new array
163
     ((and (check-values (integerp fill-pointer))
sds's avatar
sds committed
164 165
           (not (eql fill-pointer (check-values (fill-pointer a))))
           :fail-fill-pointer-1))
pfdietz's avatar
pfdietz committed
166 167 168 169

     ;; If the fill-pointer argument is t, the fill pointer must be
     ;; set to the vector size.
     ((and (eq fill-pointer t)
sds's avatar
sds committed
170 171
           (not (eql (first dimensions-list) (fill-pointer a)))
           :fail-fill-pointer-2))
pfdietz's avatar
pfdietz committed
172 173 174 175

     ;; If displaced-to another array, check that this is proper
     ((and
       displaced-to
176
       (multiple-value-bind* (actual-dt actual-dio)
sds's avatar
sds committed
177 178 179 180 181 182
           (array-displacement a)
         (cond
          ((not (eq actual-dt displaced-to))
           :fail-displacement-1)
          ((not (eql actual-dio displaced-index-offset))
           :fail-displaced-index-offset)))))
pfdietz's avatar
pfdietz committed
183

pfdietz's avatar
pfdietz committed
184
     ;; Test of array-total-size
185
     ((not (eql (check-values (array-total-size a))
sds's avatar
sds committed
186
                (reduce #'* dimensions-list :initial-value 1)))
pfdietz's avatar
pfdietz committed
187 188 189 190
      :fail-array-total-size)

     ;; Test array-row-major-index on all zeros
     ((and (> (array-total-size a) 0)
sds's avatar
sds committed
191 192 193 194
           (not (eql (check-values
                      (apply #'array-row-major-index
                             a (make-list (array-rank a) :initial-element 0)))
                     0)))
pfdietz's avatar
pfdietz committed
195 196 197 198
      :fail-array-row-major-index-0)

     ;; For the last entry
     ((and (> (array-total-size a) 0)
sds's avatar
sds committed
199 200 201
           (not (eql (apply #'array-row-major-index
                            a (mapcar #'1- dimensions-list))
                     (1- (reduce #'* dimensions-list :initial-value 1)))))
pfdietz's avatar
pfdietz committed
202 203
      :fail-array-row-major-index-last)

pfdietz's avatar
pfdietz committed
204
     ;; No problems -- return the array
pfdietz's avatar
pfdietz committed
205
     (t a))))