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