guile18/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, 2009 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   (pass-if "struct-vtable-name"
  40     (let ((ct  (make-condition-type 'chbouib &condition '(a b))))
  41       (eq? 'chbouib (struct-vtable-name ct)))))
  42
  43
  44 \f
  45 (with-test-prefix "conditions"
  46
  47   (pass-if "&condition"
  48     (let ((c (make-condition &condition)))
  49       (and (condition? c)
  50            (condition-has-type? c &condition))))
  51
  52   (pass-if "simple condition"
  53     (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
  54            (c  (make-condition ct 'b 1 'a 0)))
  55       (and (condition? c)
  56            (condition-has-type? c ct))))
  57
  58   (pass-if "simple condition with inheritance"
  59     (let* ((top (make-condition-type 'foo &condition '(a b)))
  60            (ct  (make-condition-type 'bar top '(c d)))
  61            (c   (make-condition ct 'a 1 'b 2 'c 3 'd 4)))
  62       (and (condition? c)
  63            (condition-has-type? c ct)
  64            (condition-has-type? c top))))
  65
  66   (pass-if "condition-ref"
  67     (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
  68            (c  (make-condition ct 'b 1 'a 0)))
  69       (and (eq? (condition-ref c 'a) 0)
  70            (eq? (condition-ref c 'b) 1))))
  71
  72   (pass-if "condition-ref with inheritance"
  73     (let* ((top (make-condition-type 'foo &condition '(a b)))
  74            (ct  (make-condition-type 'bar top '(c d)))
  75            (c   (make-condition ct 'b 1 'a 0 'd 3 'c 2)))
  76       (and (eq? (condition-ref c 'a) 0)
  77            (eq? (condition-ref c 'b) 1)
  78            (eq? (condition-ref c 'c) 2)
  79            (eq? (condition-ref c 'd) 3))))
  80
  81   (pass-if "extract-condition"
  82     (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
  83            (c  (make-condition ct 'b 1 'a 0)))
  84       (equal? c (extract-condition c ct)))))
  85
  86 \f
  87 (with-test-prefix "compound conditions"
  88   (pass-if "condition-has-type?"
  89     (let* ((t1 (make-condition-type 'foo &condition '(a b)))
  90            (t2 (make-condition-type 'bar &condition '(c d)))
  91            (c1 (make-condition t1 'a 0 'b 1))
  92            (c2 (make-condition t2 'c 2 'd 3))
  93            (c  (make-compound-condition c1 c2)))
  94       (and (condition? c)
  95            (condition-has-type? c t1)
  96            (condition-has-type? c t2))))
  97
  98   (pass-if "condition-ref"
  99     (let* ((t1 (make-condition-type 'foo &condition '(a b)))
 100            (t2 (make-condition-type 'bar &condition '(c d)))
 101            (c1 (make-condition t1 'a 0 'b 1))
 102            (c2 (make-condition t2 'c 2 'd 3))
 103            (c  (make-compound-condition c1 c2)))
 104       (equal? (map (lambda (field)
 105                      (condition-ref c field))
 106                    '(a b c d))
 107               '(0 1 2 3))))
 108
 109   (pass-if "condition-ref with same-named fields"
 110     (let* ((t1 (make-condition-type 'foo &condition '(a b)))
 111            (t2 (make-condition-type 'bar &condition '(a c d)))
 112            (c1 (make-condition t1 'a 0 'b 1))
 113            (c2 (make-condition t2 'a -1 'c 2 'd 3))
 114            (c  (make-compound-condition c1 c2)))
 115       (equal? (map (lambda (field)
 116                      (condition-ref c field))
 117                    '(a b c d))
 118               '(0 1 2 3))))
 119
 120   (pass-if "extract-condition"
 121     (let* ((t1 (make-condition-type 'foo &condition '(a b)))
 122            (t2 (make-condition-type 'bar &condition '(c d)))
 123            (c1 (make-condition t1 'a 0 'b 1))
 124            (c2 (make-condition t2 'c 2 'd 3))
 125            (c  (make-compound-condition c1 c2)))
 126       (and (equal? c1 (extract-condition c t1))
 127            (equal? c2 (extract-condition c t2)))))
 128
 129   (pass-if "extract-condition with same-named fields"
 130     (let* ((t1 (make-condition-type 'foo &condition '(a b)))
 131            (t2 (make-condition-type 'bar &condition '(a c)))
 132            (c1 (make-condition t1 'a 0  'b 1))
 133            (c2 (make-condition t2 'a -1 'c 2))
 134            (c  (make-compound-condition c1 c2)))
 135       (and (equal? c1 (extract-condition c t1))
 136            (equal? c2 (extract-condition c t2))))))
 137
 138
 139 \f
 140 (with-test-prefix "syntax"
 141   (pass-if "define-condition-type"
 142     (let ((m (current-module)))
 143       (eval '(define-condition-type &chbouib &condition
 144                chbouib?
 145                (one   chbouib-one)
 146                (two   chbouib-two))
 147             m)
 148       (eval '(and (condition-type? &chbouib)
 149                   (procedure? chbouib?)
 150                   (let ((c (make-condition &chbouib 'one 1 'two 2)))
 151                     (and (condition? c)
 152                          (chbouib? c)
 153                          (eq? (chbouib-one c) 1)
 154                          (eq? (chbouib-two c) 2))))
 155             m)))
 156
 157   (pass-if "condition"
 158     (let* ((t (make-condition-type 'chbouib &condition '(a b)))
 159            (c (condition (t (b 2) (a 1)))))
 160       (and (condition? c)
 161            (condition-has-type? c t)
 162            (equal? (map (lambda (f)
 163                           (condition-ref c f))
 164                         '(a b))
 165                    '(1 2)))))
 166
 167   (pass-if-exception "condition with missing fields"
 168     exception:miscellaneous-error
 169     (let ((t (make-condition-type 'chbouib &condition '(a b c))))
 170       (condition (t (a 1) (b 2)))))
 171
 172   (pass-if "compound condition"
 173     (let* ((t1 (make-condition-type 'foo &condition '(a b)))
 174            (t2 (make-condition-type 'bar &condition '(c d)))
 175            (c1 (make-condition t1 'a 0 'b 1))
 176            (c2 (make-condition t2 'c 2 'd 3))
 177            (c  (condition (t1 (a 0) (b 1))
 178                           (t2 (c 2) (d 3)))))
 179       (and (equal? c1 (extract-condition c t1))
 180            (equal? c2 (extract-condition c t2))))))
 181
 182 \f
 183 ;;;
 184 ;;; Examples from the SRFI.
 185 ;;;
 186
 187 (define-condition-type &c &condition
 188   c?
 189   (x c-x))
 190
 191 (define-condition-type &c1 &c
 192   c1?
 193   (a c1-a))
 194
 195 (define-condition-type &c2 &c
 196   c2?
 197   (b c2-b))
 198
 199 (define v1
 200   (make-condition &c1 'x "V1" 'a "a1"))
 201
 202 (define v2
 203   (condition (&c2 (x "V2") (b "b2"))))
 204
 205 (define v3
 206   (condition (&c1 (x "V3/1") (a "a3"))
 207              (&c2 (b "b3"))))
 208
 209 (define v4
 210   (make-compound-condition v1 v2))
 211
 212 (define v5
 213   (make-compound-condition v2 v3))
 214
 215
 216 (with-test-prefix "examples"
 217
 218   (pass-if "v1"
 219     (condition? v1))
 220
 221   (pass-if "(c? v1)"
 222     (c? v1))
 223
 224   (pass-if "(c1? v1)"
 225     (c1? v1))
 226
 227   (pass-if "(not (c2? v1))"
 228     (not (c2? v1)))
 229
 230   (pass-if "(c-x v1)"
 231     (equal? (c-x v1) "V1"))
 232
 233   (pass-if "(c1-a v1)"
 234     (equal? (c1-a v1) "a1"))
 235
 236
 237   (pass-if "v2"
 238     (condition? v2))
 239
 240   (pass-if "(c? v2)"
 241     (c? v2))
 242
 243   (pass-if "(c2? v2)"
 244     (c2? v2))
 245
 246   (pass-if "(not (c1? v2))"
 247     (not (c1? v2)))
 248
 249   (pass-if "(c-x v2)"
 250     (equal? (c-x v2) "V2"))
 251
 252   (pass-if "(c2-b v2)"
 253     (equal? (c2-b v2) "b2"))
 254
 255
 256   (pass-if "v3"
 257     (condition? v3))
 258
 259   (pass-if "(c? v3)"
 260     (c? v3))
 261
 262   (pass-if "(c1? v3)"
 263     (c1? v3))
 264
 265   (pass-if "(c2? v3)"
 266     (c2? v3))
 267
 268   (pass-if "(c-x v3)"
 269     (equal? (c-x v3) "V3/1"))
 270
 271   (pass-if "(c1-a v3)"
 272     (equal? (c1-a v3) "a3"))
 273
 274   (pass-if "(c2-b v3)"
 275     (equal? (c2-b v3) "b3"))
 276
 277
 278   (pass-if "v4"
 279     (condition? v4))
 280
 281   (pass-if "(c? v4)"
 282     (c? v4))
 283
 284   (pass-if "(c1? v4)"
 285     (c1? v4))
 286
 287   (pass-if "(c2? v4)"
 288     (c2? v4))
 289
 290   (pass-if "(c-x v4)"
 291     (equal? (c-x v4) "V1"))
 292
 293   (pass-if "(c1-a v4)"
 294     (equal? (c1-a v4) "a1"))
 295
 296   (pass-if "(c2-b v4)"
 297     (equal? (c2-b v4) "b2"))
 298
 299
 300   (pass-if "v5"
 301     (condition? v5))
 302
 303   (pass-if "(c? v5)"
 304     (c? v5))
 305
 306   (pass-if "(c1? v5)"
 307     (c1? v5))
 308
 309   (pass-if "(c2? v5)"
 310     (c2? v5))
 311
 312   (pass-if "(c-x v5)"
 313     (equal? (c-x v5) "V2"))
 314
 315   (pass-if "(c1-a v5)"
 316     (equal? (c1-a v5) "a3"))
 317
 318   (pass-if "(c2-b v5)"
 319     (equal? (c2-b v5) "b2")))
 320
 321
 322 ;;; Local Variables:
 323 ;;; coding: latin-1
 324 ;;; End: