blob: edc88aa7253aa86ef4cc91785c0c02f5014d800d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
;;; -*- scheme -*-
;;; r6rs-records-syntactic.test --- Test suite for R6RS (rnrs records syntactic)
;; Copyright (C) 2010 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-rnrs-records-syntactic)
#:use-module ((rnrs records syntactic) #:version (6))
#:use-module ((rnrs records procedural) #:version (6))
#:use-module ((rnrs records inspection) #:version (6))
#:use-module ((rnrs conditions) #:version (6))
#:use-module ((rnrs exceptions) #:version (6))
#:use-module ((system base compile) #:select (compile))
#:use-module (test-suite lib))
(define-record-type simple-rtd)
(define-record-type
(specified-rtd specified-rtd-constructor specified-rtd-predicate))
;; Can't be named as `parent-rtd', as that shadows the `parent-rtd'
;; literal.
(define-record-type *parent-rtd (fields x y))
(define-record-type child-parent-rtd-rtd
(parent-rtd (record-type-descriptor *parent-rtd)
(record-constructor-descriptor *parent-rtd))
(fields z))
(define-record-type child-parent-rtd (parent *parent-rtd) (fields z))
(define-record-type mutable-fields-rtd
(fields (mutable mutable-bar)
(mutable mutable-baz mutable-baz-accessor mutable-baz-mutator)))
(define-record-type immutable-fields-rtd
(fields immutable-foo
(immutable immutable-bar)
(immutable immutable-baz immutable-baz-accessor)))
(define-record-type protocol-rtd
(fields (immutable x) (immutable y))
(protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1))))))
(define-record-type sealed-rtd (sealed #t))
(define-record-type opaque-rtd (opaque #t))
(define-record-type nongenerative-rtd (nongenerative))
(define-record-type nongenerative-uid-rtd (nongenerative foo))
(with-test-prefix "simple record names"
(pass-if "define-record-type defines record type"
(defined? 'simple-rtd))
(pass-if "define-record-type defines record predicate"
(defined? 'simple-rtd?))
(pass-if "define-record-type defines record-constructor"
(defined? 'make-simple-rtd)))
(with-test-prefix "fully-specified record names"
(pass-if "define-record-type defines named predicate"
(defined? 'specified-rtd-predicate))
(pass-if "define-record-type defines named constructor"
(defined? 'specified-rtd-constructor)))
(pass-if "parent-rtd clause includes specified parent"
(eq? (record-type-parent child-parent-rtd-rtd) *parent-rtd))
(pass-if "parent clause includes specified parent"
(eq? (record-type-parent child-parent-rtd) *parent-rtd))
(pass-if "protocol clause includes specified protocol"
(let ((protocol-record (make-protocol-rtd 1 2)))
(and (eqv? (protocol-rtd-x protocol-record) 2)
(eqv? (protocol-rtd-y protocol-record) 3))))
(pass-if "sealed clause produces sealed type"
(record-type-sealed? sealed-rtd))
(pass-if "opaque clause produces opaque type"
(record-type-opaque? opaque-rtd))
(with-test-prefix "nongenerative"
(pass-if "nongenerative clause produces nongenerative type"
(not (record-type-generative? nongenerative-rtd)))
(pass-if "nongenerative clause preserves specified uid"
(and (not (record-type-generative? nongenerative-uid-rtd))
(eq? (record-type-uid nongenerative-uid-rtd) 'foo))))
(with-test-prefix "fields"
(pass-if "raw symbol produces accessor only"
(and (defined? 'immutable-fields-rtd-immutable-foo)
(not (defined? 'immutable-fields-rtd-immutable-foo-set!))))
(pass-if "(immutable x) form produces accessor only"
(and (defined? 'immutable-fields-rtd-immutable-bar)
(not (defined? 'immutable-fields-rtd-immutable-bar-set!))))
(pass-if "(immutable x y) form produces named accessor"
(defined? 'immutable-baz-accessor))
(pass-if "(mutable x) form produces accessor and mutator"
(and (defined? 'mutable-fields-rtd-mutable-bar)
(defined? 'mutable-fields-rtd-mutable-bar-set!)))
(pass-if "(mutable x y) form produces named accessor and mutator"
(and (defined? 'mutable-baz-accessor)
(defined? 'mutable-baz-mutator))))
(pass-if "record-type-descriptor returns rtd"
(eq? (record-type-descriptor simple-rtd) simple-rtd))
(pass-if "record-constructor-descriptor returns rcd"
(procedure? (record-constructor (record-constructor-descriptor simple-rtd))))
(with-test-prefix "record hygiene"
(pass-if-exception "using shadowed record keywords fails" exception:syntax-pattern-unmatched
(compile '(let ((fields #f))
(define-record-type foo (fields bar))
#t)
#:env (current-module)))
(pass-if "using shadowed record keywords fails 2"
(guard (condition ((syntax-violation? condition) #t))
(compile '(let ((immutable #f))
(define-record-type foo (fields (immutable bar)))
#t)
#:env (current-module))
#f))
(pass-if "hygiene preserved when using macros"
(compile '(begin
(define pass #t)
(define-syntax define-record
(syntax-rules ()
((define-record name field)
(define-record-type name
(protocol
(lambda (x)
(lambda ()
;; pass refers to pass in scope of macro not use
(x pass))))
(fields field)))))
(let ((pass #f))
(define-record foo bar)
(foo-bar (make-foo))))
#:env (current-module))))
|
