source: trunk/source/tests/ansi-tests/array-aux.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 6.6 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Tue Jan 21 05:11:31 2003
4;;;; Contains: Auxiliary functions for array tests
5
6(in-package :cl-test)
7
8(defun make-array-check-upgrading (type)
9  (subtypep* type (array-element-type (make-array 0 :element-type type))))
10
11(defun subtypep-or-unknown (subtype supertype)
12  (multiple-value-bind* (is-subtype is-known)
13      (subtypep subtype supertype)
14    (or (not is-known) (notnot is-subtype))))
15
16(defun make-array-with-checks (dimensions
17                               &rest options
18                               &key
19                               (element-type t element-type-p)
20                               (initial-contents nil initial-contents-p)
21                               (initial-element nil initial-element-p)
22                               (adjustable nil)
23                               (fill-pointer nil)
24                               (displaced-to nil)
25                               (displaced-index-offset 0 dio-p)
26                               &aux
27                               (dimensions-list (if (listp dimensions)
28                                                    dimensions
29                                                  (list dimensions))))
30  "Call MAKE-ARRAY and do sanity tests on the output."
31  (declare (ignore element-type-p initial-contents initial-contents-p
32                   initial-element initial-element-p dio-p))
33  (let ((a (check-values (apply #'make-array dimensions options)))
34        (rank (length dimensions-list)))
35    (cond
36
37     ((not (typep a 'array))
38      :fail-not-array)
39     ((not (typep a (find-class 'array)))
40      :fail-not-array-class)
41     ((not (typep a '(array *)))
42      :fail-not-array2)
43     ((not (typep a `(array * ,dimensions-list)))
44      :fail-not-array3)
45     ((not (typep a `(array * *)))
46      :fail-not-array4)
47     ((not (typep a `(array ,element-type)))
48      :fail-not-array5)
49     ((not (typep a `(array ,element-type *)))
50      :fail-not-array6)
51     
52;     #-gcl
53     ((not (typep a `(array ,element-type ,rank)))
54      :fail-not-array7)
55
56     ((not (typep a `(array ,element-type ,dimensions-list)))
57      :fail-not-array8)
58
59     ((not (typep a `(array ,element-type ,(mapcar (constantly '*)
60                                                   dimensions-list))))
61      :fail-not-array9)
62
63     ((loop for i from 0 below (min 10 rank)
64            thereis
65            (let ((x (append (subseq dimensions-list 0 i)
66                             (list '*)
67                             (subseq dimensions-list (1+ i)))))
68              (or (not (typep a `(array * ,x)))
69                  (not (typep a `(array ,element-type ,x))))))
70      :fail-not-array10)
71
72     ((not (check-values (arrayp a))) :fail-not-arrayp)
73
74     ((and ;; (eq t element-type)
75           (not adjustable)
76           (not fill-pointer)
77           (not displaced-to)
78           (cond
79            ((not (typep a 'simple-array))
80             :fail-not-simple-array)
81            ((not (typep a '(simple-array *)))
82             :fail-not-simple-array2)
83            ((not (typep a `(simple-array * ,dimensions-list)))
84             :fail-not-simple-array3)
85            ((not (typep a `(simple-array * *)))
86             :fail-not-simple-array4)
87            ((not (typep a `(simple-array ,element-type)))
88             :fail-not-simple-array5)
89            ((not (typep a `(simple-array ,element-type *)))
90             :fail-not-simple-array6)
91            #-gcl
92            ((not (typep a `(simple-array ,element-type
93                                          ,rank)))
94             :fail-not-array7)
95            ((not (typep a `(simple-array ,element-type ,dimensions-list)))
96             :fail-not-simple-array8)
97            ((not (typep a `(simple-array ,element-type
98                                          ,(mapcar (constantly '*)
99                                                   dimensions-list))))
100             :fail-not-simple-array9)
101            )))
102
103     ;; If the array is a vector, check that...
104     ((and (eql rank 1)
105           (cond
106            ;; ...It's in type vector
107            ((not (typep a 'vector))
108             :fail-not-vector)
109            ;; ...If the element type is a subtype of BIT, then it's a
110            ;; bit vector...
111            ((and (subtypep 'bit element-type)
112                  (subtypep element-type 'bit)
113                  (or (not (bit-vector-p a))
114                      (not (typep a 'bit-vector))))
115             :fail-not-bit-vector)
116            ;; ...If not adjustable, fill pointered, or displaced,
117            ;; then it's a simple vector or simple bit vector
118            ;; (if the element-type is appropriate)
119            ((and (not adjustable)
120                  (not fill-pointer)
121                  (not displaced-to)
122                  (cond
123                   ((and (eq t element-type)
124                         (or (not (simple-vector-p a))
125                             (not (typep a 'simple-vector))))
126                    :fail-not-simple-vector)
127                   ((and (subtypep 'bit element-type)
128                         (subtypep element-type 'bit)
129                         (or (not (simple-bit-vector-p a))
130                             (not (typep a 'simple-bit-vector))))
131                    :fail-not-simple-bit-vector) ))) )))
132
133     ;; The dimensions of the array must be initialized properly
134     ((not (equal (array-dimensions a) dimensions-list))
135      :fail-array-dimensions)
136
137     ;; The rank of the array must equal the number of dimensions
138     ((not (equal (array-rank a) rank))
139      :fail-array-rank)
140
141     ;; Arrays other than vectors cannot have fill pointers
142     ((and (not (equal (array-rank a) 1))
143           (array-has-fill-pointer-p a))
144      :fail-non-vector-fill-pointer)
145
146     ;; The actual element type must be a supertype of the element-type
147     ;; argument
148     ((not (subtypep-or-unknown element-type (array-element-type a)))
149      :failed-array-element-type)
150
151     ;; If :adjustable is given, the array must be adjustable.
152     ((and adjustable
153           (not (check-values (adjustable-array-p a)))
154           :fail-adjustable))
155
156     ;; If :fill-pointer is given, the array must have a fill pointer
157     ((and fill-pointer
158           (not (check-values (array-has-fill-pointer-p a)))
159           :fail-has-fill-pointer))
160
161     ;; If the fill pointer is given as an integer, it must be the value
162     ;; of the fill pointer of the new array
163     ((and (check-values (integerp fill-pointer))
164           (not (eql fill-pointer (check-values (fill-pointer a))))
165           :fail-fill-pointer-1))
166
167     ;; If the fill-pointer argument is t, the fill pointer must be
168     ;; set to the vector size.
169     ((and (eq fill-pointer t)
170           (not (eql (first dimensions-list) (fill-pointer a)))
171           :fail-fill-pointer-2))
172
173     ;; If displaced-to another array, check that this is proper
174     ((and
175       displaced-to
176       (multiple-value-bind* (actual-dt actual-dio)
177           (array-displacement a)
178         (cond
179          ((not (eq actual-dt displaced-to))
180           :fail-displacement-1)
181          ((not (eql actual-dio displaced-index-offset))
182           :fail-displaced-index-offset)))))
183
184     ;; Test of array-total-size
185     ((not (eql (check-values (array-total-size a))
186                (reduce #'* dimensions-list :initial-value 1)))
187      :fail-array-total-size)
188
189     ;; Test array-row-major-index on all zeros
190     ((and (> (array-total-size a) 0)
191           (not (eql (check-values
192                      (apply #'array-row-major-index
193                             a (make-list (array-rank a) :initial-element 0)))
194                     0)))
195      :fail-array-row-major-index-0)
196
197     ;; For the last entry
198     ((and (> (array-total-size a) 0)
199           (not (eql (apply #'array-row-major-index
200                            a (mapcar #'1- dimensions-list))
201                     (1- (reduce #'* dimensions-list :initial-value 1)))))
202      :fail-array-row-major-index-last)
203
204     ;; No problems -- return the array
205     (t a))))
Note: See TracBrowser for help on using the repository browser.