1;;; -*- scheme -*- 2;;; r6rs-records-syntactic.test --- Test suite for R6RS (rnrs records syntactic) 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-syntactic) 22 #:use-module ((rnrs records syntactic) #:version (6)) 23 #:use-module ((rnrs records procedural) #:version (6)) 24 #:use-module ((rnrs records inspection) #:version (6)) 25 #:use-module ((rnrs conditions) #:version (6)) 26 #:use-module ((rnrs exceptions) #:version (6)) 27 #:use-module ((system base compile) #:select (compile)) 28 #:use-module (test-suite lib)) 29 30(define-record-type simple-rtd) 31(define-record-type 32 (specified-rtd specified-rtd-constructor specified-rtd-predicate)) 33;; Can't be named as `parent-rtd', as that shadows the `parent-rtd' 34;; literal. 35(define-record-type *parent-rtd (fields x y)) 36(define-record-type child-parent-rtd-rtd 37 (parent-rtd (record-type-descriptor *parent-rtd) 38 (record-constructor-descriptor *parent-rtd)) 39 (fields z)) 40(define-record-type child-parent-rtd (parent *parent-rtd) (fields z)) 41(define-record-type mutable-fields-rtd 42 (fields (mutable mutable-bar) 43 (mutable mutable-baz mutable-baz-accessor mutable-baz-mutator))) 44(define-record-type immutable-fields-rtd 45 (fields immutable-foo 46 (immutable immutable-bar) 47 (immutable immutable-baz immutable-baz-accessor))) 48(define-record-type protocol-rtd 49 (fields (immutable x) (immutable y)) 50 (protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))) 51(define-record-type sealed-rtd (sealed #t)) 52(define-record-type opaque-rtd (opaque #t)) 53(define-record-type nongenerative-rtd (nongenerative)) 54(define-record-type nongenerative-uid-rtd (nongenerative foo)) 55 56(with-test-prefix "simple record names" 57 (pass-if "define-record-type defines record type" 58 (defined? 'simple-rtd)) 59 60 (pass-if "define-record-type defines record predicate" 61 (defined? 'simple-rtd?)) 62 63 (pass-if "define-record-type defines record-constructor" 64 (defined? 'make-simple-rtd))) 65 66(with-test-prefix "fully-specified record names" 67 (pass-if "define-record-type defines named predicate" 68 (defined? 'specified-rtd-predicate)) 69 70 (pass-if "define-record-type defines named constructor" 71 (defined? 'specified-rtd-constructor))) 72 73(pass-if "parent-rtd clause includes specified parent" 74 (eq? (record-type-parent child-parent-rtd-rtd) *parent-rtd)) 75 76(pass-if "parent clause includes specified parent" 77 (eq? (record-type-parent child-parent-rtd) *parent-rtd)) 78 79(pass-if "protocol clause includes specified protocol" 80 (let ((protocol-record (make-protocol-rtd 1 2))) 81 (and (eqv? (protocol-rtd-x protocol-record) 2) 82 (eqv? (protocol-rtd-y protocol-record) 3)))) 83 84(pass-if "sealed clause produces sealed type" 85 (record-type-sealed? sealed-rtd)) 86 87(pass-if "opaque clause produces opaque type" 88 (record-type-opaque? opaque-rtd)) 89 90(with-test-prefix "nongenerative" 91 (pass-if "nongenerative clause produces nongenerative type" 92 (not (record-type-generative? nongenerative-rtd))) 93 94 (pass-if "nongenerative clause preserves specified uid" 95 (and (not (record-type-generative? nongenerative-uid-rtd)) 96 (eq? (record-type-uid nongenerative-uid-rtd) 'foo)))) 97 98(with-test-prefix "fields" 99 (pass-if "raw symbol produces accessor only" 100 (and (defined? 'immutable-fields-rtd-immutable-foo) 101 (not (defined? 'immutable-fields-rtd-immutable-foo-set!)))) 102 103 (pass-if "(immutable x) form produces accessor only" 104 (and (defined? 'immutable-fields-rtd-immutable-bar) 105 (not (defined? 'immutable-fields-rtd-immutable-bar-set!)))) 106 107 (pass-if "(immutable x y) form produces named accessor" 108 (defined? 'immutable-baz-accessor)) 109 110 (pass-if "(mutable x) form produces accessor and mutator" 111 (and (defined? 'mutable-fields-rtd-mutable-bar) 112 (defined? 'mutable-fields-rtd-mutable-bar-set!))) 113 114 (pass-if "(mutable x y) form produces named accessor and mutator" 115 (and (defined? 'mutable-baz-accessor) 116 (defined? 'mutable-baz-mutator)))) 117 118(pass-if "record-type-descriptor returns rtd" 119 (eq? (record-type-descriptor simple-rtd) simple-rtd)) 120 121(pass-if "record-constructor-descriptor returns rcd" 122 (procedure? (record-constructor (record-constructor-descriptor simple-rtd)))) 123 124(with-test-prefix "record hygiene" 125 (pass-if-exception "using shadowed record keywords fails" exception:syntax-pattern-unmatched 126 (compile '(let ((fields #f)) 127 (define-record-type foo (fields bar)) 128 #t) 129 #:env (current-module))) 130 (pass-if "using shadowed record keywords fails 2" 131 (guard (condition ((syntax-violation? condition) #t)) 132 (compile '(let ((immutable #f)) 133 (define-record-type foo (fields (immutable bar))) 134 #t) 135 #:env (current-module)) 136 #f)) 137 (pass-if "hygiene preserved when using macros" 138 (compile '(begin 139 (define pass #t) 140 (define-syntax define-record 141 (syntax-rules () 142 ((define-record name field) 143 (define-record-type name 144 (protocol 145 (lambda (x) 146 (lambda () 147 ;; pass refers to pass in scope of macro not use 148 (x pass)))) 149 (fields field))))) 150 (let ((pass #f)) 151 (define-record foo bar) 152 (foo-bar (make-foo)))) 153 #:env (current-module)))) 154