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
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Syntax for defining record types
; This knows about the implementation of records and creates the various
; accessors, mutators, etc. directly instead of calling the procedures
; from the record structure. This is done to allow the optional auto-inlining
; optimizer to inline the accessors, mutators, etc.
; LOOPHOLE is used to get a little compile-time type checking (in addition to
; the usual complete run-time checking).
; (define-record-type name constructor-fields other-fields)
; Constructor-arguments fields are either <name> or (<name>), the second
; indicating a field whose value can be modified.
; Other-fields are one of:
; (<name> <expression>) = modifiable field with the given value.
; <name> = modifiable field with no initial value.
;(define-record-type job
; ((thunk)
; (dynamic-env)
; number
; inferior-lock
; )
; ((on-queue #f)
; (superior #f)
; (inferiors '())
; (condition #f)
; ))
(define-syntax define-record-type
(let ()
(define s->s symbol->string)
(define s-conc (lambda args (string->symbol (apply string-append args))))
(define spec-name (lambda (s) (if (pair? s) (car s) s)))
(define (filter pred lst)
(if (null? lst)
'()
(if (pred (car lst))
(cons (car lst) (filter pred (cdr lst)))
(filter pred (cdr lst)))))
(define (ass compare name list)
(cond ((null? list) #f)
((and (pair? (car list))
(compare name (caar list)))
(car list))
(else
(ass compare name (cdr list)))))
(lambda (form rename compare)
(let* ((name (cadr form))
(arg-fields (caddr form))
(other-fields (cadddr form))
(init-fields (filter pair? other-fields))
(args (map spec-name arg-fields))
(field-name (lambda (field-name)
(s-conc (s->s name) "-" (s->s field-name))))
(set-name (lambda (field-name)
(s-conc "set-" (s->s name)
"-" (s->s field-name) "!")))
(pred-name (s-conc (s->s name) "?"))
(maker-name (s-conc (s->s name) "-maker"))
(type-name (s-conc "type/" (s->s name)))
(thing (rename 'name))
(%make-record-type (rename 'make-record-type))
(%record (rename 'record))
(%define-accessors (rename 'define-accessors))
(%unspecific (rename 'unspecific))
(%loophole (rename 'loophole))
(%:value (rename ':value))
(%proc (rename 'proc))
(%define (rename 'define))
(%let (rename 'let))
(%lambda (rename 'lambda))
(%begin (rename 'begin)))
`(,%begin
(,%define ,type-name
(,%make-record-type ',name
',(map spec-name
(append arg-fields other-fields))))
(,%define ,maker-name
(,%loophole (,%proc ,(map (lambda (x) %:value) args) ,type-name)
(,%lambda ,args
(,%record ,type-name
,@args
. ,(map (lambda (field)
(cond ((ass compare
(spec-name field)
other-fields)
=> cadr)
(else
`(,%unspecific))))
other-fields)))))
(,%define ,pred-name
(,%lambda (,(rename 'x))
(,(rename 'and)
(,(rename 'record?) ,(rename 'x))
(,(rename 'eq?) ,type-name
(,(rename 'record-ref) ,(rename 'x) 0)))))
(,%define-accessors ,type-name
,@(map (lambda (spec)
(if (pair? spec)
`(,(field-name (car spec))
,(set-name (car spec)))
`(,(field-name spec))))
arg-fields)
,@(map (lambda (spec)
`(,(field-name (spec-name spec))
,(set-name (spec-name spec))))
other-fields)))))))
(define-syntax define-accessors
(lambda (e r c)
(let ((%define-accessor (r 'define-accessor))
(%begin (r 'begin))
(type (cadr e))
(field-specs (cddr e)))
(do ((i 1 (+ i 1))
(field-specs field-specs (cdr field-specs))
(ds '()
(cons `(,%define-accessor ,type ,i ,@(car field-specs))
ds)))
((null? field-specs)
`(,%begin ,@ds)))))
(define-accessor begin))
(define-syntax define-accessor
(syntax-rules ()
((define-accessor ?type ?index ?accessor)
(define ?accessor
(loophole (proc (?type) :value)
(lambda (r)
(checked-record-ref (loophole :record r) ?type ?index)))))
((define-accessor ?type ?index ?accessor ?modifier)
(begin (define-accessor ?type ?index ?accessor)
(define ?modifier
(loophole (proc (?type :value) :unspecific)
(lambda (r new)
(checked-record-set! (loophole :record r) ?type ?index new))))))
((define-accessor ?type ?index)
(begin))))
|
