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 (in-package :cl-user)
  15
  16 (load "compiler-test-util.lisp")
  17
  18 ;;; As reported by Paul Dietz from his ansi-test suite for gcl, REMOVE
  19 ;;; malfunctioned when given :START, :END and :FROM-END arguments.
  20 ;;; Make sure it doesn't happen again.
  21 (with-test (:name (remove :start :end :from-end))
  22   (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7))
  23          (x (copy-seq orig))
  24          (y (remove 3 x :from-end t :start 1 :end 5))
  25          (z (remove 2 x :from-end t :start 1 :end 5)))
  26     (assert (equalp orig x))
  27     (assert (equalp y '(1 2 2 6 1 2 4 1 3 2 7)))
  28     (assert (equalp z '(1 3 6 1 2 4 1 3 2 7)))))
  29
  30 ;;; Similarly, NSUBSTITUTE and friends were getting things wrong with
  31 ;;; :START, :END and :FROM-END:
  32 (with-test (:name (nsubstitute :start :end :from-end))
  33   (assert
  34    (loop for i from 0 to 9 always
  35             (loop for j from i to 10 always
  36                      (loop for c from 0 to (- j i) always
  37                               (let* ((orig '(a a a a a a a a a a))
  38                                      (x (copy-seq orig))
  39                                      (y (nsubstitute 'x 'a x :start i :end j :count c)))
  40                                 (equal y (nconc (make-list i :initial-element 'a)
  41                                                 (make-list c :initial-element 'x)
  42                                                 (make-list (- 10 (+ i c))
  43                                                            :initial-element 'a))))))))
  44
  45   (assert
  46    (loop for i from 0 to 9 always
  47             (loop for j from i to 10 always
  48                      (loop for c from 0 to (- j i) always
  49                               (let* ((orig '(a a a a a a a a a a))
  50                                      (x (copy-seq orig))
  51                                      (y (nsubstitute-if 'x (lambda (x) (eq x 'a)) x
  52                                                         :start i :end j
  53                                                         :count c :from-end t)))
  54                                 (equal y (nconc (make-list (- j c) :initial-element 'a)
  55                                                 (make-list c :initial-element 'x)
  56                                                 (make-list (- 10 j)
  57                                                            :initial-element 'a))))))))
  58   (assert
  59    (loop for i from 0 to 9 always
  60             (loop for j from i to 10 always
  61                      (loop for c from 0 to (- j i) always
  62                               (let* ((orig '(a a a a a a a a a a))
  63                                      (x (copy-seq orig))
  64                                      (y (nsubstitute-if-not 'x (lambda (x)
  65                                                                  (not (eq x 'a))) x
  66                                                                  :start i :end j
  67                                                                  :count c :from-end t)))
  68                                 (equal y (nconc (make-list (- j c) :initial-element 'a)
  69                                                 (make-list c :initial-element 'x)
  70                                                 (make-list (- 10 j)
  71                                                            :initial-element 'a)))))))))
  72
  73 ;;; And equally similarly, REMOVE-DUPLICATES misbehaved when given
  74 ;;; :START arguments:
  75
  76 (with-test (:name (remove-duplicates delete-duplicates :start :end))
  77   (let ((orig (list 0 1 2 0 1 2 0 1 2 0 1 2)))
  78     (assert (equalp (remove-duplicates orig :start 3 :end 9) '(0 1 2 0 1 2 0 1 2)))
  79     (assert (equalp (delete-duplicates orig :start 3 :end 9) '(0 1 2 0 1 2 0 1 2)))))
  80
  81 ;;; tests of COUNT
  82 (with-test (:name (count))
  83   (assert (= 1 (count 1 '(1 2 3))))
  84   (assert (= 2 (count 'z #(z 1 2 3 z))))
  85   (assert (= 0 (count 'y '(z 1 2 3 z)))))
  86
  87 ;;; tests of COUNT-IF and COUNT-IF-NOT
  88 (with-test (:name (count-if count-if-not))
  89   (macrolet (;; the guts of CCI, abstracted over whether we're testing
  90              ;; COUNT-IF or COUNT-IF-NOT
  91              (%cci (expected count-if test sequence-as-list &rest keys)
  92                `(let* ((list ',sequence-as-list)
  93                        (simple-vector (coerce list 'simple-vector))
  94                        (length (length list))
  95                        (vector (make-array (* 2 length) :fill-pointer length)))
  96                   (replace vector list :end1 length)
  97                   (dolist (seq (list list simple-vector vector))
  98                     (assert (= ,expected (,count-if ,test seq ,@keys))))))
  99              ;; "Check COUNT-IF"
 100              (cci (expected test sequence-as-list &rest keys)
 101                `(progn
 102                   (%cci ,expected
 103                         count-if
 104                         ,test
 105                         ,sequence-as-list
 106                         ,@keys)
 107                   (%cci ,expected
 108                         count-if-not
 109                         (complement ,test)
 110                         ,sequence-as-list
 111                         ,@keys))))
 112     (cci 1 #'consp (1 (12) 1))
 113     (cci 3 #'consp (1 (2) 3 (4) (5) 6))
 114     (cci 3 #'consp (1 (2) 3 (4) (5) 6) :from-end t)
 115     (cci 2 #'consp (1 (2) 3 (4) (5) 6) :start 2)
 116     (cci 0 #'consp (1 (2) 3 (4) (5) 6) :start 2 :end 3)
 117     (cci 1 #'consp (1 (2) 3 (4) (5) 6) :start 1 :end 3)
 118     (cci 1 #'consp (1 (2) 3 (4) (5) 6) :start 1 :end 2)
 119     (cci 0 #'consp (1 (2) 3 (4) (5) 6) :start 2 :end 2)
 120     (cci 2 #'zerop (0 10 0 11 12))
 121     (cci 1 #'zerop (0 10 0 11 12) :start 1)
 122     (cci 2 #'minusp (0 10 0 11 12) :key #'1-)
 123     (cci 1 #'minusp (0 10 0 11 12) :key #'1- :end 2))
 124
 125   (multiple-value-bind (fun failure-p warnings style-warnings)
 126       (checked-compile `(lambda ()
 127                           (count-if #'zerop '(0 a 0 b c) :start 1))
 128                        :allow-style-warnings t)
 129     (declare (ignore failure-p warnings))
 130     (assert (= (length style-warnings) 1))
 131     (let ((condition (grab-condition (funcall fun))))
 132       (assert (eql (type-error-datum condition) 'a))))
 133   (multiple-value-bind (fun failure-p warnings style-warnings)
 134       (checked-compile `(lambda ()
 135                           (count-if #'zerop #(0 a 0 b c) :start 1 :from-end 11))
 136                        :allow-style-warnings t)
 137     (declare (ignore failure-p warnings))
 138     (assert (= (length style-warnings) 1))
 139     (let ((condition (grab-condition (funcall fun))))
 140       (assert (eql (type-error-datum condition) 'c)))))
 141
 142 ;;; :COUNT may be negative and BIGNUM
 143 (with-test (:name (remove :count :negative bignum))
 144   (assert (equal (remove 1 '(1 2 3 1) :count 1) '(2 3 1)))
 145   (assert (equal (remove 1 '(1 2 3 1) :count (* 2 most-positive-fixnum)) '(2 3)))
 146   (assert (equal (remove 1 '(1 2 3 1) :count (* -2 most-positive-fixnum)) '(1 2 3 1))))
 147
 148 ;;; bug reported by Wolfgang Jenkner on sbcl-devel 2003-01-04:
 149 ;;; embedded calls of SORT do not work
 150 (with-test (:name (sort :nested-calls))
 151   (assert (equal (sort (list 0 0 0)
 152                        (lambda (x y)
 153                          (if (= x y) ; uses X, Y and SORT return value
 154                              nil
 155                              (sort (list 0 0 0) #'<))))
 156                  '(0 0 0)))
 157
 158   (assert (equal (sort (list 0 0 0 0 0)
 159                        (lambda (x y)
 160                          (declare (ignore x y))
 161                          (block compare
 162                            (sort (make-list 11 :initial-element 1)
 163                                  (let ((counter 7))
 164                                    (lambda (x y)
 165                                      (declare (ignore x y))
 166                                      (when (= (decf counter) 0)
 167                                        (return-from compare nil))
 168                                      t))))))
 169                  '(0 0 0 0 0))))
 170
 171 ;;; miscellaneous sanity checks on stuff which could've been broken by
 172 ;;; changes in MERGE-LIST* in sbcl-0.7.11.*
 173 (with-test (:name (merge stable-sort :sanity-checks))
 174   (assert (equal (merge 'list () () '<) ()))
 175   (assert (equal (merge 'list () (list 1) #'< :key 'identity) '(1)))
 176   (assert (equal (merge 'list (list 2) () '>) '(2)))
 177   (assert (equal (merge 'list (list 1 2 4) (list 2 3 7) '<) '(1 2 2 3 4 7)))
 178   (assert (equal (merge 'list (list 1 2 4) (list -2 3 7) #'<) '(-2 1 2 3 4 7)))
 179   (assert (equal (merge 'list (list 1 2 4) (vector -2 3 7) '< :key 'abs)
 180                  '(1 2 -2 3 4 7)))
 181   (assert (equal (merge 'list (list 1 -2 4) (list -2 3 7) '< :key #'abs)
 182                  '(1 -2 -2 3 4 7)))
 183   (assert (equal (stable-sort (list 1 10 2 12 13 3) '<) '(1 2 3 10 12 13)))
 184   (assert (equal (stable-sort (list 1 10 2 12 13 3) #'< :key '-)
 185                  '(13 12 10 3 2 1)))
 186   (assert (equal (stable-sort (list 1 10 2 12 13 3) '> :key #'-)
 187                  '(1 2 3 10 12 13)))
 188   (assert (equal (stable-sort (list 1 2 3 -3 -2 -1) '< :key 'abs)
 189                  '(1 -1 2 -2 3 -3))))
 190
 191 ;;; CSR broke FILL by not returning the sequence argument in a transform.
 192 (with-test (:name fill)
 193   (let* ((s1 (copy-seq "abcde"))
 194          (s2 (fill s1 #\z)))
 195     (assert s2)
 196     (assert (string= s2 "zzzzz"))))
 197
 198 ;;; POSITION on displaced arrays with non-zero offset has been broken
 199 ;;; for quite a while...
 200 (with-test (:name (position :displaced-array))
 201   (let* ((x #(1 2 3))
 202          (y (make-array 2 :displaced-to x :displaced-index-offset 1)))
 203     (assert (= (position 2 y) 0))))
 204
 205 ;;; (SIMPLE-STRING) is a legal type specifier for creation functions
 206 (with-test (:name (make-sequence concatenate map merge coerce simple-string))
 207   (let ((a (make-sequence '(simple-string) 5))
 208         (b (concatenate '(simple-string) "a" "bdec"))
 209         (c (map '(simple-string) 'identity "abcde"))
 210         (d (merge '(simple-string) (copy-seq "acd") (copy-seq "be") 'char>))
 211         (e (coerce '(#\a #\b #\c #\e #\d) '(simple-string))))
 212     (assert (= (length a) 5))
 213     (assert (string= b "abdec"))
 214     (assert (string= c "abcde"))
 215     (assert (string= d "beacd"))
 216     (assert (string= e "abced"))))
 217
 218 ;;; COPY-SEQ "should be prepared to signal an error if sequence is not
 219 ;;; a proper sequence".
 220 (with-test (:name (copy-seq type-error))
 221   (locally (declare (optimize safety))
 222     (multiple-value-bind (seq err) (ignore-errors (copy-seq '(1 2 3 . 4)))
 223       (assert (not seq))
 224       (assert (typep err 'type-error)))))
 225
 226 ;;; UBX-BASH-COPY transform had an inconsistent return type
 227 (with-test (:name (replace (unsigned-byte 8) :return-type))
 228   (let ((sb-c::*check-consistency* t))
 229     (checked-compile
 230      '(lambda (l)
 231        (declare (type fixnum l))
 232        (let* ((bsize 128)
 233               (b1 (make-array bsize :element-type '(unsigned-byte 8)))
 234               (b2 (make-array l :element-type '(unsigned-byte 8))))
 235          (replace b1 b2 :start2 0 :end2 l))))))
 236
 237 (with-test (:name :bug-452008)
 238   ;; FIND & POSITION on lists should check bounds and (in safe code) detect
 239   ;; circular and dotted lists.
 240   (labels ((safe (&key speed safety &allow-other-keys)
 241              (case safety
 242                (0 (= speed 0))
 243                (t t)))
 244            (extra-safe (&key speed safety &allow-other-keys)
 245              (case safety
 246                (0 (= speed 0))
 247                (1 (< speed 2))
 248                (t t)))
 249            (test (type expr &key (filter #'safe))
 250              (checked-compile-and-assert
 251                  (:optimize `(:compilation-speed nil :space nil :filter ,filter)
 252                   :allow-style-warnings t)
 253                  `(lambda () ,expr)
 254                (() (condition type)))))
 255     (test 'sb-kernel:bounding-indices-bad-error
 256           '(find :foo '(1 2 3 :foo) :start 1 :end 5 :from-end t))
 257     (test 'sb-kernel:bounding-indices-bad-error
 258           '(position :foo '(1 2 3 :foo) :start 1 :end 5 :from-end t))
 259     (test 'sb-kernel:bounding-indices-bad-error
 260           '(find :foo '(1 2 3 :foo) :start 3 :end 0 :from-end t))
 261     (test 'sb-kernel:bounding-indices-bad-error
 262           '(position :foo '(1 2 3 :foo) :start 3 :end 0 :from-end t))
 263     (test 'type-error
 264           '(let ((list (list 1 2 3 :foo)))
 265              (find :bar (nconc list list)))
 266           :filter #'extra-safe)
 267     (test 'type-error
 268           '(let ((list (list 1 2 3 :foo)))
 269              (position :bar (nconc list list)))
 270           :filter #'extra-safe)))
 271
 272 (with-test (:name :bug-554385)
 273   ;; FIND-IF shouldn't look through the entire list.
 274   (assert (= 2 (find-if #'evenp '(1 2 1 1 1 1 1 1 1 1 1 1 :foo))))
 275   ;; Even though the end bounds are incorrect, the
 276   ;; element is found before that's an issue.
 277   (assert (eq :foo (find :foo '(1 2 3 :foo) :start 1 :end 5)))
 278   (assert (= 3 (position :foo '(1 2 3 :foo) :start 1 :end 5))))
 279
 280 (with-test (:name (search :empty-seq))
 281   (checked-compile-and-assert ()
 282       `(lambda (x)
 283          (declare (simple-vector x))
 284          (search x #()))
 285     ((#()) 0))
 286   (checked-compile-and-assert ()
 287       `(lambda (x)
 288          (declare (simple-vector x))
 289          (search x #(t t t)))
 290     ((#()) 0))
 291   (checked-compile-and-assert ()
 292       `(lambda (x)
 293          (declare (simple-vector x))
 294          (search x #(t t t) :end1 0))
 295     ((#(t t t)) 0))
 296   (checked-compile-and-assert ()
 297       `(lambda (x)
 298          (declare (simple-vector x))
 299          (search x #(t t t) :key nil))
 300     ((#()) 0))
 301   (checked-compile-and-assert ()
 302       `(lambda (x k)
 303          (declare (simple-vector x))
 304          (search x #(t t t) :key k))
 305     ((#() nil) 0))
 306   (checked-compile-and-assert (:optimize :safe)
 307       `(lambda (x)
 308          (declare (simple-vector x))
 309          (search x #(t t t) :start2 1 :end2 0 :end1 0))
 310     ((#(t t t)) (condition 'sb-kernel:bounding-indices-bad-error)))
 311   (assert (eql 1
 312                (funcall (lambda ()
 313                           (declare (optimize speed))
 314                           (search #() #(1 1) :start2 1 :end2 1)))))
 315   (assert (eql 2
 316                (funcall (lambda ()
 317                           (declare (optimize speed))
 318                           (search #(1) #(1 1) :start1 1 :start2 2)))))
 319   (assert (eql 2
 320                (funcall (lambda ()
 321                           (declare (optimize speed))
 322                           (search #() #(1 1) :from-end t))))))
 323
 324 (with-test (:name (sort :smoke-test))
 325   (flet ((iota (n type &aux (i 0))
 326            (map-into (make-sequence type n)
 327                      (lambda ()
 328                        (incf i))))
 329          (shuffle (n type)
 330            (let ((vector (let ((i 0))
 331                            (map-into (make-array n)
 332                                      (lambda ()
 333                                        (incf i))))))
 334              (dotimes (i n (coerce vector type))
 335                (let ((j (+ i (random (- n i)))))
 336                  (rotatef (aref vector i) (aref vector j))))))
 337          (sortedp (x)
 338            (let* ((nonce (list nil))
 339                   (prev nonce))
 340              (every (lambda (x)
 341                       (prog1 (or (eql prev nonce)
 342                                  (< prev x))
 343                         (setf prev x)))
 344                     x))))
 345     (dolist (type '(simple-vector list))
 346       (dolist (size '(7 8 9 13 1023 1024 1025 1536))
 347         (loop for repeat below 5 do
 348           (assert (sortedp
 349                    (sort (funcall (case repeat
 350                                     (0 #'iota)
 351                                     (1 (lambda (n type)
 352                                          (reverse (iota n type))))
 353                                     (t #'shuffle))
 354                                   size type)
 355                          #'<))))))))
 356
 357 (with-test (:name (stable-sort :smoke-test))
 358   (flet ((iota (n type &aux (i 0))
 359            (map-into (make-sequence type n)
 360                      (lambda ()
 361                        (cons 0 (incf i)))))
 362          (shuffle (n type)
 363            (let ((max (truncate (expt n 1/4)))
 364                  (i   0))
 365              (map-into (make-sequence type n)
 366                        (lambda ()
 367                          (cons (random max) (incf i))))))
 368          (sortedp (x)
 369            (let* ((nonce (list nil))
 370                   (prev nonce))
 371              (every (lambda (x)
 372                       (prog1 (or (eql prev nonce)
 373                                  (< (car prev) (car x))
 374                                  (and (= (car prev) (car x))
 375                                       (< (cdr prev) (cdr x))))
 376                         (setf prev x)))
 377                     x))))
 378     (dolist (type '(simple-vector list))
 379       (dolist (size '(0  1  2  3  4  5  6  7  8
 380                       9 10 11 12 13 14 15 16 17
 381                       1023 1024 1025 1536))
 382         (loop for repeat below 5 do
 383           (assert
 384            (sortedp
 385             (stable-sort (funcall (case repeat
 386                                     (0 #'iota)
 387                                     (t #'shuffle))
 388                                   size type)
 389                          #'< :key #'car))))))))
 390
 391 (with-test (:name :&more-elt-index-too-large)
 392   (checked-compile-and-assert
 393       (:optimize `(:filter ,(lambda (&key safety &allow-other-keys)
 394                               (= safety 3))))
 395       `(lambda (&rest args)
 396          (elt args 0))
 397     (() (condition 'sb-kernel:index-too-large-error))))
 398
 399 (with-test (:name (sequence:dosequence :on-literals))
 400   (assert (= (sequence:dosequence (e #(1 2 3)) (return e))
 401              1)))
 402
 403 (with-test (:name (search :transform-notes))
 404   (checked-compile `(lambda (s)
 405                       (declare (optimize (speed 3) (safety 0))
 406                                (type simple-string s))
 407                       (search "foo" s))
 408                    :allow-notes nil))
 409
 410 (with-test (:name (concatenate :two-constants))
 411   (assert (equal (funcall
 412                   (lambda () (declare (optimize (speed 3)))
 413                     (concatenate 'string "a" "b")))
 414                  "ab")))
 415
 416 (with-test (:name (make-sequence :transform :bug-330299))
 417   (flet ((test (form &rest args)
 418            (multiple-value-bind (fun failure-p warnings style-warnings)
 419                (apply #'checked-compile form args)
 420              (declare (ignore fun failure-p))
 421              (assert (= (+ (length warnings) (length style-warnings)) 1)))))
 422     ;; test case from bug report.
 423     ;; erroneous situation is caught by MAKE-ARRAY
 424     (test '(lambda (size)
 425              (make-sequence 'bit-vector size :initial-element #\0))
 426           :allow-warnings 'sb-int:type-warning)
 427     ;; This is transformed, but MAKE-ARRAY does *not* consider it a problem
 428     ;; since #\x is in the upgraded array type. That's too bad, because
 429     ;; it's still poor style.
 430     #+nil
 431     (test '(lambda (size)
 432              (make-sequence '(member #\a #\b) size :initial-element #\x)))
 433     ;; additional tests where the transform gives up but warns
 434     (test '(lambda (n)
 435              (make-sequence '(vector (integer 1 15) 5) n :initial-element #\x))
 436           :allow-warnings t)
 437     (test '(lambda (n)
 438             (make-sequence '(vector (integer 1 15) 5) n))
 439           :allow-style-warnings t)))
 440
 441 ;; Precisely type-check result of full call to MAP.
 442 (with-test (:name (map notinline :maximally-safe))
 443   (assert-error
 444    (locally (declare (notinline map)) (map '(cons symbol) '+ '(1 2) '(3 4)))
 445    type-error)
 446   (assert-error
 447    (locally (declare (notinline map))
 448             (map '(cons t (cons t null)) '+ '(1 2 3) '(10 10 10)))
 449    type-error))
 450
 451 (with-test (:name (search :singleton-transform))
 452   (checked-compile-and-assert ()
 453     `(lambda (e) (search '(a) '(b) :end1 e))
 454     ((0) 0)))
 455
 456 (with-test (:name (count :no-consing)
 457             :skipped-on :interpreter)
 458   (let ((f (checked-compile
 459             '(lambda (x)
 460               (count 1 x)))))
 461     (ctu:assert-no-consing (funcall f #(1 2 3 4)))
 462     (ctu:assert-no-consing (funcall f '(1 2 3 4)))))