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 (= sb-vm:n-fixnum-tag-bits 1)
 426     (multiple-value-bind (fun failure-p warnings)
 427         (checked-compile
 428          '(lambda ()
 429             (make-array (1- array-total-size-limit)))
 430          :allow-failure t :allow-warnings t)
 431       (assert failure-p)
 432       (assert (= 1 (length warnings)))
 433       (assert-error (funcall fun) type-error))))
 434
 435 (with-test (:name (adjust-array :non-adjustable))
 436   (let* ((a (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5))))
 437          (b (adjust-array a '(2 2))))
 438     (setf (aref a 0 0) 11)
 439     (assert (zerop (aref b 0 0)))
 440     (assert (not (eq a b)))))
 441
 442 (with-test (:name :check-bound-elision)
 443   (checked-compile-and-assert (:optimize :safe)
 444       `(lambda (x)
 445          (char "abcd" x))
 446     ((4) (condition 'sb-int:invalid-array-index-error)))
 447   (checked-compile-and-assert (:optimize '(:safety 0))
 448       `(lambda (x)
 449          ;; Strings are null-terminated for C interoperability
 450          (char #.(coerce "abcd" 'simple-base-string) x))
 451     ((4) #\Nul)))
 452 (defun check-bound-multiple-reads (x i)
 453   (let* ((x (truly-the simple-vector x))
 454          (l (sb-c::vector-length x)))
 455     (sb-kernel:%check-bound x l i)
 456     l))
 457 (compile 'check-bound-multiple-reads)
 458 (with-test (:name :check-bound-vop-optimize)
 459   ;; could have crashed with the bad optimizer
 460   (check-bound-multiple-reads #(a b c) 2))
 461
 462 (with-test (:name (adjust-array :transform))
 463   (checked-compile-and-assert ()
 464       `(lambda ()
 465          (adjust-array #(1 2 3) 3 :displaced-to #(4 5 6)))
 466     (() #(4 5 6) :test #'equalp)))
 467
 468 (with-test (:name (adjust-array :fill-pointer))
 469   (let ((array (make-array 10 :fill-pointer t :initial-element 0)))
 470     (assert (= (fill-pointer (adjust-array array 5 :fill-pointer 2))
 471                2))))
 472
 473 (with-test (:name (adjust-array :initial-element))
 474   (checked-compile-and-assert ()
 475       `(lambda (x)
 476          (adjust-array x 5 :initial-element #\x))
 477     (("abc") "abcxx")))
 478
 479 (with-test (:name (make-array :initial-contents 1))
 480   (flet ((f (x y)
 481            (sb-int:dx-let ((a (make-array `(,x ,y)
 482                                           :initial-contents
 483                                           '((a b c) (1 2 3)))))
 484              (eval a)
 485              nil)))
 486     (f 2 3)
 487     (assert-error (f 3 2))))
 488
 489 (with-test (:name (make-array :initial-contents 2))
 490   (labels ((compute-contents () '((a b c) (1 2 3)))
 491            (f (x y)
 492              (sb-int:dx-let ((a (make-array `(,x ,y)
 493                                             :initial-contents
 494                                             (compute-contents))))
 495                (eval a)
 496                 nil)))
 497     (declare (notinline compute-contents))
 498     (f 2 3)
 499     (assert-error (f 3 2))))
 500
 501 (with-test (:name (make-array :initial-contents 3))
 502   (multiple-value-bind (fun failure-p warnings)
 503       (checked-compile
 504        '(lambda (z)
 505           (symbol-macrolet ((x (+ 1 1)) (y (* 2 1)))
 506             (make-array `(,x ,y)
 507                         :initial-contents
 508                         `((,z ,z 1) (,z ,z ,z)))))
 509        :allow-failure t :allow-warnings t)
 510     (assert failure-p)
 511     (assert (= 1 (length warnings)))
 512     (assert-error (funcall fun 0) error)))
 513
 514 (with-test (:name (adjust-array :element-type))
 515   (checked-compile-and-assert ()
 516       `(lambda (array)
 517          (adjust-array array 3 :element-type '(signed-byte 2)))
 518     ((#(1 2 3)) (condition 'error)))
 519   (checked-compile-and-assert ()
 520       `(lambda (array)
 521          (adjust-array array 5 :displaced-to #(1 2 3)))
 522     (((make-array 5 :adjustable t :element-type 'fixnum)) (condition 'error))))
 523
 524 (with-test (:name (make-array :transform :fill-pointer nil))
 525   (flet ((test (form)
 526            (assert (not (ctu:ir1-named-calls `(lambda () ,form))))))
 527     (test '(make-array 3      :fill-pointer nil))
 528     (test '(make-array 3      :fill-pointer nil))
 529     (test '(make-array 3      :fill-pointer t))
 530     (test '(make-array 3      :adjustable nil))
 531     (test '(make-array '(3 3) :adjustable nil))
 532     (test '(make-array '(3 3) :fill-pointer nil))))
 533
 534 (with-test (:name (make-array :transform :adjustable :fill-pointer))
 535   (multiple-value-bind (calls fun)
 536       (ctu:ir1-named-calls '(lambda (fp) (make-array 3 :adjustable t :fill-pointer fp)))
 537     (assert (not (member 'sb-kernel:%make-array calls)))
 538     (assert (= (length (funcall fun t)) 3))
 539     (assert (array-has-fill-pointer-p (funcall fun t)))
 540     (assert (= (length (funcall fun 2)) 2))
 541     (assert (= (array-total-size (funcall fun 2)) 3))
 542     (assert-error (funcall fun 4))
 543     (assert-error (funcall fun 'abc))
 544     (assert (not (array-has-fill-pointer-p (funcall fun nil))))
 545     (assert (= (length (funcall fun nil)) 3))))
 546
 547 (with-test (:name (make-array :transform :non-constant-fill-pointer))
 548   ;; Known adjustable with any fill-pointer can be inlined
 549   (multiple-value-bind (calls fun)
 550       (ctu:ir1-named-calls '(lambda (n fillp)
 551                                  (make-array (the (mod 20) n)
 552                                              :adjustable t :fill-pointer fillp)))
 553     (assert (not (member 'sb-kernel:%make-array calls)))
 554     (let ((a (funcall fun 10 3)))
 555       (assert (= (length a) 3))
 556       (assert (= (array-dimension a 0) 10))))
 557   ;; Non-adjustable w/ non-constant numeric fill-pointer can be inlined
 558   (multiple-value-bind (calls fun)
 559       (ctu:ir1-named-calls '(lambda (n)
 560                                  (make-array (the (mod 20) n)
 561                                              :fill-pointer (floor n 2))))
 562     (assert (not (member 'sb-kernel:%make-array calls)))
 563     (let ((a (funcall fun 10)))
 564       (assert (= (length a) 5))
 565       (assert (= (array-dimension a 0) 10)))))
 566
 567 (with-test (:name :check-bound-fixnum-check)
 568   (checked-compile-and-assert (:optimize :safe)
 569       `(lambda (x) (aref #100(a) x))
 570     ((#\Nul) (condition 'type-error))))
 571
 572 (with-test (:name (make-array :erroneous-type-specifiers))
 573   (dolist (atom '(signed-byte unsigned-byte))
 574     (assert (handler-case (eval `(make-array 10 :element-type '(,atom "oops")))
 575               (error (c) (search (format nil "bad size specified for ~A" atom)
 576                                  (princ-to-string c)))
 577               (:no-error (obj) obj nil)))))
 578
 579 (with-test (:name (make-array :strange-type-specifiers))
 580   (assert (stringp (make-array 10 :element-type (opaque-identity '(base-char)))))
 581   (assert (stringp (make-array 10 :element-type (opaque-identity '(standard-char)))))
 582   ;; If there are no extended characters (as on #-sb-unicode), then EXTENDED-CHAR is
 583   ;; the empty type. You'll get exactly what you ask for: an array which can hold
 584   ;; nothing. It's not a string, which is the right answer.
 585   #+sb-unicode
 586   (assert (stringp (make-array 10 :element-type (opaque-identity '(extended-char)))))
 587   (assert (bit-vector-p (make-array 10 :element-type (opaque-identity '(bit))))))
 588
 589 (with-test (:name :make-array-satisifies-element-type)
 590   (checked-compile-and-assert
 591       ()
 592       '(lambda (type)
 593         (make-array 3 :initial-element #\a :element-type type))
 594     (('(and character (satisfies eval))) "aaa" :test #'equal)
 595     (('(and character (or (satisfies eval) base-char))) "aaa" :test #'equal)))
 596
 597 (with-test (:name :make-array-or-unsigned-byte-type)
 598   (checked-compile-and-assert
 599       ()
 600       '(lambda (type)
 601         (make-array 1 :element-type type :initial-element 0))
 602     (('(or (eql -16) unsigned-byte)) #(0) :test #'equalp)))
 603
 604 (with-test (:name :check-bound-signed-bound-notes
 605             :fails-on (not (or :x86-64 :x86 :arm64)))
 606   (checked-compile-and-assert
 607       (:allow-notes nil)
 608       `(lambda (x y)
 609          (declare (fixnum y))
 610          (svref x (+ y 2)))
 611     ((#(1 2 3) 0) 3)))
 612
 613 (with-test (:name :make-array-header*-type-derivation)
 614   (let ((fun (checked-compile
 615               '(lambda (a)
 616                 (declare ((simple-array (unsigned-byte 8) (*)) a))
 617                 (make-array '(10 20) :element-type (array-element-type a))))))
 618     (assert (typep (funcall fun #A((1) (UNSIGNED-BYTE 8) 0))
 619                    '(simple-array (unsigned-byte 8) (10 20))))
 620     (assert
 621      (equal (sb-kernel:%simple-fun-type fun)
 622             '(function ((simple-array (unsigned-byte 8) (*)))
 623               (values (simple-array (unsigned-byte 8) (10 20)) &optional))))))
 624
 625 (with-test (:name :displaced-to-with-intitial)
 626   (checked-compile-and-assert
 627       ()
 628       `(lambda (x)
 629          (make-array 1 :displaced-to x :initial-element 1))
 630     ((#(0)) (condition 'error)))
 631   (assert
 632    (nth-value 2
 633               (checked-compile
 634                `(lambda ()
 635                   (lambda (x)
 636                     (make-array 1 :displaced-to (the vector x) :initial-contents '(1))))
 637                :allow-warnings t))))
 638
 639 (with-test (:name :check-bound-type-error)
 640   (assert (nth-value 2
 641                      (checked-compile
 642                       `(lambda (p)
 643                          (unless (svref p 0)
 644                            (svref p nil)))
 645                       :allow-warnings t))))
 646
 647 (with-test (:name :array-has-fill-pointer-p-folding)
 648   (assert (equal (sb-kernel:%simple-fun-type
 649                   (checked-compile `(lambda (x)
 650                                       (declare ((array * (* *)) x))
 651                                       (array-has-fill-pointer-p x))))
 652                  `(function ((array * (* *))) (values null &optional)))))
 653
 654 (with-test (:name :array-has-fill-pointer-p-transform)
 655   (checked-compile-and-assert
 656    ()
 657    `(lambda (n)
 658       (let ((a (make-array n)))
 659         (declare (vector a))
 660         (map-into a #'identity a)))
 661    ((0) #() :test #'equalp)))
 662
 663 (with-test (:name :displaced-index-offset-disallow-nil)
 664   (assert-error (eval '(make-array 4 :displaced-index-offset nil))))
 665
 666 (with-test (:name :adjust-array-copies-above-fill-pointer)
 667   (let ((a (make-array 4 :fill-pointer 2 :initial-contents '(a b c d))))
 668     (let ((b (adjust-array a 6 :initial-element 'e)))
 669       (assert (eq (aref b 2) 'c))
 670       (assert (eq (aref b 3) 'd))
 671       (assert (eq (aref b 4) 'e))
 672       (assert (eq (aref b 5) 'e)))))
 673
 674 (with-test (:name :test-array-dimensions-other-pointer-check)
 675   (checked-compile-and-assert
 676       ()
 677       `(lambda (a)
 678          (typep a '(simple-array t (2 1))))
 679     ((1) nil)
 680     ((#2A((1) (1))) t)))
 681
 682 (with-test (:name :typep-constant-%array-data-folding)
 683   (checked-compile-and-assert
 684       ()
 685       `(lambda ()
 686          (typep "abcd" '(simple-array t 2)))
 687     (() nil)))
 688
 689 (with-test (:name :vector-push-extend-specialized)
 690   (let ((extend (checked-compile `(lambda (e a)
 691                                     (vector-push-extend e a)
 692                                     a))))
 693     (loop for saetp across sb-vm:*specialized-array-element-type-properties*
 694           for type = (sb-vm:saetp-specifier saetp)
 695           when type
 696           do
 697           (let* ((value (sb-vm:saetp-initial-element-default saetp))
 698                  (value (if (characterp value)
 699                             (code-char (1+ (char-code value)))
 700                             (1+ value))))
 701             (assert (eql (aref (funcall extend value (make-array 1 :element-type type
 702                                                                    :adjustable t
 703                                                                    :fill-pointer t))
 704                                1)
 705                          value))))))
 706
 707 (with-test (:name :intersection-type-complexp)
 708   (assert (equal (caddr (sb-kernel:%simple-fun-type
 709                          (checked-compile `(lambda (x)
 710                                              (declare ((and (simple-array * (10))
 711                                                             (not simple-vector))
 712                                                        x))
 713                                              (length x)))))
 714                  `(values (integer 10 10) &optional))))
 715
 716 (with-test (:name :vector-length-intersection-types)
 717   (assert (equal (caddr (sb-kernel:%simple-fun-type
 718                          (checked-compile `(lambda (x)
 719                                              (declare ((and (or (simple-array * (11))
 720                                                                 (simple-array * (12)))
 721                                                             (not simple-vector))
 722                                                        x))
 723                                              (length x)))))
 724                  `(values (integer 11 12) &optional))))
 725
 726 (with-test (:name :aref-dimension-checking)
 727   (checked-compile-and-assert
 728       (:optimize :safe)
 729       `(lambda (x)
 730          (aref x 0))
 731     ((#2A((1 2) (3 4))) (condition 'type-error))))
 732
 733 (with-test (:name :aref-constant-type-derive)
 734   (flet ((test (form type)
 735            (assert
 736             (type-specifiers-equal
 737              (caddr
 738               (sb-kernel:%simple-fun-type
 739                (checked-compile
 740                 `(lambda (a)
 741                    ,form))))
 742              `(values ,type &optional)))))
 743     (test `(aref #(1 2 3) a)
 744           '(integer 1 3))
 745     (test `(svref #(1 2 3.0) a)
 746           '(or (integer 1 2) single-float))
 747     (test `(aref ,(make-array 3 :fill-pointer 2 :initial-contents #(1 2 3.0)) a)
 748           '(or (integer 1 2) single-float))))
 749
 750 (with-test (:name :make-array-initial-contents-zero-dimensions)
 751   (checked-compile-and-assert
 752       (:optimize :safe)
 753       `(lambda (d)
 754          (make-array d :initial-contents 1))
 755     ((nil) #0a1 :test #'equalp)))
 756
 757 (with-test (:name :negative-fill-pointer)
 758   (checked-compile-and-assert
 759    (:optimize :safe)
 760    `(lambda (a f)
 761       (setf (fill-pointer a) f))
 762    (((make-array 0 :fill-pointer 0) -1) (condition 'type-error))))
 763
 764 (with-test (:name :large-index
 765             :skipped-on (not :64-bit))
 766   (checked-compile
 767    `(lambda ()
 768       (make-array
 769        (1+ (ash 1 32))
 770        :element-type 'base-char
 771        :initial-element #\a)))
 772   (checked-compile
 773    `(lambda (x a)
 774       (setf (sbit x (ash 1 34)) a)))
 775   (checked-compile
 776    `(lambda (fn)
 777       (let ((s (make-string 536870910)))
 778         (declare (dynamic-extent s))
 779         (funcall fn s)))))