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 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 exception:not-a-record
  27   (cons 'misc-error "^not-a-record"))
  28
  29
  30 (define-record-type :foo (make-foo x) foo?
  31   (x get-x) (y get-y set-y!))
  32
  33 (define-record-type :bar (make-bar i j) bar?
  34   (i get-i) (i get-j set-j!))
  35
  36 (define f (make-foo 1))
  37 (set-y! f 2)
  38
  39 (define b (make-bar 123 456))
  40
  41 (with-test-prefix "constructor"
  42
  43   (pass-if-exception "foo 0 args" exception:wrong-num-args
  44      (make-foo))
  45   (pass-if-exception "foo 2 args" exception:wrong-num-args
  46      (make-foo 1 2)))
  47
  48 (with-test-prefix "predicate"
  49
  50   (pass-if "pass"
  51      (foo? f))
  52   (pass-if "fail wrong record type"
  53      (eq? #f (foo? b)))
  54   (pass-if "fail number"
  55      (eq? #f (foo? 123))))
  56
  57 (with-test-prefix "accessor"
  58
  59   (pass-if "get-x"
  60      (= 1 (get-x f)))
  61   (pass-if "get-y"
  62      (= 2 (get-y f)))
  63
  64   (pass-if-exception "get-x on number" exception:not-a-record
  65      (get-x 999))
  66   (pass-if-exception "get-y on number" exception:not-a-record
  67      (get-y 999))
  68
  69   ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
  70   (pass-if-exception "get-x on bar" exception:wrong-type-arg
  71      (get-x b))
  72   (pass-if-exception "get-y on bar" exception:wrong-type-arg
  73      (get-y b)))
  74
  75 (with-test-prefix "modifier"
  76
  77   (pass-if "set-y!"
  78      (set-y! f #t)
  79      (eq? #t (get-y f)))
  80
  81   (pass-if-exception "set-y! on number" exception:not-a-record
  82      (set-y! 999 #t))
  83
  84   ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
  85   (pass-if-exception "set-y! on bar" exception:wrong-type-arg
  86      (set-y! b 99)))