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
148
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees
; Macros for defining data types.
; An ugly and unsafe macro for defining VM data structures.
;
; (DEFINE-PRIMITIVE-DATA-TYPE <name> <type> <immutable?> <constructor-name>
; <slot>*)
; <slot> ::= (<accessor-name>) | (<accessor-name> <modifier-name>)
;
; (define-primitive-data-type pair N #f cons (car set-car!) (cdr))
; =>
; (begin
; (define (cons a b) (d-vector N ...))
; (define pair? (stob-predicate ...))
; (define pair-size 3)
; (define (car x) (d-vector-ref x 0))
; (define (set-car! x val) (d-vector-set! x 0 val))
; (define (cdr x) (d-vector-ref x 1))
(define-syntax define-primitive-data-type
(lambda (exp rename compare)
(destructure (((d-p-d-t name type immutable? make . body) exp))
(define (concatenate-symbol . syms)
(string->symbol (apply string-append (map symbol->string syms))))
(let* ((pred (concatenate-symbol name '?))
(size (concatenate-symbol name '- 'size))
(shorten (lambda (l1 l2) (map (lambda (x1 x2) x2 x1) l1 l2)))
(vars (shorten `(a b c d e f g h i j) body)))
`(begin ,@(if make
`((define ,make
(let ((type (enum stob ,type)))
(lambda (,@vars key)
,(if immutable?
`(immutable-d-vector type key ,@vars)
`(d-vector type key ,@vars))))))
'())
(define ,pred (stob-predicate (enum stob ,type)))
(define ,size (+ ,(length body) stob-overhead))
,@(do ((s body (cdr s))
(i 0 (+ i 1))
(d '() (let* ((slot (car s))
(d (cons `(define (,(car slot) x)
(d-vector-ref x ,i))
d)))
(if (null? (cdr slot))
d
(cons `(define (,(cadr slot) x val)
(d-vector-set! x ,i val))
d)))))
((null? s) (reverse d))))))))
; This is a front for DEFINE-PRIMITIVE-DATA-TYPE that gets the names from
; STOB-DATA (which is defined in arch.scm). This ensures that the run-time
; code, the VM, and the linker agree on what these structures look like.
;
; SCHEME? is #T if the data structure is a Scheme structure, in which case
; the names defined by the form all have VM- prepended.
(define-syntax define-shared-primitive-data-type
(lambda (exp rename compare)
(let* ((name (cadr exp))
(scheme? (if (null? (cddr exp)) #f (car (cddr exp))))
(immutable? (if (or (null? (cddr exp))
(null? (cdddr exp)))
#f
(cadr (cddr exp))))
(rest (if (or (null? (cddr exp))
(null? (cdddr exp)))
'()
(cddddr exp)))
(extra-maker (if (null? rest) #f (car rest)))
(extra-setters (if (or (null? rest)
(null? (cdr rest)))
'()
(cadr rest)))
(extra-fields (if (or (null? rest)
(null? (cdr rest)))
'()
(cddr rest))))
(define (concatenate-symbol . syms)
(string->symbol (apply string-append (map symbol->string syms))))
(let ((data (cddr (assq name stob-data)))
(fixup (lambda (n)
(if scheme? (concatenate-symbol 'vm- n) n))))
`(define-primitive-data-type
,(fixup name)
,name
,immutable?
,(fixup (if (car data) (car data) extra-maker))
. ,(map (lambda (p)
(cons (fixup (car p))
(cond ((and (not (null? (cdr p)))
(cadr p))
(list (fixup (cadr p))))
((assq (car p) extra-setters)
=> cdr)
(else '()))))
(append (cdr data) extra-fields)))))))
; A d-vector macro version of the VECTOR procedure.
; This is only used in the expansion of DEFINE-PRIMITIVE-DATA-TYPE.
(define-syntax d-vector
(lambda (exp rename compare)
(destructure (((d-v type key . args) exp))
`(let ((v (make-d-vector ,type ,(length args) key)))
,@(do ((a args (cdr a))
(i 0 (+ i 1))
(z '() (cons `(d-vector-init! v ,i ,(car a)) z)))
((null? a) (reverse z)))
v))))
(define-syntax immutable-d-vector
(syntax-rules ()
((immutable-d-vector stuff ...)
(let ((vec (d-vector stuff ...)))
(make-immutable! vec)
vec))))
; A simpler macro for defining types of vectors. Again SCHEME? being #T
; causes VM- to be prepended to the defined names.
(define-syntax define-vector-data-type
(lambda (exp rename compare)
(let ((name (cadr exp))
(scheme? (cddr exp)))
(define (concatenate-symbol . syms)
(string->symbol (apply string-append (map symbol->string syms))))
(let* ((type `(enum stob ,name))
(fix (if (not (null? scheme?))
'vm-
(string->symbol "")))
(pred (concatenate-symbol fix name '?))
(make (concatenate-symbol fix 'make- name))
(size (concatenate-symbol fix name '- 'size))
(length (concatenate-symbol fix name '- 'length))
(ref (concatenate-symbol fix name '- 'ref))
(set (concatenate-symbol fix name '- 'set!)))
`(begin (define ,make (stob-maker ,type make-d-vector))
(define ,pred (stob-predicate ,type))
(define (,size len) (+ len stob-overhead))
(define ,length d-vector-length)
(define ,ref d-vector-ref)
(define ,set d-vector-set!))))))
|
