test-suite/tests/alist.test

   1 ;;;; alist.test --- tests guile's alists     -*- scheme -*-
   2 ;;;; Copyright (C) 1999 Free Software Foundation, Inc.
   3 ;;;;
   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.
   8 ;;;;
   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.
  13 ;;;;
  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
  18 ;;;;
  19 ;;;; As a special exception, the Free Software Foundation gives permission
  20 ;;;; for additional uses of the text contained in its release of GUILE.
  21 ;;;;
  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.
  27 ;;;;
  28 ;;;; This exception does not however invalidate any other reasons why
  29 ;;;; the executable file might be covered by the GNU General Public License.
  30 ;;;;
  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.
  38 ;;;;
  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.
  42
  43 (use-modules (test-suite lib))
  44
  45 ;;; (gbh) some of these are duplicated in r4rs. This is probably a bit
  46 ;;;       more thorough, though (maybe overkill? I need it, anyway).
  47 ;;;
  48 ;;;
  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.
  54
  55 ;;; Misc
  56
  57 (define-macro (pass-if-not str form)
  58   `(pass-if ,str (not ,form)))
  59
  60 (define (safe-assq-ref alist elt)
  61   (let ((x (assq elt alist)))
  62     (if x (cdr x) x)))
  63
  64 (define (safe-assv-ref alist elt)
  65   (let ((x (assv elt alist)))
  66     (if x (cdr x) x)))
  67
  68 (define (safe-assoc-ref alist elt)
  69   (let ((x (assoc elt alist)))
  70     (if x (cdr x) x)))
  71
  72 ;;; Creators, getters
  73 (catch-test-errors
  74  (let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f ()))))
  75        (b (acons "this" "is" (acons "a" "test" ())))
  76        (deformed '(a b c d e f g)))
  77    (pass-if "alist: acons"
  78             (and (equal? a '((a . b) (c . d) (e . f)))
  79                  (equal? b '(("this" . "is") ("a" . "test")))))
  80    (pass-if "alist: sloppy-assq"
  81             (let ((x (sloppy-assq 'c a)))
  82               (and (pair? x)
  83                    (eq? (car x) 'c)
  84                    (eq? (cdr x) 'd))))
  85    (pass-if "alist: sloppy-assq not"
  86             (let ((x (sloppy-assq "this" b)))
  87               (not x)))
  88    (pass-if "alist: sloppy-assv"
  89             (let ((x (sloppy-assv 'c a)))
  90               (and (pair? x)
  91                    (eq? (car x) 'c)
  92                    (eq? (cdr x) 'd))))
  93    (pass-if "alist: sloppy-assv not"
  94             (let ((x (sloppy-assv "this" b)))
  95               (not x)))
  96    (pass-if "alist: sloppy-assoc"
  97             (let ((x (sloppy-assoc "this" b)))
  98               (and (pair? x)
  99                    (string=? (cdr x) "is"))))
 100    (pass-if "alist: sloppy-assoc not"
 101             (let ((x (sloppy-assoc "heehee" b)))
 102               (not x)))
 103    (pass-if "alist: assq"
 104             (let ((x (assq 'c a)))
 105               (and (pair? x)
 106                    (eq? (car x) 'c)
 107                    (eq? (cdr x) 'd))))
 108    (pass-if "alist: assq deformed"
 109             (catch 'wrong-type-arg
 110                    (lambda ()
 111                      (assq 'x deformed))
 112                    (lambda (key . args)
 113                      #t)))
 114    (pass-if-not "alist: assq not" (assq 'r a))
 115    (pass-if "alist: assv"
 116             (let ((x (assv 'a a)))
 117               (and (pair? x)
 118                    (eq? (car x) 'a)
 119                    (eq? (cdr x) 'b))))
 120    (pass-if "alist: assv deformed"
 121             (catch 'wrong-type-arg
 122                    (lambda ()
 123                      (assv 'x deformed)
 124                      #f)
 125                    (lambda (key . args)
 126                      #t)))
 127    (pass-if-not "alist: assv not" (assq "this" b))
 128
 129    (pass-if "alist: assoc"
 130             (let ((x (assoc "this" b)))
 131               (and (pair? x)
 132                    (string=? (car x) "this")
 133                    (string=? (cdr x) "is"))))
 134    (pass-if "alist: assoc deformed"
 135             (catch 'wrong-type-arg
 136                    (lambda ()
 137                      (assoc 'x deformed)
 138                      #f)
 139                    (lambda (key . args)
 140                      #t)))
 141    (pass-if-not "alist: assoc not" (assoc "this isn't" b))))
 142
 143
 144 ;;; Refers
 145 (catch-test-errors
 146  (let ((a '((foo bar) (baz quux)))
 147        (b '(("one" 2 3) ("four" 5 6) ("seven" 8 9)))
 148        (deformed '(thats a real sloppy assq you got there)))
 149    (pass-if "alist: assq-ref"
 150             (let ((x (assq-ref a 'foo)))
 151               (and (list? x)
 152                    (eq? (car x) 'bar))))
 153
 154    (pass-if-not "alist: assq-ref not" (assq-ref b "one"))
 155    (pass-if "alist: assv-ref"
 156             (let ((x (assv-ref a 'baz)))
 157               (and (list? x)
 158                    (eq? (car x) 'quux))))
 159
 160    (pass-if-not "alist: assv-ref not" (assv-ref b "one"))
 161
 162    (pass-if "alist: assoc-ref"
 163             (let ((x (assoc-ref b "one")))
 164               (and (list? x)
 165                    (eq? (car x) 2)
 166                    (eq? (cadr x) 3))))
 167
 168
 169    (pass-if-not "alist: assoc-ref not" (assoc-ref a 'testing))
 170    (expect-failure-if (not (defined? 'sloppy-assv-ref))
 171                       (pass-if "alist: assv-ref deformed"
 172                                (catch 'wrong-type-arg
 173                                       (lambda ()
 174                                         (assv-ref deformed 'sloppy)
 175                                         #f)
 176                                       (lambda (key . args)
 177                                         #t)))
 178                       (pass-if "alist: assoc-ref deformed"
 179                                (catch 'wrong-type-arg
 180                                       (lambda ()
 181                                         (assoc-ref deformed 'sloppy)
 182                                         #f)
 183                                       (lambda (key . args)
 184                                         #t)))
 185
 186                       (pass-if "alist: assq-ref deformed"
 187                                (catch 'wrong-type-arg
 188                                       (lambda ()
 189                                         (assq-ref deformed 'sloppy)
 190                                         #f)
 191                                       (lambda (key . args)
 192                                         #t))))))
 193
 194
 195 ;;; Setters
 196 (catch-test-errors
 197  (let ((a '((another . silly) (alist . test-case)))
 198        (b '(("this" "one" "has") ("strings" "!")))
 199        (deformed '(canada is a cold nation)))
 200    (pass-if "alist: assq-set!"
 201             (begin
 202               (set! a (assq-set! a 'another 'stupid))
 203               (let ((x (safe-assq-ref a 'another)))
 204                 (and x
 205                      (symbol? x) (eq? x 'stupid)))))
 206
 207    (pass-if "alist: assq-set! add"
 208             (begin
 209               (set! a (assq-set! a 'fickle 'pickle))
 210               (let ((x (safe-assq-ref a 'fickle)))
 211                 (and x (symbol? x)
 212                      (eq? x 'pickle)))))
 213
 214    (pass-if "alist: assv-set!"
 215             (begin
 216               (set! a (assv-set! a 'another 'boring))
 217               (let ((x (safe-assv-ref a 'another)))
 218                     (and x
 219                          (eq? x 'boring)))))
 220    (pass-if "alist: assv-set! add"
 221             (begin
 222               (set! a (assv-set! a 'whistle '(while you work)))
 223               (let ((x (safe-assv-ref a 'whistle)))
 224                 (and x (equal? x '(while you work))))))
 225
 226    (pass-if "alist: assoc-set!"
 227             (begin
 228               (set! b (assoc-set! b "this" "has"))
 229               (let ((x (safe-assoc-ref b "this")))
 230                 (and x (string? x)
 231                      (string=? x "has")))))
 232    (pass-if "alist: assoc-set! add"
 233             (begin
 234               (set! b (assoc-set! b "flugle" "horn"))
 235               (let ((x (safe-assoc-ref b "flugle")))
 236                 (and x (string? x)
 237                      (string=? x "horn")))))
 238    (expect-failure-if (not (defined? 'sloppy-assq-ref))
 239                       (pass-if "alist: assq-set! deformed"
 240                                (catch 'wrong-type-arg
 241                                       (lambda ()
 242                                         (assq-set! deformed 'cold '(very cold))
 243                                         #f)
 244                                       (lambda (key . args)
 245                                         #t)))
 246                       (pass-if "alist: assv-set! deformed"
 247                                (catch 'wrong-type-arg
 248                                       (lambda ()
 249                                         (assv-set! deformed 'canada 'Canada)
 250                                         #f)
 251                                       (lambda (key . args)
 252                                         #t)))
 253                       (pass-if "alist: assoc-set! deformed"
 254                                (catch 'wrong-type-arg
 255                                       (lambda ()
 256                                         (assoc-set! deformed 'canada
 257                                                     '(Iceland hence the name))
 258                                         #f)
 259                                       (lambda (key . args)
 260                                         #t))))))
 261
 262 ;;; Removers
 263
 264 (catch-test-errors
 265  (let ((a '((a b) (c d) (e boring)))
 266        (b '(("what" .  "else") ("could" . "I") ("say" . "here")))
 267        (deformed 1))
 268    (pass-if "alist: assq-remove!"
 269             (begin
 270               (set! a (assq-remove! a 'a))
 271               (equal? a '((c d) (e boring)))))
 272    (pass-if "alist: assv-remove!"
 273             (begin
 274               (set! a (assv-remove! a 'c))
 275               (equal? a '((e boring)))))
 276    (pass-if "alist: assoc-remove!"
 277             (begin
 278               (set! b (assoc-remove! b "what"))
 279               (equal? b '(("could" . "I") ("say" . "here")))))
 280    (expect-failure-if (not (defined? 'sloppy-assq-remove!))
 281                       (pass-if "alist: assq-remove! deformed"
 282                                (catch 'wrong-type-arg
 283                                       (lambda ()
 284                                         (assq-remove! deformed 'puddle)
 285                                         #f)
 286                                       (lambda (key . args)
 287                                         #t)))
 288                       (pass-if "alist: assv-remove! deformed"
 289                                (catch 'wrong-type-arg
 290                                       (lambda ()
 291                                         (assv-remove! deformed 'splashing)
 292                                         #f)
 293                                       (lambda (key . args)
 294                                         #t)))
 295                       (pass-if "alist: assoc-remove! deformed"
 296                                (catch 'wrong-type-arg
 297                                       (lambda ()
 298                                         (assoc-remove! deformed 'fun)
 299                                         #f)
 300                                       (lambda (key . args)
 301                                         #t))))))