blob: 2830b3c16770ea84eaeb248fdde33fbb7b391ecc (
plain) (
blame)
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
|
(export
define-record-type)
(import (only (csc builtins)
call-builtin))
(begin
; There are a few builtin types such as vector, which uses type code 0. We'll
; start at 10 to give some room for more in the future.
(define *next-type-id* 10)
(define-syntax macro-length
(syntax-rules ()
((macro-length ()) 0)
((macro-length (x xs ...))
(+ 1 (macro-length (xs ...))))))
(define-syntax set-arguments
(syntax-rules ()
((set-arguments _ _)
#f)
((set-arguments r n field1 field2 ...)
(begin
(call-builtin poke field1 r n)
(set-arguments r (+ 1 n) field2 ...)))))
(define-syntax define-selectors
(syntax-rules ()
((define-selectors pred (selectors ...))
(values selectors ...))
((define-selectors pred (selectors ...) (field getter) selector ...)
(define-selectors pred (selectors ... (lambda (r)
(unless (pred r)
(error "unexpected type in getter" r 'getter))
(call-builtin peek r field)))
selector ...))
((define-selectors pred (selectors ...) (field getter setter) selector ...)
(define-selectors pred (selectors ... (lambda (r)
(unless (pred r)
(error "unexpected type in getter" r 'getter))
(call-builtin peek r field))
(lambda (r val)
(unless (pred r)
(error "unexpected type in setter" r 'setter))
(call-builtin poke val r field)))
selector ...))))
(define-syntax enumerate-fields
(syntax-rules ()
((enumerate-fields _ selectors)
(define-selectors selectors))
((enumerate-fields n selectors field1 field2 ...)
(begin
(define field1 n)
(enumerate-fields (+ 1 n) selectors field2 ...)))))
(define-syntax selector-names
(syntax-rules ()
((selector-names selectors (field ...) (name ...))
(define-values (name ...)
(enumerate-fields 1 selectors field ...)))
((selector-names selectors fields (names ...) (_ getter) selector ...)
(selector-names selectors fields (names ... getter) selector ...))
((selector-names selectors fields (names ...) (_ getter setter) selector ...)
(selector-names selectors fields (names ... getter setter) selector ...))))
(define-syntax define-record-type
(syntax-rules ()
((define-record-type _
(constructor field ...)
pred
selectors ...)
(define type-id
(let ((id *next-type-id*))
(set! *next-type-id* (call-builtin + 1 *next-type-id*))))
(define (pred r)
(call-builtin eq? type-id (call-builtin peek r 0)))
(define (constructor field ...)
(define r (call-builtin alloc (macro-length (field ...))))
(call-builtin poke type-id r 0)
(set-arguments r 1 field ...)
r)
(selector-names (selectors ...) (field ...) () selectors ...)))))
|
