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
 187 (macrolet ((test  (expected form)
 188              (let ((numbers '((1 a) (2 b)))
 189                    (tricky '(nil (a . b) nil (nil . c) (c . d))))
 190                `(progn
 191                   (assert (equal ',expected (let ((numbers ',numbers)
 192                                                   (tricky ',tricky))
 193                                               (funcall fun ,@(cdr form)))))
 194                   (assert (equal ',expected (funcall (lambda ()
 195                                                        (declare (optimize speed))
 196                                                        (let ((numbers ',numbers)
 197                                                              (tricky ',tricky))
 198                                                          ,form)))))
 199                   (assert (equal ',expected (funcall (lambda ()
 200                                                        (declare (optimize space))
 201                                                        (let ((numbers ',numbers)
 202                                                              (tricky ',tricky))
 203                                                         ,form)))))))))
 204   (let ((fun (car (list 'assoc))))
 205     (test (1 a) (assoc 1 numbers))
 206     (test (2 b) (assoc 2 numbers))
 207     (test (1 a) (assoc 1 numbers :key 'identity))
 208     (test (2 b) (assoc 2 numbers :key #'identity))
 209     (test nil (assoc 1.0 numbers))
 210
 211     (test (1 a) (assoc 1.0 numbers :test #'=))
 212     (test (1 a) (assoc 1.0 numbers :test #'= :key nil))
 213     (test (2 b) (assoc 2.0 numbers :test '=))
 214     (test nil (assoc 0 numbers :test '=))
 215
 216     (test (1 a) (assoc 0 numbers :test-not #'>))
 217     (test (2 b) (assoc 1 numbers :test-not 'eql))
 218     (test nil (assoc 0 numbers :test-not '<))
 219
 220     (test (1 a) (assoc -1 numbers :key #'-))
 221     (test (2 b) (assoc -2 numbers :key '-))
 222     (test nil (assoc -1.0 numbers :key #'-))
 223
 224     (test (1 a) (assoc -1.0 numbers :key #'- :test '=))
 225     (test (2 b) (assoc -2.0 numbers :key #'- :test '=))
 226     (test nil (assoc -1.0 numbers :key #'- :test 'eql))
 227
 228     ;; Bug reported by Paul Dietz: ASSOC should ignore NIL elements in a
 229     ;; alist
 230     (test (nil . c) (assoc nil tricky :test #'eq))))
 231
 232 ;;; bug reported by Dan Corkill: *PRINT-CASE* affected the compiler transforms
 233 ;;; for ASSOC & MEMBER
 234 (let ((*print-case* :downcase))
 235   (assert (eql 2 (cdr (funcall (compile nil '(lambda (i l) (assoc i l)))
 236                                :b '((:a . 1) (:b . 2))))))
 237   (assert (equal '(3 4 5) (funcall (compile nil '(lambda (i l) (member i l)))
 238                                    3 '(1 2 3 4 5)))))
 239
 240 ;;; bad bounding index pair to SUBSEQ on a list
 241 (let ((list (list 0 1 2 3 4 5)))
 242   (multiple-value-bind (res err) (ignore-errors (subseq list 4 2))
 243     (assert (not res))
 244     (assert (typep err 'sb-kernel:bounding-indices-bad-error))))
 245
 246 ;;; ADJOIN must apply key to item as well
 247 (assert (equal '((:b)) (funcall
 248                         (compile nil '(lambda (x y) (adjoin x y :key #'car :test #'string=)))
 249                         (list 'b) (list '(:b)))))
 250 (assert (equal '((:b))
 251                (let ((sb-ext:*evaluator-mode* :interpret))
 252                  (eval '(adjoin (list 'b) (list '(:b)) :key #'car :test #'string=)))))
 253
 254 ;;; constant list argument to ADJOIN
 255 (assert (equal '(:x :y) (funcall
 256                          (compile nil '(lambda (elt)
 257                                         (declare (optimize speed))
 258                                         (adjoin elt '(:x :y))))
 259                          ':x)))
 260 (assert (equal '(:x :y) (funcall
 261                          (compile nil '(lambda (elt)
 262                                         (declare (optimize speed))
 263                                         (adjoin elt '(:y))))
 264                          ':x)))
 265 (assert (equal '(a) (funcall (compile nil '(lambda () (adjoin 'a nil))))))
 266
 267 (macrolet ((test (expected list-1 list-2 &rest args)
 268              `(progn
 269                 (assert (equal ,expected (funcall #'union ,list-1 ,list-2 ,@args)))
 270                 (assert (equal ,expected (funcall #'nunion
 271                                                   (copy-list ,list-1)
 272                                                   (copy-list ,list-2)
 273                                                   ,@args))))))
 274   (test nil nil nil)
 275   (test '(42) nil '(42))
 276   (test '(42) '(42) nil)
 277   (test '(42) '(42) '(42))
 278   (test '((42) (42)) '((42)) '((42)))
 279   (test '((42) (42)) '((42)) '((42)) :test-not #'equal)
 280   (test '((42)) '((42)) '((42)) :test #'equal)
 281   (test '((42)) '((42)) '((42)) :key #'car)
 282   (test '((42)) '((42)) '((42)) :key #'car :test-not #'<))
 283