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