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