File: list.pure.lisp

package info (click to toggle)
sbcl 1%3A0.9.16.0-1
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 19,960 kB
  • ctags: 16,537
  • sloc: lisp: 231,164; ansic: 19,558; asm: 2,539; sh: 1,925; makefile: 308
file content (138 lines) | stat: -rw-r--r-- 5,735 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
;;;; tests related to lists

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

(in-package :cl-user)

;;; Since *another* BUTLAST problem was reported (anonymously!) on the
;;; SourceForge summary page magical bugs web interface 2001-09-01, it
;;; looks as though it's past time to start accumulating regression
;;; tests for these.
(dolist (testcase
         '((:args ((1 2 3 4 5))   :result (1 2 3 4))
           (:args ((1 2 3 4 5) 6) :result nil)
           (:args (nil)           :result nil)
           (:args ((1 2 3) 0)     :result (1 2 3))
           (:args ((1 2 3) 1)     :result (1 2))
           (:args ((1 2 3))       :result (1 2))
           (:args ((1 2 3) 2)     :result (1))
           (:args ((1 2 3) 3)     :result nil)
           (:args ((1 2 3) 4)     :result nil)
           (:args ((1 2 3 . 4) 0) :result (1 2 3 . 4))
           (:args ((1 2 3 . 4) 1) :result (1 2))
           (:args ((1 2 3 . 4))   :result (1 2))
           (:args ((1 2 3 . 4) 2) :result (1))
           (:args ((1 2 3 . 4) 3) :result nil)
           (:args ((1 2 3 . 4) 4) :result nil)))
  (destructuring-bind (&key args result) testcase
    (destructuring-bind (list &rest rest) args
      ;; Test with BUTLAST.
      (let ((actual-result (apply #'butlast args)))
        (when (and (consp list) (eq actual-result list))
          (error "not a copy in BUTLAST for ~S" args))
        (unless (equal actual-result result)
          (error "failed BUTLAST for ~S" args)))
      ;; Test with NBUTLAST.
      (let* ((copied-list (copy-list list))
             (actual-result (apply #'nbutlast copied-list rest)))
        (unless (equal actual-result result)
          (error "failed NBUTLAST for ~S" args))))))

(multiple-value-bind (result error)
    (ignore-errors (apply #'butlast (list t)))
  (assert (null result))
  (assert (typep error 'type-error)))

;;; reported by Paul Dietz on cmucl-imp: LDIFF does not check type of
;;; its first argument
(assert (not (ignore-errors (ldiff 1 2))))

;;; evaluation order in PUSH, PUSHNEW
(let ((a (map 'vector #'list '(a b c))))
  (let ((i 0))
    (pushnew (incf i) (aref a (incf i)))
    (assert (equalp a #((a) (b) (1 c))))))

(symbol-macrolet ((s (aref a (incf i))))
    (let ((a (map 'vector #'list '(a b c))))
      (let ((i 0))
        (push t s)
        (assert (equalp a #((a) (t b) (c))))
        (pushnew 1 s)
        (assert (equalp a #((a) (t b) (1 c))))
        (setq i 0)
        (assert (eql (pop s) 't))
        (assert (equalp a #((a) (b) (1 c)))))))

;;; Type checking in NCONC
(let ((tests '((((1 . 2)) (1 . 2))
               (((1 . 2) (3 . 4)) (1 3 . 4))
               (((1 . 2) 3) (1 . 3))
               ((3) 3))))
  (loop for (args result) in tests
     do (assert (equal (apply 'nconc (copy-tree args)) result))
     do (let ((exp `(nconc ,@ (mapcar (lambda (arg)
                                        `(copy-tree ',arg))
                                      args))))
          (assert (equal (funcall (compile nil `(lambda () ,exp))) result)))))

(let ((tests '(((3 (1 . 2)) 3)
               (((1 . 2) 3 (4 . 5)) 3))))
  (macrolet ((check-error (form failed-arg)
               `(multiple-value-bind (.result. .error.)
                    (ignore-errors ,form)
                  (assert (null .result.))
                  (assert (typep .error. 'type-error))
                  (assert (eq (type-error-expected-type .error.) 'list))
                  (assert (equal (type-error-datum .error.) ,failed-arg)))))
    (loop for (args fail) in tests
       do (check-error (apply #'nconc (copy-tree args)) fail)
       do (let ((exp `(nconc ,@ (mapcar (lambda (arg)
                                          `(copy-tree ',arg))
                                        args))))
            (check-error (funcall (compile nil `(lambda () ,exp))) fail)))))

(dolist (test '((append 1 2)
                (append (1 2) nil (3 . 4) nil)
                (append nil (1 2) nil (3 . 4) nil)
                (reverse (1 2 . 3))
                (nreverse (1 2 . 3))
                (nreconc (1 2 . 3) (4 5))
                (copy-alist ((1 . 2) (3 . 4) . 5))))
  (assert (raises-error? (apply (first test) (copy-tree (rest test)))
                         type-error)))

;;; Bug reported by Paul Dietz: NSET-EXCLUSIVE-OR should not return
;;; extra elements, even when given "sets" contain duplications
(assert (equal (remove-duplicates (sort (nset-exclusive-or (list 1 2 1 3)
                                                           (list 4 1 3 3))
                                        #'<))
               '(2 4)))

;;; Bug reported by Adam Warner: valid list index designator is not
;;; necessary a fixnum
(let ((s (read-from-string "(a . #1=(b c . #1#))")))
  (assert (eq (nth (* 1440 most-positive-fixnum) s) 'c))
  (setf (nth (* 1440 most-positive-fixnum) s) 14)
  (assert (eq (nth (* 1440 most-positive-fixnum) s) 14)))

(let ((s (copy-list '(1 2 3))))
  (assert (eq s (last s (* 1440 most-positive-fixnum))))
  (assert (null (butlast s (* 1440 most-positive-fixnum))))
  (assert (null (nbutlast s (* 1440 most-positive-fixnum)))))

;;; Bug reported by Paul Dietz: ASSOC should ignore NIL elements in a
;;; alist
(let ((f (compile nil '(lambda (x)
                        (assoc x '(nil (a . b) nil (nil . c) (c . d))
                         :test #'eq)))))
  (assert (equal (funcall f 'nil) '(nil . c))))