1 ;;;; alist.test --- tests guile's alists -*- scheme -*-
2 ;;;; Copyright (C) 1999 Free Software Foundation, Inc.
4 ;;;; This program is free software; you can redistribute it and/or modify
5 ;;;; it under the terms of the GNU General Public License as published by
6 ;;;; the Free Software Foundation; either version 2, or (at your option)
7 ;;;; any later version.
9 ;;;; This program is distributed in the hope that it will be useful,
10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;;;; GNU General Public License for more details.
14 ;;;; You should have received a copy of the GNU General Public License
15 ;;;; along with this software; see the file COPYING. If not, write to
16 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
17 ;;;; Boston, MA 02111-1307 USA
19 ;;;; As a special exception, the Free Software Foundation gives permission
20 ;;;; for additional uses of the text contained in its release of GUILE.
22 ;;;; The exception is that, if you link the GUILE library with other files
23 ;;;; to produce an executable, this does not by itself cause the
24 ;;;; resulting executable to be covered by the GNU General Public License.
25 ;;;; Your use of that executable is in no way restricted on account of
26 ;;;; linking the GUILE library code into it.
28 ;;;; This exception does not however invalidate any other reasons why
29 ;;;; the executable file might be covered by the GNU General Public License.
31 ;;;; This exception applies only to the code released by the
32 ;;;; Free Software Foundation under the name GUILE. If you copy
33 ;;;; code from other Free Software Foundation releases into a copy of
34 ;;;; GUILE, as the General Public License permits, the exception does
35 ;;;; not apply to the code that you add in this way. To avoid misleading
36 ;;;; anyone as to the status of such modified files, you must delete
37 ;;;; this exception notice from them.
39 ;;;; If you write modifications of your own for GUILE, it is your choice
40 ;;;; whether to permit this exception to apply to your modifications.
41 ;;;; If you do not wish that, delete this exception notice.
43 (use-modules (test-suite lib))
45 ;;; (gbh) some of these are duplicated in r4rs. This is probably a bit
46 ;;; more thorough, though (maybe overkill? I need it, anyway).
49 ;;; Also: it will fail on the ass*-ref & remove functions.
50 ;;; Sloppy versions should be added with the current behaviour
51 ;;; (it's the only set of 'ref functions that won't cause an
52 ;;; error on an incorrect arg); they aren't actually used anywhere
53 ;;; so changing's not a big deal.
57 (define-macro (pass-if-not str form)
58 `(pass-if ,str (not ,form)))
60 (define (safe-assq-ref alist elt)
61 (let ((x (assq elt alist)))
64 (define (safe-assv-ref alist elt)
65 (let ((x (assv elt alist)))
68 (define (safe-assoc-ref alist elt)
69 (let ((x (assoc elt alist)))
73 (let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f ()))))
74 (b (acons "this" "is" (acons "a" "test" ())))
75 (deformed '(a b c d e f g)))
76 (pass-if "alist: acons"
77 (and (equal? a '((a . b) (c . d) (e . f)))
78 (equal? b '(("this" . "is") ("a" . "test")))))
79 (pass-if "alist: sloppy-assq"
80 (let ((x (sloppy-assq 'c a)))
84 (pass-if "alist: sloppy-assq not"
85 (let ((x (sloppy-assq "this" b)))
87 (pass-if "alist: sloppy-assv"
88 (let ((x (sloppy-assv 'c a)))
92 (pass-if "alist: sloppy-assv not"
93 (let ((x (sloppy-assv "this" b)))
95 (pass-if "alist: sloppy-assoc"
96 (let ((x (sloppy-assoc "this" b)))
98 (string=? (cdr x) "is"))))
99 (pass-if "alist: sloppy-assoc not"
100 (let ((x (sloppy-assoc "heehee" b)))
102 (pass-if "alist: assq"
103 (let ((x (assq 'c a)))
107 (pass-if "alist: assq deformed"
108 (catch 'wrong-type-arg
113 (pass-if-not "alist: assq not" (assq 'r a))
114 (pass-if "alist: assv"
115 (let ((x (assv 'a a)))
119 (pass-if "alist: assv deformed"
120 (catch 'wrong-type-arg
126 (pass-if-not "alist: assv not" (assq "this" b))
128 (pass-if "alist: assoc"
129 (let ((x (assoc "this" b)))
131 (string=? (car x) "this")
132 (string=? (cdr x) "is"))))
133 (pass-if "alist: assoc deformed"
134 (catch 'wrong-type-arg
140 (pass-if-not "alist: assoc not" (assoc "this isn't" b)))
144 (let ((a '((foo bar) (baz quux)))
145 (b '(("one" 2 3) ("four" 5 6) ("seven" 8 9)))
146 (deformed '(thats a real sloppy assq you got there)))
147 (pass-if "alist: assq-ref"
148 (let ((x (assq-ref a 'foo)))
150 (eq? (car x) 'bar))))
152 (pass-if-not "alist: assq-ref not" (assq-ref b "one"))
153 (pass-if "alist: assv-ref"
154 (let ((x (assv-ref a 'baz)))
156 (eq? (car x) 'quux))))
158 (pass-if-not "alist: assv-ref not" (assv-ref b "one"))
160 (pass-if "alist: assoc-ref"
161 (let ((x (assoc-ref b "one")))
167 (pass-if-not "alist: assoc-ref not" (assoc-ref a 'testing))
169 (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
171 (pass-if "alist: assv-ref deformed"
172 (catch 'wrong-type-arg
174 (if (not have-sloppy-assv-ref?) (throw 'unsupported))
175 (assv-ref deformed 'sloppy)
180 (pass-if "alist: assoc-ref deformed"
181 (catch 'wrong-type-arg
183 (if (not have-sloppy-assv-ref?) (throw 'unsupported))
184 (assoc-ref deformed 'sloppy)
189 (pass-if "alist: assq-ref deformed"
190 (catch 'wrong-type-arg
192 (if (not have-sloppy-assv-ref?) (throw 'unsupported))
193 (assq-ref deformed 'sloppy)
200 (let ((a '((another . silly) (alist . test-case)))
201 (b '(("this" "one" "has") ("strings" "!")))
202 (deformed '(canada is a cold nation)))
203 (pass-if "alist: assq-set!"
205 (set! a (assq-set! a 'another 'stupid))
206 (let ((x (safe-assq-ref a 'another)))
208 (symbol? x) (eq? x 'stupid)))))
210 (pass-if "alist: assq-set! add"
212 (set! a (assq-set! a 'fickle 'pickle))
213 (let ((x (safe-assq-ref a 'fickle)))
217 (pass-if "alist: assv-set!"
219 (set! a (assv-set! a 'another 'boring))
220 (let ((x (safe-assv-ref a 'another)))
223 (pass-if "alist: assv-set! add"
225 (set! a (assv-set! a 'whistle '(while you work)))
226 (let ((x (safe-assv-ref a 'whistle)))
227 (and x (equal? x '(while you work))))))
229 (pass-if "alist: assoc-set!"
231 (set! b (assoc-set! b "this" "has"))
232 (let ((x (safe-assoc-ref b "this")))
234 (string=? x "has")))))
235 (pass-if "alist: assoc-set! add"
237 (set! b (assoc-set! b "flugle" "horn"))
238 (let ((x (safe-assoc-ref b "flugle")))
240 (string=? x "horn")))))
242 (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
244 (pass-if "alist: assq-set! deformed"
245 (catch 'wrong-type-arg
247 (if (not have-sloppy-assv-ref?) (throw 'unsupported))
248 (assq-set! deformed 'cold '(very cold))
253 (pass-if "alist: assv-set! deformed"
254 (catch 'wrong-type-arg
256 (if (not have-sloppy-assv-ref?) (throw 'unsupported))
257 (assv-set! deformed 'canada 'Canada)
262 (pass-if "alist: assoc-set! deformed"
263 (catch 'wrong-type-arg
265 (if (not have-sloppy-assv-ref?) (throw 'unsupported))
266 (assoc-set! deformed 'canada '(Iceland hence the name))
273 (let ((a '((a b) (c d) (e boring)))
274 (b '(("what" . "else") ("could" . "I") ("say" . "here")))
276 (pass-if "alist: assq-remove!"
278 (set! a (assq-remove! a 'a))
279 (equal? a '((c d) (e boring)))))
280 (pass-if "alist: assv-remove!"
282 (set! a (assv-remove! a 'c))
283 (equal? a '((e boring)))))
284 (pass-if "alist: assoc-remove!"
286 (set! b (assoc-remove! b "what"))
287 (equal? b '(("could" . "I") ("say" . "here")))))
289 (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove)))
291 (pass-if "alist: assq-remove! deformed"
292 (catch 'wrong-type-arg
294 (if (not have-sloppy-assq-remove?) (throw 'unsupported))
295 (assq-remove! deformed 'puddle)
300 (pass-if "alist: assv-remove! deformed"
301 (catch 'wrong-type-arg
303 (if (not have-sloppy-assq-remove?) (throw 'unsupported))
304 (assv-remove! deformed 'splashing)
309 (pass-if "alist: assoc-remove! deformed"
310 (catch 'wrong-type-arg
312 (if (not have-sloppy-assq-remove?) (throw 'unsupported))
313 (assoc-remove! deformed 'fun)