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