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
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; This is file record.scm.
;;;; Records
; This is completely vanilla Scheme code. Should work anywhere.
(define (make-record-type type-id field-names)
(define unique (list type-id))
(define size (+ (length field-names) 1))
(define (constructor . names-option)
(let* ((names (if (null? names-option)
field-names
(car names-option)))
(number-of-inits (length names))
(indexes (map field-index names)))
(lambda field-values
(if (= (length field-values) number-of-inits)
(let ((record (make-vector size 'uninitialized)))
(vector-set! record 0 unique)
(for-each (lambda (index value)
(vector-set! record index value))
indexes
field-values)
record)
(assertion-violation
'<record-constructor> "wrong number of arguments to record constructor"
field-values type-id names)))))
(define (predicate obj)
(and (vector? obj)
(= (vector-length obj) size)
(eq? (vector-ref obj 0) unique)))
(define (accessor name)
(let ((i (field-index name)))
(lambda (record)
(if (predicate record) ;Faster: (eq? (vector-ref record 0) unique)
(vector-ref record i)
(assertion-violation
'<record-accessor>
"invalid argument to record accessor"
record type-id name)))))
(define (modifier name)
(let ((i (field-index name)))
(lambda (record new-value)
(if (predicate record) ;Faster: (eq? (vector-ref record 0) unique)
(vector-set! record i new-value)
(assertion-violation
'<record-modifier>
"invalid argument to record modifier"
record type-id name)))))
(define (field-index name)
(let loop ((l field-names) (i 1))
(if (null? l)
(assertion-violation 'field-index "bad field name" name)
(if (eq? name (car l))
i
(loop (cdr l) (+ i 1))))))
(define the-descriptor
(lambda (request)
(case request
((constructor) constructor)
((predicate) predicate)
((accessor) accessor)
((modifier) modifier)
((name) type-id)
((field-names) field-names))))
the-descriptor)
(define (record-constructor r-t . names-option)
(apply (r-t 'constructor) names-option))
(define (record-predicate r-t)
(r-t 'predicate))
(define (record-accessor r-t field-name)
((r-t 'accessor) field-name))
(define (record-modifier r-t field-name)
((r-t 'modifier) field-name))
(define (record-type-name r-t) (r-t 'name))
(define (record-type-field-names r-t) (r-t 'field-names))
(define (record-type? r-t)
(and (procedure? r-t)
(assertion-violation 'record-type? "record-type? not implemented" r-t)))
(define (define-record-discloser r-t proc)
"ignoring define-record-discloser form")
|
