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   (map-optimize-declarations
 241    (lambda (policy)
 242      (flet ((test (type expr)
 243               (let* ((lambda `(lambda () (declare (optimize ,@policy)) ,expr))
 244                      (fun (checked-compile lambda)))
 245                 #+nil(let ((*print-circle* t)) (format t "~&test: ~S~%" lambda))
 246                 (let ((got (handler-case (funcall fun)
 247                              (error (e) (if (typep e type) :error :lose))
 248                              (:no-error (res) (list :no-error res)))))
 249                   (unless (eq :error got)
 250                     (error "wanted an error, got ~S~%" got))))))
 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        (unless (equal policy '((speed 3) (safety 1)))
 260          (test 'type-error
 261                '(let ((list (list 1 2 3 :foo)))
 262                  (find :bar (nconc list list))))
 263          (test 'type-error
 264                '(let ((list (list 1 2 3 :foo)))
 265                  (position :bar (nconc list list)))))))
 266    :speed '(0 3) :safety '(0 1 2) :debug nil :compilation-speed nil :space nil
 267    :filter (lambda (&key speed safety)
 268              (when (zerop safety) (zerop speed)))))
 269
 270 (with-test (:name :bug-554385)
 271   ;; FIND-IF shouldn't look through the entire list.
 272   (assert (= 2 (find-if #'evenp '(1 2 1 1 1 1 1 1 1 1 1 1 :foo))))
 273   ;; Even though the end bounds are incorrect, the
 274   ;; element is found before that's an issue.
 275   (assert (eq :foo (find :foo '(1 2 3 :foo) :start 1 :end 5)))
 276   (assert (= 3 (position :foo '(1 2 3 :foo) :start 1 :end 5))))
 277
 278 (with-test (:name (search :empty-seq))
 279   (assert (eql 0
 280                (funcall (checked-compile
 281                                  `(lambda (x)
 282                                     (declare (optimize (speed 3)) (simple-vector x))
 283                                     (search x #())))
 284                         #())))
 285   (assert (eql 0
 286                (funcall (checked-compile
 287                                  `(lambda (x)
 288                                     (declare (optimize (speed 3)) (simple-vector x))
 289                                     (search x #(t t t))))
 290                         #())))
 291   (assert (eql 0
 292                (funcall (checked-compile
 293                                  `(lambda (x)
 294                                     (declare (optimize (speed 3)) (simple-vector x))
 295                                     (search x #(t t t) :end1 0)))
 296                         #(t t t))))
 297   (assert (eql 0
 298                (funcall (checked-compile
 299                                  `(lambda (x)
 300                                     (declare (optimize (speed 3)) (simple-vector x))
 301                                     (search x #(t t t) :key nil)))
 302                         #())))
 303   (assert (eql 0
 304                (funcall (checked-compile
 305                                  `(lambda (x k)
 306                                     (declare (optimize (speed 3)) (simple-vector x))
 307                                     (search x #(t t t) :key k)))
 308                         #() nil)))
 309   (assert (eq :ok
 310               (handler-case
 311                   (funcall (checked-compile
 312                                     `(lambda (x)
 313                                        (declare (optimize (speed 3)) (simple-vector x))
 314                                        (search x #(t t t) :start2 1 :end2 0 :end1 0)))
 315                            #(t t t))
 316                 (sb-kernel:bounding-indices-bad-error ()
 317                   :ok))))
 318   (assert (eql 1
 319                (funcall (lambda ()
 320                           (declare (optimize speed))
 321                           (search #() #(1 1) :start2 1 :end2 1)))))
 322   (assert (eql 2
 323                (funcall (lambda ()
 324                           (declare (optimize speed))
 325                           (search #(1) #(1 1) :start1 1 :start2 2)))))
 326   (assert (eql 2
 327                (funcall (lambda ()
 328                           (declare (optimize speed))
 329                           (search #() #(1 1) :from-end t))))))
 330
 331 (with-test (:name (sort :smoke-test))
 332   (flet ((iota (n type &aux (i 0))
 333            (map-into (make-sequence type n)
 334                      (lambda ()
 335                        (incf i))))
 336          (shuffle (n type)
 337            (let ((vector (let ((i 0))
 338                            (map-into (make-array n)
 339                                      (lambda ()
 340                                        (incf i))))))
 341              (dotimes (i n (coerce vector type))
 342                (let ((j (+ i (random (- n i)))))
 343                  (rotatef (aref vector i) (aref vector j))))))
 344          (sortedp (x)
 345            (let* ((nonce (list nil))
 346                   (prev nonce))
 347              (every (lambda (x)
 348                       (prog1 (or (eql prev nonce)
 349                                  (< prev x))
 350                         (setf prev x)))
 351                     x))))
 352     (dolist (type '(simple-vector list))
 353       (dolist (size '(7 8 9 13 1023 1024 1025 1536))
 354         (loop for repeat below 5 do
 355           (assert (sortedp
 356                    (sort (funcall (case repeat
 357                                     (0 #'iota)
 358                                     (1 (lambda (n type)
 359                                          (reverse (iota n type))))
 360                                     (t #'shuffle))
 361                                   size type)
 362                          #'<))))))))
 363
 364 (with-test (:name (stable-sort :smoke-test))
 365   (flet ((iota (n type &aux (i 0))
 366            (map-into (make-sequence type n)
 367                      (lambda ()
 368                        (cons 0 (incf i)))))
 369          (shuffle (n type)
 370            (let ((max (truncate (expt n 1/4)))
 371                  (i   0))
 372              (map-into (make-sequence type n)
 373                        (lambda ()
 374                          (cons (random max) (incf i))))))
 375          (sortedp (x)
 376            (let* ((nonce (list nil))
 377                   (prev nonce))
 378              (every (lambda (x)
 379                       (prog1 (or (eql prev nonce)
 380                                  (< (car prev) (car x))
 381                                  (and (= (car prev) (car x))
 382                                       (< (cdr prev) (cdr x))))
 383                         (setf prev x)))
 384                     x))))
 385     (dolist (type '(simple-vector list))
 386       (dolist (size '(0  1  2  3  4  5  6  7  8
 387                       9 10 11 12 13 14 15 16 17
 388                       1023 1024 1025 1536))
 389         (loop for repeat below 5 do
 390           (assert
 391            (sortedp
 392             (stable-sort (funcall (case repeat
 393                                     (0 #'iota)
 394                                     (t #'shuffle))
 395                                   size type)
 396                          #'< :key #'car))))))))
 397
 398 (with-test (:name :&more-elt-index-too-large)
 399   (assert-error (funcall
 400                  (checked-compile `(lambda (&rest args)
 401                                      (declare (optimize safety))
 402                                      (elt args 0))))
 403                 sb-kernel:index-too-large-error))
 404
 405 (with-test (:name (sequence:dosequence :on-literals))
 406   (assert (= (sequence:dosequence (e #(1 2 3)) (return e))
 407              1)))
 408
 409 (with-test (:name (search :transform-notes))
 410   (checked-compile `(lambda (s)
 411                       (declare (optimize (speed 3) (safety 0))
 412                                (type simple-string s))
 413                       (search "foo" s))
 414                    :allow-notes nil))
 415
 416 (with-test (:name (concatenate :two-constants))
 417   (assert (equal (funcall
 418                   (lambda () (declare (optimize (speed 3)))
 419                     (concatenate 'string "a" "b")))
 420                  "ab")))
 421
 422 (with-test (:name (make-sequence :transform :bug-330299))
 423   (flet ((test (form &rest args)
 424            (multiple-value-bind (fun failure-p warnings style-warnings)
 425                (apply #'checked-compile form args)
 426              (declare (ignore fun failure-p))
 427              (assert (= (+ (length warnings) (length style-warnings)) 1)))))
 428     ;; test case from bug report.
 429     ;; erroneous situation is caught by MAKE-ARRAY
 430     (test '(lambda (size)
 431              (make-sequence 'bit-vector size :initial-element #\0))
 432           :allow-warnings 'sb-int:type-warning)
 433     ;; This is transformed, but MAKE-ARRAY does *not* consider it a problem
 434     ;; since #\x is in the upgraded array type. That's too bad, because
 435     ;; it's still poor style.
 436     #+nil
 437     (test '(lambda (size)
 438              (make-sequence '(member #\a #\b) size :initial-element #\x)))
 439     ;; additional tests where the transform gives up but warns
 440     (test '(lambda (n)
 441              (make-sequence '(vector (integer 1 15) 5) n :initial-element #\x))
 442           :allow-warnings t)
 443     (test '(lambda (n)
 444             (make-sequence '(vector (integer 1 15) 5) n))
 445           :allow-style-warnings t)))
 446
 447 ;; Precisely type-check result of full call to MAP.
 448 (with-test (:name (map notinline :maximally-safe))
 449   (assert-error
 450    (locally (declare (notinline map)) (map '(cons symbol) '+ '(1 2) '(3 4)))
 451    type-error)
 452   (assert-error
 453    (locally (declare (notinline map))
 454             (map '(cons t (cons t null)) '+ '(1 2 3) '(10 10 10)))
 455    type-error))
 456
 457 (defstruct ship size name)
 458 (with-test (:name (find :derive-type))
 459   (let ((f (checked-compile '(lambda (x list)
 460                               (ship-size (find x list :key 'ship-name))))))
 461     ;; The test of SHIP-P in the SHIP-SIZE call is optimized into (NOT NULL).
 462     ;; Therefore the code header for F does not reference #<LAYOUT for SHIP>
 463     (assert (not (ctu:find-code-constants f :type 'sb-kernel:layout)))
 464     ;; And the function is safe.
 465     (assert-error (funcall f nil nil) type-error)))