blob: 052e84f8193f9a3073b194296b4e8e8e90462041 (
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
|
;;; inspection.scm --- Inspection support for R6RS records
;; Copyright (C) 2010, 2019 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 inspection (6))
(export record?
record-rtd
record-type-name
record-type-parent
record-type-uid
record-type-generative?
record-type-sealed?
record-type-opaque?
record-type-field-names
record-field-mutable?)
(import (rnrs arithmetic bitwise (6))
(rnrs base (6))
(rnrs records procedural (6))
(rename (only (guile)
unless
logbit?
record?
record-type-name
record-type-parent
record-type-fields
record-type-opaque?
record-type-extensible?
record-type-uid
record-type-mutable-fields
struct-vtable)
(record? guile:record?)))
(define (record? obj)
(and (guile:record? obj)
(not (record-type-opaque? (struct-vtable obj)))))
(define (record-rtd record)
(unless (record? record)
(assertion-violation 'record-rtd "not a record" record))
(struct-vtable record))
(define (record-type-generative? rtd)
(not (record-type-uid rtd)))
(define (record-type-sealed? rtd)
(not (record-type-extensible? rtd)))
(define (record-type-field-names rtd)
(let ((parent (record-type-parent rtd))
(fields (record-type-fields rtd)))
(list->vector
(if parent
(list-tail fields (length (record-type-fields parent)))
fields))))
(define (record-field-mutable? rtd k)
(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))))
(r6rs-raise (make-assertion-violation)))
(logbit? k (record-type-mutable-fields rtd)))))
|