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

(in-package :cl-test)

(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))))