dyndebug_init: fix gencgc_verbose handling.
[sbcl.git] / tests / array.pure.lisp
blobab4b5fe31edcbed82105f733c6727b3da304e97f
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
6 ;;;; from CMU CL.
7 ;;;;
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
12 (in-package :cl-user)
14 (load "compiler-test-util.lisp")
16 ;;; Array initialization has complicated defaulting for :ELEMENT-TYPE,
17 ;;; and both compile-time and run-time logic takes a whack at it.
18 (with-test (:name (make-array :element-type :bug-126))
19 (let ((testcases '(;; Bug 126, confusion between high-level default string
20 ;; initial element #\SPACE and low-level default array
21 ;; element #\NULL, is gone.
22 (#\null (make-array 11 :element-type 'character) simple-string)
23 (#\space (make-string 11 :initial-element #\space) string)
24 (#\* (make-string 11 :initial-element #\*))
25 (#\null (make-string 11))
26 (#\null (make-string 11 :initial-element #\null))
27 (#\x (make-string 11 :initial-element #\x))
28 ;; And the other tweaks made when fixing bug 126 didn't
29 ;; mess things up too badly either.
30 (0 (make-array 11) simple-vector)
31 (nil (make-array 11 :initial-element nil))
32 (12 (make-array 11 :initial-element 12))
33 (0 (make-array 11 :element-type '(unsigned-byte 4)) (simple-array (unsigned-byte 4) (*)))
34 (12 (make-array 11
35 :element-type '(unsigned-byte 4)
36 :initial-element 12)))))
37 (dolist (testcase testcases)
38 (destructuring-bind (expected-result form &optional type) testcase
39 (unless (eql expected-result (aref (eval form) 3))
40 (error "expected ~S in EVAL ~S" expected-result form))
41 (unless (eql expected-result
42 (aref (funcall (checked-compile `(lambda () ,form)
43 :allow-warnings t))
44 3))
45 (error "expected ~S in FUNCALL COMPILE ~S" expected-result form))
46 ;; also do some testing of compilation and verification that
47 ;; errors are thrown appropriately.
48 (unless (eql expected-result
49 (funcall (checked-compile `(lambda () (aref ,form 3))
50 :allow-warnings t)))
51 (error "expected ~S in COMPILED-AREF ~S" expected-result form))
52 (when type
53 (unless (eql expected-result
54 (funcall (checked-compile `(lambda ()
55 (let ((x ,form))
56 (declare (type ,type x))
57 (aref x 3)))
58 :allow-warnings t)))
59 (error "expected ~S in COMPILED-DECLARED-AREF ~S" expected-result form)))
60 (when (ignore-errors (aref (eval form) 12))
61 (error "error not thrown in EVAL ~S" form))
62 (when (ignore-errors (aref (funcall (checked-compile `(lambda () ,form)
63 :allow-warnings t))
64 12))
65 (error "error not thrown in FUNCALL COMPILE ~S" form))
66 (when (ignore-errors (funcall (checked-compile `(lambda () (aref ,form 12))
67 :allow-warnings t)))
68 (error "error not thrown in COMPILED-AREF ~S" form))
69 (when type
70 (when (ignore-errors (funcall
71 (checked-compile `(lambda ()
72 (let ((x ,form))
73 (declare (type ,type x))
74 (aref x 12)))
75 :allow-warnings t)))
76 (error "error not thrown in COMPILED-DECLARED-AREF ~S" form)))))))
78 ;;; On the SPARC, until sbcl-0.7.7.20, there was a bug in array
79 ;;; references for small vector elements (spotted by Raymond Toy); the
80 ;;; bug persisted on the PPC until sbcl-0.7.8.20.
81 (let (vector)
82 (loop for i below 64
83 for list = (make-list 64 :initial-element 1)
84 do (setf (nth i list) 0)
85 do (setf vector (make-array 64 :element-type 'bit
86 :initial-contents list))
87 do (assert (= (funcall
88 (compile nil
89 `(lambda (rmdr)
90 (declare (type (simple-array bit (*)) rmdr)
91 (optimize (speed 3) (safety 0)))
92 (aref rmdr ,i)))
93 vector)
94 0))))
96 ;;; Following refactoring of sequence functions to detect bad type
97 ;;; specifiers, REVERSE was left broken on vectors with fill pointers.
98 (with-test (:name :reverse-fill-pointer.string)
99 (let ((a (make-array 10
100 :fill-pointer 5
101 :element-type 'character
102 :initial-contents "abcdefghij")))
103 (assert (string= (reverse a) "edcba"))))
105 (with-test (:name :reverse-fill-pointer.fixnum)
106 (let ((a (make-array 10
107 :fill-pointer 6
108 :element-type 'fixnum
109 :initial-contents '(0 1 2 3 4 5 7 8 9 10))))
110 (assert (equalp (reverse a) #(5 4 3 2 1 0)))))
112 ;;; ARRAY-IN-BOUNDS-P should work when given non-INDEXes as its
113 ;;; subscripts (and return NIL, of course)
114 (with-test (:name array-in-bounds-p)
115 (macrolet
116 ((test-case (array subscript expected)
117 `(progn
118 (assert (,(if expected 'progn 'not)
119 (array-in-bounds-p ,array ,subscript)))
120 (assert (,(if expected 'progn 'not)
121 (funcall (checked-compile `(lambda (array subscript)
122 (array-in-bounds-p array subscript)))
123 ,array ,subscript))))))
124 (let ((a (make-array 10 :fill-pointer 5)))
125 (test-case a -1 nil)
126 (test-case a 3 t)
127 (test-case a 7 t)
128 (test-case a 11 nil)
129 (test-case a (1+ most-positive-fixnum) nil))))
131 ;;; arrays of bits should work:
132 (let ((a (make-array '(10 10) :element-type 'bit :adjustable t)))
133 (setf (bit a 0 0) 1)
134 (assert (= (bit a 0 0) 1)))
135 (let ((a (make-array '(10 10) :element-type 'bit)))
136 (setf (sbit a 0 0) 1)
137 (assert (= (sbit a 0 0) 1)))
139 (let ((x (copy-seq #*0011))
140 (y (copy-seq #*0101)))
141 (assert (equalp (bit-and x y nil) #*0001)))
143 ;;; arrays of NIL should work, FSVO "work".
144 (let ((a (make-array '(10 10) :element-type 'nil)))
145 (assert (= (array-total-size a) 100))
146 (assert (equal (array-dimensions a) '(10 10)))
147 (assert (eq (array-element-type a) 'nil)))
149 (assert (eq (upgraded-array-element-type 'nil) 'nil))
151 (with-test (:name (aref 0 :compile-time-error))
152 (multiple-value-bind (fun fail)
153 (checked-compile `(lambda () (aref (make-array 0) 0))
154 :allow-warnings t)
155 (assert fail)
156 (assert-error (funcall fun) sb-int:invalid-array-index-error)))
158 (with-test (:name (aref 1 :compile-time-error))
159 (multiple-value-bind (fun fail)
160 (checked-compile `(lambda () (aref (make-array 1) 1))
161 :allow-warnings t)
162 (assert fail)
163 (assert-error (funcall fun) sb-int:invalid-array-index-error)))
165 (with-test (:name (make-array :element-type :compile-time error))
166 (multiple-value-bind (fun fail warnings style-warnings)
167 (checked-compile `(lambda () (make-array 5 :element-type 'undefined-type))
168 :allow-style-warnings t)
169 (declare (ignore fun fail warnings))
170 (assert style-warnings)))
172 (with-test (:name (make-array :default :element-type :supplied :compile-time warning))
173 ;; Supplied :initial-element, EQL to the default initial element,
174 ;; results in full warning, even if not "used" due to 0 array total
175 ;; size.
176 (flet ((check (dimensions)
177 (multiple-value-bind (fun fail warnings)
178 (checked-compile
179 `(lambda ()
180 (make-array ,dimensions
181 :initial-element 0 :element-type 'string))
182 :allow-warnings t)
183 (declare (ignore fun fail))
184 (assert (= (length warnings) 1)))))
185 (check 1)
186 (check 0)))
188 (with-test (:name (make-array :default :element-type :implicit :compile-time style-warning))
189 ;; Implicit default initial element used to initialize array
190 ;; elements results in a style warning.
191 (multiple-value-bind (fun fail warnings style-warnings)
192 (checked-compile `(lambda () (make-array 5 :element-type 'string))
193 :allow-style-warnings t)
194 (declare (ignore fun fail warnings))
195 (assert (= (length style-warnings) 1)))
197 ;; But not if the default initial-element is not actually used to
198 ;; initialize any elements due to 0 array total size.
199 (checked-compile `(lambda () (make-array 0 :element-type 'string)))
200 (checked-compile `(lambda () (make-array '(0 2) :element-type 'string))))
202 (flet ((opaque-identity (x) x))
203 (declare (notinline opaque-identity))
204 ;; we used to have leakage from cross-compilation hosts of the INDEX
205 ;; type, which prevented us from actually using all the large array
206 ;; dimensions that we promised. Let's make sure that we can create
207 ;; an array with more than 2^24 elements, since that was a symptom
208 ;; from the CLISP and OpenMCL hosts.
209 (let ((big-array (opaque-identity
210 (make-array (expt 2 26) :element-type 'bit))))
211 (assert (= (length big-array) (expt 2 26)))))
213 ;;; Bug reported by Kalle Olavi Niemitalo for CMUCL through Debian BTS
214 (let ((array (make-array nil :initial-contents nil)))
215 (assert (eql (aref array) nil)))
217 (let ((f (compile nil '(lambda ()
218 (let ((a (make-array '(4)
219 :element-type 'base-char
220 :initial-element #\z)))
221 (setf (aref a 0) #\a)
222 (setf (aref a 1) #\b)
223 (setf (aref a 2) #\c)
224 a)))))
225 (assert (= (length (funcall f)) 4)))
227 (let ((x (make-array nil :initial-element 'foo)))
228 (adjust-array x nil)
229 (assert (eql (aref x) 'foo)))
231 ;;; BUG 315: "no bounds check for access to displaced array"
232 ;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP
233 ;;; test suite.
234 (locally (declare (optimize (safety 3) (speed 0)))
235 (let* ((x (make-array 10 :fill-pointer 4 :element-type 'character
236 :initial-element #\space :adjustable t))
237 (y (make-array 10 :fill-pointer 4 :element-type 'character
238 :displaced-to x)))
239 (assert (eq x (adjust-array x '(5))))
240 (assert (eq :error (handler-case
241 (char y 0)
242 (sb-int:invalid-array-error (e)
243 (assert (eq y (type-error-datum e)))
244 (assert (equal `(vector character 10)
245 (type-error-expected-type e)))
246 :error))))))
248 ;;; MISC.527: bit-vector bitwise operations used LENGTH to get a size
249 ;;; of a vector
250 (with-test (:name (bit-vector :bitwise-operations))
251 (flet ((bit-vector-equal (v1 v2)
252 (and (bit-vector-p v1) (bit-vector-p v2)
253 (equal (array-dimension v1 0) (array-dimension v2 0))
254 (loop for i below (array-dimension v1 0)
255 always (eql (aref v1 i) (aref v2 i))))))
256 (let* ((length 1024)
257 (v1 (make-array length :element-type 'bit :fill-pointer 0))
258 (v2 (make-array length :element-type 'bit :fill-pointer 1)))
259 (loop for i from 0 below length
260 for x1 in '#1=(0 0 1 1 . #1#)
261 and x2 in '#2=(0 1 0 1 . #2#)
262 do (setf (aref v1 i) x1)
263 do (setf (aref v2 i) x2))
264 (loop for (bf lf) in '((bit-and logand)
265 (bit-andc1 logandc1)
266 (bit-andc2 logandc2)
267 (bit-eqv logeqv)
268 (bit-ior logior)
269 (bit-nand lognand)
270 (bit-nor lognor)
271 (bit-orc1 logorc1)
272 (bit-orc2 logorc2)
273 (bit-xor logxor)
274 ((lambda (x y) (bit-not x)) #.(lambda (x y)
275 (declare (ignore y))
276 (lognot x))))
277 for fun = (checked-compile `(lambda (v)
278 (declare (type (array bit (*)) v))
279 (declare (optimize (speed 3) (safety 0)))
280 (,bf v ,v2))
281 :allow-style-warnings t)
282 for r1 = (funcall fun v1)
283 and r2 = (coerce (loop for i below length
284 collect (logand 1 (funcall lf (aref v1 i) (aref v2 i))))
285 'bit-vector)
286 do (assert (bit-vector-equal r1 r2))))))
288 (with-test (:name (adjust-array fill-pointer))
289 ;; CLHS, ADJUST-ARRAY: An error of type error is signaled if
290 ;; fill-pointer is supplied and non-nil but array has no fill pointer.
291 (assert (eq :good
292 (handler-case
293 (let ((array (make-array 12)))
294 (assert (not (array-has-fill-pointer-p array)))
295 (adjust-array array 12 :fill-pointer t)
296 array)
297 (type-error ()
298 :good)))))
300 (with-test (:name (adjust-array :multidimensional))
301 (let ((ary (make-array '(2 2))))
302 ;; SBCL used to give multidimensional arrays a bogus fill-pointer
303 (assert (not (array-has-fill-pointer-p (adjust-array ary '(2 2)))))))
305 (with-test (:name :%set-fill-pointer/error)
306 (let ((v (make-array 3 :fill-pointer 0)))
307 (handler-case
308 (progn
309 (setf (fill-pointer v) 12)
310 (error "WTF"))
311 (error (e)
312 (assert (eql 12 (type-error-datum e)))
313 (assert (equal '(integer 0 3) (type-error-expected-type e)))))))
315 (with-test (:name array-storage-vector)
316 (let ((vec (vector 1 2 3)))
317 (assert (eq vec (sb-ext:array-storage-vector vec)))
318 (assert (equalp (vector 1 2 3 4)
319 (sb-ext:array-storage-vector
320 (make-array '(2 2) :initial-contents '((1 2) (3 4))))))
321 (assert (eq 'fixnum (array-element-type
322 (sb-ext:array-storage-vector (make-array '(3 4 5)
323 :element-type 'fixnum)))))
324 (assert (not (array-has-fill-pointer-p
325 (sb-ext::array-storage-vector
326 (make-array 5 :fill-pointer 4)))))))
328 (with-test (:name :invalid-array-index-error)
329 (let ((array (make-array '(3 3 3))))
330 (assert
331 (eq :right
332 (handler-case
333 (eval `(aref ,array 0 1 3))
334 (sb-int:invalid-array-index-error (e)
335 (when (and (eq array (sb-kernel::invalid-array-index-error-array e))
336 (= 3 (type-error-datum e))
337 (equal '(integer 0 (3)) (type-error-expected-type e)))
338 :right)))))))
340 (with-test (:name :out-of-bounds-error-details)
341 (assert (eq :good
342 (handler-case
343 (flet ((test (array i)
344 (aref array i)))
345 (test (eval '(vector 0 1 2 3)) 6))
346 (sb-int:invalid-array-index-error (e)
347 (when (and (equal '(integer 0 (4))
348 (type-error-expected-type e))
349 (eql 6 (type-error-datum e)))
350 :good))))))
352 (with-test (:name :odd-keys-for-make-array)
353 (multiple-value-bind (fun fail warnings)
354 (checked-compile `(lambda (m) (make-array m 1))
355 :allow-warnings 'simple-warning)
356 (declare (ignore fun fail))
357 (assert (= 1 (length warnings)))))
360 (with-test (:name :bug-1096359)
361 (let ((a (make-array 1 :initial-element 5)))
362 (assert (equalp (adjust-array a 2 :initial-element 10)
363 #(5 10)))))
365 (with-test (:name (:make-array-transform-unknown-type :bug-1156095))
366 (assert
367 (handler-case
368 (compile nil `(lambda () (make-array '(1 2)
369 :element-type ',(gensym))))
370 (style-warning ()
372 (:no-error (&rest args)
373 (declare (ignore args))
374 nil))))
376 (with-test (:name :dont-make-array-bad-keywords)
377 ;; This used to get a heap exhaustion error because of trying
378 ;; to make the array before checking keyword validity.
379 (handler-case
380 (locally
381 (declare (notinline make-array))
382 (make-array (1- array-total-size-limit)
383 :initial-contents '(a b c) :initial-element 9))
384 (simple-error (c)
385 (assert
386 (string= (simple-condition-format-control c)
387 "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")))))
389 (with-test (:name (make-array :sanity-check-dims-first))
390 ;; A full call to %MAKE-ARRAY will signal a TYPE-ERROR on these inputs
391 ;; instead of trying to consume a massive amount of memory.
392 ;; Additionally, the relevent IR1 transform should give up.
393 (flet ((test (inline)
394 (multiple-value-bind (fun failure-p warnings)
395 (checked-compile
396 `(lambda ()
397 (declare (,inline make-array))
398 (make-array `(-1 -1 ,(- (ash array-dimension-limit -2) 4))))
399 :allow-failure t :allow-warnings t)
400 (ecase inline
401 (inline
402 (assert failure-p)
403 (assert (= 1 (length warnings))))
404 (notinline
405 (assert failure-p)
406 (assert (= 1 (length warnings)))))
407 (assert-error (funcall fun) type-error))))
408 (test 'inline)
409 (test 'notinline)))
411 (with-test (:name (make-array :size-overflow))
412 ;; 1-bit fixnum tags make array limits overflow the word length
413 ;; when converted to bytes
414 (when (= sb-vm:n-fixnum-tag-bits 1)
415 (multiple-value-bind (fun failure-p warnings)
416 (checked-compile
417 '(lambda ()
418 (make-array (1- array-total-size-limit)))
419 :allow-failure t :allow-warnings t)
420 (assert failure-p)
421 (assert (= 1 (length warnings)))
422 (assert-error (funcall fun) type-error))))
424 (with-test (:name (adjust-array :non-adjustable))
425 (let* ((a (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5))))
426 (b (adjust-array a '(2 2))))
427 (setf (aref a 0 0) 11)
428 (assert (zerop (aref b 0 0)))
429 (assert (not (eq a b)))))
431 (with-test (:name :check-bound-elision)
432 (assert-error (funcall (checked-compile
433 `(lambda (x)
434 (char "abcd" x)))
436 sb-int:invalid-array-index-error)
437 (assert (eql (funcall (checked-compile
438 `(lambda (x)
439 (declare (optimize (safety 0)))
440 ;; Strings are null-terminated for C interoperability
441 (char "abcd" x)))
443 #\Nul)))
445 (with-test (:name (adjust-array :transform))
446 (assert (equalp (funcall
447 (checked-compile
448 `(lambda ()
449 (adjust-array #(1 2 3) 3 :displaced-to #(4 5 6)))))
450 #(4 5 6))))
452 (with-test (:name (adjust-array :fill-pointer))
453 (let ((array (make-array 10 :fill-pointer t)))
454 (assert (= (fill-pointer (adjust-array array 5 :fill-pointer 2))
455 2))))
457 (with-test (:name (adjust-array :initial-element))
458 (assert (equal (funcall
459 (checked-compile
460 `(lambda (x)
461 (adjust-array x 5 :initial-element #\x)))
462 "abc")
463 "abcxx")))
465 (with-test (:name (make-array :initial-contents 1))
466 (flet ((f (x y)
467 (sb-int:dx-let ((a (make-array `(,x ,y)
468 :initial-contents
469 '((a b c) (1 2 3)))))
470 (eval a)
471 nil)))
472 (f 2 3)
473 (assert-error (f 3 2))))
475 (with-test (:name (make-array :initial-contents 2))
476 (labels ((compute-contents () '((a b c) (1 2 3)))
477 (f (x y)
478 (sb-int:dx-let ((a (make-array `(,x ,y)
479 :initial-contents
480 (compute-contents))))
481 (eval a)
482 nil)))
483 (declare (notinline compute-contents))
484 (f 2 3)
485 (assert-error (f 3 2))))
487 (with-test (:name (make-array :initial-contents 3))
488 (multiple-value-bind (fun failure-p warnings)
489 (checked-compile
490 '(lambda (z)
491 (symbol-macrolet ((x (+ 1 1)) (y (* 2 1)))
492 (make-array `(,x ,y)
493 :initial-contents
494 `((,z ,z 1) (,z ,z ,z)))))
495 :allow-failure t :allow-warnings t)
496 (assert failure-p)
497 (assert (= 1 (length warnings)))
498 (assert-error (funcall fun) error)))
500 (with-test (:name (adjust-array :element-type))
501 (let ((fun (checked-compile '(lambda (array)
502 (adjust-array array 3 :element-type '(signed-byte 2))))))
503 (assert-error (funcall fun #(1 2 3))))
504 (let ((fun (checked-compile '(lambda (array)
505 (adjust-array array 5 :displaced-to #(1 2 3))))))
506 (assert-error (funcall fun (make-array 5 :adjustable t :element-type 'fixnum)))))
508 (with-test (:name (make-array :transform :fill-pointer nil))
509 (flet ((test (form)
510 (let ((fun (checked-compile `(lambda () ,form))))
511 (assert (not (ctu:find-named-callees
512 fun :name 'sb-kernel:%make-array))))))
513 (test '(make-array 3 :fill-pointer nil))
514 (test '(make-array 3 :fill-pointer nil))
515 (test '(make-array 3 :fill-pointer t))
516 (test '(make-array 3 :adjustable nil))
517 (test '(make-array '(3 3) :adjustable nil))
518 (test '(make-array '(3 3) :fill-pointer nil))))
520 (with-test (:name (make-array :transform :adjustable :fill-pointer))
521 (let ((fun (checked-compile '(lambda (fp)
522 (make-array 3 :adjustable t :fill-pointer fp)))))
523 (assert (not (ctu:find-named-callees fun :name 'sb-kernel:%make-array)))
524 (assert (= (length (funcall fun t)) 3))
525 (assert (array-has-fill-pointer-p (funcall fun t)))
526 (assert (= (length (funcall fun 2)) 2))
527 (assert (= (array-total-size (funcall fun 2)) 3))
528 (assert-error (funcall fun 4))
529 (assert-error (funcall fun 'abc))
530 (assert (not (array-has-fill-pointer-p (funcall fun nil))))
531 (assert (= (length (funcall fun nil)) 3))))
533 (with-test (:name :check-bound-fixnum-check)
534 (assert-error
535 (funcall (checked-compile `(lambda (x) (aref #100(a) x)))
536 #\Nul)
537 type-error))