blob: a41a4a72a5c3801491cb6fb82cacf1925a848635 (
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
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
|
(define-library (csc macros)
(export
expand
test-environment)
(import (scheme base)
(only (csc gensym) gensym)
(only (csc hash-map)
alist->map
hash-bytevector
insert
key-not-found-error?
lookup)
(only (csc ir1)
make-call
make-constant
make-lambda
make-lambda-case)
(only (csc list) revappend)
(only (csc match) match))
(begin
(define-record-type <macro-transformer>
(make-macro-transformer transformer)
macro-transformer?
(transformer transformer-function))
(define-record-type <macro-syntax-error>
(make-macro-syntax-error message irritants)
macro-syntax-error?
(message syntax-error-object-message)
(irritants syntax-error-object-irritants))
(define (raise-syntax-error message . irritants)
(raise (make-macro-syntax-error message irritants)))
; symbols is a map with symbols as keys, and the values can be one of:
; - <lexical-ref>,
; - <module-ref>,
; - or <macro-transformer>.
; The first two correspond to variables bound lexically or from a module,
; and the third represents a macro transformer bound in the
; current context.
;
; library is the current library name being compiled. A nil library
; corresponds to top level expressions.
(define-record-type <environment>
(make-environment symbols library)
environment?
(symbols environment-symbols)
(library environment-library))
(define (with-binding environment symbol binding)
(make-environment (insert (environment-symbols environment) symbol binding) (environment-library environment)))
(define (expand-procedure-call procedure arguments environment)
(let*-values (((expanded-procedure environment) (expand procedure environment))
((expanded-arguments environment)
(let loop ((arguments arguments)
(environment environment)
(expanded-arguments '()))
(match arguments
('() (values (reverse expanded-arguments) environment))
((argument . rest)
(let-values (((expanded-argument environment) (expand argument environment)))
(loop
rest
environment
(cons expanded-argument expanded-arguments))))
(_ (raise-syntax-error "arguments to a procedure call must be a list" procedure arguments))))))
(make-call expanded-procedure expanded-arguments)))
; expand can be thought of as a compiler from Scheme to IR1. Macros
; included in the environment can be used to extend the syntax. Returns an
; IR1 expression and an environment which has been modified with any new
; bindings introduced by the expression.
(define (expand expression environment)
(cond
((null? expression) (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" expression))
((and (pair? expression)
(symbol? (car expression)))
(let* ((macro-name (car expression))
(macro-body
(guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" macro-name)))
(lookup (environment-symbols environment) macro-name))))
(if (macro-transformer? macro-body)
((transformer-function macro-body) expression environment)
(expand-procedure-call macro-name (cdr expression) environment))))
((pair? expression)
(let ((procedure (car expression))
(arguments (cdr expression)))
(expand-procedure-call procedure arguments environment)))
((symbol? expression)
(let ((binding
(guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" expression)))
(lookup (environment-symbols environment) expression))))
(if (macro-transformer? binding)
(raise-syntax-error "macro is not allowed in this context" expression)
(values binding environment))))
((or (boolean? expression)
(bytevector? expression)
(char? expression)
(number? expression)
(string? expression)
(vector? expression))
(values (make-constant expression) environment))
(else (raise-syntax-error "unexpected expression type" expression))))
(define builtin-quote
(make-macro-transformer
(lambda (expression environment)
(match expression
((_ datum) (values (make-constant datum) environment))
(_ (raise-syntax-error "invalid form for quote" expression))))))
(define builtin-lambda
(make-macro-transformer
(lambda (expression environment)
(match expression
((_ formals body)
(let loop ((formals formals)
(environment environment)
(argument-names '())
(gensyms '()))
(match formals
('()
(make-lambda
(make-lambda-case
(reverse argument-names)
#f
(reverse gensyms)
(expand body environment)
#f)))
((variable . variables) (when (symbol? variable))
(let ((sym (gensym)))
(loop
variables
(with-binding environment variable sym)
(cons variable argument-names)
(cons sym gensyms))))
(variable (when (symbol? variable))
(let ((sym (gensym)))
(make-lambda
(make-lambda-case
(reverse argument-names)
variable
(revappend gensyms (list sym))
(expand body (with-binding environment variable sym))
#f))))
(_ (raise-syntax-error "invalid form for lambda arguments" expression)))))
(_ (raise-syntax-error "invalid form for lambda" expression))))))
#;(define builtin-syntax-rules
(make-macro-transformer
(lambda (expression environment)
(match expression))))
(define (hash-symbol s)
(hash-bytevector (string->utf8 (symbol->string s))))
(define (symbol<? s1 s2)
(string<? (symbol->string s1) (symbol->string s2)))
(define test-environment
(make-environment
(alist->map
hash-symbol
symbol<?
(list
(cons 'quote builtin-quote)
(cons 'lambda builtin-lambda)))
'()))))
|
