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 (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)))
  81              (and (pair? x)
  82                   (eq? (car x) 'c)
  83                   (eq? (cdr x) 'd))))
  84   (pass-if "alist: sloppy-assq not"
  85            (let ((x (sloppy-assq "this" b)))
  86              (not x)))
  87   (pass-if "alist: sloppy-assv"
  88            (let ((x (sloppy-assv 'c a)))
  89              (and (pair? x)
  90                   (eq? (car x) 'c)
  91                   (eq? (cdr x) 'd))))
  92   (pass-if "alist: sloppy-assv not"
  93            (let ((x (sloppy-assv "this" b)))
  94              (not x)))
  95   (pass-if "alist: sloppy-assoc"
  96            (let ((x (sloppy-assoc "this" b)))
  97              (and (pair? x)
  98                   (string=? (cdr x) "is"))))
  99   (pass-if "alist: sloppy-assoc not"
 100            (let ((x (sloppy-assoc "heehee" b)))
 101              (not x)))
 102   (pass-if "alist: assq"
 103            (let ((x (assq 'c a)))
 104              (and (pair? x)
 105                   (eq? (car x) 'c)
 106                   (eq? (cdr x) 'd))))
 107   (pass-if "alist: assq deformed"
 108            (catch 'wrong-type-arg
 109                   (lambda ()
 110                     (assq 'x deformed))
 111                   (lambda (key . args)
 112                     #t)))
 113   (pass-if-not "alist: assq not" (assq 'r a))
 114   (pass-if "alist: assv"
 115            (let ((x (assv 'a a)))
 116              (and (pair? x)
 117                   (eq? (car x) 'a)
 118                   (eq? (cdr x) 'b))))
 119   (pass-if "alist: assv deformed"
 120            (catch 'wrong-type-arg
 121                   (lambda ()
 122                     (assv 'x deformed)
 123                     #f)
 124                   (lambda (key . args)
 125                     #t)))
 126   (pass-if-not "alist: assv not" (assq "this" b))
 127
 128   (pass-if "alist: assoc"
 129            (let ((x (assoc "this" b)))
 130              (and (pair? x)
 131                   (string=? (car x) "this")
 132                   (string=? (cdr x) "is"))))
 133   (pass-if "alist: assoc deformed"
 134            (catch 'wrong-type-arg
 135                   (lambda ()
 136                     (assoc 'x deformed)
 137                     #f)
 138                   (lambda (key . args)
 139                     #t)))
 140   (pass-if-not "alist: assoc not" (assoc "this isn't" b)))
 141
 142
 143 ;;; Refers
 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)))
 149              (and (list? x)
 150                   (eq? (car x) 'bar))))
 151
 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)))
 155              (and (list? x)
 156                   (eq? (car x) 'quux))))
 157
 158   (pass-if-not "alist: assv-ref not" (assv-ref b "one"))
 159
 160   (pass-if "alist: assoc-ref"
 161            (let ((x (assoc-ref b "one")))
 162              (and (list? x)
 163                   (eq? (car x) 2)
 164                   (eq? (cadr x) 3))))
 165
 166
 167   (pass-if-not "alist: assoc-ref not" (assoc-ref a 'testing))
 168
 169   (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
 170
 171     (pass-if "alist: assv-ref deformed"
 172       (catch 'wrong-type-arg
 173         (lambda ()
 174           (if (not have-sloppy-assv-ref?) (throw 'unsupported))
 175           (assv-ref deformed 'sloppy)
 176           #f)
 177         (lambda (key . args)
 178           #t)))
 179
 180     (pass-if "alist: assoc-ref deformed"
 181       (catch 'wrong-type-arg
 182         (lambda ()
 183           (if (not have-sloppy-assv-ref?) (throw 'unsupported))
 184           (assoc-ref deformed 'sloppy)
 185           #f)
 186         (lambda (key . args)
 187           #t)))
 188
 189     (pass-if "alist: assq-ref deformed"
 190       (catch 'wrong-type-arg
 191         (lambda ()
 192           (if (not have-sloppy-assv-ref?) (throw 'unsupported))
 193           (assq-ref deformed 'sloppy)
 194           #f)
 195         (lambda (key . args)
 196           #t)))))
 197
 198
 199 ;;; Setters
 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!"
 204            (begin
 205              (set! a (assq-set! a 'another 'stupid))
 206              (let ((x (safe-assq-ref a 'another)))
 207                (and x
 208                     (symbol? x) (eq? x 'stupid)))))
 209
 210   (pass-if "alist: assq-set! add"
 211            (begin
 212              (set! a (assq-set! a 'fickle 'pickle))
 213              (let ((x (safe-assq-ref a 'fickle)))
 214                (and x (symbol? x)
 215                     (eq? x 'pickle)))))
 216
 217   (pass-if "alist: assv-set!"
 218            (begin
 219              (set! a (assv-set! a 'another 'boring))
 220              (let ((x (safe-assv-ref a 'another)))
 221                    (and x
 222                         (eq? x 'boring)))))
 223   (pass-if "alist: assv-set! add"
 224            (begin
 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))))))
 228
 229   (pass-if "alist: assoc-set!"
 230            (begin
 231              (set! b (assoc-set! b "this" "has"))
 232              (let ((x (safe-assoc-ref b "this")))
 233                (and x (string? x)
 234                     (string=? x "has")))))
 235   (pass-if "alist: assoc-set! add"
 236            (begin
 237              (set! b (assoc-set! b "flugle" "horn"))
 238              (let ((x (safe-assoc-ref b "flugle")))
 239                (and x (string? x)
 240                     (string=? x "horn")))))
 241
 242   (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
 243
 244     (pass-if "alist: assq-set! deformed"
 245       (catch 'wrong-type-arg
 246         (lambda ()
 247           (if (not have-sloppy-assv-ref?) (throw 'unsupported))
 248           (assq-set! deformed 'cold '(very cold))
 249           #f)
 250         (lambda (key . args)
 251           #t)))
 252
 253     (pass-if "alist: assv-set! deformed"
 254       (catch 'wrong-type-arg
 255         (lambda ()
 256           (if (not have-sloppy-assv-ref?) (throw 'unsupported))
 257           (assv-set! deformed 'canada 'Canada)
 258           #f)
 259         (lambda (key . args)
 260           #t)))
 261
 262     (pass-if "alist: assoc-set! deformed"
 263       (catch 'wrong-type-arg
 264         (lambda ()
 265           (if (not have-sloppy-assv-ref?) (throw 'unsupported))
 266           (assoc-set! deformed 'canada '(Iceland hence the name))
 267           #f)
 268         (lambda (key . args)
 269           #t)))))
 270
 271 ;;; Removers
 272
 273 (let ((a '((a b) (c d) (e boring)))
 274       (b '(("what" .  "else") ("could" . "I") ("say" . "here")))
 275       (deformed 1))
 276   (pass-if "alist: assq-remove!"
 277            (begin
 278              (set! a (assq-remove! a 'a))
 279              (equal? a '((c d) (e boring)))))
 280   (pass-if "alist: assv-remove!"
 281            (begin
 282              (set! a (assv-remove! a 'c))
 283              (equal? a '((e boring)))))
 284   (pass-if "alist: assoc-remove!"
 285            (begin
 286              (set! b (assoc-remove! b "what"))
 287              (equal? b '(("could" . "I") ("say" . "here")))))
 288
 289   (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove)))
 290
 291     (pass-if "alist: assq-remove! deformed"
 292       (catch 'wrong-type-arg
 293         (lambda ()
 294           (if (not have-sloppy-assq-remove?) (throw 'unsupported))
 295           (assq-remove! deformed 'puddle)
 296           #f)
 297         (lambda (key . args)
 298           #t)))
 299
 300     (pass-if "alist: assv-remove! deformed"
 301       (catch 'wrong-type-arg
 302         (lambda ()
 303           (if (not have-sloppy-assq-remove?) (throw 'unsupported))
 304           (assv-remove! deformed 'splashing)
 305           #f)
 306         (lambda (key . args)
 307           #t)))
 308
 309     (pass-if "alist: assoc-remove! deformed"
 310       (catch 'wrong-type-arg
 311         (lambda ()
 312           (if (not have-sloppy-assq-remove?) (throw 'unsupported))
 313           (assoc-remove! deformed 'fun)
 314           #f)
 315         (lambda (key . args)
 316           #t)))))