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

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

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

revision 1.2 by pfdietz, Wed Jan 22 04:26:22 2003 UTC revision 1.3 by pfdietz, Fri Jan 24 04:22:54 2003 UTC
# Line 9  Line 9 
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 subtypep-or-unknown (subtype supertype)  (defun subtypep-or-unknown (subtype supertype)
12    (multiple-value-bind (is-subtype is-known)    (multiple-value-bind* (is-subtype is-known)
13        (subtypep subtype supertype)        (subtypep subtype supertype)
14      (or (not is-known) (notnot is-subtype))))      (or (not is-known) (notnot is-subtype))))
15    
# Line 30  Line 30 
30    "Call MAKE-ARRAY and do sanity tests on the output."    "Call MAKE-ARRAY and do sanity tests on the output."
31    (declare (ignore element-type-p initial-contents initial-contents-p    (declare (ignore element-type-p initial-contents initial-contents-p
32                     initial-element initial-element-p dio-p))                     initial-element initial-element-p dio-p))
33    (let ((a (apply #'make-array dimensions options)))    (let ((a (check-values (apply #'make-array dimensions options))))
34      (cond      (cond
35       ((not (typep a 'array)) :fail-not-array)       ((not (typep a 'array)) :fail-not-array)
36       ((not (arrayp a)) :fail-not-arrayp)       ((not (check-values (arrayp a))) :fail-not-arrayp)
37    
38       ((and (eq t element-type)       ((and (eq t element-type)
39             (not adjustable)             (not adjustable)
# Line 92  Line 92 
92    
93       ;; If :adjustable is given, the array must be adjustable.       ;; If :adjustable is given, the array must be adjustable.
94       ((and adjustable       ((and adjustable
95             (not (adjustable-array-p a))             (not (check-values (adjustable-array-p a)))
96             :fail-adjustable))             :fail-adjustable))
97    
98       ;; If :fill-pointer is given, the array must have a fill pointer       ;; If :fill-pointer is given, the array must have a fill pointer
99       ((and fill-pointer       ((and fill-pointer
100             (not (array-has-fill-pointer-p a))             (not (check-values (array-has-fill-pointer-p a)))
101             :fail-has-fill-pointer))             :fail-has-fill-pointer))
102    
103       ;; If the fill pointer is given as an integer, it must be the value       ;; If the fill pointer is given as an integer, it must be the value
104       ;; of the fill pointer of the new array       ;; of the fill pointer of the new array
105       ((and (integerp fill-pointer)       ((and (check-values (integerp fill-pointer))
106             (not (eql fill-pointer (fill-pointer a)))             (not (eql fill-pointer (check-values (fill-pointer a))))
107             :fail-fill-pointer-1))             :fail-fill-pointer-1))
108    
109       ;; If the fill-pointer argument is t, the fill pointer must be       ;; If the fill-pointer argument is t, the fill pointer must be
# Line 115  Line 115 
115       ;; If displaced-to another array, check that this is proper       ;; If displaced-to another array, check that this is proper
116       ((and       ((and
117         displaced-to         displaced-to
118         (multiple-value-bind (actual-dt actual-dio)         (multiple-value-bind* (actual-dt actual-dio)
119             (array-displacement a)             (array-displacement a)
120           (cond           (cond
121            ((not (eq actual-dt displaced-to))            ((not (eq actual-dt displaced-to))
# Line 124  Line 124 
124             :fail-displaced-index-offset)))))             :fail-displaced-index-offset)))))
125    
126       ;; Test of array-total-size       ;; Test of array-total-size
127       ((not (eql (array-total-size a)       ((not (eql (check-values (array-total-size a))
128                  (reduce #'* dimensions-list :initial-value 1)))                  (reduce #'* dimensions-list :initial-value 1)))
129        :fail-array-total-size)        :fail-array-total-size)
130    
131       ;; Test array-row-major-index on all zeros       ;; Test array-row-major-index on all zeros
132       ((and (> (array-total-size a) 0)       ((and (> (array-total-size a) 0)
133             (not (eql (apply #'array-row-major-index             (not (eql (check-values
134                              a (make-list (array-rank a) :initial-element 0))                        (apply #'array-row-major-index
135                                 a (make-list (array-rank a) :initial-element 0)))
136                       0)))                       0)))
137        :fail-array-row-major-index-0)        :fail-array-row-major-index-0)
138    

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