1;;; r6rs-records-procedural.test --- Test suite for R6RS 2;;; (rnrs records procedural) 3 4;; Copyright (C) 2010 Free Software Foundation, Inc. 5;; 6;; This library is free software; you can redistribute it and/or 7;; modify it under the terms of the GNU Lesser General Public 8;; License as published by the Free Software Foundation; either 9;; version 3 of the License, or (at your option) any later version. 10;; 11;; This library 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 GNU 14;; Lesser General Public License for more details. 15;; 16;; You should have received a copy of the GNU Lesser General Public 17;; License along with this library; if not, write to the Free Software 18;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 19 20 21(define-module (test-suite test-rnrs-records-procedural) 22 :use-module ((rnrs conditions) :version (6)) 23 :use-module ((rnrs exceptions) :version (6)) 24 :use-module ((rnrs records procedural) :version (6)) 25 :use-module (test-suite lib)) 26 27(define :point (make-record-type-descriptor 28 'point #f #f #f #f '#((mutable x) (mutable y)))) 29(define :point-cd (make-record-constructor-descriptor :point #f #f)) 30 31(define :voxel (make-record-type-descriptor 32 'voxel :point #f #f #f '#((mutable z)))) 33(define :voxel-cd (make-record-constructor-descriptor :voxel :point-cd #f)) 34 35(with-test-prefix "make-record-type-descriptor" 36 (pass-if "simple" 37 (let* ((:point-cd (make-record-constructor-descriptor :point #f #f)) 38 (make-point (record-constructor :point-cd)) 39 (point? (record-predicate :point)) 40 (point-x (record-accessor :point 0)) 41 (point-y (record-accessor :point 1)) 42 (point-x-set! (record-mutator :point 0)) 43 (point-y-set! (record-mutator :point 1)) 44 (p1 (make-point 1 2))) 45 (point? p1) 46 (eqv? (point-x p1) 1) 47 (eqv? (point-y p1) 2) 48 (unspecified? (point-x-set! p1 5)) 49 (eqv? (point-x p1) 5))) 50 51 (pass-if "sealed records cannot be subtyped" 52 (let* ((:sealed-point (make-record-type-descriptor 53 'sealed-point #f #f #t #f '#((mutable x) 54 (mutable y)))) 55 (success #f)) 56 (call/cc 57 (lambda (continuation) 58 (with-exception-handler 59 (lambda (condition) 60 ;; FIXME: While R6RS specifies an assertion violation, by 61 ;; building on core Guile records we just see a Guile 62 ;; condition, which is just &serious. 63 (set! success (serious-condition? condition)) 64 (continuation)) 65 (lambda () (make-record-type-descriptor 66 'sealed-point-subtype :sealed-point #f #f #f 67 '#((mutable z))))))) 68 success)) 69 70 (pass-if "non-generative records with same uid are eq" 71 (let* ((:rtd-1 (make-record-type-descriptor 72 'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar)))) 73 (:rtd-2 (make-record-type-descriptor 74 'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar))))) 75 (eq? :rtd-1 :rtd-2))) 76 77 (pass-if "&assertion raised on conflicting non-generative types" 78 (let* ((:rtd-1 (make-record-type-descriptor 79 'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))) 80 (success 0) 81 (check-definition 82 (lambda (thunk) 83 (call/cc 84 (lambda (continuation) 85 (with-exception-handler 86 (lambda (condition) 87 ;; FIXME: While R6RS specifies an assertion 88 ;; violation, by building on core Guile records we 89 ;; just see a Guile condition, which is just 90 ;; &serious. 91 (if (serious-condition? condition) 92 (set! success (+ success 1))) 93 (continuation)) 94 thunk)))))) 95 (check-definition 96 (lambda () 97 (make-record-type-descriptor 98 'rtd1a #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar))))) 99 (check-definition 100 (lambda () 101 (make-record-type-descriptor 102 'rtd1 :point 'my-uid-2 #f #f '#((mutable foo) (immutable bar))))) 103 (check-definition 104 (lambda () 105 (make-record-type-descriptor 106 'rtd1 #f 'my-uid-2 #t #f '#((mutable foo) (immutable bar))))) 107 (check-definition 108 (lambda () 109 (make-record-type-descriptor 110 'rtd1 #f 'my-uid-2 #f #t '#((mutable foo) (immutable bar))))) 111 (check-definition 112 (lambda () (make-record-type-descriptor 'rtd1 #f 'my-uid-2 #f #f '#()))) 113 (check-definition 114 (lambda () 115 (make-record-type-descriptor 116 'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable baz))))) 117 (check-definition 118 (lambda () 119 (make-record-type-descriptor 120 'rtd1 #f 'my-uid-2 #f #f '#((immutable foo) (immutable bar))))) 121 (eqv? success 7)))) 122 123(with-test-prefix "make-record-constructor-descriptor" 124 (pass-if "simple protocol" 125 (let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1))))) 126 (:point-protocol-cd (make-record-constructor-descriptor 127 :point #f :point-protocol)) 128 (make-point (record-constructor :point-protocol-cd)) 129 (point-x (record-accessor :point 0)) 130 (point-y (record-accessor :point 1)) 131 (point (make-point 1 2))) 132 (and (eqv? (point-x point) 2) 133 (eqv? (point-y point) 3)))) 134 135 (pass-if "protocol delegates to parent with protocol" 136 (let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1))))) 137 (:point-protocol-cd (make-record-constructor-descriptor 138 :point #f :point-protocol)) 139 (:voxel-protocol (lambda (n) 140 (lambda (x y z) 141 (let ((p (n x y))) (p (+ z 100)))))) 142 (:voxel-protocol-cd (make-record-constructor-descriptor 143 :voxel :point-protocol-cd :voxel-protocol)) 144 (make-voxel (record-constructor :voxel-protocol-cd)) 145 (point-x (record-accessor :point 0)) 146 (point-y (record-accessor :point 1)) 147 (voxel-z (record-accessor :voxel 0)) 148 (voxel (make-voxel 1 2 3))) 149 (and (eqv? (point-x voxel) 2) 150 (eqv? (point-y voxel) 3) 151 (eqv? (voxel-z voxel) 103))))) 152 153(with-test-prefix "record-type-descriptor?" 154 (pass-if "simple" 155 (record-type-descriptor? 156 (make-record-type-descriptor 'test #f #f #f #f '#())))) 157 158(with-test-prefix "record-constructor" 159 (pass-if "simple" 160 (let* ((make-point (record-constructor :point-cd)) 161 (point? (record-predicate :point)) 162 (point-x (record-accessor :point 0)) 163 (point-y (record-accessor :point 1)) 164 (point (make-point 1 2))) 165 (and (point? point) 166 (eqv? (point-x point) 1) 167 (eqv? (point-y point) 2)))) 168 169 (pass-if "construct record subtype" 170 (let* ((make-voxel (record-constructor :voxel-cd)) 171 (voxel? (record-predicate :voxel)) 172 (voxel-z (record-accessor :voxel 0)) 173 (voxel (make-voxel 1 2 3))) 174 (and (voxel? voxel) 175 (eqv? (voxel-z voxel) 3))))) 176 177(with-test-prefix "record-predicate" 178 (pass-if "simple" 179 (let* ((make-point (record-constructor :point-cd)) 180 (point (make-point 1 2)) 181 (point? (record-predicate :point))) 182 (point? point))) 183 184 (pass-if "predicate returns true on subtype" 185 (let* ((make-voxel (record-constructor :voxel-cd)) 186 (voxel (make-voxel 1 2 3)) 187 (point? (record-predicate :point))) 188 (point? voxel))) 189 190 (pass-if "predicate returns false on supertype" 191 (let* ((make-point (record-constructor :point-cd)) 192 (point (make-point 1 2)) 193 (voxel? (record-predicate :voxel))) 194 (not (voxel? point))))) 195 196(with-test-prefix "record-accessor" 197 (pass-if "simple" 198 (let* ((make-point (record-constructor :point-cd)) 199 (point (make-point 1 2)) 200 (point-x (record-accessor :point 0)) 201 (point-y (record-accessor :point 1))) 202 (and (eqv? (point-x point) 1) 203 (eqv? (point-y point) 2)))) 204 205 (pass-if "accessor for supertype applied to subtype" 206 (let* ((make-voxel (record-constructor :voxel-cd)) 207 (voxel (make-voxel 1 2 3)) 208 (point-x (record-accessor :point 0)) 209 (point-y (record-accessor :point 1))) 210 (and (eqv? (point-x voxel) 1) 211 (eqv? (point-y voxel) 2))))) 212 213(with-test-prefix "record-mutator" 214 (pass-if "simple" 215 (let* ((make-point (record-constructor :point-cd)) 216 (point (make-point 1 2)) 217 (point-set-x! (record-mutator :point 0)) 218 (point-set-y! (record-mutator :point 1)) 219 (point-x (record-accessor :point 0)) 220 (point-y (record-accessor :point 1))) 221 (point-set-x! point 3) 222 (point-set-y! point 4) 223 (and (eqv? (point-x point) 3) 224 (eqv? (point-y point) 4)))) 225 226 (pass-if "&assertion raised on request for immutable field" 227 (let* ((:immutable-point (make-record-type-descriptor 228 'point #f #f #f #f '#((immutable x) 229 (immutable y)))) 230 (success #f)) 231 (call/cc 232 (lambda (continuation) 233 (with-exception-handler 234 (lambda (condition) 235 (set! success (assertion-violation? condition)) 236 (continuation)) 237 (lambda () (record-mutator :immutable-point 0))))) 238 success)) 239 240 (pass-if "mutator for supertype applied to subtype" 241 (let* ((make-voxel (record-constructor :voxel-cd)) 242 (voxel (make-voxel 1 2 3)) 243 (point-set-x! (record-mutator :point 0)) 244 (point-set-y! (record-mutator :point 1)) 245 (point-x (record-accessor :point 0)) 246 (point-y (record-accessor :point 1))) 247 (point-set-x! voxel 3) 248 (point-set-y! voxel 4) 249 (and (eqv? (point-x voxel) 3) 250 (eqv? (point-y voxel) 4))))) 251 252