test-suite/tests/r6rs-records-inspection.test

   1 ;;; r6rs-control.test --- Test suite for R6RS (rnrs control)
   2
   3 ;;      Copyright (C) 2010 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18 \f
  19
  20 (define-module (test-suite test-rnrs-records-procedural)
  21   :use-module ((rnrs conditions) :version (6))
  22   :use-module ((rnrs exceptions) :version (6))
  23   :use-module ((rnrs records inspection) :version (6))
  24   :use-module ((rnrs records procedural) :version (6))
  25   :use-module (test-suite lib))
  26
  27 (with-test-prefix "record?"
  28   (pass-if "record? recognizes non-opaque records"
  29     (let* ((rec (make-record-type-descriptor 'rec #f #f #f #f '#()))
  30            (make-rec (record-constructor
  31                       (make-record-constructor-descriptor rec #f #f))))
  32       (record? (make-rec))))
  33
  34   (pass-if "record? doesn't recognize opaque records"
  35     (let* ((rec (make-record-type-descriptor 'rec #f #f #f #t '#()))
  36            (make-rec (record-constructor
  37                       (make-record-constructor-descriptor rec #f #f))))
  38       (not (record? (make-rec)))))
  39
  40   (pass-if "record? doesn't recognize non-records" (not (record? 'foo))))
  41
  42 (with-test-prefix "record-rtd"
  43   (pass-if "simple"
  44     (let* ((rtd (make-record-type-descriptor 'rec #f #f #f #f '#()))
  45            (make-rec (record-constructor
  46                       (make-record-constructor-descriptor rtd #f #f))))
  47       (eq? (record-rtd (make-rec)) rtd)))
  48
  49   (pass-if "&assertion on opaque record"
  50     (let* ((rtd (make-record-type-descriptor 'rec #f #f #f #t '#()))
  51            (make-rec (record-constructor
  52                       (make-record-constructor-descriptor rtd #f #f)))
  53            (success #f))
  54       (call/cc
  55        (lambda (continuation)
  56          (with-exception-handler
  57           (lambda (condition)
  58             (set! success (assertion-violation? condition))
  59             (continuation))
  60           (lambda () (record-rtd (make-rec))))))
  61       success)))
  62
  63 (with-test-prefix "record-type-name"
  64   (pass-if "simple"
  65     (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
  66       (eq? (record-type-name rtd) 'foo))))
  67
  68 (with-test-prefix "record-type-parent"
  69   (pass-if "eq? to parent"
  70     (let* ((rtd-parent (make-record-type-descriptor 'foo #f #f #f #f '#()))
  71            (rtd (make-record-type-descriptor 'bar rtd-parent #f #f #f '#())))
  72       (eq? (record-type-parent rtd) rtd-parent)))
  73
  74   (pass-if "#f when parent not present"
  75     (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
  76       (not (record-type-parent rtd)))))
  77
  78 (with-test-prefix "record-type-uid"
  79   (pass-if "eq? to uid"
  80     (let* ((uid (gensym))
  81            (rtd (make-record-type-descriptor uid #f uid #f #f '#())))
  82       (eq? (record-type-uid rtd) uid)))
  83
  84   (pass-if "#f when uid not present"
  85     (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
  86       (not (record-type-uid rtd)))))
  87
  88 (with-test-prefix "record-type-generative?"
  89   (pass-if "#f when uid is not #f"
  90     (let* ((uid (gensym))
  91            (rtd (make-record-type-descriptor uid #f uid #f #f '#())))
  92       (not (record-type-generative? rtd))))
  93
  94   (pass-if "#t when uid is #f"
  95     (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
  96       (record-type-generative? rtd))))
  97
  98 (with-test-prefix "record-type-sealed?"
  99   (pass-if "#t when sealed? is #t"
 100     (let* ((rtd (make-record-type-descriptor 'foo #f #f #t #f '#())))
 101       (record-type-sealed? rtd)))
 102
 103   (pass-if "#f when sealed? is #f"
 104     (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
 105       (not (record-type-sealed? rtd)))))
 106
 107 (with-test-prefix "record-type-opaque?"
 108   (pass-if "#t when opaque? is #t"
 109     (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #t '#())))
 110       (record-type-opaque? rtd)))
 111
 112   (pass-if "#f when opaque? is #f"
 113     (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
 114       (not (record-type-opaque? rtd))))
 115
 116   (pass-if "#t when parent is opaque"
 117     (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #t '#()))
 118            (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f '#())))
 119       (record-type-opaque? rtd))))
 120
 121 (with-test-prefix "record-type-field-names"
 122   (pass-if "simple"
 123     (let* ((rtd (make-record-type-descriptor 'foobar #f #f #f #f
 124                                              '#((immutable foo)
 125                                                 (mutable bar)))))
 126       (equal? (record-type-field-names rtd) '#(foo bar))))
 127
 128   (pass-if "parent fields not included"
 129     (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #f
 130                                                     '#((mutable foo))))
 131            (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f
 132                                              '#((immutable bar)))))
 133       (equal? (record-type-field-names rtd) '#(bar))))
 134
 135   (pass-if "subtype fields not included"
 136     (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #f
 137                                                     '#((mutable foo))))
 138            (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f
 139                                              '#((immutable bar)))))
 140       (equal? (record-type-field-names parent-rtd) '#(foo)))))
 141
 142 (with-test-prefix "record-field-mutable?"
 143   (pass-if "simple"
 144     (let* ((rtd (make-record-type-descriptor 'foobar #f #f #f #f
 145                                              '#((mutable foo)
 146                                                 (immutable bar)))))
 147       (and (record-field-mutable? rtd 0)
 148            (not (record-field-mutable? rtd 1))))))