Commit | Line | Data |
---|---|---|
d062a8c1 AW |
1 | ;;; -*- mode: scheme; coding: utf-8; -*- |
2 | ;;; | |
1624e149 | 3 | ;;; Copyright (C) 2012, 2013 Free Software Foundation, Inc. |
d062a8c1 AW |
4 | ;;; |
5 | ;;; This library is free software; you can redistribute it and/or | |
6 | ;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;; License as published by the Free Software Foundation; either | |
8 | ;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;; | |
10 | ;;; This library is distributed in the hope that it will be useful, | |
11 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;; Lesser General Public License for more details. | |
14 | ;;; | |
15 | ;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;; License along with this library; if not, write to the Free Software | |
17 | ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | (define-module (ice-9 local-eval) | |
20 | #:use-module (ice-9 format) | |
21 | #:use-module (srfi srfi-9) | |
22 | #:use-module (srfi srfi-9 gnu) | |
23 | #:use-module (system base compile) | |
24 | #:use-module (system syntax) | |
25 | #:export (the-environment local-eval local-compile)) | |
26 | ||
27 | (define-record-type lexical-environment-type | |
28 | (make-lexical-environment scope wrapper boxes patterns) | |
29 | lexical-environment? | |
30 | (scope lexenv-scope) | |
31 | (wrapper lexenv-wrapper) | |
32 | (boxes lexenv-boxes) | |
33 | (patterns lexenv-patterns)) | |
34 | ||
35 | (set-record-type-printer! | |
36 | lexical-environment-type | |
37 | (lambda (e port) | |
38 | (format port "#<lexical-environment ~S (~S bindings)>" | |
39 | (syntax-module (lexenv-scope e)) | |
40 | (+ (length (lexenv-boxes e)) (length (lexenv-patterns e)))))) | |
41 | ||
42 | (define-syntax syntax-object-of | |
43 | (lambda (form) | |
44 | (syntax-case form () | |
45 | ((_ x) #`(quote #,(datum->syntax #'x #'x)))))) | |
46 | ||
47 | (define-syntax-rule (make-box v) | |
48 | (case-lambda | |
49 | (() v) | |
50 | ((x) (set! v x)))) | |
51 | ||
52 | (define (make-transformer-from-box id trans) | |
53 | (set-procedure-property! trans 'identifier-syntax-box id) | |
54 | trans) | |
55 | ||
56 | (define-syntax-rule (identifier-syntax-from-box box) | |
57 | (make-transformer-from-box | |
58 | (syntax-object-of box) | |
59 | (identifier-syntax (id (box)) | |
60 | ((set! id x) (box x))))) | |
61 | ||
62 | (define (unsupported-binding name) | |
63 | (make-variable-transformer | |
64 | (lambda (x) | |
65 | (syntax-violation | |
66 | 'local-eval | |
67 | "unsupported binding captured by (the-environment)" | |
68 | x)))) | |
69 | ||
70 | (define (within-nested-ellipses id lvl) | |
71 | (let loop ((s id) (n lvl)) | |
72 | (if (zero? n) | |
73 | s | |
74 | (loop #`(#,s (... ...)) (- n 1))))) | |
75 | ||
76 | ;; Analyze the set of bound identifiers IDS. Return four values: | |
77 | ;; | |
78 | ;; capture: A list of forms that will be emitted in the expansion of | |
79 | ;; `the-environment' to capture lexical variables. | |
80 | ;; | |
81 | ;; formals: Corresponding formal parameters for use in the lambda that | |
82 | ;; re-introduces those variables. These are temporary identifiers, and | |
83 | ;; as such if we have a nested `the-environment', there is no need to | |
84 | ;; capture them. (See the notes on nested `the-environment' and | |
85 | ;; proxies, below.) | |
86 | ;; | |
87 | ;; wrappers: A list of procedures of type SYNTAX -> SYNTAX, used to wrap | |
88 | ;; the expression to be evaluated in forms that re-introduce the | |
89 | ;; variable. The forms will be nested so that the variable shadowing | |
90 | ;; semantics of the original form are maintained. | |
91 | ;; | |
92 | ;; patterns: A terrible hack. The issue is that for pattern variables, | |
93 | ;; we can't emit lexically nested with-syntax forms, like: | |
94 | ;; | |
95 | ;; (with-syntax ((foo 1)) (the-environment)) | |
96 | ;; => (with-syntax ((foo 1)) | |
97 | ;; ... #'(with-syntax ((foo ...)) ... exp) ...) | |
98 | ;; | |
99 | ;; The reason is that the outer "foo" substitutes into the inner "foo", | |
100 | ;; yielding something like: | |
101 | ;; | |
102 | ;; (with-syntax ((foo 1)) | |
103 | ;; ... (with-syntax ((1 ...)) ...) | |
104 | ;; | |
105 | ;; Which ain't what we want. So we hide the information needed to | |
106 | ;; re-make the inner pattern binding form in the lexical environment | |
107 | ;; object, and then introduce those identifiers via another with-syntax. | |
108 | ;; | |
109 | ;; | |
110 | ;; There are four different kinds of lexical bindings: normal lexicals, | |
111 | ;; macros, displaced lexicals, and pattern variables. See the | |
112 | ;; documentation of syntax-local-binding for more info on these. | |
113 | ;; | |
114 | ;; We capture normal lexicals via `make-box', which creates a | |
115 | ;; case-lambda that can reference or set a variable. These get | |
116 | ;; re-introduced with an identifier-syntax. | |
117 | ;; | |
118 | ;; We can't capture macros currently. However we do recognize our own | |
119 | ;; macros that are actually proxying lexicals, so that nested | |
120 | ;; `the-environment' forms are possible. In that case we drill down to | |
121 | ;; the identifier for the already-existing box, and just capture that | |
122 | ;; box. | |
123 | ;; | |
124 | ;; And that's it: we skip displaced lexicals, and the pattern variables | |
125 | ;; are discussed above. | |
126 | ;; | |
127 | (define (analyze-identifiers ids) | |
128 | (define (mktmp) | |
129 | (datum->syntax #'here (gensym "t "))) | |
130 | (let lp ((ids ids) (capture '()) (formals '()) (wrappers '()) (patterns '())) | |
131 | (cond | |
132 | ((null? ids) | |
133 | (values capture formals wrappers patterns)) | |
134 | (else | |
135 | (let ((id (car ids)) (ids (cdr ids))) | |
136 | (call-with-values (lambda () (syntax-local-binding id)) | |
137 | (lambda (type val) | |
138 | (case type | |
139 | ((lexical) | |
140 | (if (or-map (lambda (x) (bound-identifier=? x id)) formals) | |
141 | (lp ids capture formals wrappers patterns) | |
142 | (let ((t (mktmp))) | |
143 | (lp ids | |
144 | (cons #`(make-box #,id) capture) | |
145 | (cons t formals) | |
146 | (cons (lambda (x) | |
147 | #`(let-syntax ((#,id (identifier-syntax-from-box #,t))) | |
148 | #,x)) | |
149 | wrappers) | |
150 | patterns)))) | |
151 | ((displaced-lexical) | |
152 | (lp ids capture formals wrappers patterns)) | |
153 | ((macro) | |
154 | (let ((b (procedure-property val 'identifier-syntax-box))) | |
155 | (if b | |
156 | (lp ids (cons b capture) (cons b formals) | |
157 | (cons (lambda (x) | |
158 | #`(let-syntax ((#,id (identifier-syntax-from-box #,b))) | |
159 | #,x)) | |
160 | wrappers) | |
161 | patterns) | |
162 | (lp ids capture formals | |
163 | (cons (lambda (x) | |
164 | #`(let-syntax ((#,id (unsupported-binding '#,id))) | |
165 | #,x)) | |
166 | wrappers) | |
167 | patterns)))) | |
168 | ((pattern-variable) | |
169 | (let ((t (datum->syntax id (gensym "p "))) | |
170 | (nested (within-nested-ellipses id (cdr val)))) | |
171 | (lp ids capture formals | |
172 | (cons (lambda (x) | |
173 | #`(with-syntax ((#,t '#,nested)) | |
174 | #,x)) | |
175 | wrappers) | |
176 | ;; This dance is to hide these pattern variables | |
177 | ;; from the expander. | |
178 | (cons (list (datum->syntax #'here (syntax->datum id)) | |
179 | (cdr val) | |
180 | t) | |
181 | patterns)))) | |
1624e149 MW |
182 | ((ellipsis) |
183 | (lp ids capture formals | |
184 | (cons (lambda (x) | |
185 | #`(with-ellipsis #,val #,x)) | |
186 | wrappers) | |
187 | patterns)) | |
d062a8c1 | 188 | (else |
3bf3d735 AW |
189 | ;; Interestingly, this case can include globals (and |
190 | ;; global macros), now that Guile tracks which globals it | |
191 | ;; introduces. Not sure what to do here! For now, punt. | |
192 | ;; | |
193 | (lp ids capture formals wrappers patterns)))))))))) | |
d062a8c1 AW |
194 | |
195 | (define-syntax the-environment | |
196 | (lambda (x) | |
197 | (syntax-case x () | |
198 | ((the-environment) | |
199 | #'(the-environment the-environment)) | |
200 | ((the-environment scope) | |
201 | (call-with-values (lambda () | |
202 | (analyze-identifiers | |
203 | (syntax-locally-bound-identifiers #'scope))) | |
204 | (lambda (capture formals wrappers patterns) | |
205 | (define (wrap-expression x) | |
206 | (let lp ((x x) (wrappers wrappers)) | |
207 | (if (null? wrappers) | |
208 | x | |
209 | (lp ((car wrappers) x) (cdr wrappers))))) | |
210 | (with-syntax (((f ...) formals) | |
211 | ((c ...) capture) | |
212 | (((pname plvl pformal) ...) patterns) | |
213 | (wrapped (wrap-expression #'(begin #f exp)))) | |
214 | #'(make-lexical-environment | |
215 | #'scope | |
216 | (lambda (exp pformal ...) | |
217 | (with-syntax ((exp exp) | |
218 | (pformal pformal) | |
219 | ...) | |
220 | #'(lambda (f ...) | |
221 | wrapped))) | |
222 | (list c ...) | |
223 | (list (list 'pname plvl #'pformal) ...))))))))) | |
224 | ||
225 | (define (env-module e) | |
226 | (cond | |
227 | ((lexical-environment? e) (resolve-module (syntax-module (lexenv-scope e)))) | |
228 | ((module? e) e) | |
229 | (else (error "invalid lexical environment" e)))) | |
230 | ||
231 | (define (env-boxes e) | |
232 | (cond | |
233 | ((lexical-environment? e) (lexenv-boxes e)) | |
234 | ((module? e) '()) | |
235 | (else (error "invalid lexical environment" e)))) | |
236 | ||
237 | (define (local-wrap x e) | |
238 | (cond | |
239 | ((lexical-environment? e) | |
240 | (apply (lexenv-wrapper e) | |
241 | (datum->syntax (lexenv-scope e) x) | |
242 | (map (lambda (l) | |
243 | (let ((name (car l)) | |
244 | (lvl (cadr l)) | |
245 | (scope (caddr l))) | |
246 | (within-nested-ellipses (datum->syntax scope name) lvl))) | |
247 | (lexenv-patterns e)))) | |
2f3e4364 | 248 | ((module? e) #`(lambda () #f #,x)) |
d062a8c1 AW |
249 | (else (error "invalid lexical environment" e)))) |
250 | ||
251 | (define (local-eval x e) | |
252 | "Evaluate the expression @var{x} within the lexical environment @var{e}." | |
253 | (apply (eval (local-wrap x e) (env-module e)) | |
254 | (env-boxes e))) | |
255 | ||
256 | (define* (local-compile x e #:key (opts '())) | |
257 | "Compile and evaluate the expression @var{x} within the lexical | |
258 | environment @var{e}." | |
259 | (apply (compile (local-wrap x e) #:env (env-module e) | |
260 | #:from 'scheme #:opts opts) | |
261 | (env-boxes e))) |