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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
|
; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
; The DEFINE-INTERFACE and DEFINE-STRUCTURE macros.
(define-syntax def
(syntax-rules ()
((def (?name . ?args) ?body ...)
(really-def () ?name (lambda ?args ?body ...)))
((def ?name ...)
(really-def () ?name ...))))
(define-syntax really-def
(syntax-rules ()
((really-def (?name ...) ?exp)
(define-multiple (?name ...)
(begin (verify-later! (lambda () ?name))
...
?exp)))
((really-def (?name ...) ?name1 ?etc ...)
(really-def (?name ... ?name1) ?etc ...))))
(define-syntax define-multiple
(syntax-rules ()
((define-multiple (?name) ?exp)
(define ?name (note-name! ?exp '?name)))
((define-multiple (?name ...) ?exp)
(begin (define ?name #f)
...
(let ((frob (lambda things
(begin (set! ?name
(note-name! (car things) '?name))
(set! things (cdr things)))
...)))
(call-with-values (lambda () ?exp) frob))))))
; Interfaces
; <definition> ::= (define-interface <name> <int>)
; <int> ::= <name> | (export <item> ...) | (compound-interface <int> ...)
(define-syntax define-interface
(syntax-rules ()
((define-interface ?name ?int)
(def ?name ?int))))
(define-syntax compound-interface
(syntax-rules ()
((compound-interface ?int ...)
(make-compound-interface #f ?int ...))))
; <item> ::= <name> | (<name> <type>) | ((<name> ...) <type>)
(define-syntax export
(lambda (e r c)
(let ((items (cdr e)))
(let loop ((items items)
(plain '())
(others '()))
(if (null? items)
`(,(r 'make-simple-interface)
#f
(,(r 'list) (,(r 'quote) ,(list (reverse plain)
':undeclared))
,@(reverse others)))
(let ((item (car items)))
(if (pair? item)
(loop (cdr items)
plain
(cons `(,(r 'list) (,(r 'quote) ,(car item))
,(cadr item))
others))
(loop (cdr items)
(cons item plain)
others)))))))
(make-simple-interface list quote value))
; Structures
(define-syntax define-structure
(syntax-rules ()
((define-structure ?name ?int ?clause1 ?clause ...)
(def ?name (structure ?int ?clause1 ?clause ...)))
;; For compatibility. Use DEF instead.
((define-structure ?name ?exp)
(def ?name ?exp))))
(define-syntax define-structures
(syntax-rules ()
((define-structures ((?name ?int) ...)
?clause ...)
(def ?name ... (structures (?int ...) ?clause ...)))))
(define-syntax structure
(syntax-rules ()
((structure ?int ?clause ...)
(structures (?int) ?clause ...))))
(define-syntax structures
(syntax-rules ()
((structures (?int ...) ?clause ...)
(let ((p (a-package #f ?clause ...)))
(values (make-structure p (lambda () ?int))
...)))))
(define-syntax modify
(syntax-rules ()
((modify ?struct ?command ...)
(make-modified-structure ?struct '(?command ...)))))
; Two handy shorthands for MODIFY.
(define-syntax subset
(syntax-rules ()
((restrict struct (name ...))
(modify struct (expose name ...)))))
(define-syntax with-prefix
(syntax-rules ()
((with-prefix struct the-prefix)
(modify struct (prefix the-prefix)))))
; Packages
(define-syntax a-package
(let ()
(define (parse-package-clauses clauses rename compare)
(let ((%open (rename 'open))
(%access (rename 'access))
(%for-syntax (rename 'for-syntax)))
(let loop ((clauses clauses)
(opens '())
(accesses '())
(for-syntaxes '())
(others '()))
(cond ((null? clauses)
(values opens accesses for-syntaxes (reverse others)))
((not (list? (car clauses)))
(display "Ignoring invalid define-structures clause")
(newline)
(write (car clauses)) (newline)
(loop (cdr clauses)
opens
accesses
for-syntaxes
others))
(else
(let ((keyword (caar clauses)))
(cond ((compare keyword %open)
(loop (cdr clauses)
(append opens (cdar clauses))
accesses
for-syntaxes
others))
((compare keyword %access)
(loop (cdr clauses)
opens
(append (cdar clauses) accesses)
for-syntaxes
others))
((compare keyword %for-syntax)
(loop (cdr clauses)
opens
accesses
(append (cdar clauses) for-syntaxes)
others))
(else
(loop (cdr clauses)
opens
accesses
for-syntaxes
(cons (car clauses) others))))))))))
(lambda (form rename compare)
(let ((names (cadr form))
(clauses (cddr form)))
(call-with-values (lambda ()
(parse-package-clauses clauses rename compare))
(lambda (opens accesses for-syntaxes others)
(let ((%make (rename 'make-a-package))
(%lambda (rename 'lambda))
(%cons (rename 'cons))
(%list (rename 'list))
(%quote (rename 'quote))
(%a-package (rename 'a-package))
(%file-name (rename '%file-name%)))
`(,%make (,%lambda () (,%list ,@opens))
(,%lambda ()
(,%list ,@(map (lambda (a)
`(,%cons (,%quote ,a) ,a))
accesses)))
(,(string->symbol ".make-reflective-tower.")
(,%quote ,for-syntaxes)
(,%quote ,names)) ; for discloser
(,%file-name)
(,%quote ,others)
(,%quote ,names))))))))
(cons lambda list make-a-package quote make-reflective-tower %file-name%))
(define-syntax receive
(syntax-rules ()
((receive (?var ...) ?producer . ?body)
(call-with-values (lambda () ?producer)
(lambda (?var ...)
(note-name! ?var '?var) ...
(let () . ?body))))))
; (DEFINE-REFLECTIVE-TOWER-MAKER <proc>)
; <proc> should be an expression that evaluates to a procedure of
; two arguments. The first argument is a list of DEFINE-STRUCTURE
; clauses, and the second is some identifying information (no
; semantic content). The procedure should return a "reflective
; tower", which is a pair (<eval-proc> . <env>). To evaluate the
; right-hand side of a DEFINE-SYNTAX (LET-SYNTAX, etc.) form,
; <eval-proc> is called on the right-hand side and <env>.
; Got that?
(define-syntax define-reflective-tower-maker
(lambda (e r c)
`(,(r 'define) ,(string->symbol ".make-reflective-tower.") ,(cadr e)))
(define))
(define-syntax export-reflective-tower-maker
(lambda (e r c)
`(,(r 'export) ,(string->symbol ".make-reflective-tower.")))
(export))
; Modules = package combinators...
(define-syntax define-module
(syntax-rules ()
((define-module (?name . ?args) ?body ...)
(def ?name (lambda ?args ?body ...)))))
|
