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
154
155
156
157
158
159
160
161
162
163
|
;;; procedural.scm --- Procedural interface to R6RS records
;; Copyright (C) 2010, 2017, 2019-2020 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
(library (rnrs records procedural (6))
(export make-record-type-descriptor
(rename (record-type? record-type-descriptor?))
make-record-constructor-descriptor
record-constructor
record-predicate
record-accessor
record-mutator)
(import (rnrs base (6))
(rnrs conditions (6))
(rnrs exceptions (6))
(only (rename (guile)
(record-accessor guile:record-accessor))
logbit?
when
unless
struct-ref
struct-set!
make-record-type
record-type?
record-type-name
record-type-fields
record-type-constructor
record-type-mutable-fields
record-type-parent
record-type-opaque?
record-predicate
guile:record-accessor
record-modifier
vector->list))
(define (make-record-type-descriptor name parent uid sealed? opaque? fields)
(make-record-type name (vector->list fields) #:parent parent #:uid uid
#:extensible? (not sealed?)
#:allow-duplicate-field-names? #t
#:opaque? (or opaque?
(and parent (record-type-opaque? parent)))))
(define record-constructor-descriptor
(make-record-type 'record-constructor-descriptor
'((immutable rtd)
(immutable parent)
(immutable protocol))))
(define rcd-rtd
(guile:record-accessor record-constructor-descriptor 'rtd))
(define rcd-parent
(guile:record-accessor record-constructor-descriptor 'parent))
(define rcd-protocol
(guile:record-accessor record-constructor-descriptor 'protocol))
(define (make-record-constructor-descriptor rtd parent-rcd protocol)
(unless (record-type? rtd)
(raise (make-assertion-violation)))
(when protocol
(unless (procedure? protocol)
(raise (make-assertion-violation))))
(when parent-rcd
(unless (eq? (rcd-rtd parent-rcd)
(record-type-parent rtd))
(when protocol
(raise (make-assertion-violation)))))
((record-type-constructor record-constructor-descriptor)
rtd parent-rcd protocol))
(define (record-constructor rcd)
;; The protocol facility allows users to define constructors whose
;; arguments don't directly correspond to the fields of the record
;; type; instead, the protocol managed a mapping from "args" to
;; "inits", where args are constructor args, and inits are the
;; resulting set of initial field values.
(define-syntax if*
(syntax-rules (=>)
((if* (exp => id) consequent alternate)
(cond (exp => (lambda (id) consequent)) (else alternate)))))
(define raw-constructor
(record-type-constructor (rcd-rtd rcd)))
(if* ((rcd-protocol rcd) => protocol)
(protocol
(if* ((rcd-parent rcd) => parent)
(lambda parent-args
(lambda inits
(let collect-inits ((parent parent)
(parent-args parent-args)
(inits inits))
(apply
(if* ((and parent (rcd-protocol parent)) => protocol)
(protocol
(if* ((rcd-parent parent) => parent)
;; Parent has a protocol too; collect
;; inits from parent.
(lambda parent-args
(lambda parent-inits
(collect-inits parent parent-args
(append parent-inits
inits))))
;; Default case: parent args correspond
;; to inits.
(lambda parent-args
(apply raw-constructor
(append parent-args inits)))))
;; Default case: parent args correspond to inits.
(lambda parent-args
(apply raw-constructor
(append parent-args inits))))
parent-args))))
raw-constructor))
raw-constructor))
(define (record-accessor rtd k)
(define pred (record-predicate rtd))
(let* ((parent (record-type-parent rtd))
(parent-nfields (if parent
(length (record-type-fields parent))
0))
(k (+ k parent-nfields)))
(unless (and (<= parent-nfields k)
(< k (length (record-type-fields rtd))))
(raise (make-assertion-violation)))
(lambda (obj)
(unless (pred obj)
(raise (make-assertion-violation)))
(struct-ref obj k))))
(define (record-mutator rtd k)
(define pred (record-predicate rtd))
(let* ((parent (record-type-parent rtd))
(parent-nfields (if parent
(length (record-type-fields parent))
0))
(k (+ k parent-nfields)))
(unless (and (<= parent-nfields k)
(< k (length (record-type-fields rtd))))
(raise (make-assertion-violation)))
(unless (logbit? k (record-type-mutable-fields rtd))
(raise (make-assertion-violation)))
(lambda (obj val)
(unless (pred obj)
(raise (make-assertion-violation)))
(struct-set! obj k val))))
)
|
