guile18/test-suite/tests/alist.test

   1 ;;;; alist.test --- tests guile's alists     -*- scheme -*-
   2 ;;;; Copyright (C) 1999, 2001, 2006 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 2.1 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 (use-modules (test-suite lib))
  19
  20 ;;; (gbh) some of these are duplicated in r4rs. This is probably a bit
  21 ;;;       more thorough, though (maybe overkill? I need it, anyway).
  22 ;;;
  23 ;;;
  24 ;;;       Also: it will fail on the ass*-ref & remove functions.
  25 ;;;       Sloppy versions should be added with the current behaviour
  26 ;;;       (it's the only set of 'ref functions that won't cause an
  27 ;;;       error on an incorrect arg); they aren't actually used anywhere
  28 ;;;       so changing's not a big deal.
  29
  30 ;;; Misc
  31
  32 (define-macro (pass-if-not str form)
  33   `(pass-if ,str (not ,form)))
  34
  35 (define (safe-assq-ref alist elt)
  36   (let ((x (assq elt alist)))
  37     (if x (cdr x) x)))
  38
  39 (define (safe-assv-ref alist elt)
  40   (let ((x (assv elt alist)))
  41     (if x (cdr x) x)))
  42
  43 (define (safe-assoc-ref alist elt)
  44   (let ((x (assoc elt alist)))
  45     (if x (cdr x) x)))
  46
  47 ;;; Creators, getters
  48 (let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f '()))))
  49       (b (acons "this" "is" (acons "a" "test" '())))
  50       (deformed '(a b c d e f g)))
  51   (pass-if "acons"
  52            (and (equal? a '((a . b) (c . d) (e . f)))
  53                 (equal? b '(("this" . "is") ("a" . "test")))))
  54   (pass-if "sloppy-assq"
  55            (let ((x (sloppy-assq 'c a)))
  56              (and (pair? x)
  57                   (eq? (car x) 'c)
  58                   (eq? (cdr x) 'd))))
  59   (pass-if "sloppy-assq not"
  60            (let ((x (sloppy-assq "this" b)))
  61              (not x)))
  62   (pass-if "sloppy-assv"
  63            (let ((x (sloppy-assv 'c a)))
  64              (and (pair? x)
  65                   (eq? (car x) 'c)
  66                   (eq? (cdr x) 'd))))
  67   (pass-if "sloppy-assv not"
  68            (let ((x (sloppy-assv "this" b)))
  69              (not x)))
  70   (pass-if "sloppy-assoc"
  71            (let ((x (sloppy-assoc "this" b)))
  72              (and (pair? x)
  73                   (string=? (cdr x) "is"))))
  74   (pass-if "sloppy-assoc not"
  75            (let ((x (sloppy-assoc "heehee" b)))
  76              (not x)))
  77   (pass-if "assq"
  78            (let ((x (assq 'c a)))
  79              (and (pair? x)
  80                   (eq? (car x) 'c)
  81                   (eq? (cdr x) 'd))))
  82   (pass-if-exception "assq deformed"
  83     exception:wrong-type-arg
  84     (assq 'x deformed))
  85   (pass-if-not "assq not" (assq 'r a))
  86   (pass-if "assv"
  87            (let ((x (assv 'a a)))
  88              (and (pair? x)
  89                   (eq? (car x) 'a)
  90                   (eq? (cdr x) 'b))))
  91   (pass-if-exception "assv deformed"
  92     exception:wrong-type-arg
  93     (assv 'x deformed))
  94   (pass-if-not "assv not" (assq "this" b))
  95
  96   (pass-if "assoc"
  97            (let ((x (assoc "this" b)))
  98              (and (pair? x)
  99                   (string=? (car x) "this")
 100                   (string=? (cdr x) "is"))))
 101   (pass-if-exception "assoc deformed"
 102     exception:wrong-type-arg
 103     (assoc 'x deformed))
 104   (pass-if-not "assoc not" (assoc "this isn't" b)))
 105
 106
 107 ;;; Refers
 108 (let ((a '((foo bar) (baz quux)))
 109       (b '(("one" 2 3) ("four" 5 6) ("seven" 8 9)))
 110       (deformed '(thats a real sloppy assq you got there)))
 111   (pass-if "assq-ref"
 112            (let ((x (assq-ref a 'foo)))
 113              (and (list? x)
 114                   (eq? (car x) 'bar))))
 115
 116   (pass-if-not "assq-ref not" (assq-ref b "one"))
 117   (pass-if "assv-ref"
 118            (let ((x (assv-ref a 'baz)))
 119              (and (list? x)
 120                   (eq? (car x) 'quux))))
 121
 122   (pass-if-not "assv-ref not" (assv-ref b "one"))
 123
 124   (pass-if "assoc-ref"
 125            (let ((x (assoc-ref b "one")))
 126              (and (list? x)
 127                   (eq? (car x) 2)
 128                   (eq? (cadr x) 3))))
 129
 130
 131   (pass-if-not "assoc-ref not" (assoc-ref a 'testing))
 132
 133   (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
 134
 135     (pass-if-exception "assv-ref deformed"
 136       exception:wrong-type-arg
 137       (if (not have-sloppy-assv-ref?) (throw 'unsupported))
 138       (assv-ref deformed 'sloppy))
 139
 140     (pass-if-exception "assoc-ref deformed"
 141       exception:wrong-type-arg
 142       (if (not have-sloppy-assv-ref?) (throw 'unsupported))
 143       (assoc-ref deformed 'sloppy))
 144
 145     (pass-if-exception "assq-ref deformed"
 146       exception:wrong-type-arg
 147       (if (not have-sloppy-assv-ref?) (throw 'unsupported))
 148       (assq-ref deformed 'sloppy))))
 149
 150
 151 ;;; Setters
 152 (let ((a '((another . silly) (alist . test-case)))
 153       (b '(("this" "one" "has") ("strings" "!")))
 154       (deformed '(canada is a cold nation)))
 155   (pass-if "assq-set!"
 156            (begin
 157              (set! a (assq-set! a 'another 'stupid))
 158              (let ((x (safe-assq-ref a 'another)))
 159                (and x
 160                     (symbol? x) (eq? x 'stupid)))))
 161
 162   (pass-if "assq-set! add"
 163            (begin
 164              (set! a (assq-set! a 'fickle 'pickle))
 165              (let ((x (safe-assq-ref a 'fickle)))
 166                (and x (symbol? x)
 167                     (eq? x 'pickle)))))
 168
 169   (pass-if "assv-set!"
 170            (begin
 171              (set! a (assv-set! a 'another 'boring))
 172              (let ((x (safe-assv-ref a 'another)))
 173                    (and x
 174                         (eq? x 'boring)))))
 175   (pass-if "assv-set! add"
 176            (begin
 177              (set! a (assv-set! a 'whistle '(while you work)))
 178              (let ((x (safe-assv-ref a 'whistle)))
 179                (and x (equal? x '(while you work))))))
 180
 181   (pass-if "assoc-set!"
 182            (begin
 183              (set! b (assoc-set! b "this" "has"))
 184              (let ((x (safe-assoc-ref b "this")))
 185                (and x (string? x)
 186                     (string=? x "has")))))
 187   (pass-if "assoc-set! add"
 188            (begin
 189              (set! b (assoc-set! b "flugle" "horn"))
 190              (let ((x (safe-assoc-ref b "flugle")))
 191                (and x (string? x)
 192                     (string=? x "horn")))))
 193
 194   (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
 195
 196     (pass-if-exception "assq-set! deformed"
 197       exception:wrong-type-arg
 198       (if (not have-sloppy-assv-ref?) (throw 'unsupported))
 199       (assq-set! deformed 'cold '(very cold)))
 200
 201     (pass-if-exception "assv-set! deformed"
 202       exception:wrong-type-arg
 203       (if (not have-sloppy-assv-ref?) (throw 'unsupported))
 204       (assv-set! deformed 'canada 'Canada))
 205
 206     (pass-if-exception "assoc-set! deformed"
 207       exception:wrong-type-arg
 208       (if (not have-sloppy-assv-ref?) (throw 'unsupported))
 209       (assoc-set! deformed 'canada '(Iceland hence the name)))))
 210
 211 ;;; Removers
 212
 213 (let ((a '((a b) (c d) (e boring)))
 214       (b '(("what" .  "else") ("could" . "I") ("say" . "here")))
 215       (deformed 1))
 216   (pass-if "assq-remove!"
 217            (begin
 218              (set! a (assq-remove! a 'a))
 219              (equal? a '((c d) (e boring)))))
 220   (pass-if "assv-remove!"
 221            (begin
 222              (set! a (assv-remove! a 'c))
 223              (equal? a '((e boring)))))
 224   (pass-if "assoc-remove!"
 225            (begin
 226              (set! b (assoc-remove! b "what"))
 227              (equal? b '(("could" . "I") ("say" . "here")))))
 228
 229   (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove)))
 230
 231     (pass-if-exception "assq-remove! deformed"
 232       exception:wrong-type-arg
 233       (if (not have-sloppy-assq-remove?) (throw 'unsupported))
 234       (assq-remove! deformed 'puddle))
 235
 236     (pass-if-exception "assv-remove! deformed"
 237       exception:wrong-type-arg
 238       (if (not have-sloppy-assq-remove?) (throw 'unsupported))
 239       (assv-remove! deformed 'splashing))
 240
 241     (pass-if-exception "assoc-remove! deformed"
 242       exception:wrong-type-arg
 243       (if (not have-sloppy-assq-remove?) (throw 'unsupported))
 244       (assoc-remove! deformed 'fun))))