test-suite/tests/srfi-9.test

   1 ;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
   2 ;;;; Martin Grabmueller, 2001-05-10
   3 ;;;;
   4 ;;;; Copyright (C) 2001, 2006, 2007 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-suite test-numbers)
  22   #:use-module (test-suite lib)
  23   #:use-module (srfi srfi-9))
  24
  25
  26 (define-record-type :foo (make-foo x) foo?
  27   (x get-x) (y get-y set-y!))
  28
  29 (define-record-type :bar (make-bar i j) bar?
  30   (i get-i) (i get-j set-j!))
  31
  32 (define f (make-foo 1))
  33 (set-y! f 2)
  34
  35 (define b (make-bar 123 456))
  36
  37 (with-test-prefix "constructor"
  38
  39   (pass-if-exception "foo 0 args" exception:wrong-num-args
  40      (make-foo))
  41   (pass-if-exception "foo 2 args" exception:wrong-num-args
  42      (make-foo 1 2)))
  43
  44 (with-test-prefix "predicate"
  45
  46   (pass-if "pass"
  47      (foo? f))
  48   (pass-if "fail wrong record type"
  49      (eq? #f (foo? b)))
  50   (pass-if "fail number"
  51      (eq? #f (foo? 123))))
  52
  53 (with-test-prefix "accessor"
  54
  55   (pass-if "get-x"
  56      (= 1 (get-x f)))
  57   (pass-if "get-y"
  58      (= 2 (get-y f)))
  59
  60   (pass-if-exception "get-x on number" exception:wrong-type-arg
  61      (get-x 999))
  62   (pass-if-exception "get-y on number" exception:wrong-type-arg
  63      (get-y 999))
  64
  65   ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
  66   (pass-if-exception "get-x on bar" exception:wrong-type-arg
  67      (get-x b))
  68   (pass-if-exception "get-y on bar" exception:wrong-type-arg
  69      (get-y b)))
  70
  71 (with-test-prefix "modifier"
  72
  73   (pass-if "set-y!"
  74      (set-y! f #t)
  75      (eq? #t (get-y f)))
  76
  77   (pass-if-exception "set-y! on number" exception:wrong-type-arg
  78      (set-y! 999 #t))
  79
  80   ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
  81   (pass-if-exception "set-y! on bar" exception:wrong-type-arg
  82      (set-y! b 99)))