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 ;;; Bug reported by Paul Dietz: ASSOC should ignore NIL elements in a
 134 ;;; alist
 135 (let ((f (compile nil '(lambda (x)
 136                         (assoc x '(nil (a . b) nil (nil . c) (c . d))
 137                          :test #'eq)))))
 138   (assert (equal (funcall f 'nil) '(nil . c))))
 139
 140 ;;; enforce lists in symbol-plist
 141 (let ((s (gensym))
 142       (l (list 1 3 4)))
 143   (assert (not (symbol-plist s)))
 144   (assert (eq l (setf (symbol-plist s) l)))
 145   (multiple-value-bind (res err)
 146       (ignore-errors (setf (symbol-plist s) (car l)))
 147     (assert (not res))
 148     (assert (typep err 'type-error))))
 149
 150 ;;; member
 151
 152 (macrolet ((test  (expected form)
 153              `(progn
 154                 (assert (eq ,expected (funcall fun ,@(cdr form))))
 155                 (assert (eq ,expected (funcall (lambda ()
 156                                                  (declare (optimize speed))
 157                                                  ,form))))
 158                 (assert (eq ,expected (funcall (lambda ()
 159                                                  (declare (optimize space))
 160                                                  ,form)))))))
 161   (let ((numbers '(1 2))
 162         (fun (car (list 'member))))
 163     (test numbers (member 1 numbers))
 164     (test (cdr numbers) (member 2 numbers))
 165     (test nil (member 1.0 numbers ))
 166
 167     (test numbers (member 1.0 numbers :test #'=))
 168     (test numbers (member 1.0 numbers :test #'= :key nil))
 169     (test (cdr numbers) (member 2.0 numbers :test '=))
 170     (test nil (member 0 numbers :test '=))
 171
 172     (test numbers (member 0 numbers :test-not #'>))
 173     (test (cdr numbers) (member 1 numbers :test-not 'eql))
 174     (test nil (member 0 numbers :test-not '<))
 175
 176     (test numbers (member -1 numbers :key #'-))
 177     (test (cdr numbers) (member -2 numbers :key '-))
 178     (test nil (member -1.0 numbers :key #'-))
 179
 180     (test numbers (member -1.0 numbers :key #'- :test '=))
 181     (test (cdr numbers) (member -2.0 numbers :key #'- :test '=))
 182     (test nil (member -1.0 numbers :key #'- :test 'eql))))