/[gcl]/gcl/ansi-tests/make-array.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/make-array.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by pfdietz, Thu Oct 17 13:16:56 2002 UTC revision 1.3 by pfdietz, Thu Jan 2 13:00:50 2003 UTC
# Line 8  Line 8 
8  (defun make-array-check-upgrading (type)  (defun make-array-check-upgrading (type)
9    (subtypep* type (array-element-type (make-array 0 :element-type type))))    (subtypep* type (array-element-type (make-array 0 :element-type type))))
10    
11    (defun make-array-with-checks (dimensions
12                                   &rest options
13                                   &key
14                                   (element-type t element-type-p)
15                                   (initial-contents nil intial-contents-p)
16                                   (initial-element nil initial-element-p)
17                                   (adjustable nil)
18                                   (fill-pointer nil)
19                                   (displaced-to nil)
20                                   (displaced-index-offset 0 dio-p)
21                                   &aux
22                                   (dimensions-list (if (listp dimensions)
23                                                        dimensions
24                                                      (list dimensions))))
25      "Call MAKE-ARRAY and do sanity tests on the output."
26      (let ((a (apply #'make-array dimensions options)))
27        (cond
28         ((not (typep a 'array)) :fail-not-array)
29         ((and (eq t element-type)
30               (not adjustable)
31               (not fill-pointer)
32               (not displaced-to)
33               (not (typep a 'simple-array)))
34          :fail-not-simple-array)
35         ((and (eq (length dimensions-list) 1)
36               (cond
37                ((not (typep a 'vector))
38                 :fail-not-vector)
39                ((and (subtypep 'bit element-type)
40                      (subtypep element-type 'bit)
41                      (or (not (bit-vector-p a))
42                          (not (typep a 'bit-vector))))
43                 :fail-not-bit-vector)
44                ((and (not adjustable)
45                      (not fill-pointer)
46                      (not displaced-to)
47                      (cond
48                       ((and (eq t element-type)
49                             (or (not (simple-vector-p a))
50                                 (not (typep a 'simple-vector))))
51                        :fail-not-simple-vector)
52                       ((and (subtypep 'bit element-type)
53                             (subtypep element-type 'bit)
54                             (or (not (simple-bit-vector-p a))
55                                 (not (typep a 'simple-bit-vector))))
56                        :fail-not-simple-bit-vector) ))) )))
57         ((not (equal (array-dimensions a) dimensions-list))
58          :fail-array-dimensions)
59         ((not (equal (array-rank a) (length dimensions-list)))
60          :fail-array-rank)
61         ((multiple-value-bind (sub good)
62              (subtypep element-type (array-element-type a))
63            (and good
64                 (not sub)
65                 :failed-array-element-type)))
66         ((and adjustable
67               (not (adjustable-array-p a))
68               :fail-adjustable))
69         ((and fill-pointer
70               (not (array-has-fill-pointer-p a))
71               :fail-has-fill-pointer))
72         ((and (integerp fill-pointer)
73               (not (eql fill-pointer (fill-pointer a)))
74               :fail-fill-pointer-1))
75         ((and (eq fill-pointer t)
76               (not (eql (first dimensions-list) (fill-pointer a)))
77               :fail-fill-pointer-2))
78         (t a))))
79    
80    (deftest make-array.1
81      (let ((a (make-array-with-checks 10)))
82        (and (symbolp a) a))
83      nil)
84    
85    (deftest make-array.1a
86      (let ((a (make-array-with-checks '(10))))
87        (and (symbolp a) a))
88      nil)
89    
90    (deftest make-array.2
91      (make-array-with-checks 3 :initial-element 'z)
92      #(z z z))
93    
94    (deftest make-array.2a
95      (make-array-with-checks 3 :initial-contents '(a b c))
96      #(a b c))
97    
98    (deftest make-array.2b
99      (make-array-with-checks 3 :initial-contents #(a b c))
100      #(a b c))
101    
102    (deftest make-array.2c
103      (make-array-with-checks 3 :initial-contents "abc")
104      #(#\a #\b #\c))
105    
106    (deftest make-array.2d
107      (make-array-with-checks 3 :initial-contents #*010)
108      #(0 1 0))
109    
110    (deftest make-array.3
111      (let ((a (make-array-with-checks 5 :element-type 'bit)))
112        (and (symbolp a) a))
113      nil)
114    
115    (deftest make-array.4
116      (make-array-with-checks 5 :element-type 'bit :initial-element 1)
117      #*11111)
118    
119    (deftest make-array.4a
120      (make-array-with-checks 5 :element-type 'bit :initial-contents '(1 0 0 1 0))
121      #*10010)
122    
123    (deftest make-array.4b
124      (make-array-with-checks 5 :element-type 'bit :initial-contents #(1 0 0 1 0))
125      #*10010)
126    
127    (deftest make-array.4c
128      (make-array-with-checks 5 :element-type 'bit :initial-contents #*10010)
129      #*10010)
130    
131    (deftest make-array.5
132      (let ((a (make-array-with-checks 4 :element-type 'character)))
133        (and (symbolp a) a))
134      nil)
135    
136    (deftest make-array.5a
137      (let ((a (make-array-with-checks '(4) :element-type 'character)))
138        (and (symbolp a) a))
139      nil)
140    
141    (deftest make-array.6
142      (make-array-with-checks 4 :element-type 'character
143                              :initial-element #\x)
144      "xxxx")
145    
146    (deftest make-array.6a
147      (make-array-with-checks 4 :element-type 'character
148                              :initial-contents '(#\a #\b #\c #\d))
149      "abcd")
150    
151    (deftest make-array.6b
152      (make-array-with-checks 4 :element-type 'character
153                              :initial-contents "abcd")
154      "abcd")
155    
156    (deftest make-array.7
157      (make-array-with-checks 5 :element-type 'symbol
158                              :initial-element 'a)
159      #(a a a a a))
160    
161    (deftest make-array.7a
162      (make-array-with-checks 5 :element-type 'symbol
163                              :initial-contents '(a b c d e))
164      #(a b c d e))
165    
166    (deftest make-array.7b
167      (make-array-with-checks '(5) :element-type 'symbol
168                              :initial-contents '(a b c d e))
169      #(a b c d e))
170    
171    (deftest make-array.8
172      (let ((a (make-array-with-checks 8 :element-type '(integer 0 (256)))))
173        (and (symbolp a) a))
174      nil)
175    
176    (deftest make-array.8a
177      (make-array-with-checks 8 :element-type '(integer 0 (256))
178                              :initial-element 9)
179      #(9 9 9 9 9 9 9 9))
180    
181    (deftest make-array.8b
182      (make-array-with-checks '(8) :element-type '(integer 0 (256))
183                              :initial-contents '(4 3 2 1 9 8 7 6))
184      #(4 3 2 1 9 8 7 6))
185    
186    ;;; Zero dimensional arrays
187    
188    (deftest make-array.9
189      (let ((a (make-array-with-checks nil)))
190        (and (symbolp a) a))
191      nil)
192    
193    (deftest make-array.10
194      (make-array-with-checks nil :initial-element 1)
195      #0A1)
196    
197    (deftest make-array.11
198      (make-array-with-checks nil :initial-contents 2)
199      #0A2)
200    
201    (deftest make-array.12
202      (make-array-with-checks nil :element-type 'bit :initial-contents 1)
203      #0A1)
204    
205    (deftest make-array.13
206      (make-array-with-checks nil :element-type t :initial-contents 'a)
207      #0Aa)
208    
209    
210    
211    
212    
213    
214    
215    

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26