test-suite/tests/srfi-35.test

   1 ;;;; srfi-35.test --- Test suite for SRFI-35               -*- Scheme -*-
   2 ;;;; Ludovic Courtès <ludo@gnu.org>
   3 ;;;;
   4 ;;;;    Copyright (C) 2007, 2008 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This program is free software; you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation; either version 2, or (at your option)
   9 ;;;; any later version.
  10 ;;;;
  11 ;;;; This program is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with this software; see the file COPYING.  If not, write to
  18 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19 ;;;; Boston, MA 02110-1301 USA
  20
  21 (define-module (test-srfi-35)
  22   :use-module (test-suite lib)
  23   :use-module (srfi srfi-35))
  24
  25 \f
  26 (with-test-prefix "cond-expand"
  27   (pass-if "srfi-35"
  28     (cond-expand (srfi-35 #t)
  29                  (else    #f))))
  30
  31 \f
  32 (with-test-prefix "condition types"
  33   (pass-if "&condition"
  34     (condition-type? &condition))
  35
  36   (pass-if "make-condition-type"
  37     (condition-type? (make-condition-type 'foo &condition '(a b)))))
  38
  39
  40 \f
  41 (with-test-prefix "conditions"
  42
  43   (pass-if "&condition"
  44     (let ((c (make-condition &condition)))
  45       (and (condition? c)
  46            (condition-has-type? c &condition))))
  47
  48   (pass-if "simple condition"
  49     (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
  50            (c  (make-condition ct 'b 1 'a 0)))
  51       (and (condition? c)
  52            (condition-has-type? c ct))))
  53
  54   (pass-if "simple condition with inheritance"
  55     (let* ((top (make-condition-type 'foo &condition '(a b)))
  56            (ct  (make-condition-type 'bar top '(c d)))
  57            (c   (make-condition ct 'a 1 'b 2 'c 3 'd 4)))
  58       (and (condition? c)
  59            (condition-has-type? c ct)
  60            (condition-has-type? c top))))
  61
  62   (pass-if "condition-ref"
  63     (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
  64            (c  (make-condition ct 'b 1 'a 0)))
  65       (and (eq? (condition-ref c 'a) 0)
  66            (eq? (condition-ref c 'b) 1))))
  67
  68   (pass-if "condition-ref with inheritance"
  69     (let* ((top (make-condition-type 'foo &condition '(a b)))
  70            (ct  (make-condition-type 'bar top '(c d)))
  71            (c   (make-condition ct 'b 1 'a 0 'd 3 'c 2)))
  72       (and (eq? (condition-ref c 'a) 0)
  73            (eq? (condition-ref c 'b) 1)
  74            (eq? (condition-ref c 'c) 2)
  75            (eq? (condition-ref c 'd) 3))))
  76
  77   (pass-if "extract-condition"
  78     (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
  79            (c  (make-condition ct 'b 1 'a 0)))
  80       (equal? c (extract-condition c ct)))))
  81
  82 \f
  83 (with-test-prefix "compound conditions"
  84   (pass-if "condition-has-type?"
  85     (let* ((t1 (make-condition-type 'foo &condition '(a b)))
  86            (t2 (make-condition-type 'bar &condition '(c d)))
  87            (c1 (make-condition t1 'a 0 'b 1))
  88            (c2 (make-condition t2 'c 2 'd 3))
  89            (c  (make-compound-condition c1 c2)))
  90       (and (condition? c)
  91            (condition-has-type? c t1)
  92            (condition-has-type? c t2))))
  93
  94   (pass-if "condition-ref"
  95     (let* ((t1 (make-condition-type 'foo &condition '(a b)))
  96            (t2 (make-condition-type 'bar &condition '(c d)))
  97            (c1 (make-condition t1 'a 0 'b 1))
  98            (c2 (make-condition t2 'c 2 'd 3))
  99            (c  (make-compound-condition c1 c2)))
 100       (equal? (map (lambda (field)
 101                      (condition-ref c field))
 102                    '(a b c d))
 103               '(0 1 2 3))))
 104
 105   (pass-if "condition-ref with same-named fields"
 106     (let* ((t1 (make-condition-type 'foo &condition '(a b)))
 107            (t2 (make-condition-type 'bar &condition '(a c d)))
 108            (c1 (make-condition t1 'a 0 'b 1))
 109            (c2 (make-condition t2 'a -1 'c 2 'd 3))
 110            (c  (make-compound-condition c1 c2)))
 111       (equal? (map (lambda (field)
 112                      (condition-ref c field))
 113                    '(a b c d))
 114               '(0 1 2 3))))
 115
 116   (pass-if "extract-condition"
 117     (let* ((t1 (make-condition-type 'foo &condition '(a b)))
 118            (t2 (make-condition-type 'bar &condition '(c d)))
 119            (c1 (make-condition t1 'a 0 'b 1))
 120            (c2 (make-condition t2 'c 2 'd 3))
 121            (c  (make-compound-condition c1 c2)))
 122       (and (equal? c1 (extract-condition c t1))
 123            (equal? c2 (extract-condition c t2)))))
 124
 125   (pass-if "extract-condition with same-named fields"
 126     (let* ((t1 (make-condition-type 'foo &condition '(a b)))
 127            (t2 (make-condition-type 'bar &condition '(a c)))
 128            (c1 (make-condition t1 'a 0  'b 1))
 129            (c2 (make-condition t2 'a -1 'c 2))
 130            (c  (make-compound-condition c1 c2)))
 131       (and (equal? c1 (extract-condition c t1))
 132            (equal? c2 (extract-condition c t2))))))
 133
 134
 135 \f
 136 (with-test-prefix "syntax"
 137   (pass-if "define-condition-type"
 138     (let ((m (current-module)))
 139       (eval '(define-condition-type &chbouib &condition
 140                chbouib?
 141                (one   chbouib-one)
 142                (two   chbouib-two))
 143             m)
 144       (eval '(and (condition-type? &chbouib)
 145                   (procedure? chbouib?)
 146                   (let ((c (make-condition &chbouib 'one 1 'two 2)))
 147                     (and (condition? c)
 148                          (chbouib? c)
 149                          (eq? (chbouib-one c) 1)
 150                          (eq? (chbouib-two c) 2))))
 151             m)))
 152
 153   (pass-if "condition"
 154     (let* ((t (make-condition-type 'chbouib &condition '(a b)))
 155            (c (condition (t (b 2) (a 1)))))
 156       (and (condition? c)
 157            (condition-has-type? c t)
 158            (equal? (map (lambda (f)
 159                           (condition-ref c f))
 160                         '(a b))
 161                    '(1 2)))))
 162
 163   (pass-if-exception "condition with missing fields"
 164     exception:miscellaneous-error
 165     (let ((t (make-condition-type 'chbouib &condition '(a b c))))
 166       (condition (t (a 1) (b 2)))))
 167
 168   (pass-if "compound condition"
 169     (let* ((t1 (make-condition-type 'foo &condition '(a b)))
 170            (t2 (make-condition-type 'bar &condition '(c d)))
 171            (c1 (make-condition t1 'a 0 'b 1))
 172            (c2 (make-condition t2 'c 2 'd 3))
 173            (c  (condition (t1 (a 0) (b 1))
 174                           (t2 (c 2) (d 3)))))
 175       (and (equal? c1 (extract-condition c t1))
 176            (equal? c2 (extract-condition c t2))))))
 177
 178 \f
 179 ;;;
 180 ;;; Examples from the SRFI.
 181 ;;;
 182
 183 (define-condition-type &c &condition
 184   c?
 185   (x c-x))
 186
 187 (define-condition-type &c1 &c
 188   c1?
 189   (a c1-a))
 190
 191 (define-condition-type &c2 &c
 192   c2?
 193   (b c2-b))
 194
 195 (define v1
 196   (make-condition &c1 'x "V1" 'a "a1"))
 197
 198 (define v2
 199   (condition (&c2 (x "V2") (b "b2"))))
 200
 201 (define v3
 202   (condition (&c1 (x "V3/1") (a "a3"))
 203              (&c2 (b "b3"))))
 204
 205 (define v4
 206   (make-compound-condition v1 v2))
 207
 208 (define v5
 209   (make-compound-condition v2 v3))
 210
 211
 212 (with-test-prefix "examples"
 213
 214   (pass-if "v1"
 215     (condition? v1))
 216
 217   (pass-if "(c? v1)"
 218     (c? v1))
 219
 220   (pass-if "(c1? v1)"
 221     (c1? v1))
 222
 223   (pass-if "(not (c2? v1))"
 224     (not (c2? v1)))
 225
 226   (pass-if "(c-x v1)"
 227     (equal? (c-x v1) "V1"))
 228
 229   (pass-if "(c1-a v1)"
 230     (equal? (c1-a v1) "a1"))
 231
 232
 233   (pass-if "v2"
 234     (condition? v2))
 235
 236   (pass-if "(c? v2)"
 237     (c? v2))
 238
 239   (pass-if "(c2? v2)"
 240     (c2? v2))
 241
 242   (pass-if "(not (c1? v2))"
 243     (not (c1? v2)))
 244
 245   (pass-if "(c-x v2)"
 246     (equal? (c-x v2) "V2"))
 247
 248   (pass-if "(c2-b v2)"
 249     (equal? (c2-b v2) "b2"))
 250
 251
 252   (pass-if "v3"
 253     (condition? v3))
 254
 255   (pass-if "(c? v3)"
 256     (c? v3))
 257
 258   (pass-if "(c1? v3)"
 259     (c1? v3))
 260
 261   (pass-if "(c2? v3)"
 262     (c2? v3))
 263
 264   (pass-if "(c-x v3)"
 265     (equal? (c-x v3) "V3/1"))
 266
 267   (pass-if "(c1-a v3)"
 268     (equal? (c1-a v3) "a3"))
 269
 270   (pass-if "(c2-b v3)"
 271     (equal? (c2-b v3) "b3"))
 272
 273
 274   (pass-if "v4"
 275     (condition? v4))
 276
 277   (pass-if "(c? v4)"
 278     (c? v4))
 279
 280   (pass-if "(c1? v4)"
 281     (c1? v4))
 282
 283   (pass-if "(c2? v4)"
 284     (c2? v4))
 285
 286   (pass-if "(c-x v4)"
 287     (equal? (c-x v4) "V1"))
 288
 289   (pass-if "(c1-a v4)"
 290     (equal? (c1-a v4) "a1"))
 291
 292   (pass-if "(c2-b v4)"
 293     (equal? (c2-b v4) "b2"))
 294
 295
 296   (pass-if "v5"
 297     (condition? v5))
 298
 299   (pass-if "(c? v5)"
 300     (c? v5))
 301
 302   (pass-if "(c1? v5)"
 303     (c1? v5))
 304
 305   (pass-if "(c2? v5)"
 306     (c2? v5))
 307
 308   (pass-if "(c-x v5)"
 309     (equal? (c-x v5) "V2"))
 310
 311   (pass-if "(c1-a v5)"
 312     (equal? (c1-a v5) "a3"))
 313
 314   (pass-if "(c2-b v5)"
 315     (equal? (c2-b v5) "b2")))
 316
 317
 318 ;;; Local Variables:
 319 ;;; coding: latin-1
 320 ;;; End: