Signal floating-point-overflow from bignum-to-float.
[sbcl.git] / tests / array.pure.lisp
blob8acdcb67339e35c83866823fe9f766de1dbc1942
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 (checked-compile-and-assert (:optimize '(:speed 3 :safety 0))
88 `(lambda (rmdr)
89 (declare (type (simple-array bit (*)) rmdr))
90 (aref rmdr ,i))
91 ((vector) 0))))
93 ;;; Following refactoring of sequence functions to detect bad type
94 ;;; specifiers, REVERSE was left broken on vectors with fill pointers.
95 (with-test (:name :reverse-fill-pointer.string)
96 (let ((a (make-array 10
97 :fill-pointer 5
98 :element-type 'character
99 :initial-contents "abcdefghij")))
100 (assert (string= (reverse a) "edcba"))))
102 (with-test (:name :reverse-fill-pointer.fixnum)
103 (let ((a (make-array 10
104 :fill-pointer 6
105 :element-type 'fixnum
106 :initial-contents '(0 1 2 3 4 5 7 8 9 10))))
107 (assert (equalp (reverse a) #(5 4 3 2 1 0)))))
109 ;;; ARRAY-IN-BOUNDS-P should work when given non-INDEXes as its
110 ;;; subscripts (and return NIL, of course)
111 (with-test (:name array-in-bounds-p)
112 (macrolet
113 ((test-case (array subscript expected)
114 `(progn
115 (assert (,(if expected 'progn 'not)
116 (array-in-bounds-p ,array ,subscript)))
117 (assert (,(if expected 'progn 'not)
118 (funcall (checked-compile `(lambda (array subscript)
119 (array-in-bounds-p array subscript)))
120 ,array ,subscript))))))
121 (let ((a (make-array 10 :fill-pointer 5)))
122 (test-case a -1 nil)
123 (test-case a 3 t)
124 (test-case a 7 t)
125 (test-case a 11 nil)
126 (test-case a (1+ most-positive-fixnum) nil))))
128 ;;; arrays of bits should work:
129 (let ((a (make-array '(10 10) :element-type 'bit :adjustable t)))
130 (setf (bit a 0 0) 1)
131 (assert (= (bit a 0 0) 1)))
132 (let ((a (make-array '(10 10) :element-type 'bit)))
133 (setf (sbit a 0 0) 1)
134 (assert (= (sbit a 0 0) 1)))
136 (let ((x (copy-seq #*0011))
137 (y (copy-seq #*0101)))
138 (assert (equalp (bit-and x y nil) #*0001)))
140 ;;; arrays of NIL should work, FSVO "work".
141 (let ((a (make-array '(10 10) :element-type 'nil)))
142 (assert (= (array-total-size a) 100))
143 (assert (equal (array-dimensions a) '(10 10)))
144 (assert (eq (array-element-type a) 'nil)))
146 (assert (eq (upgraded-array-element-type 'nil) 'nil))
148 (with-test (:name (aref 0 :compile-time-error))
149 (multiple-value-bind (fun fail)
150 (checked-compile `(lambda () (aref (make-array 0) 0))
151 :allow-warnings t)
152 (assert fail)
153 (assert-error (funcall fun) sb-int:invalid-array-index-error)))
155 (with-test (:name (aref 1 :compile-time-error))
156 (multiple-value-bind (fun fail)
157 (checked-compile `(lambda () (aref (make-array 1) 1))
158 :allow-warnings t)
159 (assert fail)
160 (assert-error (funcall fun) sb-int:invalid-array-index-error)))
162 (with-test (:name (make-array :element-type :compile-time error))
163 (multiple-value-bind (fun fail warnings style-warnings)
164 (checked-compile `(lambda () (make-array 5 :element-type 'undefined-type))
165 :allow-style-warnings t)
166 (declare (ignore fun fail warnings))
167 (assert style-warnings)))
169 (with-test (:name (make-array :default :element-type :supplied :compile-time warning))
170 ;; Supplied :initial-element, EQL to the default initial element,
171 ;; results in full warning, even if not "used" due to 0 array total
172 ;; size.
173 (flet ((check (dimensions)
174 (multiple-value-bind (fun fail warnings)
175 (checked-compile
176 `(lambda ()
177 (make-array ,dimensions
178 :initial-element 0 :element-type 'string))
179 :allow-warnings t)
180 (declare (ignore fun fail))
181 (assert (= (length warnings) 1)))))
182 (check 1)
183 (check 0)))
185 (with-test (:name (make-array :default :element-type :implicit :compile-time style-warning))
186 ;; Implicit default initial element used to initialize array
187 ;; elements results in a style warning.
188 (multiple-value-bind (fun fail warnings style-warnings)
189 (checked-compile `(lambda () (make-array 5 :element-type 'string))
190 :allow-style-warnings t)
191 (declare (ignore fun fail warnings))
192 (assert (= (length style-warnings) 1)))
194 ;; But not if the default initial-element is not actually used to
195 ;; initialize any elements due to 0 array total size.
196 (checked-compile `(lambda () (make-array 0 :element-type 'string)))
197 (checked-compile `(lambda () (make-array '(0 2) :element-type 'string))))
199 (flet ((opaque-identity (x) x))
200 (declare (notinline opaque-identity))
201 ;; we used to have leakage from cross-compilation hosts of the INDEX
202 ;; type, which prevented us from actually using all the large array
203 ;; dimensions that we promised. Let's make sure that we can create
204 ;; an array with more than 2^24 elements, since that was a symptom
205 ;; from the CLISP and OpenMCL hosts.
206 (let ((big-array (opaque-identity
207 (make-array (expt 2 26) :element-type 'bit))))
208 (assert (= (length big-array) (expt 2 26)))))
210 ;;; Bug reported by Kalle Olavi Niemitalo for CMUCL through Debian BTS
211 (let ((array (make-array nil :initial-contents nil)))
212 (assert (eql (aref array) nil)))
214 (with-test (:name (make-array (setf aref) length))
215 (checked-compile-and-assert ()
216 '(lambda ()
217 (let ((a (make-array '(4)
218 :element-type 'base-char
219 :initial-element #\z)))
220 (setf (aref a 0) #\a)
221 (setf (aref a 1) #\b)
222 (setf (aref a 2) #\c)
224 (() 4 :test (lambda (values expected)
225 (= (length (first values)) (first expected))))))
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 (with-test (:name (:displaced-to aref sb-int:invalid-array-index-error :bug-315))
235 (locally (declare (optimize (safety 3) (speed 0)))
236 (let* ((x (make-array 10 :fill-pointer 4 :element-type 'character
237 :initial-element #\space :adjustable t))
238 (y (make-array 10 :fill-pointer 4 :element-type 'character
239 :displaced-to x)))
240 (assert (eq x (adjust-array x '(5))))
241 (assert (eq :error (handler-case
242 (char y 0)
243 (sb-int:invalid-array-error (e)
244 (assert (eq y (type-error-datum e)))
245 (assert (equal `(vector character 10)
246 (type-error-expected-type e)))
247 :error)))))))
249 ;;; MISC.527: bit-vector bitwise operations used LENGTH to get a size
250 ;;; of a vector
251 (with-test (:name (bit-vector :bitwise-operations))
252 (flet ((bit-vector-equal (v1 v2)
253 (and (bit-vector-p v1) (bit-vector-p v2)
254 (equal (array-dimension v1 0) (array-dimension v2 0))
255 (loop for i below (array-dimension v1 0)
256 always (eql (aref v1 i) (aref v2 i))))))
257 (let* ((length 1024)
258 (v1 (make-array length :element-type 'bit :fill-pointer 0))
259 (v2 (make-array length :element-type 'bit :fill-pointer 1)))
260 (loop for i from 0 below length
261 for x1 in '#1=(0 0 1 1 . #1#)
262 and x2 in '#2=(0 1 0 1 . #2#)
263 do (setf (aref v1 i) x1)
264 do (setf (aref v2 i) x2))
265 (loop for (bf lf) in '((bit-and logand)
266 (bit-andc1 logandc1)
267 (bit-andc2 logandc2)
268 (bit-eqv logeqv)
269 (bit-ior logior)
270 (bit-nand lognand)
271 (bit-nor lognor)
272 (bit-orc1 logorc1)
273 (bit-orc2 logorc2)
274 (bit-xor logxor)
275 ((lambda (x y) (bit-not x)) #.(lambda (x y)
276 (declare (ignore y))
277 (lognot x))))
278 for fun = (checked-compile `(lambda (v)
279 (declare (type (array bit (*)) v))
280 (declare (optimize (speed 3) (safety 0)))
281 (,bf v ,v2))
282 :allow-style-warnings t)
283 for r1 = (funcall fun v1)
284 and r2 = (coerce (loop for i below length
285 collect (logand 1 (funcall lf (aref v1 i) (aref v2 i))))
286 'bit-vector)
287 do (assert (bit-vector-equal r1 r2))))))
289 (with-test (:name (adjust-array fill-pointer))
290 ;; CLHS, ADJUST-ARRAY: An error of type error is signaled if
291 ;; fill-pointer is supplied and non-nil but array has no fill pointer.
292 (assert (eq :good
293 (handler-case
294 (let ((array (make-array 12)))
295 (assert (not (array-has-fill-pointer-p array)))
296 (adjust-array array 12 :fill-pointer t)
297 array)
298 (type-error ()
299 :good)))))
301 (with-test (:name (adjust-array :multidimensional))
302 (let ((ary (make-array '(2 2))))
303 ;; SBCL used to give multidimensional arrays a bogus fill-pointer
304 (assert (not (array-has-fill-pointer-p (adjust-array ary '(2 2)))))))
306 (with-test (:name :%set-fill-pointer/error)
307 (let ((v (make-array 3 :fill-pointer 0)))
308 (handler-case
309 (progn
310 (setf (fill-pointer v) 12)
311 (error "WTF"))
312 (error (e)
313 (assert (eql 12 (type-error-datum e)))
314 (assert (equal '(integer 0 3) (type-error-expected-type e)))))))
316 (with-test (:name array-storage-vector)
317 (let ((vec (vector 1 2 3)))
318 (assert (eq vec (sb-ext:array-storage-vector vec)))
319 (assert (equalp (vector 1 2 3 4)
320 (sb-ext:array-storage-vector
321 (make-array '(2 2) :initial-contents '((1 2) (3 4))))))
322 (assert (eq 'fixnum (array-element-type
323 (sb-ext:array-storage-vector (make-array '(3 4 5)
324 :element-type 'fixnum)))))
325 (assert (not (array-has-fill-pointer-p
326 (sb-ext::array-storage-vector
327 (make-array 5 :fill-pointer 4)))))))
329 (with-test (:name :invalid-array-index-error)
330 (let ((array (make-array '(3 3 3))))
331 (assert
332 (eq :right
333 (handler-case
334 (eval `(aref ,array 0 1 3))
335 (sb-int:invalid-array-index-error (e)
336 (when (and (eq array (sb-kernel::invalid-array-index-error-array e))
337 (= 3 (type-error-datum e))
338 (equal '(integer 0 (3)) (type-error-expected-type e)))
339 :right)))))))
341 (with-test (:name :out-of-bounds-error-details)
342 (assert (eq :good
343 (handler-case
344 (flet ((test (array i)
345 (aref array i)))
346 (test (eval '(vector 0 1 2 3)) 6))
347 (sb-int:invalid-array-index-error (e)
348 (when (and (equal '(integer 0 (4))
349 (type-error-expected-type e))
350 (eql 6 (type-error-datum e)))
351 :good))))))
353 (with-test (:name :odd-keys-for-make-array)
354 (multiple-value-bind (fun fail warnings)
355 (checked-compile `(lambda (m) (make-array m 1))
356 :allow-warnings 'simple-warning)
357 (declare (ignore fun fail))
358 (assert (= 1 (length warnings)))))
361 (with-test (:name :bug-1096359)
362 (let ((a (make-array 1 :initial-element 5)))
363 (assert (equalp (adjust-array a 2 :initial-element 10)
364 #(5 10)))))
366 (with-test (:name (:make-array-transform-unknown-type :bug-1156095))
367 (assert (nth-value 3 (checked-compile
368 `(lambda () (make-array '(1 2) :element-type ',(gensym)))
369 :allow-style-warnings t))))
371 (with-test (:name :dont-make-array-bad-keywords)
372 ;; This used to get a heap exhaustion error because of trying
373 ;; to make the array before checking keyword validity.
374 (handler-case
375 (locally
376 (declare (notinline make-array))
377 (make-array (1- array-total-size-limit)
378 :initial-contents '(a b c) :initial-element 9))
379 (simple-error (c)
380 (assert
381 (string= (simple-condition-format-control c)
382 "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")))))
384 (with-test (:name (make-array :sanity-check-dims-first))
385 ;; A full call to %MAKE-ARRAY will signal a TYPE-ERROR on these inputs
386 ;; instead of trying to consume a massive amount of memory.
387 ;; Additionally, the relevent IR1 transform should give up.
388 (flet ((test (inline)
389 (multiple-value-bind (fun failure-p warnings)
390 (checked-compile
391 `(lambda ()
392 (declare (,inline make-array))
393 (make-array `(-1 -1 ,(- (ash array-dimension-limit -2) 4))))
394 :allow-failure t :allow-warnings t)
395 (ecase inline
396 (inline
397 (assert failure-p)
398 (assert (= 1 (length warnings))))
399 (notinline
400 (assert failure-p)
401 (assert (= 1 (length warnings)))))
402 (assert-error (funcall fun) type-error))))
403 (test 'inline)
404 (test 'notinline)))
406 (with-test (:name (make-array :size-overflow))
407 ;; 1-bit fixnum tags make array limits overflow the word length
408 ;; when converted to bytes
409 (when (= sb-vm:n-fixnum-tag-bits 1)
410 (multiple-value-bind (fun failure-p warnings)
411 (checked-compile
412 '(lambda ()
413 (make-array (1- array-total-size-limit)))
414 :allow-failure t :allow-warnings t)
415 (assert failure-p)
416 (assert (= 1 (length warnings)))
417 (assert-error (funcall fun) type-error))))
419 (with-test (:name (adjust-array :non-adjustable))
420 (let* ((a (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5))))
421 (b (adjust-array a '(2 2))))
422 (setf (aref a 0 0) 11)
423 (assert (zerop (aref b 0 0)))
424 (assert (not (eq a b)))))
426 (with-test (:name :check-bound-elision)
427 (checked-compile-and-assert (:optimize :safe)
428 `(lambda (x)
429 (char "abcd" x))
430 ((4) (condition 'sb-int:invalid-array-index-error)))
431 (checked-compile-and-assert (:optimize '(:safety 0))
432 `(lambda (x)
433 ;; Strings are null-terminated for C interoperability
434 (char "abcd" x))
435 ((4) #\Nul)))
437 (with-test (:name (adjust-array :transform))
438 (checked-compile-and-assert ()
439 `(lambda ()
440 (adjust-array #(1 2 3) 3 :displaced-to #(4 5 6)))
441 (() #(4 5 6) :test #'equalp)))
443 (with-test (:name (adjust-array :fill-pointer))
444 (let ((array (make-array 10 :fill-pointer t)))
445 (assert (= (fill-pointer (adjust-array array 5 :fill-pointer 2))
446 2))))
448 (with-test (:name (adjust-array :initial-element))
449 (checked-compile-and-assert ()
450 `(lambda (x)
451 (adjust-array x 5 :initial-element #\x))
452 (("abc") "abcxx")))
454 (with-test (:name (make-array :initial-contents 1))
455 (flet ((f (x y)
456 (sb-int:dx-let ((a (make-array `(,x ,y)
457 :initial-contents
458 '((a b c) (1 2 3)))))
459 (eval a)
460 nil)))
461 (f 2 3)
462 (assert-error (f 3 2))))
464 (with-test (:name (make-array :initial-contents 2))
465 (labels ((compute-contents () '((a b c) (1 2 3)))
466 (f (x y)
467 (sb-int:dx-let ((a (make-array `(,x ,y)
468 :initial-contents
469 (compute-contents))))
470 (eval a)
471 nil)))
472 (declare (notinline compute-contents))
473 (f 2 3)
474 (assert-error (f 3 2))))
476 (with-test (:name (make-array :initial-contents 3))
477 (multiple-value-bind (fun failure-p warnings)
478 (checked-compile
479 '(lambda (z)
480 (symbol-macrolet ((x (+ 1 1)) (y (* 2 1)))
481 (make-array `(,x ,y)
482 :initial-contents
483 `((,z ,z 1) (,z ,z ,z)))))
484 :allow-failure t :allow-warnings t)
485 (assert failure-p)
486 (assert (= 1 (length warnings)))
487 (assert-error (funcall fun) error)))
489 (with-test (:name (adjust-array :element-type))
490 (checked-compile-and-assert ()
491 `(lambda (array)
492 (adjust-array array 3 :element-type '(signed-byte 2)))
493 ((#(1 2 3)) (condition 'error)))
494 (checked-compile-and-assert ()
495 `(lambda (array)
496 (adjust-array array 5 :displaced-to #(1 2 3)))
497 (((make-array 5 :adjustable t :element-type 'fixnum)) (condition 'error))))
499 (with-test (:name (make-array :transform :fill-pointer nil))
500 (flet ((test (form)
501 (let ((fun (checked-compile `(lambda () ,form))))
502 (assert (not (ctu:find-named-callees
503 fun :name 'sb-kernel:%make-array))))))
504 (test '(make-array 3 :fill-pointer nil))
505 (test '(make-array 3 :fill-pointer nil))
506 (test '(make-array 3 :fill-pointer t))
507 (test '(make-array 3 :adjustable nil))
508 (test '(make-array '(3 3) :adjustable nil))
509 (test '(make-array '(3 3) :fill-pointer nil))))
511 (with-test (:name (make-array :transform :adjustable :fill-pointer))
512 (let ((fun (checked-compile '(lambda (fp)
513 (make-array 3 :adjustable t :fill-pointer fp)))))
514 (assert (not (ctu:find-named-callees fun :name 'sb-kernel:%make-array)))
515 (assert (= (length (funcall fun t)) 3))
516 (assert (array-has-fill-pointer-p (funcall fun t)))
517 (assert (= (length (funcall fun 2)) 2))
518 (assert (= (array-total-size (funcall fun 2)) 3))
519 (assert-error (funcall fun 4))
520 (assert-error (funcall fun 'abc))
521 (assert (not (array-has-fill-pointer-p (funcall fun nil))))
522 (assert (= (length (funcall fun nil)) 3))))
524 (with-test (:name :check-bound-fixnum-check)
525 (checked-compile-and-assert (:optimize :safe)
526 `(lambda (x) (aref #100(a) x))
527 ((#\Nul) (condition 'type-error))))