1;;;; alist.test --- tests guile's alists     -*- scheme -*-
2;;;; Copyright (C) 1999, 2001, 2006, 2017 Free Software Foundation, Inc.
3;;;;
4;;;; This library is free software; you can redistribute it and/or
5;;;; modify it under the terms of the GNU Lesser General Public
6;;;; License as published by the Free Software Foundation; either
7;;;; version 3 of the License, or (at your option) any later version.
8;;;;
9;;;; This library 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 GNU
12;;;; Lesser General Public License for more details.
13;;;;
14;;;; You should have received a copy of the GNU Lesser General Public
15;;;; License along with this library; if not, write to the Free Software
16;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
17
18(define-module (test-suite alist)
19  #:use-module (test-suite lib))
20
21(define-syntax-rule (pass-if-not str form)
22  (pass-if str (not form)))
23
24(define (safe-assq-ref alist elt)
25  (let ((x (assq elt alist)))
26    (if x (cdr x) x)))
27
28(define (safe-assv-ref alist elt)
29  (let ((x (assv elt alist)))
30    (if x (cdr x) x)))
31
32(define (safe-assoc-ref alist elt)
33  (let ((x (assoc elt alist)))
34    (if x (cdr x) x)))
35
36;;; Creators, getters
37(let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f '()))))
38      (b (acons "this" "is" (acons "a" "test" '())))
39      (deformed '(a b c d e f g)))
40  (pass-if "acons"
41	   (and (equal? a '((a . b) (c . d) (e . f)))
42		(equal? b '(("this" . "is") ("a" . "test")))))
43  (pass-if "sloppy-assq"
44	   (let ((x (sloppy-assq 'c a)))
45	     (and (pair? x)
46		  (eq? (car x) 'c)
47		  (eq? (cdr x) 'd))))
48  (pass-if "sloppy-assq not"
49	   (let ((x (sloppy-assq "this" b)))
50	     (not x)))
51  (pass-if "sloppy-assv"
52	   (let ((x (sloppy-assv 'c a)))
53	     (and (pair? x)
54		  (eq? (car x) 'c)
55		  (eq? (cdr x) 'd))))
56  (pass-if "sloppy-assv not"
57	   (let ((x (sloppy-assv "this" b)))
58	     (not x)))
59  (pass-if "sloppy-assoc"
60	   (let ((x (sloppy-assoc "this" b)))
61	     (and (pair? x)
62		  (string=? (cdr x) "is"))))
63  (pass-if "sloppy-assoc not"
64	   (let ((x (sloppy-assoc "heehee" b)))
65	     (not x)))
66  (pass-if "assq"
67	   (let ((x (assq 'c a)))
68	     (and (pair? x)
69		  (eq? (car x) 'c)
70		  (eq? (cdr x) 'd))))
71  (pass-if-exception "assq deformed"
72    exception:wrong-type-arg
73    (assq 'x deformed))
74  (pass-if-not "assq not" (assq 'r a))
75  (pass-if "assv"
76	   (let ((x (assv 'a a)))
77	     (and (pair? x)
78		  (eq? (car x) 'a)
79		  (eq? (cdr x) 'b))))
80  (pass-if-exception "assv deformed"
81    exception:wrong-type-arg
82    (assv 'x deformed))
83  (pass-if-not "assv not" (assq "this" b))
84
85  (pass-if "assoc"
86	   (let ((x (assoc "this" b)))
87	     (and (pair? x)
88		  (string=? (car x) "this")
89		  (string=? (cdr x) "is"))))
90  (pass-if-exception "assoc deformed"
91    exception:wrong-type-arg
92    (assoc 'x deformed))
93  (pass-if-not "assoc not" (assoc "this isn't" b)))
94
95
96;;; Refers
97(let ((a '((foo bar) (baz quux)))
98      (b '(("one" 2 3) ("four" 5 6) ("seven" 8 9)))
99      (deformed '(thats a real sloppy assq you got there)))
100  (pass-if "assq-ref"
101	   (let ((x (assq-ref a 'foo)))
102	     (and (list? x)
103		  (eq? (car x) 'bar))))
104
105  (pass-if-not "assq-ref not" (assq-ref b "one"))
106  (pass-if "assv-ref"
107	   (let ((x (assv-ref a 'baz)))
108	     (and (list? x)
109		  (eq? (car x) 'quux))))
110
111  (pass-if-not "assv-ref not" (assv-ref b "one"))
112
113  (pass-if "assoc-ref"
114	   (let ((x (assoc-ref b "one")))
115	     (and (list? x)
116		  (eqv? (car x) 2)
117		  (eqv? (cadr x) 3))))
118
119
120  (pass-if-not "assoc-ref not" (assoc-ref a 'testing))
121
122  (pass-if-not "assv-ref deformed"
123               (assv-ref deformed 'sloppy))
124
125  (pass-if-not "assoc-ref deformed"
126               (assoc-ref deformed 'sloppy))
127
128  (pass-if-not "assq-ref deformed"
129               (assq-ref deformed 'sloppy)))
130
131
132;;; Setters
133(let ((a '((another . silly) (alist . test-case)))
134      (b '(("this" "one" "has") ("strings" "!")))
135      (deformed '(canada is a cold nation)))
136  (pass-if "assq-set!"
137	   (begin
138	     (set! a (assq-set! a 'another 'stupid))
139	     (let ((x (safe-assq-ref a 'another)))
140	       (and x
141		    (symbol? x) (eq? x 'stupid)))))
142
143  (pass-if "assq-set! add"
144	   (begin
145	     (set! a (assq-set! a 'fickle 'pickle))
146	     (let ((x (safe-assq-ref a 'fickle)))
147	       (and x (symbol? x)
148		    (eq? x 'pickle)))))
149
150  (pass-if "assv-set!"
151	   (begin
152	     (set! a (assv-set! a 'another 'boring))
153	     (let ((x (safe-assv-ref a 'another)))
154		   (and x
155			(eq? x 'boring)))))
156  (pass-if "assv-set! add"
157	   (begin
158	     (set! a (assv-set! a 'whistle '(while you work)))
159	     (let ((x (safe-assv-ref a 'whistle)))
160	       (and x (equal? x '(while you work))))))
161
162  (pass-if "assoc-set!"
163	   (begin
164	     (set! b (assoc-set! b "this" "has"))
165	     (let ((x (safe-assoc-ref b "this")))
166	       (and x (string? x)
167		    (string=? x "has")))))
168  (pass-if "assoc-set! add"
169	   (begin
170	     (set! b (assoc-set! b "flugle" "horn"))
171	     (let ((x (safe-assoc-ref b "flugle")))
172	       (and x (string? x)
173		    (string=? x "horn")))))
174
175  (pass-if-equal "assq-set! deformed"
176      (assq-set! deformed 'cold '(very cold))
177    '((cold very cold) canada is a cold nation))
178
179  (pass-if-equal "assv-set! deformed"
180      (assv-set! deformed 'canada 'Canada)
181    '((canada . Canada) canada is a cold nation))
182
183  (pass-if-equal "assoc-set! deformed"
184      (assoc-set! deformed 'canada '(Iceland hence the name))
185    '((canada Iceland hence the name) canada is a cold nation)))
186
187;;; Removers
188
189(let ((a '((a b) (c d) (e boring)))
190      (b '(("what" .  "else") ("could" . "I") ("say" . "here")))
191      (deformed 1))
192  (pass-if "assq-remove!"
193	   (begin
194	     (set! a (assq-remove! a 'a))
195	     (equal? a '((c d) (e boring)))))
196  (pass-if "assv-remove!"
197	   (begin
198	     (set! a (assv-remove! a 'c))
199	     (equal? a '((e boring)))))
200  (pass-if "assoc-remove!"
201	   (begin
202	     (set! b (assoc-remove! b "what"))
203	     (equal? b '(("could" . "I") ("say" . "here")))))
204
205  (pass-if-equal "assq-remove! deformed"
206      (assq-remove! deformed 'puddle)
207    1)
208
209  (pass-if-equal "assv-remove! deformed"
210      (assv-remove! deformed 'splashing)
211    1)
212
213  (pass-if-equal "assoc-remove! deformed"
214      (assoc-remove! deformed 'fun)
215    1))
216