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