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 ;;; enforce lists in symbol-plist
 134 (let ((s (gensym))
 135       (l (list 1 3 4)))
 136   (assert (not (symbol-plist s)))
 137   (assert (eq l (setf (symbol-plist s) l)))
 138   (multiple-value-bind (res err)
 139       (ignore-errors (setf (symbol-plist s) (car l)))
 140     (assert (not res))
 141     (assert (typep err 'type-error))))
 142
 143 ;;; member
 144
 145 (macrolet ((test  (expected form)
 146              `(progn
 147                 (assert (equal ,expected (let ((numbers '(1 2)))
 148                                            (funcall fun ,@(cdr form)))))
 149                 (assert (equal ,expected (funcall (lambda ()
 150                                                     (declare (optimize speed))
 151                                                     (let ((numbers '(1 2)))
 152                                                       ,form)))))
 153                 (assert (equal ,expected (funcall (lambda ()
 154                                                     (declare (optimize space))
 155                                                     (let ((numbers '(1 2)))
 156                                                       ,form))))))))
 157   (let ((x-numbers '(1 2))
 158         (fun (car (list 'member))))
 159     (test x-numbers (member 1 numbers))
 160     (test (cdr x-numbers) (member 2 numbers))
 161     (test nil (member 1.0 numbers ))
 162
 163     (test x-numbers (member 1.0 numbers :test #'=))
 164     (test x-numbers (member 1.0 numbers :test #'= :key nil))
 165     (test (cdr x-numbers) (member 2.0 numbers :test '=))
 166     (test nil (member 0 numbers :test '=))
 167
 168     (test x-numbers (member 0 numbers :test-not #'>))
 169     (test (cdr x-numbers) (member 1 numbers :test-not 'eql))
 170     (test nil (member 0 numbers :test-not '<))
 171
 172     (test x-numbers (member -1 numbers :key #'-))
 173     (test (cdr x-numbers) (member -2 numbers :key '-))
 174     (test nil (member -1.0 numbers :key #'-))
 175
 176     (test x-numbers (member -1.0 numbers :key #'- :test '=))
 177     (test (cdr x-numbers) (member -2.0 numbers :key #'- :test '=))
 178     (test nil (member -1.0 numbers :key #'- :test 'eql))))
 179
 180 ;;; assoc
 181
 182 (macrolet ((test  (expected form)
 183              (let ((numbers '((1 a) (2 b)))
 184                    (tricky '(nil (a . b) nil (nil . c) (c . d))))
 185                `(progn
 186                   (assert (equal ',expected (let ((numbers ',numbers)
 187                                                   (tricky ',tricky))
 188                                               (funcall fun ,@(cdr form)))))
 189                   (assert (equal ',expected (funcall (lambda ()
 190                                                        (declare (optimize speed))
 191                                                        (let ((numbers ',numbers)
 192                                                              (tricky ',tricky))
 193                                                          ,form)))))
 194                   (assert (equal ',expected (funcall (lambda ()
 195                                                        (declare (optimize space))
 196                                                        (let ((numbers ',numbers)
 197                                                              (tricky ',tricky))
 198                                                         ,form)))))))))
 199   (let ((fun (car (list 'assoc))))
 200     (test (1 a) (assoc 1 numbers))
 201     (test (2 b) (assoc 2 numbers))
 202     (test nil (assoc 1.0 numbers))
 203
 204     (test (1 a) (assoc 1.0 numbers :test #'=))
 205     (test (1 a) (assoc 1.0 numbers :test #'= :key nil))
 206     (test (2 b) (assoc 2.0 numbers :test '=))
 207     (test nil (assoc 0 numbers :test '=))
 208
 209     (test (1 a) (assoc 0 numbers :test-not #'>))
 210     (test (2 b) (assoc 1 numbers :test-not 'eql))
 211     (test nil (assoc 0 numbers :test-not '<))
 212
 213     (test (1 a) (assoc -1 numbers :key #'-))
 214     (test (2 b) (assoc -2 numbers :key '-))
 215     (test nil (assoc -1.0 numbers :key #'-))
 216
 217     (test (1 a) (assoc -1.0 numbers :key #'- :test '=))
 218     (test (2 b) (assoc -2.0 numbers :key #'- :test '=))
 219     (test nil (assoc -1.0 numbers :key #'- :test 'eql))
 220
 221     ;; Bug reported by Paul Dietz: ASSOC should ignore NIL elements in a
 222     ;; alist
 223     (test (nil . c) (assoc nil tricky :test #'eq))))
 224
 225 ;;; bug reported by Dan Corkill: *PRINT-CASE* affected the compiler transforms
 226 ;;; for ASSOC & MEMBER
 227 (let ((*print-case* :downcase))
 228   (assert (eql 2 (cdr (funcall (compile nil '(lambda (i l) (assoc i l)))
 229                                :b '((:a . 1) (:b . 2))))))
 230   (assert (equal '(3 4 5) (funcall (compile nil '(lambda (i l) (member i l)))
 231                                    3 '(1 2 3 4 5)))))