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
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; 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-syntax define-record-type
(syntax-rules ()
((define-record-type ?id ?type
(?constructor ?arg ...)
(?field . ?field-stuff)
...)
(begin (define ?type (make-record-type '?id '(?field ...)))
(define-constructor ?constructor ?type
((?arg :value) ...)
(?field ...))
(define-accessors ?type (?field . ?field-stuff) ...)))
((define-record-type ?id ?type
(?constructor ?arg ...)
?pred
?more ...)
(begin (define-record-type ?id ?type
(?constructor ?arg ...)
?more ...)
(define ?pred
(lambda (x)
(and (record? x)
(eq? ?type (record-ref x 0)))))))))
; (define-constructor <id> <type> ((<arg> <arg-type>)*) (<field-name>*))
;
; Checks to see that there is an <arg> corresponding to every <field-name>.
(define-syntax define-constructor
(lambda (e r c)
(let ((%record (r 'record))
(%begin (r 'begin))
(%lambda (r 'lambda))
(%loophole (r 'loophole))
(%proc (r 'proc))
(%unspecific (r 'unspecific))
(name (cadr e))
(type (caddr e))
(args (map r (map car (cadddr e))))
(arg-types (map cadr (cadddr e)))
(fields (map r (caddr (cddr e)))))
(define (mem? name list)
(cond ((null? list) #f)
((c name (car list)) #t)
(else
(mem? name (cdr list)))))
(define (every? pred list)
(cond ((null? list) #t)
((pred (car list))
(every? pred (cdr list)))
(else #f)))
(if (every? (lambda (arg)
(mem? arg fields))
args)
`(define ,name
(,%loophole (,%proc ,arg-types ,type)
(,%lambda ,args
(,%record ,type . ,(map (lambda (field)
(if (mem? field args)
field
(list %unspecific)))
fields)))))
e)))
(record begin lambda loophole proc unspecific))
(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 ,@(cdar 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))))
|
