tests/list.pure.lisp

   1 ;;;; tests related to lists
   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 ;;; Since *another* BUTLAST problem was reported (anonymously!) on the
  17 ;;; SourceForge summary page magical bugs web interface 2001-09-01, it
  18 ;;; looks as though it's past time to start accumulating regression
  19 ;;; tests for these.
  20 (with-test (:name (butlast nbutlast :structure-sharing))
  21   (dolist (testcase
  22             '((:args ((1 2 3 4 5))   :result (1 2 3 4))
  23               (:args ((1 2 3 4 5) 6) :result nil)
  24               (:args (nil)           :result nil)
  25               (:args ((1 2 3) 0)     :result (1 2 3))
  26               (:args ((1 2 3) 1)     :result (1 2))
  27               (:args ((1 2 3))       :result (1 2))
  28               (:args ((1 2 3) 2)     :result (1))
  29               (:args ((1 2 3) 3)     :result nil)
  30               (:args ((1 2 3) 4)     :result nil)
  31               (:args ((1 2 3 . 4) 0) :result (1 2 3 . 4))
  32               (:args ((1 2 3 . 4) 1) :result (1 2))
  33               (:args ((1 2 3 . 4))   :result (1 2))
  34               (:args ((1 2 3 . 4) 2) :result (1))
  35               (:args ((1 2 3 . 4) 3) :result nil)
  36               (:args ((1 2 3 . 4) 4) :result nil)))
  37     (destructuring-bind (&key args result) testcase
  38       (destructuring-bind (list &rest rest) args
  39         ;; Test with BUTLAST.
  40         (let ((actual-result (apply #'butlast args)))
  41           (when (and (consp list) (eq actual-result list))
  42             (error "not a copy in BUTLAST for ~S" args))
  43           (unless (equal actual-result result)
  44             (error "failed BUTLAST for ~S" args)))
  45         ;; Test with NBUTLAST.
  46         (let* ((copied-list (copy-list list))
  47                (actual-result (apply #'nbutlast copied-list rest)))
  48           (unless (equal actual-result result)
  49             (error "failed NBUTLAST for ~S" args)))))))
  50
  51 (with-test (:name (butlast type-error))
  52   (assert-error (apply #'butlast (list t)) type-error))
  53
  54 ;;; reported by Paul Dietz on cmucl-imp: LDIFF does not check type of
  55 ;;; its first argument
  56 (with-test (:name (ldiff type-error))
  57   (multiple-value-bind (fun failure-p warnings)
  58       (checked-compile '(lambda () (ldiff 1 2))
  59                        :allow-failure t :allow-warnings t)
  60     (assert failure-p)
  61     (assert (= 1 (length warnings)))
  62     (assert (typep (first warnings) 'sb-int:type-warning))
  63     (assert-error (funcall fun) type-error)))
  64
  65 ;;; evaluation order in PUSH, PUSHNEW
  66 (with-test (:name (push :evaluation-order.1))
  67   (let ((a (map 'vector #'list '(a b c)))
  68         (i 0))
  69     (pushnew (incf i) (aref a (incf i)))
  70     (assert (equalp a #((a) (b) (1 c))))))
  71
  72 (with-test (:name (push pushnew :evaluation-order.2))
  73   (symbol-macrolet ((s (aref a (incf i))))
  74     (let ((a (map 'vector #'list '(a b c)))
  75           (i 0))
  76       (push t s)
  77       (assert (equalp a #((a) (t b) (c))))
  78       (pushnew 1 s)
  79       (assert (equalp a #((a) (t b) (1 c))))
  80       (setq i 0)
  81       (assert (eql (pop s) 't))
  82       (assert (equalp a #((a) (b) (1 c)))))))
  83
  84 ;;; Type checking in NCONC
  85 (with-test (:name (nconc :improper-list))
  86  (let ((tests '((((1 . 2)) (1 . 2))
  87                 (((1 . 2) (3 . 4)) (1 3 . 4))
  88                 (((1 . 2) 3) (1 . 3))
  89                 ((3) 3))))
  90    (loop for (args result) in tests
  91       do (assert (equal (apply 'nconc (copy-tree args)) result))
  92       do (let* ((exp `(nconc ,@ (mapcar (lambda (arg)
  93                                           `(copy-tree ',arg))
  94                                         args))))
  95            (checked-compile-and-assert ()
  96                `(lambda () ,exp)
  97              (() result))))))
  98
  99 (with-test (:name (nconc :improper-list type-error))
 100   (let ((tests '(((3 (1 . 2)) 3)
 101                  (((1 . 2) 3 (4 . 5)) 3))))
 102     (macrolet ((check-error (form failed-arg)
 103                  `(multiple-value-bind (.result. .error.)
 104                       (ignore-errors ,form)
 105                     (assert (null .result.))
 106                     (assert (typep .error. 'type-error))
 107                     (assert (eq (type-error-expected-type .error.) 'list))
 108                     (assert (equal (type-error-datum .error.) ,failed-arg)))))
 109       (loop for (args fail) in tests
 110          do (check-error (apply #'nconc (copy-tree args)) fail)
 111          do (let* ((exp `(nconc ,@(mapcar (lambda (arg)
 112                                             `(copy-tree ',arg))
 113                                           args)))
 114                    (fun (checked-compile `(lambda () ,exp))))
 115               (check-error (funcall fun) fail))))))
 116
 117 (with-test (:name (append nreverse nreverse nreconc copy-alist type-error))
 118   (dolist (test '((append 1 2)
 119                   (append (1 2) nil (3 . 4) nil)
 120                   (append nil (1 2) nil (3 . 4) nil)
 121                   (reverse (1 2 . 3))
 122                   (nreverse (1 2 . 3))
 123                   (nreconc (1 2 . 3) (4 5))
 124                   (copy-alist ((1 . 2) (3 . 4) . 5))))
 125     (assert-error (apply (first test) (copy-tree (rest test)))
 126                   type-error)))
 127
 128 ;;; Bug reported by Paul Dietz: NSET-EXCLUSIVE-OR should not return
 129 ;;; extra elements, even when given "sets" contain duplications
 130 (with-test (:name (nset-exclusive-or :duplicates))
 131   (assert (equal (remove-duplicates (sort (nset-exclusive-or (list 1 2 1 3)
 132                                                              (list 4 1 3 3))
 133                                           #'<))
 134                  '(2 4))))
 135
 136 ;;; Bug reported by Adam Warner: valid list index designator is not
 137 ;;; necessarily a fixnum
 138 (with-test (:name (nth bignum))
 139   (let ((s (read-from-string "(a . #1=(b c . #1#))")))
 140     (assert (eq (nth (* 1440 most-positive-fixnum) s) 'c))
 141     (setf (nth (* 1440 most-positive-fixnum) s) 14)
 142     (assert (eq (nth (* 1440 most-positive-fixnum) s) 14)))
 143
 144   (let ((s (copy-list '(1 2 3))))
 145     (assert (eq s (last s (* 1440 most-positive-fixnum))))
 146     (assert (null (butlast s (* 1440 most-positive-fixnum))))
 147     (assert (null (nbutlast s (* 1440 most-positive-fixnum))))))
 148
 149 (assert (eq :atom (last (list* 1 2 3 :atom) (eval 0))))
 150 (assert (eq :atom (last (list* 1 2 3 :atom) 0)))
 151
 152 ;;; enforce lists in symbol-plist
 153 (with-test (:name symbol-plist)
 154  (let ((s (gensym))
 155        (l (list 1 3 4)))
 156    (assert (not (symbol-plist s)))
 157    (assert (eq l (setf (symbol-plist s) l)))
 158    (assert-error (setf (symbol-plist s) (car l)) type-error)))
 159
 160 ;;; member
 161
 162 (with-test (:name member)
 163   (macrolet ((test  (expected form)
 164                `(progn
 165                   (assert (equal ,expected (let ((numbers '(1 2)))
 166                                              (funcall fun ,@(cdr form)))))
 167                   (assert (equal ,expected (funcall (lambda ()
 168                                                       (declare (optimize speed))
 169                                                       (let ((numbers '(1 2)))
 170                                                         ,form)))))
 171                   (assert (equal ,expected (funcall (lambda ()
 172                                                       (declare (optimize space))
 173                                                       (let ((numbers '(1 2)))
 174                                                         ,form))))))))
 175     (let ((x-numbers '(1 2))
 176           (fun (car (list 'member))))
 177       (test x-numbers (member 1 numbers))
 178       (test x-numbers (member 1 numbers :key 'identity))
 179       (test x-numbers (member 1 numbers :key #'identity))
 180       (test (cdr x-numbers) (member 2 numbers))
 181       (test nil (member 1.0 numbers ))
 182
 183       (test x-numbers (member 1.0 numbers :test #'=))
 184       (test x-numbers (member 1.0 numbers :test #'= :key nil))
 185       (test (cdr x-numbers) (member 2.0 numbers :test '=))
 186       (test nil (member 0 numbers :test '=))
 187
 188       (test x-numbers (member 0 numbers :test-not #'>))
 189       (test (cdr x-numbers) (member 1 numbers :test-not 'eql))
 190       (test nil (member 0 numbers :test-not '<))
 191
 192       (test x-numbers (member -1 numbers :key #'-))
 193       (test (cdr x-numbers) (member -2 numbers :key '-))
 194       (test nil (member -1.0 numbers :key #'-))
 195
 196       (test x-numbers (member -1.0 numbers :key #'- :test '=))
 197       (test (cdr x-numbers) (member -2.0 numbers :key #'- :test '=))
 198       (test nil (member -1.0 numbers :key #'- :test 'eql)))))
 199
 200 (flet ((test (function needle haystack args expected)
 201          (checked-compile-and-assert ()
 202              `(lambda ()
 203                 (let ((function (car (list ',function)))
 204                       (list ',haystack))
 205                   (funcall function ,needle list ,@args)))
 206            (() expected))
 207          (checked-compile-and-assert ()
 208              `(lambda ()
 209                 (let ((list ',haystack))
 210                   (,function ,needle list ,@args)))
 211            (() expected))))
 212
 213   (with-test (:name assoc)
 214     (let ((numbers '((1 a) (2 b)))
 215           (tricky '(nil (a . b) nil (nil . c) (c . d))))
 216       (test 'assoc 1    numbers '()                    '(1 a))
 217       (test 'assoc 2    numbers '()                    '(2 b))
 218       (test 'assoc 1    numbers '(:key 'identity)      '(1 a))
 219       (test 'assoc 2    numbers '(:key #'identity)     '(2 b))
 220       (test 'assoc 1.0  numbers '()                    nil)
 221
 222       (test 'assoc 1.0  numbers '(:test #'=)           '(1 a))
 223       (test 'assoc 1.0  numbers '(:test #'= :key nil)  '(1 a))
 224       (test 'assoc 2.0  numbers '(:test '=)            '(2 b))
 225       (test 'assoc 0    numbers '(:test '=)            nil)
 226
 227       (test 'assoc 0    numbers '(:test-not #'>)       '(1 a))
 228       (test 'assoc 1    numbers '(:test-not 'eql)      '(2 b))
 229       (test 'assoc 0    numbers '(:test-not '<)        nil)
 230
 231       (test 'assoc -1   numbers '(:key #'-)            '(1 a))
 232       (test 'assoc -2   numbers '(:key '-)             '(2 b))
 233       (test 'assoc -1.0 numbers '(:key #'-)            nil)
 234
 235       (test 'assoc -1.0 numbers '(:key #'- :test '=)   '(1 a))
 236       (test 'assoc -2.0 numbers '(:key #'- :test '=)   '(2 b))
 237       (test 'assoc -1.0 numbers '(:key #'- :test 'eql) nil)
 238
 239       ;; Bug reported by Paul Dietz: ASSOC should ignore NIL elements
 240       ;; in a alist
 241       (test 'assoc nil tricky  '(:test #'eq)      '(nil . c))))
 242
 243   (with-test (:name rassoc)
 244     (let ((numbers '((a . 1) (b . 2)))
 245           (tricky '(nil (b . a) nil (c . nil) (d . c))))
 246       (test 'rassoc 1    numbers '()                    '(a . 1))
 247       (test 'rassoc 2    numbers '()                    '(b . 2))
 248       (test 'rassoc 1    numbers '(:key 'identity)      '(a . 1))
 249       (test 'rassoc 2    numbers '(:key #'identity)     '(b . 2))
 250       (test 'rassoc 1.0  numbers '()                    nil)
 251
 252       (test 'rassoc 1.0  numbers '(:test #'=)           '(a . 1))
 253       (test 'rassoc 1.0  numbers '(:test #'= :key nil)  '(a . 1))
 254       (test 'rassoc 2.0  numbers '(:test '=)            '(b . 2))
 255       (test 'rassoc 0    numbers '(:test '=)            nil)
 256
 257       (test 'rassoc 0    numbers '(:test-not #'>)       '(a . 1))
 258       (test 'rassoc 1    numbers '(:test-not 'eql)      '(b . 2))
 259       (test 'rassoc 0    numbers '(:test-not '<)        nil)
 260
 261       (test 'rassoc -1   numbers '(:key #'-)            '(a . 1))
 262       (test 'rassoc -2   numbers '(:key '-)             '(b . 2))
 263       (test 'rassoc -1.0 numbers '(:key #'-)            nil)
 264
 265       (test 'rassoc -1.0 numbers '(:key #'- :test '=)   '(a . 1))
 266       (test 'rassoc -2.0 numbers '(:key #'- :test '=)   '(b . 2))
 267       (test 'rassoc -1.0 numbers '(:key #'- :test 'eql) nil)
 268
 269       (test 'rassoc nil  tricky  '(:test #'eq)          '(c . nil)))))
 270
 271 ;;;; member-if & assoc-if & rassoc-if
 272 (with-test (:name (member-if assoc-if rassoc-if))
 273   (macrolet ((test (value form)
 274                `(let ((* ,value))
 275                   (assert (eval ,form))
 276                   (checked-compile-and-assert (:optimize :safe)
 277                       '(lambda () ,form)
 278                     (() t)))))
 279     (test 'evenp
 280           (equal '(2 3 4) (member-if * (list 1 2 3 4))))
 281     (test 'evenp
 282           (equal '(2 3 4) (locally (declare (optimize speed))
 283                             (member-if * '(1 2 3 4)))))
 284     (test 'evenp
 285           (equal '(3 4) (member-if * (list 1 2 3 4) :key (lambda (x) (if (= 3 x) 2 1)))))
 286     (test 'evenp
 287           (equal '(2 :two) (assoc-if * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four)))))
 288     (test 'evenp
 289           (equal '(3 :three) (assoc-if * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four))
 290                                        :key (lambda (x) (if (= 3 x) 2 1)))))
 291     (test 'evenp
 292           (equal '(:two . 2) (rassoc-if * (list '(:one . 1) '(:three . 3) '(:two . 2) '(:four . 4)))))
 293     (test (list 1 2 3 4)
 294           (equal '(2 3 4) (member-if 'evenp *)))
 295     (test (list (cons 1 'a) (cons 2 'b) (cons 3 'c))
 296           (equal (cons 2 'b) (assoc-if 'evenp *)))))
 297
 298 ;;;; member-if-not & assoc-if-not
 299 (with-test (:name (member-if-not assoc-if-not))
 300   (macrolet ((test (value form)
 301                `(let ((* ,value))
 302                   (assert (eval ,form))
 303                   (checked-compile-and-assert ()
 304                       '(lambda () ,form)
 305                     (() t)))))
 306     (test 'oddp
 307           (equal '(2 3 4) (member-if-not * (list 1 2 3 4))))
 308     (test 'oddp
 309           (equal '(2 3 4) (locally (declare (optimize speed))
 310                             (member-if-not * '(1 2 3 4)))))
 311     (test 'oddp
 312           (equal '(3 4) (member-if-not * (list 1 2 3 4) :key (lambda (x) (if (= 3 x) 2 1)))))
 313     (test 'oddp
 314           (equal '(2 :two) (assoc-if-not * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four)))))
 315     (test 'oddp
 316           (equal '(3 :three) (assoc-if-not * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four))
 317                                            :key (lambda (x) (if (= 3 x) 2 1)))))
 318     (test (list 1 2 3 4)
 319           (equal '(2 3 4) (member-if-not 'oddp *)))
 320     (test (list (cons 1 'a) (cons 2 'b) (cons 3 'c))
 321           (equal (cons 2 'b) (assoc-if-not 'oddp *)))))
 322
 323 ;;; bug reported by Dan Corkill: *PRINT-CASE* affected the compiler transforms
 324 ;;; for ASSOC & MEMBER
 325 (with-test (:name (assoc member *print-case*))
 326   (let ((*print-case* :downcase))
 327     (checked-compile-and-assert ()
 328         `(lambda (i l) (assoc i l))
 329       ((:b '((:a . 1) (:b . 2))) '(:b . 2)))
 330     (checked-compile-and-assert ()
 331         `(lambda (i l) (member i l))
 332       ((3 '(1 2 3 4 5)) '(3 4 5)))))
 333
 334 ;;; bad bounding index pair to SUBSEQ on a list
 335 (with-test (:name (subseq sb-kernel:bounding-indices-bad-error))
 336   (multiple-value-bind (fun failure-p warnings)
 337       (checked-compile `(lambda ()
 338                           (let ((list (list 0 1 2 3 4 5)))
 339                             (subseq list 4 2)))
 340                        :allow-warnings t)
 341     (assert failure-p)
 342     (assert (= (length warnings) 1))
 343     (assert-error (funcall fun)  sb-kernel:bounding-indices-bad-error)))
 344
 345 ;;; ADJOIN must apply key to item as well
 346 (with-test (:name (adjoin :key))
 347   (checked-compile-and-assert ()
 348       `(lambda (x y)
 349          (adjoin x y :key #'car :test #'string=))
 350     (((list 'b) (list '(:b))) '((:b))))
 351
 352   #+(or sb-eval sb-fasteval)
 353   (assert (equal '((:b))
 354                  (let ((sb-ext:*evaluator-mode* :interpret))
 355                    (eval '(adjoin (list 'b) (list '(:b))
 356                                   :key #'car :test #'string=))))))
 357
 358 ;;; constant list argument to ADJOIN
 359 (with-test (:name (adjoin :constant :list-argument))
 360   (flet ((test (form args expected)
 361            (let ((fun (checked-compile form)))
 362              (assert (equal expected (apply fun args))))))
 363     (test `(lambda (elt)
 364              (declare (optimize speed))
 365              (adjoin elt '(:x :y)))
 366           '(:x) '(:x :y))
 367     (test `(lambda (elt)
 368              (declare (optimize speed))
 369              (adjoin elt '(:y)))
 370           '(:x) '(:x :y))
 371     (test `(lambda () (adjoin 'a nil)) '() '(a))))
 372
 373 (with-test (:name union)
 374   (macrolet ((test (expected list-1 list-2 &rest args)
 375                `(progn
 376                   (assert (equal ,expected (funcall #'union ,list-1 ,list-2 ,@args)))
 377                   (assert (equal ,expected (funcall #'nunion
 378                                                     (copy-list ,list-1)
 379                                                     (copy-list ,list-2)
 380                                                     ,@args))))))
 381     (test nil nil nil)
 382     (test '(42) nil '(42))
 383     (test '(42) '(42) nil)
 384     (test '(42) '(42) '(42))
 385     (test '((42) (42)) '((42)) '((42)))
 386     (test '((42) (42)) '((42)) '((42)) :test-not #'equal)
 387     (test '((42)) '((42)) '((42)) :test #'equal)
 388     (test '((42)) '((42)) '((42)) :key #'car)
 389     (test '((42)) '((42)) '((42)) :key #'car :test-not #'<)))
 390
 391 ;;; FIND on lists should not call key outside the specified
 392 ;;; subsequence.
 393 (with-test (:name (find :start :end))
 394   (assert (not (find :a '(0 (:c) 1) :start 1 :end 2 :key #'car))))
 395
 396 (with-test (:name (adjoin :folding))
 397   (flet ((%f () (adjoin 'x '(a b))))
 398     (assert (not (eq (%f) (%f))))))
 399
 400 (with-test (:name (butlast :dotted))
 401   (assert (null (butlast '(1 2 . 3) 4)))
 402   (assert (null (nbutlast (list* 1 2 3) 4))))