test-suite/tests/r6rs-records-procedural.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 procedural) :version (6))
  24   :use-module (test-suite lib))
  25
  26 (define :point (make-record-type-descriptor
  27                 'point #f #f #f #f '#((mutable x) (mutable y))))
  28 (define :point-cd (make-record-constructor-descriptor :point #f #f))
  29
  30 (define :voxel (make-record-type-descriptor
  31                 'voxel :point #f #f #f '#((mutable z))))
  32 (define :voxel-cd (make-record-constructor-descriptor :voxel :point-cd #f))
  33
  34 (with-test-prefix "make-record-type-descriptor"
  35   (pass-if "simple"
  36     (let* ((:point-cd (make-record-constructor-descriptor :point #f #f))
  37            (make-point (record-constructor :point-cd))
  38            (point? (record-predicate :point))
  39            (point-x (record-accessor :point 0))
  40            (point-y (record-accessor :point 1))
  41            (point-x-set! (record-mutator :point 0))
  42            (point-y-set! (record-mutator :point 1))
  43            (p1 (make-point 1 2)))
  44       (point? p1)
  45       (eqv? (point-x p1) 1)
  46       (eqv? (point-y p1) 2)
  47       (unspecified? (point-x-set! p1 5))
  48       (eqv? (point-x p1) 5)))
  49
  50   (pass-if "sealed records cannot be subtyped"
  51     (let* ((:sealed-point (make-record-type-descriptor
  52                            'sealed-point #f #f #t #f '#((mutable x)
  53                                                         (mutable y))))
  54            (success #f))
  55       (call/cc
  56        (lambda (continuation)
  57          (with-exception-handler
  58           (lambda (condition)
  59             (set! success (assertion-violation? condition))
  60             (continuation))
  61           (lambda () (make-record-type-descriptor
  62                       'sealed-point-subtype :sealed-point #f #f #f
  63                       '#((mutable z)))))))
  64       success))
  65
  66   (pass-if "non-generative records with same uid are eq"
  67     (let* ((:rtd-1 (make-record-type-descriptor
  68                     'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar))))
  69            (:rtd-2 (make-record-type-descriptor
  70                     'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar)))))
  71        (eq? :rtd-1 :rtd-2)))
  72
  73   (pass-if "&assertion raised on conflicting non-generative types"
  74     (let* ((:rtd-1 (make-record-type-descriptor
  75                     'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar))))
  76            (success 0)
  77            (check-definition
  78             (lambda (thunk)
  79               (call/cc
  80                (lambda (continuation)
  81                  (with-exception-handler
  82                   (lambda (condition)
  83                     (if (assertion-violation? condition)
  84                         (set! success (+ success 1)))
  85                     (continuation))
  86                   thunk))))))
  87       (check-definition
  88        (lambda ()
  89          (make-record-type-descriptor
  90           'rtd1a #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))))
  91       (check-definition
  92        (lambda ()
  93          (make-record-type-descriptor
  94           'rtd1 :point 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))))
  95       (check-definition
  96        (lambda ()
  97          (make-record-type-descriptor
  98           'rtd1 #f 'my-uid-2 #t #f '#((mutable foo) (immutable bar)))))
  99       (check-definition
 100        (lambda ()
 101          (make-record-type-descriptor
 102           'rtd1 #f 'my-uid-2 #f #t '#((mutable foo) (immutable bar)))))
 103       (check-definition
 104        (lambda () (make-record-type-descriptor 'rtd1 #f 'my-uid-2 #f #f '#())))
 105       (check-definition
 106        (lambda ()
 107          (make-record-type-descriptor
 108           'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable baz)))))
 109       (check-definition
 110        (lambda ()
 111          (make-record-type-descriptor
 112           'rtd1 #f 'my-uid-2 #f #f '#((immutable foo) (immutable bar)))))
 113       (eqv? success 7))))
 114
 115 (with-test-prefix "make-record-constructor-descriptor"
 116   (pass-if "simple protocol"
 117     (let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))
 118            (:point-protocol-cd (make-record-constructor-descriptor
 119                                 :point #f :point-protocol))
 120            (make-point (record-constructor :point-protocol-cd))
 121            (point-x (record-accessor :point 0))
 122            (point-y (record-accessor :point 1))
 123            (point (make-point 1 2)))
 124       (and (eqv? (point-x point) 2)
 125            (eqv? (point-y point) 3))))
 126
 127   (pass-if "protocol delegates to parent with protocol"
 128     (let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))
 129            (:point-protocol-cd (make-record-constructor-descriptor
 130                                 :point #f :point-protocol))
 131            (:voxel-protocol (lambda (n)
 132                               (lambda (x y z)
 133                                 (let ((p (n x y))) (p (+ z 100))))))
 134            (:voxel-protocol-cd (make-record-constructor-descriptor
 135                                 :voxel :point-protocol-cd :voxel-protocol))
 136            (make-voxel (record-constructor :voxel-protocol-cd))
 137            (point-x (record-accessor :point 0))
 138            (point-y (record-accessor :point 1))
 139            (voxel-z (record-accessor :voxel 0))
 140            (voxel (make-voxel 1 2 3)))
 141       (and (eqv? (point-x voxel) 2)
 142            (eqv? (point-y voxel) 3)
 143            (eqv? (voxel-z voxel) 103)))))
 144
 145 (with-test-prefix "record-type-descriptor?"
 146   (pass-if "simple"
 147     (record-type-descriptor?
 148      (make-record-type-descriptor 'test #f #f #f #f '#()))))
 149
 150 (with-test-prefix "record-constructor"
 151   (pass-if "simple"
 152     (let* ((make-point (record-constructor :point-cd))
 153            (point? (record-predicate :point))
 154            (point-x (record-accessor :point 0))
 155            (point-y (record-accessor :point 1))
 156            (point (make-point 1 2)))
 157       (and (point? point)
 158            (eqv? (point-x point) 1)
 159            (eqv? (point-y point) 2))))
 160
 161   (pass-if "construct record subtype"
 162     (let* ((make-voxel (record-constructor :voxel-cd))
 163            (voxel? (record-predicate :voxel))
 164            (voxel-z (record-accessor :voxel 0))
 165            (voxel (make-voxel 1 2 3)))
 166       (and (voxel? voxel)
 167            (eqv? (voxel-z voxel) 3)))))
 168
 169 (with-test-prefix "record-predicate"
 170   (pass-if "simple"
 171     (let* ((make-point (record-constructor :point-cd))
 172            (point (make-point 1 2))
 173            (point? (record-predicate :point)))
 174       (point? point)))
 175
 176   (pass-if "predicate returns true on subtype"
 177     (let* ((make-voxel (record-constructor :voxel-cd))
 178            (voxel (make-voxel 1 2 3))
 179            (point? (record-predicate :point)))
 180       (point? voxel)))
 181
 182   (pass-if "predicate returns false on supertype"
 183     (let* ((make-point (record-constructor :point-cd))
 184            (point (make-point 1 2))
 185            (voxel? (record-predicate :voxel)))
 186       (not (voxel? point)))))
 187
 188 (with-test-prefix "record-accessor"
 189   (pass-if "simple"
 190     (let* ((make-point (record-constructor :point-cd))
 191            (point (make-point 1 2))
 192            (point-x (record-accessor :point 0))
 193            (point-y (record-accessor :point 1)))
 194       (and (eqv? (point-x point) 1)
 195            (eqv? (point-y point) 2))))
 196
 197   (pass-if "accessor for supertype applied to subtype"
 198     (let* ((make-voxel (record-constructor :voxel-cd))
 199            (voxel (make-voxel 1 2 3))
 200            (point-x (record-accessor :point 0))
 201            (point-y (record-accessor :point 1)))
 202       (and (eqv? (point-x voxel) 1)
 203            (eqv? (point-y voxel) 2)))))
 204
 205 (with-test-prefix "record-mutator"
 206   (pass-if "simple"
 207     (let* ((make-point (record-constructor :point-cd))
 208            (point (make-point 1 2))
 209            (point-set-x! (record-mutator :point 0))
 210            (point-set-y! (record-mutator :point 1))
 211            (point-x (record-accessor :point 0))
 212            (point-y (record-accessor :point 1)))
 213       (point-set-x! point 3)
 214       (point-set-y! point 4)
 215       (and (eqv? (point-x point) 3)
 216            (eqv? (point-y point) 4))))
 217
 218   (pass-if "&assertion raised on request for immutable field"
 219     (let* ((:immutable-point (make-record-type-descriptor
 220                               'point #f #f #f #f '#((immutable x)
 221                                                     (immutable y))))
 222            (success #f))
 223       (call/cc
 224        (lambda (continuation)
 225          (with-exception-handler
 226           (lambda (condition)
 227             (set! success (assertion-violation? condition))
 228             (continuation))
 229           (lambda () (record-mutator :immutable-point 0)))))
 230       success))
 231
 232   (pass-if "mutator for supertype applied to subtype"
 233     (let* ((make-voxel (record-constructor :voxel-cd))
 234            (voxel (make-voxel 1 2 3))
 235            (point-set-x! (record-mutator :point 0))
 236            (point-set-y! (record-mutator :point 1))
 237            (point-x (record-accessor :point 0))
 238            (point-y (record-accessor :point 1)))
 239       (point-set-x! voxel 3)
 240       (point-set-y! voxel 4)
 241       (and (eqv? (point-x voxel) 3)
 242            (eqv? (point-y voxel) 4)))))
 243