tests/array.pure.lisp

   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.
  11
  12 (enable-test-parallelism)
  13
  14 ;;; Array initialization has complicated defaulting for :ELEMENT-TYPE,
  15 ;;; and both compile-time and run-time logic takes a whack at it.
  16 (with-test (:name (make-array :element-type :bug-126))
  17   (let ((testcases '(;; Bug 126, confusion between high-level default string
  18                      ;; initial element #\SPACE and low-level default array
  19                      ;; element #\NULL, is gone.
  20                      (#\null (make-array 11 :element-type 'character :initial-element #\null)
  21                              simple-string)
  22                      (#\space (make-string 11 :initial-element #\space) string)
  23                      (#\* (make-string 11 :initial-element #\*))
  24                      (#\null (make-string 11))
  25                      (#\null (make-string 11 :initial-element #\null))
  26                      (#\x (make-string 11 :initial-element #\x))
  27                      ;; And the other tweaks made when fixing bug 126 didn't
  28                      ;; mess things up too badly either.
  29                      (0 (make-array 11 :initial-element 0) simple-vector)
  30                      (nil (make-array 11 :initial-element nil))
  31                      (12 (make-array 11 :initial-element 12))
  32                      (0 (make-array 11 :element-type '(unsigned-byte 4) :initial-element 0)
  33                         (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)))))))
  77
  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))))
  92
  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"))))
 101
 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)))))
 108
 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))))
 127
 128 ;;; arrays of bits should work:
 129 (with-test (:name (make-array :element-type bit))
 130   (let ((a (make-array '(10 10) :element-type 'bit :adjustable t)))
 131     (setf (bit a 0 0) 1)
 132     (assert (= (bit a 0 0) 1)))
 133   (let ((a (make-array '(10 10) :element-type 'bit)))
 134     (setf (sbit a 0 0) 1)
 135     (assert (= (sbit a 0 0) 1))))
 136
 137 (with-test (:name (copy-seq bit-and equalp))
 138   (let ((x (copy-seq #*0011))
 139         (y (copy-seq #*0101)))
 140     (assert (equalp (bit-and x y nil) #*0001))))
 141
 142 ;;; arrays of NIL should work, FSVO "work".
 143 (with-test (:name (make-array upgraded-array-element-type :element-type nil))
 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)))
 148
 149   (assert (eq (upgraded-array-element-type 'nil) 'nil)))
 150
 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)))
 157
 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)))
 164
 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)))
 171
 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)))
 187
 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)))
 196
 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))))
 201
 202 (with-test (:name (make-array standard-char))
 203   ;; Maybe this is a kludge, but STANDARD-CHAR should just work,
 204   ;; I don't care if #\nul is nonstandard. Because, seriously?
 205   (checked-compile '(lambda ()
 206                      (make-array 5 :fill-pointer 0 :element-type 'standard-char))))
 207
 208 (with-test (:name :big-array)
 209   ;; we used to have leakage from cross-compilation hosts of the INDEX
 210   ;; type, which prevented us from actually using all the large array
 211   ;; dimensions that we promised.  Let's make sure that we can create
 212   ;; an array with more than 2^24 elements, since that was a symptom
 213   ;; from the CLISP and OpenMCL hosts.
 214   (let ((big-array (opaque-identity
 215                     (make-array (expt 2 26) :element-type 'bit))))
 216     (assert (= (length big-array) (expt 2 26)))))
 217
 218 ;;; Bug reported by Kalle Olavi Niemitalo for CMUCL through Debian BTS
 219 (with-test (:name (make-array aref :rank 0))
 220   (let ((array (make-array nil :initial-contents nil)))
 221     (assert (eql (aref array) nil))))
 222
 223 (with-test (:name (make-array (setf aref) length))
 224   (checked-compile-and-assert ()
 225       '(lambda ()
 226          (let ((a (make-array '(4)
 227                               :element-type 'base-char
 228                               :initial-element #\z)))
 229            (setf (aref a 0) #\a)
 230            (setf (aref a 1) #\b)
 231            (setf (aref a 2) #\c)
 232            a))
 233     (() 4 :test (lambda (values expected)
 234                   (= (length (first values)) (first expected))))))
 235
 236 ;;; I have no idea how this is testing adjust-array with an initial-element !
 237 (with-test (:name (make-array adjust-array :initial-element))
 238   (let ((x (make-array nil :initial-element 'foo)))
 239     ;; make the result look used
 240     (opaque-identity (adjust-array x nil))
 241     (assert (eql (aref x) 'foo))))
 242
 243 ;;; BUG 315: "no bounds check for access to displaced array"
 244 ;;;  reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP
 245 ;;;  test suite.
 246 (with-test (:name (:displaced-to aref sb-int:invalid-array-index-error :bug-315))
 247   (locally (declare (optimize (safety 3) (speed 0)))
 248     (let* ((x (make-array 10 :fill-pointer 4 :element-type 'character
 249                           :initial-element #\space :adjustable t))
 250            (y (make-array 10 :fill-pointer 4 :element-type 'character
 251                           :displaced-to x)))
 252       (assert (eq x (adjust-array x '(5))))
 253       (assert (eq :error (handler-case
 254                              (char y 0)
 255                            (sb-int:invalid-array-error (e)
 256                              (assert (eq y (type-error-datum e)))
 257                              (assert (equal `(vector character 10)
 258                                             (type-error-expected-type e)))
 259                              :error)))))))
 260
 261 ;;; MISC.527: bit-vector bitwise operations used LENGTH to get a size
 262 ;;; of a vector
 263 (with-test (:name (bit-vector :bitwise-operations))
 264   (flet ((bit-vector-equal (v1 v2)
 265            (and (bit-vector-p v1) (bit-vector-p v2)
 266                 (equal (array-dimension v1 0) (array-dimension v2 0))
 267                 (loop for i below (array-dimension v1 0)
 268                    always (eql (aref v1 i) (aref v2 i))))))
 269     (let* ((length 1024)
 270            (v1 (make-array length :element-type 'bit :fill-pointer 0))
 271            (v2 (make-array length :element-type 'bit :fill-pointer 1)))
 272       (loop for i from 0 below length
 273          for x1 in '#1=(0 0 1 1 . #1#)
 274          and x2 in '#2=(0 1 0 1 . #2#)
 275          do (setf (aref v1 i) x1)
 276          do (setf (aref v2 i) x2))
 277       (loop for (bf lf) in '((bit-and logand)
 278                              (bit-andc1 logandc1)
 279                              (bit-andc2 logandc2)
 280                              (bit-eqv logeqv)
 281                              (bit-ior logior)
 282                              (bit-nand lognand)
 283                              (bit-nor lognor)
 284                              (bit-orc1 logorc1)
 285                              (bit-orc2 logorc2)
 286                              (bit-xor logxor)
 287                              ((lambda (x y) (bit-not x)) #.(lambda (x y)
 288                                                              (declare (ignore y))
 289                                                              (lognot x))))
 290          for fun = (checked-compile `(lambda (v)
 291                                        (declare (type (array bit (*)) v))
 292                                        (declare (optimize (speed 3) (safety 0)))
 293                                        (,bf v ,v2))
 294                                     :allow-style-warnings t)
 295          for r1 = (funcall fun v1)
 296          and r2 = (coerce (loop for i below length
 297                              collect (logand 1 (funcall lf (aref v1 i) (aref v2 i))))
 298                           'bit-vector)
 299          do (assert (bit-vector-equal r1 r2))))))
 300
 301 (with-test (:name (adjust-array fill-pointer))
 302   ;; CLHS, ADJUST-ARRAY: An error of type error is signaled if
 303   ;; fill-pointer is supplied and non-nil but array has no fill pointer.
 304   (assert (eq :good
 305               (handler-case
 306                   (let ((array (make-array 12)))
 307                     (assert (not (array-has-fill-pointer-p array)))
 308                     ;; make the result look used
 309                     (opaque-identity (adjust-array array 12 :fill-pointer t))
 310                     array)
 311                 (type-error ()
 312                   :good)))))
 313
 314 (with-test (:name (adjust-array :multidimensional))
 315   (let ((ary (make-array '(2 2) :initial-element 0)))
 316     ;; SBCL used to give multidimensional arrays a bogus fill-pointer
 317     (assert (not (array-has-fill-pointer-p (adjust-array ary '(2 2)))))))
 318
 319 (with-test (:name :%set-fill-pointer/error)
 320   (let ((v (make-array 3 :fill-pointer 0)))
 321     (handler-case
 322         (progn
 323           (setf (fill-pointer v) 12)
 324           (error "WTF"))
 325       (error (e)
 326         (assert (eql 12 (type-error-datum e)))
 327         (assert (equal '(integer 0 3) (type-error-expected-type e)))))))
 328
 329 (with-test (:name array-storage-vector)
 330   (let ((vec (vector 1 2 3)))
 331     (assert (eq vec (sb-ext:array-storage-vector vec)))
 332     (assert (equalp (vector 1 2 3 4)
 333                     (sb-ext:array-storage-vector
 334                      (make-array '(2 2) :initial-contents '((1 2) (3 4))))))
 335     (assert (eq 'fixnum (array-element-type
 336                          (sb-ext:array-storage-vector (make-array '(3 4 5)
 337                                                                  :element-type 'fixnum)))))
 338     (assert (not (array-has-fill-pointer-p
 339                   (sb-ext::array-storage-vector
 340                    (make-array 5 :fill-pointer 4)))))))
 341
 342 (with-test (:name :invalid-array-index-error)
 343   (let ((array (make-array '(3 3 3))))
 344     (assert
 345      (eq :right
 346          (handler-case
 347              (eval `(aref ,array 0 1 3))
 348            (sb-int:invalid-array-index-error (e)
 349              (when (and (eq array (sb-kernel::invalid-array-index-error-array e))
 350                         (= 3 (type-error-datum e))
 351                         (equal '(integer 0 (3)) (type-error-expected-type e)))
 352                :right)))))))
 353
 354 (with-test (:name :out-of-bounds-error-details)
 355   (assert (eq :good
 356               (handler-case
 357                   (flet ((test (array i)
 358                            (aref array i)))
 359                     (test (eval '(vector 0 1 2 3)) 6))
 360                 (sb-int:invalid-array-index-error (e)
 361                   (when (and (equal '(integer 0 (4))
 362                                     (type-error-expected-type e))
 363                              (eql 6 (type-error-datum e)))
 364                     :good))))))
 365
 366 (with-test (:name :odd-keys-for-make-array)
 367   (multiple-value-bind (fun fail warnings)
 368       (checked-compile `(lambda (m) (make-array m 1))
 369                        :allow-warnings 'simple-warning)
 370     (declare (ignore fun fail))
 371     (assert (= 1 (length warnings)))))
 372
 373
 374 (with-test (:name :bug-1096359)
 375   (let ((a (make-array 1 :initial-element 5)))
 376     (assert (equalp (adjust-array a 2 :initial-element 10)
 377                     #(5 10)))))
 378
 379 (with-test (:name (:make-array-transform-unknown-type :bug-1156095))
 380   (assert (nth-value 3 (checked-compile
 381                         `(lambda () (make-array '(1 2) :element-type ',(gensym)))
 382                         :allow-style-warnings t))))
 383
 384 (with-test (:name :dont-make-array-bad-keywords)
 385   ;; This used to get a heap exhaustion error because of trying
 386   ;; to make the array before checking keyword validity.
 387   (handler-case
 388       (locally
 389           (declare (notinline make-array))
 390         (make-array (1- array-total-size-limit)
 391                     :initial-contents '(a b c) :initial-element 9))
 392     (simple-error (c)
 393       (assert
 394        (string= (simple-condition-format-control c)
 395                 "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")))))
 396
 397 (with-test (:name (make-array :sanity-check-dims-first))
 398   ;; A full call to %MAKE-ARRAY will signal a TYPE-ERROR on these inputs
 399   ;; instead of trying to consume a massive amount of memory.
 400   ;; Additionally, the relevent IR1 transform should give up.
 401   (flet ((test (inline)
 402            (multiple-value-bind (fun failure-p warnings)
 403                (checked-compile
 404                 `(lambda ()
 405                    (declare (,inline make-array))
 406                    (make-array `(-1 -1 ,(- (ash array-dimension-limit -2) 4))))
 407                 :allow-failure t :allow-warnings t)
 408              (ecase inline
 409                (inline
 410                 (assert failure-p)
 411                 (assert (= 1 (length warnings))))
 412                (notinline
 413                 (assert failure-p)
 414                 (assert (= 1 (length warnings)))))
 415              (assert-error (funcall fun) type-error))))
 416     (test 'inline)
 417     (test 'notinline)))
 418
 419 (with-test (:name (make-array :size-overflow)
 420                   ;; size limit is small enough that this fails by not failing
 421                   ;; in the expected way
 422                   :skipped-on :ubsan)
 423   ;; 1-bit fixnum tags make array limits overflow the word length
 424   ;; when converted to bytes
 425   (when (and (= sb-vm:n-fixnum-tag-bits 1)
 426              (<= (- most-positive-fixnum
 427                     array-total-size-limit)
 428                  2))
 429     (multiple-value-bind (fun failure-p warnings)
 430         (checked-compile
 431          '(lambda ()
 432             (make-array (1- array-total-size-limit)))
 433          :allow-failure t :allow-warnings t)
 434       (assert failure-p)
 435       (assert (= 1 (length warnings)))
 436       (assert-error (funcall fun) type-error))))
 437
 438 (with-test (:name (adjust-array :non-adjustable))
 439   (let* ((a (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5))))
 440          (b (adjust-array a '(2 2))))
 441     (setf (aref a 0 0) 11)
 442     (assert (zerop (aref b 0 0)))
 443     (assert (not (eq a b)))))
 444
 445 (with-test (:name :check-bound-elision)
 446   (checked-compile-and-assert (:optimize :safe)
 447       `(lambda (x)
 448          (char "abcd" x))
 449     ((4) (condition 'sb-int:invalid-array-index-error)))
 450   (checked-compile-and-assert (:optimize '(:safety 0))
 451       `(lambda (x)
 452          ;; Strings are null-terminated for C interoperability
 453          (char #.(coerce "abcd" 'simple-base-string) x))
 454     ((4) #\Nul)))
 455 (defun check-bound-multiple-reads (x i)
 456   (let* ((x (truly-the simple-vector x))
 457          (l (sb-c::vector-length x)))
 458     (sb-kernel:%check-bound x l i)
 459     l))
 460 (compile 'check-bound-multiple-reads)
 461 (with-test (:name :check-bound-vop-optimize)
 462   ;; could have crashed with the bad optimizer
 463   (check-bound-multiple-reads #(a b c) 2))
 464
 465 (with-test (:name (adjust-array :transform))
 466   (checked-compile-and-assert ()
 467       `(lambda ()
 468          (adjust-array #(1 2 3) 3 :displaced-to #(4 5 6)))
 469     (() #(4 5 6) :test #'equalp)))
 470
 471 (with-test (:name (adjust-array :fill-pointer))
 472   (let ((array (make-array 10 :fill-pointer t :initial-element 0)))
 473     (assert (= (fill-pointer (adjust-array array 5 :fill-pointer 2))
 474                2))))
 475
 476 (with-test (:name (adjust-array :initial-element))
 477   (checked-compile-and-assert ()
 478       `(lambda (x)
 479          (adjust-array x 5 :initial-element #\x))
 480     (("abc") "abcxx")))
 481
 482 (with-test (:name (make-array :initial-contents 1))
 483   (flet ((f (x y)
 484            (sb-int:dx-let ((a (make-array `(,x ,y)
 485                                           :initial-contents
 486                                           '((a b c) (1 2 3)))))
 487              (eval a)
 488              nil)))
 489     (f 2 3)
 490     (assert-error (f 3 2))))
 491
 492 (with-test (:name (make-array :initial-contents 2))
 493   (labels ((compute-contents () '((a b c) (1 2 3)))
 494            (f (x y)
 495              (sb-int:dx-let ((a (make-array `(,x ,y)
 496                                             :initial-contents
 497                                             (compute-contents))))
 498                (eval a)
 499                 nil)))
 500     (declare (notinline compute-contents))
 501     (f 2 3)
 502     (assert-error (f 3 2))))
 503
 504 (with-test (:name (make-array :initial-contents 3))
 505   (multiple-value-bind (fun failure-p warnings)
 506       (checked-compile
 507        '(lambda (z)
 508           (symbol-macrolet ((x (+ 1 1)) (y (* 2 1)))
 509             (make-array `(,x ,y)
 510                         :initial-contents
 511                         `((,z ,z 1) (,z ,z ,z)))))
 512        :allow-failure t :allow-warnings t)
 513     (assert failure-p)
 514     (assert (= 1 (length warnings)))
 515     (assert-error (funcall fun 0) error)))
 516
 517 (with-test (:name (adjust-array :element-type))
 518   (checked-compile-and-assert ()
 519       `(lambda (array)
 520          (adjust-array array 3 :element-type '(signed-byte 2)))
 521     ((#(1 2 3)) (condition 'error)))
 522   (checked-compile-and-assert ()
 523       `(lambda (array)
 524          (adjust-array array 5 :displaced-to #(1 2 3)))
 525     (((make-array 5 :adjustable t :element-type 'fixnum)) (condition 'error))))
 526
 527 (with-test (:name (make-array :transform :fill-pointer nil))
 528   (flet ((test (form)
 529            (assert (not (ctu:ir1-named-calls `(lambda () ,form))))))
 530     (test '(make-array 3      :fill-pointer nil))
 531     (test '(make-array 3      :fill-pointer nil))
 532     (test '(make-array 3      :fill-pointer t))
 533     (test '(make-array 3      :adjustable nil))
 534     (test '(make-array '(3 3) :adjustable nil))
 535     (test '(make-array '(3 3) :fill-pointer nil))))
 536
 537 (with-test (:name (make-array :transform :adjustable :fill-pointer))
 538   (multiple-value-bind (calls fun)
 539       (ctu:ir1-named-calls '(lambda (fp) (make-array 3 :adjustable t :fill-pointer fp)))
 540     (assert (not (member 'sb-kernel:%make-array calls)))
 541     (assert (= (length (funcall fun t)) 3))
 542     (assert (array-has-fill-pointer-p (funcall fun t)))
 543     (assert (= (length (funcall fun 2)) 2))
 544     (assert (= (array-total-size (funcall fun 2)) 3))
 545     (assert-error (funcall fun 4))
 546     (assert-error (funcall fun 'abc))
 547     (assert (not (array-has-fill-pointer-p (funcall fun nil))))
 548     (assert (= (length (funcall fun nil)) 3))))
 549
 550 (with-test (:name (make-array :transform :non-constant-fill-pointer))
 551   ;; Known adjustable with any fill-pointer can be inlined
 552   (multiple-value-bind (calls fun)
 553       (ctu:ir1-named-calls '(lambda (n fillp)
 554                                  (make-array (the (mod 20) n)
 555                                              :adjustable t :fill-pointer fillp)))
 556     (assert (not (member 'sb-kernel:%make-array calls)))
 557     (let ((a (funcall fun 10 3)))
 558       (assert (= (length a) 3))
 559       (assert (= (array-dimension a 0) 10))))
 560   ;; Non-adjustable w/ non-constant numeric fill-pointer can be inlined
 561   (multiple-value-bind (calls fun)
 562       (ctu:ir1-named-calls '(lambda (n)
 563                                  (make-array (the (mod 20) n)
 564                                              :fill-pointer (floor n 2))))
 565     (assert (not (member 'sb-kernel:%make-array calls)))
 566     (let ((a (funcall fun 10)))
 567       (assert (= (length a) 5))
 568       (assert (= (array-dimension a 0) 10)))))
 569
 570 (with-test (:name :check-bound-fixnum-check)
 571   (checked-compile-and-assert (:optimize :safe)
 572       `(lambda (x) (aref #100(a) x))
 573     ((#\Nul) (condition 'type-error))))
 574
 575 (with-test (:name (make-array :erroneous-type-specifiers))
 576   (dolist (atom '(signed-byte unsigned-byte))
 577     (assert (handler-case (eval `(make-array 10 :element-type '(,atom "oops")))
 578               (error (c) (search (format nil "bad size specified for ~A" atom)
 579                                  (princ-to-string c)))
 580               (:no-error (obj) obj nil)))))
 581
 582 (with-test (:name (make-array :strange-type-specifiers))
 583   (assert (stringp (make-array 10 :element-type (opaque-identity '(base-char)))))
 584   (assert (stringp (make-array 10 :element-type (opaque-identity '(standard-char)))))
 585   ;; If there are no extended characters (as on #-sb-unicode), then EXTENDED-CHAR is
 586   ;; the empty type. You'll get exactly what you ask for: an array which can hold
 587   ;; nothing. It's not a string, which is the right answer.
 588   #+sb-unicode
 589   (assert (stringp (make-array 10 :element-type (opaque-identity '(extended-char)))))
 590   (assert (bit-vector-p (make-array 10 :element-type (opaque-identity '(bit))))))
 591
 592 (with-test (:name :make-array-satisifies-element-type)
 593   (checked-compile-and-assert
 594       ()
 595       '(lambda (type)
 596         (make-array 3 :initial-element #\a :element-type type))
 597     (('(and character (satisfies eval))) "aaa" :test #'equal)
 598     (('(and character (or (satisfies eval) base-char))) "aaa" :test #'equal)))
 599
 600 (with-test (:name :make-array-or-unsigned-byte-type)
 601   (checked-compile-and-assert
 602       ()
 603       '(lambda (type)
 604         (make-array 1 :element-type type :initial-element 0))
 605     (('(or (eql -16) unsigned-byte)) #(0) :test #'equalp)))
 606
 607 (with-test (:name :check-bound-signed-bound-notes
 608             :fails-on (not (or :x86-64 :x86 :arm64)))
 609   (checked-compile-and-assert
 610       (:allow-notes nil)
 611       `(lambda (x y)
 612          (declare (fixnum y))
 613          (svref x (+ y 2)))
 614     ((#(1 2 3) 0) 3)))
 615
 616 (with-test (:name :make-array-header*-type-derivation)
 617   (let ((fun (checked-compile
 618               '(lambda (a)
 619                 (declare ((simple-array (unsigned-byte 8) (*)) a))
 620                 (make-array '(10 20) :element-type (array-element-type a))))))
 621     (assert (typep (funcall fun #A((1) (UNSIGNED-BYTE 8) 0))
 622                    '(simple-array (unsigned-byte 8) (10 20))))
 623     (assert
 624      (equal (sb-kernel:%simple-fun-type fun)
 625             '(function ((simple-array (unsigned-byte 8) (*)))
 626               (values (simple-array (unsigned-byte 8) (10 20)) &optional))))))
 627
 628 (with-test (:name :displaced-to-with-intitial)
 629   (checked-compile-and-assert
 630       ()
 631       `(lambda (x)
 632          (make-array 1 :displaced-to x :initial-element 1))
 633     ((#(0)) (condition 'error)))
 634   (assert
 635    (nth-value 2
 636               (checked-compile
 637                `(lambda ()
 638                   (lambda (x)
 639                     (make-array 1 :displaced-to (the vector x) :initial-contents '(1))))
 640                :allow-warnings t))))
 641
 642 (with-test (:name :check-bound-type-error)
 643   (assert (nth-value 2
 644                      (checked-compile
 645                       `(lambda (p)
 646                          (unless (svref p 0)
 647                            (svref p nil)))
 648                       :allow-warnings t))))
 649
 650 (with-test (:name :array-has-fill-pointer-p-folding)
 651   (assert (equal (sb-kernel:%simple-fun-type
 652                   (checked-compile `(lambda (x)
 653                                       (declare ((array * (* *)) x))
 654                                       (array-has-fill-pointer-p x))))
 655                  `(function ((array * (* *))) (values null &optional)))))
 656
 657 (with-test (:name :array-has-fill-pointer-p-transform)
 658   (checked-compile-and-assert
 659    ()
 660    `(lambda (n)
 661       (let ((a (make-array n)))
 662         (declare (vector a))
 663         (map-into a #'identity a)))
 664    ((0) #() :test #'equalp)))
 665
 666 (with-test (:name :displaced-index-offset-disallow-nil)
 667   (assert-error (eval '(make-array 4 :displaced-index-offset nil))))
 668
 669 (with-test (:name :adjust-array-copies-above-fill-pointer)
 670   (let ((a (make-array 4 :fill-pointer 2 :initial-contents '(a b c d))))
 671     (let ((b (adjust-array a 6 :initial-element 'e)))
 672       (assert (eq (aref b 2) 'c))
 673       (assert (eq (aref b 3) 'd))
 674       (assert (eq (aref b 4) 'e))
 675       (assert (eq (aref b 5) 'e)))))
 676
 677 (with-test (:name :test-array-dimensions-other-pointer-check)
 678   (checked-compile-and-assert
 679       ()
 680       `(lambda (a)
 681          (typep a '(simple-array t (2 1))))
 682     ((1) nil)
 683     ((#2A((1) (1))) t)))
 684
 685 (with-test (:name :typep-constant-%array-data-folding)
 686   (checked-compile-and-assert
 687       ()
 688       `(lambda ()
 689          (typep "abcd" '(simple-array t 2)))
 690     (() nil)))
 691
 692 (with-test (:name :vector-push-extend-specialized)
 693   (let ((extend (checked-compile `(lambda (e a)
 694                                     (vector-push-extend e a)
 695                                     a))))
 696     (loop for saetp across sb-vm:*specialized-array-element-type-properties*
 697           for type = (sb-vm:saetp-specifier saetp)
 698           when type
 699           do
 700           (let* ((value (sb-vm:saetp-initial-element-default saetp))
 701                  (value (if (characterp value)
 702                             (code-char (1+ (char-code value)))
 703                             (1+ value))))
 704             (assert (eql (aref (funcall extend value (make-array 1 :element-type type
 705                                                                    :adjustable t
 706                                                                    :fill-pointer t))
 707                                1)
 708                          value))))))
 709
 710 (with-test (:name :intersection-type-complexp)
 711   (assert (equal (caddr (sb-kernel:%simple-fun-type
 712                          (checked-compile `(lambda (x)
 713                                              (declare ((and (simple-array * (10))
 714                                                             (not simple-vector))
 715                                                        x))
 716                                              (length x)))))
 717                  `(values (integer 10 10) &optional))))
 718
 719 (with-test (:name :vector-length-intersection-types)
 720   (assert (equal (caddr (sb-kernel:%simple-fun-type
 721                          (checked-compile `(lambda (x)
 722                                              (declare ((and (or (simple-array * (11))
 723                                                                 (simple-array * (12)))
 724                                                             (not simple-vector))
 725                                                        x))
 726                                              (length x)))))
 727                  `(values (integer 11 12) &optional))))
 728
 729 (with-test (:name :aref-dimension-checking)
 730   (checked-compile-and-assert
 731       (:optimize :safe)
 732       `(lambda (x)
 733          (aref x 0))
 734     ((#2A((1 2) (3 4))) (condition 'type-error))))
 735
 736 (with-test (:name :aref-constant-type-derive)
 737   (flet ((test (form type)
 738            (assert
 739             (type-specifiers-equal
 740              (caddr
 741               (sb-kernel:%simple-fun-type
 742                (checked-compile
 743                 `(lambda (a)
 744                    ,form))))
 745              `(values ,type &optional)))))
 746     (test `(aref #(1 2 3) a)
 747           '(integer 1 3))
 748     (test `(svref #(1 2 3.0) a)
 749           '(or (integer 1 2) single-float))
 750     (test `(aref ,(make-array 3 :fill-pointer 2 :initial-contents #(1 2 3.0)) a)
 751           '(or (integer 1 2) single-float))))
 752
 753 (with-test (:name :make-array-initial-contents-zero-dimensions)
 754   (checked-compile-and-assert
 755       (:optimize :safe)
 756       `(lambda (d)
 757          (make-array d :initial-contents 1))
 758     ((nil) #0a1 :test #'equalp)))
 759
 760 (with-test (:name :negative-fill-pointer)
 761   (checked-compile-and-assert
 762    (:optimize :safe)
 763    `(lambda (a f)
 764       (setf (fill-pointer a) f))
 765    (((make-array 0 :fill-pointer 0) -1) (condition 'type-error))))
 766
 767 (with-test (:name :large-index
 768             :skipped-on (not :64-bit))
 769   (checked-compile
 770    `(lambda ()
 771       (make-array
 772        (1+ (ash 1 32))
 773        :element-type 'base-char
 774        :initial-element #\a)))
 775   (checked-compile
 776    `(lambda (x a)
 777       (setf (sbit x (ash 1 34)) a)))
 778   (checked-compile
 779    `(lambda (fn)
 780       (let ((s (make-string 536870910)))
 781         (declare (dynamic-extent s))
 782         (funcall fn s))))
 783   (checked-compile
 784    `(lambda (fn)
 785       (let ((s (make-string 536870910 :element-type 'base-char)))
 786         (declare (dynamic-extent s))
 787         (funcall fn s)))))
 788
 789 (with-test (:name :hairy-aref-check-bounds)
 790   (assert (= (count 'sb-kernel:%check-bound
 791                     (ctu:ir1-named-calls
 792                      `(lambda (x)
 793                         (declare ((vector t) x))
 794                         (aref x 0))
 795                      nil))
 796              0)))
 797
 798 (with-test (:name :setf-aref-simple-vector-from-new-value)
 799   (assert (not
 800            (ctu:ir1-named-calls
 801             `(lambda (x)
 802                (declare ((simple-array * (*)) x))
 803                (setf (aref x 0) 'm))))))
 804
 805 (with-test (:name :typep-displaced)
 806   (checked-compile-and-assert
 807       ()
 808       `(lambda (a)
 809          (typep a '(vector double-float)))
 810     (((make-array 1 :element-type 'double-float :displaced-to (make-array '(1 1) :element-type 'double-float))) t))
 811   (checked-compile-and-assert
 812       ()
 813       `(lambda (a)
 814          (typep a '(vector t 2)))
 815     (((make-array 2 :displaced-to (make-array '(2 1)))) t)))
 816
 817 (defun aindex (i array) (aref array i))
 818 (defun 2d-aindex (i array) (aref array i i))
 819 (defun seqindex (i seq) (elt seq i))
 820
 821 (with-test (:name :array-index-error-wording)
 822   ;; message contains a "should be ... below"
 823   (macrolet ((try (form)
 824                `(handler-case ,form
 825                   (:no-error (x) (error "Got ~S instead an error" x))
 826                   (condition (c)
 827                     (let ((str (princ-to-string c)))
 828                       (assert (search "Invalid index" str))
 829                       (assert (search "should be" str)))))))
 830     (try (aindex 5 #(1)))
 831     (try (2d-aindex 5 (make-array '(10 1))))
 832     (try (seqindex 5 #(1)))
 833     (try (seqindex 5 (make-array 9 :fill-pointer 1))))
 834   ;; message does not contains a "should be"
 835   (macrolet ((try (form)
 836                `(handler-case ,form
 837                   (:no-error (x) (error "Got ~S instead of an error" x))
 838                   (condition (c)
 839                     (let ((str (princ-to-string c)))
 840                       (assert (search "Invalid index" str))
 841                       (assert (not (search "should be" str)))
 842                       (assert (not (search "below 0" str))))))))
 843     (try (aindex 5 #()))
 844     (try (2d-aindex 5 (make-array '(10 0))))
 845     (try (seqindex 5 #()))
 846     (try (seqindex 5 (make-array 9 :fill-pointer 0)))))
 847
 848 (with-test (:name :fill-pointer-derive-type)
 849   (assert-type
 850    (lambda (n)
 851      (make-array n :element-type 'character :fill-pointer 0))
 852    (and (vector character) (not simple-array)))
 853   (assert-type
 854    (lambda (n f)
 855      (make-array n :element-type 'character :fill-pointer f))
 856    (array character)))
 857
 858 (with-test (:name :backquote-transform)
 859   (assert (nth-value 2
 860                      (checked-compile
 861                       `(lambda (a)
 862                          (make-array `(,a (+ 1 2))))
 863                       :allow-warnings t))))