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
|
; Copyright (c) 1993-2008 by Richard Kelsey. See file COPYING.
; Records that translate into C structs.
; Representation of record types.
(define-record-type record-type :record-type
(really-make-record-type name)
record-type?
(name record-type-name)
; FIELDS and CONSTRUCTOR-ARGS are filled in later because of circularity
(fields record-type-fields set-record-type-fields!)
(constructor-args ; fields passed to the constructor
record-type-constructor-args set-record-type-constructor-args!))
(define-record-discloser :record-type
(lambda (rtype)
(list 'record-type (record-type-name rtype))))
; Fields of record types.
(define-record-type record-field :record-field
(make-record-field record-type name type)
record-field?
(record-type record-field-record-type)
(name record-field-name)
(type record-field-type))
; Global table of record types. Since we compile to a single C file the
; record types used within a single computation must have distinct names.
; (This should really be a fluid.)
(define *record-type-table* (make-symbol-table))
(define (reset-record-data!)
(set! *record-type-table* (make-symbol-table)))
(define (get-record-type id)
(cond ((table-ref *record-type-table* id)
=> identity)
(else
(error "no record type ~S" id))))
(define (lookup-record-type id)
(table-ref *record-type-table* id))
(define (all-record-types)
(table->entry-list *record-type-table*))
; Construction a record type. This gets the name, the list of fields whose
; initial values are passed to the constructor, and the field specifications.
; Each field specification consists of a name and a type.
(define (make-record-type id constructor-args specs)
(let ((rt (really-make-record-type id)))
(if (table-ref *record-type-table* id)
(user-error "multiple definitions of record type ~S" id))
(table-set! *record-type-table* id rt)
(set-record-type-fields! rt (map (lambda (spec)
(make-record-field
rt
(car spec)
(expand-type-spec (cadr spec))))
specs))
(set-record-type-constructor-args! rt
(map (lambda (name)
(get-record-type-field id name))
constructor-args))
rt))
; Return the field record for FIELD-ID in record-type TYPE-ID.
(define (get-record-type-field type-id field-id)
(let ((rtype (get-record-type type-id)))
(cond ((any (lambda (field)
(eq? field-id (record-field-name field)))
(record-type-fields rtype))
=> identity)
(else
(user-error "~S is not a field of ~S" field-id rtype)))))
; The macro expander for DEFINE-RECORD-TYPE.
;
; (define-record-type <id> <type-id>
; (<constructor> . <field-names>)
; (<field-name> <type> <accessor-name> [<modifier-name>]) ...)
;
; The <type-id> is used only by Pre-Scheme-in-Scheme.
(define (expand-define-record-type exp r c)
(let ((id (cadr exp))
(maker (cadddr exp))
(fields (cddddr exp)))
(let ((rt (make-record-type id (cdr maker) fields)))
`(,(r 'begin)
(,(r 'define) ,maker
(,(r 'let) ((,(r id) (,(r 'make-record) ',id)))
(,(r 'if) (,(r 'not) (,(r 'null-pointer?) ,(r id)))
(,(r 'begin)
. ,(map (lambda (name)
`(,(r 'record-set!) ,(r id) ,name ',id ',name))
(cdr maker))))
,(r id)))
,@(map (lambda (field)
`(,(r 'define) (,(caddr field) ,(r id))
(,(r 'record-ref) ,(r id) ',id ',(car field))))
fields)
,@(map (lambda (field)
`(,(r 'define) (,(cadddr field) ,(r id) ,(r 'x))
(,(r 'record-set!)
,(r id) ,(r 'x)',id ',(car field))))
(filter (lambda (spec)
(not (null? (cdddr spec))))
fields))))))
; primitives
; (make-record 'type . args)
; (record-ref thing 'type 'field)
; (record-set! thing value 'type 'field)
;
; C record creator
; global list of these things
|
