tests/seq.pure.lisp

   1 ;;;; tests related to sequences
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 ;;; As reported by Paul Dietz from his ansi-test suite for gcl, REMOVE
  15 ;;; malfunctioned when given :START, :END and :FROM-END arguments.
  16 ;;; Make sure it doesn't happen again.
  17 (with-test (:name (remove :start :end :from-end))
  18   (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7))
  19          (x (copy-seq orig))
  20          (y (remove 3 x :from-end t :start 1 :end 5))
  21          (z (remove 2 x :from-end t :start 1 :end 5)))
  22     (assert (equalp orig x))
  23     (assert (equalp y '(1 2 2 6 1 2 4 1 3 2 7)))
  24     (assert (equalp z '(1 3 6 1 2 4 1 3 2 7)))))
  25
  26 ;;; Similarly, NSUBSTITUTE and friends were getting things wrong with
  27 ;;; :START, :END and :FROM-END:
  28 (with-test (:name (nsubstitute :start :end :from-end))
  29   (assert
  30    (loop for i from 0 to 9 always
  31             (loop for j from i to 10 always
  32                      (loop for c from 0 to (- j i) always
  33                               (let* ((orig '(a a a a a a a a a a))
  34                                      (x (copy-seq orig))
  35                                      (y (nsubstitute 'x 'a x :start i :end j :count c)))
  36                                 (equal y (nconc (make-list i :initial-element 'a)
  37                                                 (make-list c :initial-element 'x)
  38                                                 (make-list (- 10 (+ i c))
  39                                                            :initial-element 'a))))))))
  40
  41   (assert
  42    (loop for i from 0 to 9 always
  43             (loop for j from i to 10 always
  44                      (loop for c from 0 to (- j i) always
  45                               (let* ((orig '(a a a a a a a a a a))
  46                                      (x (copy-seq orig))
  47                                      (y (nsubstitute-if 'x (lambda (x) (eq x 'a)) x
  48                                                         :start i :end j
  49                                                         :count c :from-end t)))
  50                                 (equal y (nconc (make-list (- j c) :initial-element 'a)
  51                                                 (make-list c :initial-element 'x)
  52                                                 (make-list (- 10 j)
  53                                                            :initial-element 'a))))))))
  54   (assert
  55    (loop for i from 0 to 9 always
  56             (loop for j from i to 10 always
  57                      (loop for c from 0 to (- j i) always
  58                               (let* ((orig '(a a a a a a a a a a))
  59                                      (x (copy-seq orig))
  60                                      (y (nsubstitute-if-not 'x (lambda (x)
  61                                                                  (not (eq x 'a))) x
  62                                                                  :start i :end j
  63                                                                  :count c :from-end t)))
  64                                 (equal y (nconc (make-list (- j c) :initial-element 'a)
  65                                                 (make-list c :initial-element 'x)
  66                                                 (make-list (- 10 j)
  67                                                            :initial-element 'a)))))))))
  68
  69 ;;; And equally similarly, REMOVE-DUPLICATES misbehaved when given
  70 ;;; :START arguments:
  71
  72 (with-test (:name (remove-duplicates delete-duplicates :start :end))
  73   (let ((orig (list 0 1 2 0 1 2 0 1 2 0 1 2)))
  74     (assert (equalp (remove-duplicates orig :start 3 :end 9) '(0 1 2 0 1 2 0 1 2)))
  75     (assert (equalp (delete-duplicates orig :start 3 :end 9) '(0 1 2 0 1 2 0 1 2)))))
  76
  77 ;;; tests of COUNT
  78 (with-test (:name (count))
  79   (assert (= 1 (count 1 '(1 2 3))))
  80   (assert (= 2 (count 'z #(z 1 2 3 z))))
  81   (assert (= 0 (count 'y '(z 1 2 3 z)))))
  82
  83 ;;; tests of COUNT-IF and COUNT-IF-NOT
  84 (with-test (:name (count-if count-if-not))
  85   (macrolet (;; the guts of CCI, abstracted over whether we're testing
  86              ;; COUNT-IF or COUNT-IF-NOT
  87              (%cci (expected count-if test sequence-as-list &rest keys)
  88                `(let* ((list ',sequence-as-list)
  89                        (simple-vector (coerce list 'simple-vector))
  90                        (length (length list))
  91                        (vector (make-array (* 2 length) :fill-pointer length)))
  92                   (replace vector list :end1 length)
  93                   (dolist (seq (list list simple-vector vector))
  94                     (assert (= ,expected (,count-if ,test seq ,@keys))))))
  95              ;; "Check COUNT-IF"
  96              (cci (expected test sequence-as-list &rest keys)
  97                `(progn
  98                   (%cci ,expected
  99                         count-if
 100                         ,test
 101                         ,sequence-as-list
 102                         ,@keys)
 103                   (%cci ,expected
 104                         count-if-not
 105                         (complement ,test)
 106                         ,sequence-as-list
 107                         ,@keys))))
 108     (cci 1 #'consp (1 (12) 1))
 109     (cci 3 #'consp (1 (2) 3 (4) (5) 6))
 110     (cci 3 #'consp (1 (2) 3 (4) (5) 6) :from-end t)
 111     (cci 2 #'consp (1 (2) 3 (4) (5) 6) :start 2)
 112     (cci 0 #'consp (1 (2) 3 (4) (5) 6) :start 2 :end 3)
 113     (cci 1 #'consp (1 (2) 3 (4) (5) 6) :start 1 :end 3)
 114     (cci 1 #'consp (1 (2) 3 (4) (5) 6) :start 1 :end 2)
 115     (cci 0 #'consp (1 (2) 3 (4) (5) 6) :start 2 :end 2)
 116     (cci 2 #'zerop (0 10 0 11 12))
 117     (cci 1 #'zerop (0 10 0 11 12) :start 1)
 118     (cci 2 #'minusp (0 10 0 11 12) :key #'1-)
 119     (cci 1 #'minusp (0 10 0 11 12) :key #'1- :end 2))
 120
 121   (multiple-value-bind (fun failure-p warnings style-warnings)
 122       (checked-compile `(lambda ()
 123                           (count-if #'zerop '(0 a 0 b c) :start 1))
 124                        :allow-style-warnings t)
 125     (declare (ignore failure-p warnings))
 126     (assert (= (length style-warnings) 1))
 127     (let ((condition (grab-condition (funcall fun))))
 128       (assert (eql (type-error-datum condition) 'a))))
 129   (multiple-value-bind (fun failure-p warnings style-warnings)
 130       (checked-compile `(lambda ()
 131                           (count-if #'zerop #(0 a 0 b c) :start 1 :from-end 11))
 132                        :allow-style-warnings t)
 133     (declare (ignore failure-p warnings))
 134     (assert (= (length style-warnings) 1))
 135     (let ((condition (grab-condition (funcall fun))))
 136       (assert (eql (type-error-datum condition) 'c)))))
 137
 138 ;;; :COUNT may be negative and BIGNUM
 139 (with-test (:name (remove :count :negative bignum))
 140   (assert (equal (remove 1 '(1 2 3 1) :count 1) '(2 3 1)))
 141   (assert (equal (remove 1 '(1 2 3 1) :count (* 2 most-positive-fixnum)) '(2 3)))
 142   (assert (equal (remove 1 '(1 2 3 1) :count (* -2 most-positive-fixnum)) '(1 2 3 1))))
 143
 144 ;;; bug reported by Wolfgang Jenkner on sbcl-devel 2003-01-04:
 145 ;;; embedded calls of SORT do not work
 146 (with-test (:name (sort :nested-calls))
 147   (assert (equal (sort (list 0 0 0)
 148                        (lambda (x y)
 149                          (if (= x y) ; uses X, Y and SORT return value
 150                              nil
 151                              (sort (list 0 0 0) #'<))))
 152                  '(0 0 0)))
 153
 154   (assert (equal (sort (list 0 0 0 0 0)
 155                        (lambda (x y)
 156                          (declare (ignore x y))
 157                          (block compare
 158                            (sort (make-list 11 :initial-element 1)
 159                                  (let ((counter 7))
 160                                    (lambda (x y)
 161                                      (declare (ignore x y))
 162                                      (when (= (decf counter) 0)
 163                                        (return-from compare nil))
 164                                      t))))))
 165                  '(0 0 0 0 0))))
 166
 167 ;;; miscellaneous sanity checks on stuff which could've been broken by
 168 ;;; changes in MERGE-LIST* in sbcl-0.7.11.*
 169 (with-test (:name (merge stable-sort :sanity-checks))
 170   (assert (equal (merge 'list () () '<) ()))
 171   (assert (equal (merge 'list () (list 1) #'< :key 'identity) '(1)))
 172   (assert (equal (merge 'list (list 2) () '>) '(2)))
 173   (assert (equal (merge 'list (list 1 2 4) (list 2 3 7) '<) '(1 2 2 3 4 7)))
 174   (assert (equal (merge 'list (list 1 2 4) (list -2 3 7) #'<) '(-2 1 2 3 4 7)))
 175   (assert (equal (merge 'list (list 1 2 4) (vector -2 3 7) '< :key 'abs)
 176                  '(1 2 -2 3 4 7)))
 177   (assert (equal (merge 'list (list 1 -2 4) (list -2 3 7) '< :key #'abs)
 178                  '(1 -2 -2 3 4 7)))
 179   (assert (equal (stable-sort (list 1 10 2 12 13 3) '<) '(1 2 3 10 12 13)))
 180   (assert (equal (stable-sort (list 1 10 2 12 13 3) #'< :key '-)
 181                  '(13 12 10 3 2 1)))
 182   (assert (equal (stable-sort (list 1 10 2 12 13 3) '> :key #'-)
 183                  '(1 2 3 10 12 13)))
 184   (assert (equal (stable-sort (list 1 2 3 -3 -2 -1) '< :key 'abs)
 185                  '(1 -1 2 -2 3 -3))))
 186
 187 ;;; CSR broke FILL by not returning the sequence argument in a transform.
 188 (with-test (:name fill)
 189   (let* ((s1 (copy-seq "abcde"))
 190          (s2 (fill s1 #\z)))
 191     (assert s2)
 192     (assert (string= s2 "zzzzz"))))
 193
 194 ;;; POSITION on displaced arrays with non-zero offset has been broken
 195 ;;; for quite a while...
 196 (with-test (:name (position :displaced-array))
 197   (let* ((x #(1 2 3))
 198          (y (make-array 2 :displaced-to x :displaced-index-offset 1)))
 199     (assert (= (position 2 y) 0))))
 200
 201 ;;; (SIMPLE-STRING) is a legal type specifier for creation functions
 202 (with-test (:name (make-sequence concatenate map merge coerce simple-string))
 203   (let ((a (make-sequence '(simple-string) 5))
 204         (b (concatenate '(simple-string) "a" "bdec"))
 205         (c (map '(simple-string) 'identity "abcde"))
 206         (d (merge '(simple-string) (copy-seq "acd") (copy-seq "be") 'char>))
 207         (e (coerce '(#\a #\b #\c #\e #\d) '(simple-string))))
 208     (assert (= (length a) 5))
 209     (assert (string= b "abdec"))
 210     (assert (string= c "abcde"))
 211     (assert (string= d "beacd"))
 212     (assert (string= e "abced"))))
 213
 214 ;;; COPY-SEQ "should be prepared to signal an error if sequence is not
 215 ;;; a proper sequence".
 216 (with-test (:name (copy-seq type-error))
 217   (locally (declare (optimize safety))
 218     (multiple-value-bind (seq err) (ignore-errors (copy-seq (opaque-identity '(1 2 3 . 4))))
 219       (assert (not seq))
 220       (assert (typep err 'type-error)))))
 221
 222 ;;; UBX-BASH-COPY transform had an inconsistent return type
 223 (with-test (:name (replace (unsigned-byte 8) :return-type))
 224   (let ((sb-c::*check-consistency* t))
 225     (checked-compile
 226      '(lambda (l)
 227        (declare (type fixnum l))
 228        (let* ((bsize 128)
 229               (b1 (make-array bsize :element-type '(unsigned-byte 8)))
 230               (b2 (make-array l :element-type '(unsigned-byte 8))))
 231          (replace b1 b2 :start2 0 :end2 l))))))
 232
 233 (with-test (:name :bug-452008)
 234   ;; FIND & POSITION on lists should check bounds and (in safe code) detect
 235   ;; circular and dotted lists.
 236   (labels ((safe (&key speed safety &allow-other-keys)
 237              (case safety
 238                (0 (= speed 0))
 239                (t t)))
 240            (extra-safe (&key speed safety &allow-other-keys)
 241              (case safety
 242                (0 (= speed 0))
 243                (1 (< speed 2))
 244                (t t)))
 245            (test (type expr &key (filter #'safe))
 246              (checked-compile-and-assert
 247                  (:optimize `(:compilation-speed nil :space nil :filter ,filter)
 248                   :allow-style-warnings t)
 249                  `(lambda () ,expr)
 250                (() (condition type)))))
 251     (test 'sb-kernel:bounding-indices-bad-error
 252           '(find :foo '(1 2 3 :foo) :start 1 :end 5 :from-end t))
 253     (test 'sb-kernel:bounding-indices-bad-error
 254           '(position :foo '(1 2 3 :foo) :start 1 :end 5 :from-end t))
 255     (test 'sb-kernel:bounding-indices-bad-error
 256           '(find :foo '(1 2 3 :foo) :start 3 :end 0 :from-end t))
 257     (test 'sb-kernel:bounding-indices-bad-error
 258           '(position :foo '(1 2 3 :foo) :start 3 :end 0 :from-end t))
 259     (test 'type-error
 260           '(let ((list (list 1 2 3 :foo)))
 261              (find :bar (nconc list list)))
 262           :filter #'extra-safe)
 263     (test 'type-error
 264           '(let ((list (list 1 2 3 :foo)))
 265              (position :bar (nconc list list)))
 266           :filter #'extra-safe)))
 267
 268 (with-test (:name :bug-554385)
 269   ;; FIND-IF shouldn't look through the entire list.
 270   (assert (= 2 (find-if #'evenp '(1 2 1 1 1 1 1 1 1 1 1 1 :foo))))
 271   ;; Even though the end bounds are incorrect, the
 272   ;; element is found before that's an issue.
 273   (assert (eq :foo (find :foo '(1 2 3 :foo) :start 1 :end 5)))
 274   (assert (= 3 (position :foo '(1 2 3 :foo) :start 1 :end 5))))
 275
 276 (with-test (:name (search :empty-seq))
 277   (checked-compile-and-assert ()
 278       `(lambda (x)
 279          (declare (simple-vector x))
 280          (search x #()))
 281     ((#()) 0))
 282   (checked-compile-and-assert ()
 283       `(lambda (x)
 284          (declare (simple-vector x))
 285          (search x #(t t t)))
 286     ((#()) 0))
 287   (checked-compile-and-assert ()
 288       `(lambda (x)
 289          (declare (simple-vector x))
 290          (search x #(t t t) :end1 0))
 291     ((#(t t t)) 0))
 292   (checked-compile-and-assert ()
 293       `(lambda (x)
 294          (declare (simple-vector x))
 295          (search x #(t t t) :key nil))
 296     ((#()) 0))
 297   (checked-compile-and-assert ()
 298       `(lambda (x k)
 299          (declare (simple-vector x))
 300          (search x #(t t t) :key k))
 301     ((#() nil) 0))
 302   (checked-compile-and-assert (:optimize :safe :allow-warnings 'warning)
 303       `(lambda (x)
 304          (declare (simple-vector x))
 305          (search x #(t t t) :start2 1 :end2 0 :end1 0))
 306     ((#(t t t)) (condition 'sb-kernel:bounding-indices-bad-error)))
 307   (assert (eql 1
 308                (funcall (lambda ()
 309                           (declare (optimize speed))
 310                           (search #() #(1 1) :start2 1 :end2 1)))))
 311   (assert (eql 2
 312                (funcall (lambda ()
 313                           (declare (optimize speed))
 314                           (search #(1) #(1 1) :start1 1 :start2 2)))))
 315   (assert (eql 2
 316                (funcall (lambda ()
 317                           (declare (optimize speed))
 318                           (search #() #(1 1) :from-end t))))))
 319
 320 (with-test (:name (sort :smoke-test))
 321   (flet ((iota (n type &aux (i 0))
 322            (map-into (make-sequence type n)
 323                      (lambda ()
 324                        (incf i))))
 325          (shuffle (n type)
 326            (let ((vector (let ((i 0))
 327                            (map-into (make-array n)
 328                                      (lambda ()
 329                                        (incf i))))))
 330              (dotimes (i n (coerce vector type))
 331                (let ((j (+ i (random (- n i)))))
 332                  (rotatef (aref vector i) (aref vector j))))))
 333          (sortedp (x)
 334            (let* ((nonce (list nil))
 335                   (prev nonce))
 336              (every (lambda (x)
 337                       (prog1 (or (eql prev nonce)
 338                                  (< prev x))
 339                         (setf prev x)))
 340                     x))))
 341     (dolist (type '(simple-vector list))
 342       (dolist (size '(7 8 9 13 1023 1024 1025 1536))
 343         (loop for repeat below 5 do
 344           (assert (sortedp
 345                    (sort (funcall (case repeat
 346                                     (0 #'iota)
 347                                     (1 (lambda (n type)
 348                                          (reverse (iota n type))))
 349                                     (t #'shuffle))
 350                                   size type)
 351                          #'<))))))))
 352
 353 (with-test (:name (stable-sort :smoke-test))
 354   (flet ((iota (n type &aux (i 0))
 355            (map-into (make-sequence type n)
 356                      (lambda ()
 357                        (cons 0 (incf i)))))
 358          (shuffle (n type)
 359            (let ((max (truncate (expt n 1/4)))
 360                  (i   0))
 361              (map-into (make-sequence type n)
 362                        (lambda ()
 363                          (cons (random max) (incf i))))))
 364          (sortedp (x)
 365            (let* ((nonce (list nil))
 366                   (prev nonce))
 367              (every (lambda (x)
 368                       (prog1 (or (eql prev nonce)
 369                                  (< (car prev) (car x))
 370                                  (and (= (car prev) (car x))
 371                                       (< (cdr prev) (cdr x))))
 372                         (setf prev x)))
 373                     x))))
 374     (dolist (type '(simple-vector list))
 375       (dolist (size '(0  1  2  3  4  5  6  7  8
 376                       9 10 11 12 13 14 15 16 17
 377                       1023 1024 1025 1536))
 378         (loop for repeat below 5 do
 379           (assert
 380            (sortedp
 381             (stable-sort (funcall (case repeat
 382                                     (0 #'iota)
 383                                     (t #'shuffle))
 384                                   size type)
 385                          #'< :key #'car))))))))
 386
 387 (with-test (:name :&more-elt-index-too-large)
 388   (checked-compile-and-assert
 389       (:optimize `(:filter ,(lambda (&key safety &allow-other-keys)
 390                               (= safety 3))))
 391       `(lambda (&rest args)
 392          (elt args 0))
 393     (() (condition 'sb-kernel:index-too-large-error))))
 394
 395 (with-test (:name (sequence:dosequence :on-literals))
 396   (assert (= (sequence:dosequence (e #(1 2 3)) (return e))
 397              1)))
 398
 399 (with-test (:name (search :transform-notes))
 400   (checked-compile `(lambda (s)
 401                       (declare (optimize (speed 3) (safety 0))
 402                                (type simple-string s))
 403                       (search "foo" s))
 404                    :allow-notes nil))
 405
 406 (with-test (:name (concatenate :two-constants))
 407   (assert (equal (funcall
 408                   (lambda () (declare (optimize (speed 3)))
 409                     (concatenate 'string "a" "b")))
 410                  "ab")))
 411
 412 (with-test (:name (make-sequence :transform :bug-330299))
 413   (flet ((test (form &rest args)
 414            (multiple-value-bind (fun failure-p warnings style-warnings)
 415                (apply #'checked-compile form args)
 416              (declare (ignore fun failure-p))
 417              (assert (= (+ (length warnings) (length style-warnings)) 1)))))
 418     ;; test case from bug report.
 419     ;; erroneous situation is caught by MAKE-ARRAY
 420     (test '(lambda (size)
 421              (make-sequence 'bit-vector size :initial-element #\0))
 422           :allow-warnings 'sb-int:type-warning)
 423     ;; This is transformed, but MAKE-ARRAY does *not* consider it a problem
 424     ;; since #\x is in the upgraded array type. That's too bad, because
 425     ;; it's still poor style.
 426     #+nil
 427     (test '(lambda (size)
 428              (make-sequence '(member #\a #\b) size :initial-element #\x)))
 429     ;; additional tests where the transform gives up but warns
 430     (test '(lambda (n)
 431              (make-sequence '(vector (integer 1 15) 5) n :initial-element #\x))
 432           :allow-warnings t)
 433     (test '(lambda (n)
 434             (make-sequence '(vector (integer 1 15) 5) n))
 435           :allow-style-warnings t)))
 436
 437 ;; Precisely type-check result of full call to MAP.
 438 (with-test (:name (map notinline :maximally-safe))
 439   (assert-error
 440    (locally (declare (notinline map)) (map '(cons symbol) '+ '(1 2) '(3 4)))
 441    type-error)
 442   (assert-error
 443    (locally (declare (notinline map))
 444             (map '(cons t (cons t null)) '+ '(1 2 3) '(10 10 10)))
 445    type-error))
 446
 447 (with-test (:name (search :singleton-transform))
 448   (checked-compile-and-assert ()
 449     `(lambda (e) (search '(a) '(b) :end1 e))
 450     ((0) 0)))
 451
 452 (with-test (:name (search :type-derivation))
 453   (checked-compile-and-assert
 454    ()
 455    `(lambda (a b)
 456       (eql (search a (the (simple-vector 2) b) :from-end t) 2))
 457    ((#() #(1 2)) t)
 458    ((#(1) #(1 2)) nil)))
 459
 460 (with-test (:name (count :no-consing)
 461             :skipped-on :interpreter)
 462   (let ((f (checked-compile
 463             '(lambda (x)
 464               (count 1 x)))))
 465     (ctu:assert-no-consing (funcall f #(1 2 3 4)))
 466     (ctu:assert-no-consing (funcall f '(1 2 3 4)))))
 467
 468 (with-test (:name :hash-based-position)
 469   (let* ((items '(a b c d d d h e f b g b))
 470          (f (checked-compile
 471              `(lambda (x) (position x ',items))))
 472          (g (checked-compile
 473              `(lambda (x) (position x ',items :from-end t)))))
 474     (dolist (x items)
 475       ;; opaque-identify prevents optimizing the POSITION call
 476       (assert (= (funcall f x) (position x (opaque-identity items))))
 477       (assert (= (funcall g x) (position x (opaque-identity items) :from-end t))))
 478     (assert (not (funcall f 'blah)))
 479     (assert (not (funcall g 'blah)))))
 480
 481 (with-test (:name :hash-based-position-type-derivation)
 482   ;; should neither crash nor warn about NIL being fed into ASH
 483   (checked-compile '(lambda (x)
 484                      (declare (type (member a b) x))
 485                      (ash 1 (position x #(a b c d d e f))))))
 486
 487 (with-test (:name :position-empty-seq)
 488   (assert (not (funcall (checked-compile '(lambda (x) (position x #()))) 1))))
 489
 490 ;;; I'm keeping this not-very-great test so that if I decide to re-allow hash collisions
 491 ;;; in the hash-based MEMBER transform, then there's already a test for it.
 492 (with-test (:name :hash-based-memq :skipped-on :sbcl)
 493   (let* ((f (checked-compile
 494              '(lambda (x)
 495                (if (member x '(:and :or :not and or not)) t nil))))
 496          (consts (ctu:find-code-constants f :type 'vector)))
 497     ;; Since there's no canonical order within a bin - we don't know
 498     ;; whether bin 0 is {:AND,AND} or {AND,:AND} - this gets tricky to check.
 499     ;; This is unfortunately a change-detector (if we alter SXHASH, or anything).
 500     (assert (equalp (car consts) #(:and and :not not :or or 0 0)))))
 501
 502 (with-test (:name :memq-empty-seq)
 503   (assert (not (funcall (checked-compile '(lambda (x) (member x '()))) 1)))
 504   (assert (not (funcall (checked-compile '(lambda (x) (sb-int:memq x '()))) 1))))
 505
 506 (with-test (:name :adjoin-key-eq-comparable)
 507   (checked-compile-and-assert
 508       ()
 509       `(lambda (x y)
 510          (adjoin (list x) y :key 'car))
 511       ((3d0 '((3d0))) '((3d0)) :test #'equal)))
 512
 513 (with-test (:name :fill-transform-bounds-checks)
 514   (checked-compile-and-assert
 515       (:optimize :default)
 516       `(lambda (item start end)
 517          (fill (make-array 3 :element-type '(unsigned-byte 8)) item :start start :end end))
 518     ((2 0 nil) #(2 2 2) :test #'equalp)
 519     ((2 10 10)  (condition 'sb-kernel:bounding-indices-bad-error))
 520     ((2 2 1)  (condition 'sb-kernel:bounding-indices-bad-error))
 521     ((2 10 nil)  (condition 'sb-kernel:bounding-indices-bad-error))))
 522
 523 (with-test (:name :fill-transform-derive-type)
 524   (assert
 525    (equal (sb-kernel:%simple-fun-type
 526            (checked-compile
 527             '(lambda (x)
 528               (fill (the (simple-array (unsigned-byte 32) (*)) x) 0))))
 529           '(FUNCTION (T) (VALUES (SIMPLE-ARRAY (UNSIGNED-BYTE 32) (*)) &OPTIONAL)))))
 530
 531
 532 (with-test (:name :fill-transform-print-case)
 533   (let ((*print-case* :downcase))
 534     (checked-compile-and-assert
 535         ()
 536         `(lambda (x)
 537            (make-array 3 :element-type 'fixnum :initial-element x))
 538       ((1) #(1 1 1) :test #'equalp))))
 539
 540
 541 (with-test (:name (search :type-derivation))
 542   (checked-compile-and-assert
 543       ()
 544       `(lambda (s)
 545          (search '(a) s :end1 nil))
 546     (('(b a)) 1)
 547     ((#(1)) nil)))
 548
 549 (with-test (:name :array-equalp-non-consing
 550                   :skipped-on :interpreter)
 551   (let ((a (make-array 1000 :element-type 'double-float :initial-element 0d0))
 552         (b (make-array 1000 :element-type 'double-float :initial-element 0d0)))
 553     (ctu:assert-no-consing (equalp a b))))
 554
 555 (with-test (:name (search :array-equalp-numerics))
 556   ;; This tests something that wasn't broken, but given that the new algorithm
 557   ;; is potentially more complicated, it makes sense to test that various
 558   ;; combinations of numeric arrays compare as equalp when they should.
 559   (let (arrays (testdata '(7 3 1 5)))
 560     (sb-int:dovector
 561         (saetp (remove-if (lambda (x)
 562                             (not (typep (sb-vm:saetp-ctype x) 'sb-kernel:numeric-type)))
 563                           sb-vm:*specialized-array-element-type-properties*))
 564       (let ((et (sb-vm::saetp-specifier saetp)))
 565         (unless (or (eq et 'bit) (equal et '(unsigned-byte 2)))
 566           (let ((fancy-array
 567                  (make-array 4 :element-type et
 568                                :displaced-to (make-array 5 :element-type et)
 569                                :displaced-index-offset 1)))
 570             (replace fancy-array
 571                      (mapcar (lambda (x) (coerce x et)) testdata))
 572             (push fancy-array arrays)))))
 573     ;; All pairs should be EQUALP and it should be commutative
 574     ;; and they should be EQUALP to a simple-vector.
 575     (let* ((sv1 (coerce testdata 'simple-vector))
 576            (sv2 (map 'simple-vector (lambda (x) (coerce x 'single-float)) sv1))
 577            (sv3 (map 'simple-vector (lambda (x) (coerce x 'double-float)) sv1))
 578            (sv4 (map 'simple-vector (lambda (x) (coerce x '(complex single-float))) sv1))
 579            (sv5 (map 'simple-vector (lambda (x) (coerce x '(complex double-float))) sv1))
 580            (svs (list sv1 sv2 sv3 sv4 sv5)))
 581       (dolist (x arrays)
 582         ;; Try simple vectors containing types that are not EQL to the testdata
 583         (dolist (sv svs)
 584           (assert (equalp x sv))
 585           (assert (equalp sv x)))
 586         ;; Try all other numeric array types
 587         (dolist (y arrays)
 588           (assert (equalp x y)))))))
 589
 590 ;; lp#1938598
 591 (with-test (:name :vector-replace-self)
 592   ;; example 1
 593   (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
 594     (declare (notinline replace))
 595     (vector-push-extend #\_ string)
 596     ;; also test it indirectly
 597     (replace string string :start1 1 :start2 0))
 598   ;; example 2
 599   (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
 600     (declare (notinline replace))
 601     (loop for char across "tset" do (vector-push-extend char string))
 602     (replace string string :start2 1 :start1 2)
 603     (assert (string= string "tsse"))))
 604
 605 (with-test (:name :sort-vector-length-1
 606                   :skipped-on :interpreter)
 607   (let ((v (vector 5)))
 608     (ctu:assert-no-consing (stable-sort v #'<))))
 609
 610 (with-test (:name (replace :empty-constant))
 611   (checked-compile-and-assert
 612       ()
 613       `(lambda (v s)
 614          (replace (the simple-vector v) #() :start1 s))
 615     ((#(1) 0) #(1) :test #'equalp)))
 616
 617 (with-test (:name :reduce-type-derive)
 618   (macrolet
 619       ((check (fun expected)
 620          `(assert
 621            (equal (second
 622                    (third
 623                     (sb-kernel:%simple-fun-type
 624                      (checked-compile '(lambda (x)
 625                                         ,fun)))))
 626                   ',expected))))
 627     (check (reduce '+ x)
 628            t)
 629     (check (reduce '+ x :end 10)
 630            number)
 631     (check (reduce '+ x :initial-value 10)
 632            number)
 633     (check (reduce '+ (the (simple-array t (1)) x))
 634            t)
 635     (check (reduce '+ (the (simple-array t (2)) x))
 636            number)
 637     (check (reduce '+ (the (simple-array t (10)) x) :end 1)
 638            t)
 639     (check (reduce '+ (the (simple-array fixnum (*)) x))
 640            integer)
 641     (check (reduce '+ (the (simple-array (unsigned-byte 8) (*)) x))
 642            unsigned-byte)
 643     (check (reduce '+ (the (simple-array (unsigned-byte 8) (*)) x) :initial-value -1)
 644            integer)
 645     (check (reduce '+ (the (simple-array double-float (*)) x) :initial-value 1)
 646            (or double-float (integer 1 1)))
 647     (check (reduce '+ (the (simple-array double-float (*)) x) :initial-value 1d0)
 648            double-float)
 649     (check (reduce '+ (the (simple-array double-float (*)) x))
 650            (or double-float (integer 0 0)))
 651     (check (reduce '+ (the (simple-array double-float (10)) x))
 652            double-float)
 653     (check (reduce '+ (the (simple-array double-float (1)) x))
 654            double-float)
 655     (check (reduce '+ x :key #'length)
 656            unsigned-byte)
 657     (check (reduce '+ x :key #'length :initial-value -1)
 658            integer)))
 659
 660 (with-test (:name :find-type-derive)
 661   (macrolet
 662       ((check (fun expected)
 663          `(assert
 664            (type-specifiers-equal
 665             (second
 666                    (third
 667                     (sb-kernel:%simple-fun-type
 668                      (checked-compile '(lambda (x y)
 669                                         (declare (ignorable x y))
 670                                         ,fun)))))
 671                   ',expected))))
 672     (check (find x y) t)
 673     (check (find 1 y) (or (integer 1 1) null))
 674     (check (find x y :key #'car) list)
 675     (check (find x y :test #'=) (or number null))
 676     (check (find x y :key #'car :test #'=) list)
 677     (check (find x (the vector y) :key #'car) list)
 678     (check (find-if #'evenp y) (or integer null))
 679     (check (find-if #'evenp (the list y) :key #'car) list)
 680     (check (find x (the (simple-array character (*)) y)) (or character null))
 681     (check (find x (the string y)) (or character null))))
 682
 683 (with-test (:name :position-type-derive)
 684   (macrolet
 685       ((check (fun expected)
 686          `(assert
 687            (ctype= (second
 688                     (third
 689                      (sb-kernel:%simple-fun-type
 690                       (checked-compile '(lambda (x y)
 691                                          (declare (ignorable x y))
 692                                          ,fun)))))
 693                    ',expected))))
 694     (check (position x y) (or (integer 0 (#.(1- array-dimension-limit))) null))
 695     (check (position x (the (simple-string 10) y)) (or (mod 10) null))
 696     (check (position x y :end 10) (or (mod 10) null))
 697     (check (position x (the cons y) :start 5 :end 10) (or (integer 5 9) null))
 698     (check (position-if x y :end 10) (or (mod 10) null))))
 699
 700 (with-test (:name :string-cmp)
 701   (macrolet
 702       ((check (fun expected)
 703          `(assert
 704            (ctype= (second
 705                     (third
 706                      (sb-kernel:%simple-fun-type
 707                       (checked-compile '(lambda (x y)
 708                                          (declare (ignorable x y))
 709                                          ,fun)))))
 710                    ',expected))))
 711     (check (string/= (the simple-string x) (the simple-string y) :end2 0)
 712            (or (integer 0 0) null))))
 713
 714 (with-test (:name :reverse-specialized-arrays)
 715   (loop for saetp across sb-vm:*specialized-array-element-type-properties*
 716         for type = (sb-kernel:type-specifier (sb-vm:saetp-ctype saetp))
 717         when type
 718         do
 719         (let ((value-transformer (cond ((eq type #+sb-unicode 'base-char
 720                                                  #-sb-unicode 'character)
 721                                         (lambda (x)
 722                                           (code-char
 723                                            (if (>= x sb-int:base-char-code-limit)
 724                                                (random sb-int:base-char-code-limit)
 725                                                x))))
 726                                        #+sb-unicode
 727                                        ((eq type 'character)
 728                                         (lambda (x)
 729                                           (code-char x)))
 730                                        ((eq type 'bit)
 731                                         (lambda (x)
 732                                           x
 733                                           (random 2)))
 734                                        ((subtypep type 'integer)
 735                                         (if (eq type 'fixnum)
 736                                             #'identity
 737                                             (let* ((signed (eq (car type) 'signed-byte))
 738                                                    (width (second type))
 739                                                    (mod (expt 2 (- width
 740                                                                    (if signed
 741                                                                        1
 742                                                                        0)))))
 743                                               (if (< mod 1300)
 744                                                   (lambda (x)
 745                                                     (if (>= x mod)
 746                                                         (random mod)
 747                                                         x))
 748                                                   (lambda (x)
 749                                                     x)))))
 750                                        (t
 751                                         (lambda (x)
 752                                           (coerce x type))))))
 753           (loop for i to (floor 1300
 754                                 (ceiling (sb-vm:saetp-n-bits saetp) sb-vm:n-word-bytes))
 755                 for list = (loop for j from 1 to i
 756                                  collect (funcall value-transformer j))
 757                 for reverse = (reverse list)
 758                 for vector = (make-array i :element-type type
 759                                            :initial-contents list)
 760                 do
 761                 (let* ((offset (1+ (random 120)))
 762                        (prefix (loop for j from 1 to offset
 763                                      collect (funcall value-transformer j)))
 764                        (suffix (loop for j from 1 to (- 128 offset)
 765                                      collect (funcall value-transformer j)))
 766                        (contents (concatenate 'list prefix list suffix))
 767                        (source (make-array (+ i 128) :element-type type
 768                                                      :initial-contents contents))
 769                        (displaced (make-array i :element-type type
 770                                                 :displaced-to source
 771                                                 :displaced-index-offset offset
 772                                                 :fill-pointer i)))
 773                   (assert (equal reverse (coerce (reverse displaced) 'list)))
 774                   (assert (equal reverse (coerce (nreverse displaced) 'list)))
 775                   (assert (equal prefix (coerce (subseq source 0 offset) 'list)))
 776                   (assert (equal suffix (coerce (subseq source (+ offset i)) 'list))))
 777                 (assert (equal reverse (coerce (reverse vector) 'list)))
 778                 (assert (equal reverse (coerce (nreverse vector) 'list)))))))
 779
 780 (with-test (:name :list-derived-type)
 781   (macrolet
 782       ((check (fun expected)
 783          `(assert
 784            (ctype= (second
 785                     (third
 786                      (sb-kernel:%simple-fun-type
 787                       (checked-compile '(lambda (x y)
 788                                          (declare (ignorable x y))
 789                                          ,fun)))))
 790                    ',expected))))
 791     (check (sort (the (cons (eql 0)) x) y)
 792            cons)))
 793
 794 (with-test (:name :range-error-fill-transform)
 795   (assert
 796    (nth-value 2 (checked-compile `(lambda (x y)
 797                                     (declare ((simple-base-string 10) x))
 798                                     (fill x y :start 12))
 799                                  :allow-warnings t))))
 800
 801 (with-test (:name :find-compile-time-mismatch)
 802   (assert
 803    (nth-value 2 (checked-compile `(lambda (c) (find c #*10 :test #'char-equal))
 804                                  :allow-warnings t))))
 805
 806 (with-test (:name :subseq-nil-array)
 807   (checked-compile-and-assert
 808    ()
 809    `(lambda (s)
 810       (subseq s 2))
 811    (((make-array 5 :element-type nil))
 812     3 :test (lambda (s n)
 813               (= (car n) (length (car s)))))))
 814
 815 (with-test (:name :use-%bit-pos-fwd/1)
 816   (assert (equal  (ctu:ir1-named-calls `(lambda (x)
 817                                           (declare (optimize speed))
 818                                           (find 1 (the simple-bit-vector x))))
 819                   '(SB-KERNEL:%BIT-POS-FWD/1))))
 820
 821 (with-test (:name :sort-inlining-warnings)
 822   (checked-compile `(lambda (x)
 823                       (declare (optimize (debug 2) (space 0)))
 824                       (sort x #'< :key #'car))))
 825
 826 (with-test (:name :sort-inline-return-value)
 827   (checked-compile-and-assert
 828    ()
 829    `(lambda (v)
 830       (declare ((vector t) v))
 831       (locally (declare (optimize (space 0)))
 832         (sort v #'<)))
 833    (((vector 2 1)) #(1 2) :test #'equalp)))
 834
 835 (with-test (:name :read-sequence-type)
 836   (assert-type
 837    (lambda (stream)
 838      (let ((seq (make-string 100)))
 839        (read-sequence seq stream)))
 840    (mod 101))
 841   (assert-type
 842    (lambda (stream n)
 843      (let ((seq (make-string n)))
 844        (read-sequence seq stream :end 10)))
 845    (mod 11))
 846   (assert-type
 847    (lambda (stream)
 848      (let ((seq (make-string 10)))
 849        (read-sequence seq stream :start 1)))
 850    (integer 1 10)))