source: trunk/source/tests/ansi-tests/nsublis.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 4.5 KB
RevLine 
[8991]1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Apr 19 21:35:33 2003
4;;;; Contains: Tests of NSUBLIS
5
6(in-package :cl-test)
7
8(compile-and-load "cons-aux.lsp")
9
10(deftest nsublis.1
11  (check-nsublis '((a b) g (d e 10 g h) 15 . g)
12                 '((e . e2) (g . 17)))
13  ((a b) 17 (d e2 10 17 h) 15 . 17))
14
15(deftest nsublis.2
16  (check-nsublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b)))
17                 '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b)))
18                 :test #'equal)
19  (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b))))
20
21(deftest nsublis.3
22  (check-nsublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40))))
23                 '((30 . "foo")))
24  (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40)))))
25
26(deftest nsublis.4
27  (check-nsublis
28   (nsublis (copy-tree '((a . 2) (b . 4) (c . 1)))
29            (copy-tree '(a b c d e (a b c a d b) f)))
30   '((t . "yes"))
31   :key #'(lambda (x) (and (typep x 'integer)
32                           (evenp x))))
33  ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f))
34
35(deftest nsublis.5
36  (check-nsublis '("fee" (("fee" "Fie" "foo"))
37                   fie ("fee" "fie"))
38                 `((,(copy-seq "fie") . #\f)))
39  ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie")))
40
41(deftest nsublis.6
42  (check-nsublis '("fee" fie (("fee" "Fie" "foo") 1)
43                   ("fee" "fie"))
44                 `((,(copy-seq "fie") . #\f))
45                 :test 'equal)
46  ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f)))
47
48(deftest nsublis.7
49  (check-nsublis '(("aa" a b)
50                   (z "bb" d)
51                   ((x . "aa")))
52                 `((,(copy-seq "aa") . 1)
53                   (,(copy-seq "bb") . 2))
54                 :test 'equal
55                 :key #'(lambda (x) (if (consp x) (car x)
56                                      '*not-present*)))
57  (1 (z . 2) ((x . "aa"))))
58
59(deftest nsublis.8
60  (nsublis nil 'a :bad-keyword t :allow-other-keys t)
61  a)
62
63;; Check that a null key arg is ignored.
64
65(deftest nsublis.9
66  (check-nsublis
67   '(1 2 a b)
68   '((1 . 2) (a . b))
69   :key nil)
70  (2 2 b b))
71
72(deftest nsublis.10
73  (check-nsublis  (list 0 3 8 20)
74                  '((1 . x) (5 . y) (10 . z))
75                  :test #'(lambda (x y) (and (realp x) (realp y) (< x y))))
76  (x y z 20))
77
78(deftest nsublis.11
79  (check-nsublis  (list 0 3 8 20)
80                  '((1 . x) (5 . y) (10 . z))
81                  :test-not
82                  #'(lambda (x y) (not (and (realp x) (realp y) (< x y)))))
83  (x y z 20))
84
85(defharmless nsublis.test-and-test-not.1
86  (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd)
87           :test #'eql :test-not #'eql))
88
89(defharmless nsublis.test-and-test-not.2
90  (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd)
91           :test-not #'eql :test #'eql))
92
93;;; Order of argument evaluation
94(deftest nsublis.order.1
95  (let ((i 0) w x y z)
96    (values
97     (nsublis
98      (progn (setf w (incf i))
99             '((a . z)))
100      (progn (setf x (incf i))
101             (copy-tree '(a b c d)))
102      :test (progn (setf y (incf i)) #'eql)
103      :key (progn (setf z (incf i)) #'identity))
104     i w x y z))
105  (z b c d)
106  4 1 2 3 4)
107
108(deftest nsublis.order.2
109  (let ((i 0) w x y z)
110    (values
111     (nsublis
112      (progn (setf w (incf i))
113             '((a . z)))
114      (progn (setf x (incf i))
115             (copy-tree '(a b c d)))
116      :key (progn (setf y (incf i)) #'identity)
117      :test-not (progn (setf z (incf i)) (complement #'eql))
118      )
119     i w x y z))
120  (z b c d)
121  4 1 2 3 4)
122
123;;; Keyword tests
124
125(deftest nsublis.allow-other-keys.1
126  (nsublis nil 'a :bad t :allow-other-keys t)
127  a)
128
129(deftest nsublis.allow-other-keys.2
130  (nsublis nil 'a :allow-other-keys t :bad t)
131  a)
132
133(deftest nsublis.allow-other-keys.3
134  (nsublis nil 'a :allow-other-keys t)
135  a)
136
137(deftest nsublis.allow-other-keys.4
138  (nsublis nil 'a :allow-other-keys nil)
139  a)
140
141(deftest nsublis.allow-other-keys.5
142  (nsublis nil 'a :allow-other-keys t :allow-other-keys t :bad t)
143  a)
144
145(deftest nsublis.keywords.6
146  (nsublis '((1 . a)) (list 0 1 2)
147           :key #'(lambda (x) (if (numberp x) (1+ x) x))
148           :key #'identity)
149  (a 1 2))
150
151;; Argument error cases
152
153(deftest nsublis.error.1
154  (signals-error (nsublis) program-error)
155  t)
156
157(deftest nsublis.error.2
158  (signals-error (nsublis nil) program-error)
159  t)
160
161(deftest nsublis.error.3
162  (signals-error (nsublis nil 'a :test) program-error)
163  t)
164
165(deftest nsublis.error.4
166  (signals-error (nsublis nil 'a :bad-keyword t) program-error)
167  t)
168
169(deftest nsublis.error.5
170  (signals-error (nsublis '((a . 1) (b . 2))
171                           (list 'a 'b 'c 'd)
172                           :test #'identity)
173                 program-error)
174  t)
175
176(deftest nsublis.error.6
177  (signals-error (nsublis '((a . 1) (b . 2))
178                           (list 'a 'b 'c 'd)
179                           :key #'cons)
180                 program-error)
181  t)
182
183(deftest nsublis.error.7
184  (signals-error (nsublis '((a . 1) (b . 2))
185                           (list 'a 'b 'c 'd)
186                           :test-not #'identity)
187                 program-error)
188  t)
189
190(deftest nsublis.error.8
191  (signals-error (nsublis '((a . 1) . bad)
192                           (list 'a 'b 'c 'd))
193                 type-error)
194  t)
Note: See TracBrowser for help on using the repository browser.