1 |
|
;;;-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*- |
2 |
|
;;; |
3 |
|
;;; ************************************************************************* |
4 |
|
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. |
5 |
|
;;; All rights reserved. |
6 |
|
;;; |
7 |
|
;;; Use and copying of this software and preparation of derivative works |
8 |
|
;;; based upon this software are permitted. Any distribution of this |
9 |
|
;;; software or derivative works must comply with all applicable United |
10 |
|
;;; States export control laws. |
11 |
|
;;; |
12 |
|
;;; This software is made available AS IS, and Xerox Corporation makes no |
13 |
|
;;; warranty about the software, its performance or its conformity to any |
14 |
|
;;; specification. |
15 |
|
;;; |
16 |
|
;;; Any person obtaining a copy of this software is requested to send their |
17 |
|
;;; name and post office or electronic mail address to: |
18 |
|
;;; CommonLoops Coordinator |
19 |
|
;;; Xerox PARC |
20 |
|
;;; 3333 Coyote Hill Rd. |
21 |
|
;;; Palo Alto, CA 94304 |
22 |
|
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) |
23 |
|
;;; |
24 |
|
;;; Suggestions, comments and requests for improvements are also welcome. |
25 |
|
;;; ************************************************************************* |
26 |
|
;;; |
27 |
|
;;; A simple code walker, based IN PART on: (roll the credits) |
28 |
|
;;; Larry Masinter's Masterscope |
29 |
|
;;; Moon's Common Lisp code walker |
30 |
|
;;; Gary Drescher's code walker |
31 |
|
;;; Larry Masinter's simple code walker |
32 |
|
;;; . |
33 |
|
;;; . |
34 |
|
;;; boy, thats fair (I hope). |
35 |
|
;;; |
36 |
|
;;; For now at least, this code walker really only does what PCL needs it to |
37 |
|
;;; do. Maybe it will grow up someday. |
38 |
|
;;; |
39 |
|
|
40 |
|
;;; |
41 |
|
;;; This code walker used to be completely portable. Now it is just "Real |
42 |
|
;;; easy to port". This change had to happen because the hack that made it |
43 |
|
;;; completely portable kept breaking in different releases of different |
44 |
|
;;; Common Lisps, and in addition it never worked entirely anyways. So, |
45 |
|
;;; its now easy to port. To port this walker, all you have to write is one |
46 |
|
;;; simple macro and two simple functions. These macros and functions are |
47 |
|
;;; used by the walker to manipluate the macroexpansion environments of |
48 |
|
;;; the Common Lisp it is running in. |
49 |
|
;;; |
50 |
|
;;; The code which implements the macroexpansion environment manipulation |
51 |
|
;;; mechanisms is in the first part of the file, the real walker follows it. |
52 |
|
;;; |
53 |
|
|
54 |
|
(in-package :walker) |
55 |
|
|
56 |
|
;;; |
57 |
|
;;; The user entry points are walk-form and nested-walked-form. In addition, |
58 |
|
;;; it is legal for user code to call the variable information functions: |
59 |
|
;;; variable-lexical-p, variable-special-p and variable-class. Some users |
60 |
|
;;; will need to call define-walker-template, they will have to figure that |
61 |
|
;;; out for themselves. |
62 |
|
;;; |
63 |
|
(export '(define-walker-template |
64 |
|
walk-form |
65 |
|
walk-form-expand-macros-p |
66 |
|
nested-walk-form |
67 |
|
variable-lexical-p |
68 |
|
variable-special-p |
69 |
|
variable-globally-special-p |
70 |
|
*variable-declarations* |
71 |
|
variable-declaration |
72 |
|
macroexpand-all |
73 |
|
)) |
74 |
|
|
75 |
|
|
76 |
|
|
77 |
|
;;; |
78 |
|
;;; On the following pages are implementations of the implementation specific |
79 |
|
;;; environment hacking functions for each of the implementations this walker |
80 |
|
;;; has been ported to. If you add a new one, so this walker can run in a new |
81 |
|
;;; implementation of Common Lisp, please send the changes back to us so that |
82 |
|
;;; others can also use this walker in that implementation of Common Lisp. |
83 |
|
;;; |
84 |
|
;;; This code just hacks 'macroexpansion environments'. That is, it is only |
85 |
|
;;; concerned with the function binding of symbols in the environment. The |
86 |
|
;;; walker needs to be able to tell if the symbol names a lexical macro or |
87 |
|
;;; function, and it needs to be able to build environments which contain |
88 |
|
;;; lexical macro or function bindings. It must be able, when walking a |
89 |
|
;;; macrolet, flet or labels form to construct an environment which reflects |
90 |
|
;;; the bindings created by that form. Note that the environment created |
91 |
|
;;; does NOT have to be sufficient to evaluate the body, merely to walk its |
92 |
|
;;; body. This means that definitions do not have to be supplied for lexical |
93 |
|
;;; functions, only the fact that that function is bound is important. For |
94 |
|
;;; macros, the macroexpansion function must be supplied. |
95 |
|
;;; |
96 |
|
;;; This code is organized in a way that lets it work in implementations that |
97 |
|
;;; stack cons their environments. That is reflected in the fact that the |
98 |
|
;;; only operation that lets a user build a new environment is a with-body |
99 |
|
;;; macro which executes its body with the specified symbol bound to the new |
100 |
|
;;; environment. No code in this walker or in PCL will hold a pointer to |
101 |
|
;;; these environments after the body returns. Other user code is free to do |
102 |
|
;;; so in implementations where it works, but that code is not considered |
103 |
|
;;; portable. |
104 |
|
;;; |
105 |
|
;;; There are 3 environment hacking tools. One macro which is used for |
106 |
|
;;; creating new environments, and two functions which are used to access the |
107 |
|
;;; bindings of existing environments. |
108 |
|
;;; |
109 |
|
;;; WITH-AUGMENTED-ENVIRONMENT |
110 |
|
;;; |
111 |
|
;;; ENVIRONMENT-FUNCTION |
112 |
|
;;; |
113 |
|
;;; ENVIRONMENT-MACRO |
114 |
|
;;; |
115 |
|
|
116 |
|
(defun unbound-lexical-function (&rest args) |
117 |
|
(declare (ignore args)) |
118 |
|
(error "The evaluator was called to evaluate a form in a macroexpansion~%~ |
119 |
|
environment constructed by the PCL portable code walker. These~%~ |
120 |
|
environments are only useful for macroexpansion, they cannot be~%~ |
121 |
|
used for evaluation.~%~ |
122 |
|
This error should never occur when using PCL.~%~ |
123 |
|
This most likely source of this error is a program which tries to~%~ |
124 |
|
to use the PCL portable code walker to build its own evaluator.")) |
125 |
|
|
126 |
|
|
127 |
|
;;; |
128 |
|
;;; In Coral Common Lisp, the macroexpansion environment is just a list |
129 |
|
;;; of environment entries. The cadr of each element specifies the type |
130 |
|
;;; of the element. The only types that interest us are CCL::MACRO and |
131 |
|
;;; FUNCTION. In these cases the element is interpreted as follows. |
132 |
|
;;; |
133 |
|
;;; (<function-name> CCL::MACRO . macroexpansion-function) |
134 |
|
;;; |
135 |
|
;;; (<function-name> FUNCTION . <fn>) |
136 |
|
;;; |
137 |
|
;;; When in the compiler, <fn> is a gensym which will be |
138 |
|
;;; a variable which bound at run-time to the function. |
139 |
|
;;; When in the interpreter, <fn> is the actual function. |
140 |
|
;;; |
141 |
|
;;; |
142 |
|
#+:Coral |
143 |
|
(progn |
144 |
|
|
145 |
|
(defmacro with-augmented-environment |
146 |
|
((new-env old-env &key functions macros) &body body) |
147 |
|
`(let ((,new-env (with-augmented-environment-internal ,old-env |
148 |
|
,functions |
149 |
|
,macros))) |
150 |
|
,@body)) |
151 |
|
|
152 |
|
(defun with-augmented-environment-internal (env functions macros) |
153 |
|
(dolist (f functions) |
154 |
|
(push (list* f 'function (gensym)) env)) |
155 |
|
(dolist (m macros) |
156 |
|
(push (list* (car m) 'ccl::macro (cadr m)) env)) |
157 |
|
env) |
158 |
|
|
159 |
|
(defun environment-function (env fn) |
160 |
|
(let ((entry (assoc fn env :test #'equal))) |
161 |
|
(and entry |
162 |
|
(eq (cadr entry) 'function) |
163 |
|
(cddr entry)))) |
164 |
|
|
165 |
|
(defun environment-macro (env macro) |
166 |
|
(let ((entry (assoc macro env :test #'equal))) |
167 |
|
(and entry |
168 |
|
(eq (cadr entry) 'ccl::macro) |
169 |
|
(cddr entry)))) |
170 |
|
|
171 |
|
);#+:Coral |
172 |
|
|
173 |
|
|
174 |
|
;;; |
175 |
|
;;; Franz Common Lisp is a lot like Coral Lisp. The macroexpansion |
176 |
|
;;; environment is just a list of entries. The cadr of each element |
177 |
|
;;; specifies the type of the element. The types that interest us |
178 |
|
;;; are FUNCTION, EXCL::MACRO, and COMPILER::FUNCTION-VALUE. These |
179 |
|
;;; are interpreted as follows: |
180 |
|
;;; |
181 |
|
;;; (<function-name> FUNCTION . <a lexical closure>) |
182 |
|
;;; |
183 |
|
;;; This happens in the interpreter with lexically |
184 |
|
;;; bound functions. |
185 |
|
;;; |
186 |
|
;;; (<function-name> COMPILER::FUNCTION-VALUE . <gensym>) |
187 |
|
;;; |
188 |
|
;;; This happens in the compiler. The gensym represents |
189 |
|
;;; a variable which will be bound at run time to the |
190 |
|
;;; function object. |
191 |
|
;;; |
192 |
|
;;; (<function-name> EXCL::MACRO . <a lambda>) |
193 |
|
;;; |
194 |
|
;;; In both interpreter and compiler, this is the |
195 |
|
;;; representation used for macro definitions. |
196 |
|
;;; |
197 |
|
;;; |
198 |
|
#+:ExCL |
199 |
|
(progn |
200 |
|
|
201 |
|
(defmacro with-augmented-environment |
202 |
|
((new-env old-env &key functions macros) &body body) |
203 |
|
`(let ((,new-env (with-augmented-environment-internal ,old-env |
204 |
|
,functions |
205 |
|
,macros))) |
206 |
|
,@body)) |
207 |
|
|
208 |
|
(defun with-augmented-environment-internal (env functions macros) |
209 |
|
(let (#+allegro-v4.1 (env-tail (cdr env)) #+allegro-v4.1 (env (car env))) |
210 |
|
(dolist (f functions) |
211 |
|
(push (list* f 'function #'unbound-lexical-function) env)) |
212 |
|
(dolist (m macros) |
213 |
|
(push (list* (car m) 'excl::macro (cadr m)) env)) |
214 |
|
#-allegro-v4.1 env #+allegro-v4.1 (cons env env-tail))) |
215 |
|
|
216 |
|
(defun environment-function (env fn) |
217 |
|
(let* (#+allegro-v4.1 (env (car env)) |
218 |
|
(entry (assoc fn env :test #'equal))) |
219 |
|
(and entry |
220 |
|
(or (eq (cadr entry) 'function) |
221 |
|
(eq (cadr entry) 'compiler::function-value)) |
222 |
|
(cddr entry)))) |
223 |
|
|
224 |
|
(defun environment-macro (env macro) |
225 |
|
(let* (#+allegro-v4.1 (env (car env)) |
226 |
|
(entry (assoc macro env :test #'equal))) |
227 |
|
(and entry |
228 |
|
(eq (cadr entry) 'excl::macro) |
229 |
|
(cddr entry)))) |
230 |
|
|
231 |
|
);#+:ExCL |
232 |
|
|
233 |
|
|
234 |
|
#+Lucid |
235 |
|
(progn |
236 |
|
|
237 |
|
(proclaim '(inline |
238 |
|
%alphalex-p |
239 |
|
add-contour-to-env-shape |
240 |
|
make-function-variable |
241 |
|
make-sfc-contour |
242 |
|
sfc-contour-type |
243 |
|
sfc-contour-elements |
244 |
|
add-sfc-contour |
245 |
|
add-function-contour |
246 |
|
add-macrolet-contour |
247 |
|
find-variable-in-contour |
248 |
|
find-alist-element-in-contour |
249 |
|
find-macrolet-in-contour)) |
250 |
|
|
251 |
|
(defun %alphalex-p (object) |
252 |
|
#-Prime |
253 |
|
(eq (cadddr (cddddr object)) 'lucid::%alphalex) |
254 |
|
#+Prime |
255 |
|
(eq (caddr (cddddr object)) 'lucid::%alphalex)) |
256 |
|
|
257 |
|
#+Prime |
258 |
|
(defun lucid::augment-lexenv-fvars-dummy (lexical vars) |
259 |
|
(lucid::augment-lexenv-fvars-aux lexical vars '() '() 'flet '())) |
260 |
|
|
261 |
|
#-lcl4.0 ; Maybe this should be #-lcl4.1 |
262 |
|
(progn |
263 |
|
(defconstant function-contour 1) |
264 |
|
(defconstant macrolet-contour 5)) |
265 |
|
#+lcl4.0 ; Maybe this should be #+lcl4.1 |
266 |
|
(progn |
267 |
|
(defconstant function-contour 2) |
268 |
|
(defconstant macrolet-contour 6)) |
269 |
|
|
270 |
|
(defstruct lucid::contour |
271 |
|
type |
272 |
|
elements) |
273 |
|
|
274 |
|
(defun add-contour-to-env-shape (contour-type elements env-shape) |
275 |
|
(cons (make-contour :type contour-type |
276 |
|
:elements elements) |
277 |
|
env-shape)) |
278 |
|
|
279 |
|
(defstruct (variable (:constructor make-variable (name source-type))) |
280 |
|
name |
281 |
|
(identifier nil) |
282 |
|
source-type) |
283 |
|
|
284 |
|
(defconstant function-sfc-contour 1) |
285 |
|
(defconstant macrolet-sfc-contour 8) |
286 |
|
(defconstant function-variable-type 1) |
287 |
|
|
288 |
|
(defun make-function-variable (name) |
289 |
|
(make-variable name function-variable-type)) |
290 |
|
|
291 |
|
(defun make-sfc-contour (type elements) |
292 |
|
(cons type elements)) |
293 |
|
|
294 |
|
(defun sfc-contour-type (sfc-contour) |
295 |
|
(car sfc-contour)) |
296 |
|
|
297 |
|
(defun sfc-contour-elements (sfc-contour) |
298 |
|
(cdr sfc-contour)) |
299 |
|
|
300 |
|
(defun add-sfc-contour (element-list environment type) |
301 |
|
(cons (make-sfc-contour type element-list) environment)) |
302 |
|
|
303 |
|
(defun add-function-contour (variable-list environment) |
304 |
|
(add-sfc-contour variable-list environment function-sfc-contour)) |
305 |
|
|
306 |
|
(defun add-macrolet-contour (alist environment) |
307 |
|
(add-sfc-contour alist environment macrolet-sfc-contour)) |
308 |
|
|
309 |
|
(defun find-variable-in-contour (name contour) |
310 |
|
(dolist (element (sfc-contour-elements contour) nil) |
311 |
|
(when (eq (variable-name element) name) |
312 |
|
(return element)))) |
313 |
|
|
314 |
|
(defun find-alist-element-in-contour (name contour) |
315 |
|
(cdr (assoc name (sfc-contour-elements contour)))) |
316 |
|
|
317 |
|
(defun find-macrolet-in-contour (name contour) |
318 |
|
(find-alist-element-in-contour name contour)) |
319 |
|
|
320 |
|
(defmacro do-sfc-contours ((contour-var environment &optional result) |
321 |
|
&body body) |
322 |
|
`(dolist (,contour-var ,environment ,result) ,@body)) |
323 |
|
|
324 |
|
|
325 |
|
(defmacro with-augmented-environment |
326 |
|
((new-env old-env &key functions macros) &body body) |
327 |
|
`(let* ((,new-env (with-augmented-environment-internal ,old-env |
328 |
|
,functions |
329 |
|
,macros))) |
330 |
|
,@body)) |
331 |
|
|
332 |
|
;;; |
333 |
|
;;; with-augmented-environment-internal is where the real work of augmenting |
334 |
|
;;; the environment happens. |
335 |
|
;;; |
336 |
|
(defun with-augmented-environment-internal (env functions macros) |
337 |
|
(let ((function-names (mapcar #'first functions)) |
338 |
|
(macro-names (mapcar #'first macros)) |
339 |
|
(macro-functions (mapcar #'second macros))) |
340 |
|
(cond ((or (null env) |
341 |
|
(contour-p (first env))) |
342 |
|
(when function-names |
343 |
|
(setq env (add-contour-to-env-shape function-contour |
344 |
|
function-names |
345 |
|
env))) |
346 |
|
(when macro-names |
347 |
|
(setq env (add-contour-to-env-shape macrolet-contour |
348 |
|
(pairlis macro-names |
349 |
|
macro-functions) |
350 |
|
env)))) |
351 |
|
((%alphalex-p env) |
352 |
|
(when function-names |
353 |
|
(setq env (lucid::augment-lexenv-fvars-dummy env function-names))) |
354 |
|
(when macro-names |
355 |
|
(setq env (lucid::augment-lexenv-mvars env |
356 |
|
macro-names |
357 |
|
macro-functions)))) |
358 |
|
(t |
359 |
|
(when function-names |
360 |
|
(setq env (add-function-contour |
361 |
|
(mapcar #'make-function-variable function-names) |
362 |
|
env))) |
363 |
|
(when macro-names |
364 |
|
(setq env (add-macrolet-contour |
365 |
|
(pairlis macro-names macro-functions) |
366 |
|
env))))) |
367 |
|
env)) |
368 |
|
|
369 |
|
|
370 |
|
(defun environment-function (env fn) |
371 |
|
(cond ((null env) nil) |
372 |
|
((contour-p (first env)) |
373 |
|
(if (lucid::find-lexical-function fn env) |
374 |
|
t |
375 |
|
nil)) |
376 |
|
((%alphalex-p env) |
377 |
|
(if (lucid::lexenv-fvar fn env) |
378 |
|
t |
379 |
|
nil)) |
380 |
|
(t (do-sfc-contours (contour env nil) |
381 |
|
(let ((type (sfc-contour-type contour))) |
382 |
|
(cond ((eql type function-sfc-contour) |
383 |
|
(when (find-variable-in-contour fn contour) |
384 |
|
(return t))) |
385 |
|
((eql type macrolet-sfc-contour) |
386 |
|
(when (find-macrolet-in-contour fn contour) |
387 |
|
(return nil))))))))) |
388 |
|
|
389 |
|
(defun environment-macro (env macro) |
390 |
|
(cond ((null env) nil) |
391 |
|
((contour-p (first env)) |
392 |
|
(lucid::find-lexical-macro macro env)) |
393 |
|
((%alphalex-p env) |
394 |
|
(lucid::lexenv-mvar macro env)) |
395 |
|
(t (do-sfc-contours (contour env nil) |
396 |
|
(let ((type (sfc-contour-type contour))) |
397 |
|
(cond ((eql type function-sfc-contour) |
398 |
|
(when (find-variable-in-contour macro contour) |
399 |
|
(return nil))) |
400 |
|
((eql type macrolet-sfc-contour) |
401 |
|
(let ((fn (find-macrolet-in-contour macro contour))) |
402 |
|
(when fn |
403 |
|
(return fn)))))))))) |
404 |
|
|
405 |
|
|
406 |
|
);#+Lucid |
407 |
|
|
408 |
|
|
409 |
|
|
410 |
|
;;; |
411 |
|
;;; On the 3600, the documentation for how the environments are represented |
412 |
|
;;; is in sys:sys;eval.lisp. That total information is not repeated here. |
413 |
|
;;; The important points are that: |
414 |
|
;;; si:env-variables returns a list of which each element is: |
415 |
|
;;; |
416 |
|
;;; (symbol value) |
417 |
|
;;; or (symbol . locative) |
418 |
|
;;; |
419 |
|
;;; The first form is for lexical variables, the second for |
420 |
|
;;; special and instance variables. In either case CADR of |
421 |
|
;;; the entry is the value and SETF of CADR is used to change |
422 |
|
;;; the value. Variables are looked up with ASSQ. |
423 |
|
;;; |
424 |
|
;;; si:env-functions returns a list of which each element is: |
425 |
|
;;; |
426 |
|
;;; (symbol definition) |
427 |
|
;;; |
428 |
|
;;; where definition is anything that could go in a function cell. |
429 |
|
;;; This is used for both local functions and local macros. |
430 |
|
;;; |
431 |
|
;;; The 3600 stack conses its environments (at least in the interpreter). |
432 |
|
;;; This means that code written using this walker and running on the 3600 |
433 |
|
;;; must not hold on to the environment after the walk-function returns. |
434 |
|
;;; No code in this walker or in PCL does that. |
435 |
|
;;; |
436 |
|
#+Genera |
437 |
|
(progn |
438 |
|
|
439 |
|
(defmacro with-augmented-environment |
440 |
|
((new-env old-env &key functions macros) &body body) |
441 |
|
(let ((funs (make-symbol "FNS")) |
442 |
|
(macs (make-symbol "MACROS")) |
443 |
|
(new (make-symbol "NEW"))) |
444 |
|
`(let ((,funs ,functions) |
445 |
|
(,macs ,macros) |
446 |
|
(,new ())) |
447 |
|
(dolist (f ,funs) |
448 |
|
(push `(,(car f) ,#'unbound-lexical-function) ,new)) |
449 |
|
(dolist (m ,macs) |
450 |
|
(push `(,(car m) (special ,(cadr m))) ,new)) |
451 |
|
(let* ((.old-env. ,old-env) |
452 |
|
(.old-vars. (pop .old-env.)) |
453 |
|
(.old-funs. (pop .old-env.)) |
454 |
|
(.old-blks. (pop .old-env.)) |
455 |
|
(.old-tags. (pop .old-env.)) |
456 |
|
(.old-dcls. (pop .old-env.))) |
457 |
|
(si:with-interpreter-environment (,new-env |
458 |
|
.old-env. |
459 |
|
.old-vars. |
460 |
|
(append ,new .old-funs.) |
461 |
|
.old-blks. |
462 |
|
.old-tags. |
463 |
|
.old-dcls.) |
464 |
|
,@body))))) |
465 |
|
|
466 |
|
|
467 |
|
(defun environment-function (env fn) |
468 |
|
(if (null env) |
469 |
|
(values nil nil) |
470 |
|
(let ((entry (assoc fn (si:env-functions env) :test #'equal))) |
471 |
|
(if (and entry |
472 |
|
(or (not (listp (cadr entry))) |
473 |
|
(not (eq (caadr entry) 'special)))) |
474 |
|
(values (cadr entry) t) |
475 |
|
(environment-function (si:env-parent env) fn))))) |
476 |
|
|
477 |
|
(defun environment-macro (env macro) |
478 |
|
(if (null env) |
479 |
|
(values nil nil) |
480 |
|
(let ((entry (assoc macro (si:env-functions env) :test #'equal))) |
481 |
|
(if (and entry |
482 |
|
(listp (cadr entry)) |
483 |
|
(eq (caadr entry) 'special)) |
484 |
|
(values (cadadr entry) t) |
485 |
|
(environment-macro (si:env-parent env) macro))))) |
486 |
|
|
487 |
|
);#+Genera |
488 |
|
|
489 |
|
#+Cloe-Runtime |
490 |
|
(progn |
491 |
|
|
492 |
|
(defmacro with-augmented-environment |
493 |
|
((new-env old-env &key functions macros) &body body) |
494 |
|
`(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) |
495 |
|
,@body)) |
496 |
|
|
497 |
|
(defun with-augmented-environment-internal (env functions macros) |
498 |
|
functions |
499 |
|
(dolist (m macros) |
500 |
|
(setf env `(,(first m) (compiler::macro . ,(second m)) ,@env))) |
501 |
|
env) |
502 |
|
|
503 |
|
(defun environment-function (env fn) |
504 |
|
nil) |
505 |
|
|
506 |
|
(defun environment-macro (env macro) |
507 |
|
(let ((entry (getf env macro))) |
508 |
|
(if (and (consp entry) |
509 |
|
(eq (car entry) 'compiler::macro)) |
510 |
|
(values (cdr entry) t) |
511 |
|
(values nil nil)))) |
512 |
|
|
513 |
|
);#+Cloe-Runtime |
514 |
|
|
515 |
|
|
516 |
|
;;; |
517 |
|
;;; In Xerox Lisp, the compiler and interpreter use different structures for |
518 |
|
;;; the environment. This doesn't cause a serious problem, the parts of the |
519 |
|
;;; environments we are concerned with are fairly similar. |
520 |
|
;;; |
521 |
|
#+:Xerox |
522 |
|
(progn |
523 |
|
|
524 |
|
(defmacro with-augmented-environment |
525 |
|
((new-env old-env &key functions macros) &body body) |
526 |
|
`(let* ((,new-env (with-augmented-environment-internal ,old-env |
527 |
|
,functions |
528 |
|
,macros))) |
529 |
|
,@body)) |
530 |
|
|
531 |
|
;;; |
532 |
|
;;; with-augmented-environment-internal is where the real work of augmenting |
533 |
|
;;; the environment happens. Before it gets there, env had better not be NIL |
534 |
|
;;; anymore because we have to know what kind of environment we are supposed |
535 |
|
;;; to be building up. This is probably never a real concern in practice. |
536 |
|
;;; It better not be because we don't do anything about it. |
537 |
|
;;; |
538 |
|
(defun with-augmented-environment-internal (env functions macros) |
539 |
|
(cond |
540 |
|
((compiler::env-p env) |
541 |
|
(dolist (f functions) |
542 |
|
(setq env (compiler::copy-env-with-function |
543 |
|
env f :function))) |
544 |
|
(dolist (m macros) |
545 |
|
(setq env (compiler::copy-env-with-function |
546 |
|
env (car m) :macro (cadr m))))) |
547 |
|
(t (setq env (if (il:environment-p env) |
548 |
|
(il:\\copy-environment env) |
549 |
|
(il:\\make-environment))) |
550 |
|
;; The functions field of the environment is a plist of function names |
551 |
|
;; and conses like (:function . fn) or (:macro . expansion-fn). |
552 |
|
;; Note that we can't smash existing entries in this plist since these |
553 |
|
;; are likely shared with older environments. |
554 |
|
(dolist (f functions) |
555 |
|
(setf (il:environment-functions env) |
556 |
|
(list* f (cons :function #'unbound-lexical-function) |
557 |
|
(il:environment-functions env)))) |
558 |
|
(dolist (m macros) |
559 |
|
(setf (il:environment-functions env) |
560 |
|
(list* (car m) (cons :macro (cadr m)) |
561 |
|
(il:environment-functions env)))))) |
562 |
|
env) |
563 |
|
|
564 |
|
(defun environment-function (env fn) |
565 |
|
(cond ((compiler::env-p env) (eq (compiler:env-fboundp env fn) :function)) |
566 |
|
((il:environment-p env) (eq (getf (il:environment-functions env) fn) |
567 |
|
:function)) |
568 |
|
(t nil))) |
569 |
|
|
570 |
|
(defun environment-macro (env macro) |
571 |
|
(cond ((compiler::env-p env) |
572 |
|
(multiple-value-bind (type def) |
573 |
|
(compiler:env-fboundp env macro) |
574 |
|
(when (eq type :macro) def))) |
575 |
|
((il:environment-p env) |
576 |
|
(xcl:destructuring-bind (type . def) |
577 |
|
(getf (il:environment-functions env) macro) |
578 |
|
(when (eq type :macro) def))) |
579 |
|
(t nil))) |
580 |
|
|
581 |
|
);#+:Xerox |
582 |
|
|
583 |
|
|
584 |
|
;;; |
585 |
|
;;; In IBUKI Common Lisp, the macroexpansion environment is a three element |
586 |
|
;;; list. The second element describes lexical functions and macros. The |
587 |
|
;;; function entries in this list have the form |
588 |
|
;;; (<name> . (FUNCTION . (<function-value> . nil)) |
589 |
|
;;; The macro entries have the form |
590 |
|
;;; (<name> . (MACRO . (<macro-value> . nil)). |
591 |
|
;;; |
592 |
|
;;; |
593 |
|
#+(or KCL IBCL) |
594 |
|
(progn |
595 |
|
|
596 |
|
(defmacro with-augmented-environment |
597 |
|
((new-env old-env &key functions macros) &body body) |
598 |
|
`(let ((,new-env (with-augmented-environment-internal ,old-env |
599 |
|
,functions |
600 |
|
,macros))) |
601 |
|
,@body)) |
602 |
|
|
603 |
|
(defun with-augmented-environment-internal (env functions macros) |
604 |
|
(let ((first (first env)) |
605 |
|
(lexicals (second env)) |
606 |
|
(third (third env))) |
607 |
|
(dolist (f functions) |
608 |
|
(push `(,(car f) . (function . (,#'unbound-lexical-function . nil))) |
609 |
|
lexicals)) |
610 |
|
(dolist (m macros) |
611 |
|
(push `(,(car m) . (macro . ( ,(cadr m) . nil))) |
612 |
|
lexicals)) |
613 |
|
(list first lexicals third))) |
614 |
|
|
615 |
|
(defun environment-function (env fn) |
616 |
|
(when env |
617 |
|
(let ((entry (assoc fn (second env)))) |
618 |
|
(and entry |
619 |
|
(eq (cadr entry) 'function) |
620 |
|
(caddr entry))))) |
621 |
|
|
622 |
|
(defun environment-macro (env macro) |
623 |
|
(when env |
624 |
|
(let ((entry (assoc macro (second env)))) |
625 |
|
(and entry |
626 |
|
(eq (cadr entry) 'macro) |
627 |
|
(caddr entry))))) |
628 |
|
);#+(or KCL IBCL) |
629 |
|
|
630 |
|
|
631 |
|
;;; --- TI Explorer -- |
632 |
|
|
633 |
|
;;; An environment is a two element list, whose car we can ignore and |
634 |
|
;;; whose cadr is list of the local-definitions-frames. Each |
635 |
|
;;; local-definitions-frame holds either macros or functions, but not |
636 |
|
;;; both. Each frame is a plist of <name> <def> <name> <def> ... where |
637 |
|
;;; <name> is a locative to the function cell of the symbol that names |
638 |
|
;;; the function or macro, and <def> is the new def or NIL if this is function |
639 |
|
;;; redefinition or (cons 'ticl:macro <macro-expansion-function>) if this is a macro |
640 |
|
;;; redefinition. |
641 |
|
;;; |
642 |
|
;;; Here's an example. For the form: |
643 |
|
;;; (defun foo () |
644 |
|
;;; (macrolet ((bar (a b) (list a b)) |
645 |
|
;;; (bar2 (a b) (list a b))) |
646 |
|
;;; (flet ((some-local-fn (c d) (print (list c d))) |
647 |
|
;;; (another (c d) (print (list c d)))) |
648 |
|
;;; (bar (some-local-fn 1 2) 3)))) |
649 |
|
|
650 |
|
;;; the environment arg to macroexpand-1 when called on |
651 |
|
;;; (bar (some-local-fn 1 2) 3) |
652 |
|
;;;is |
653 |
|
;;;(NIL ((#<DTP-LOCATIVE 4710602> NIL |
654 |
|
;;; #<DTP-LOCATIVE 4710671> NIL) |
655 |
|
;;; (#<DTP-LOCATIVE 7346562> |
656 |
|
;;; (TICL:MACRO TICL:NAMED-LAMBDA (BAR (:DESCRIPTIVE-ARGLIST (A B))) |
657 |
|
;;; (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*) |
658 |
|
;;; (BLOCK BAR ....)) |
659 |
|
;;; #<DTP-LOCATIVE 4710664> |
660 |
|
;;; (TICL:MACRO TICL:NAMED-LAMBDA (BAR2 (:DESCRIPTIVE-ARGLIST (A B))) |
661 |
|
;;; (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*) |
662 |
|
;;; (BLOCK BAR2 ....)))) |
663 |
|
#+TI |
664 |
|
(progn |
665 |
|
|
666 |
|
;;; from sys:site;macros.lisp |
667 |
|
(eval-when (compile load eval) |
668 |
|
|
669 |
|
(DEFMACRO MACRO-DEF? (thing) |
670 |
|
`(AND (CONSP ,thing) (EQ (CAR ,thing) 'TICL::MACRO))) |
671 |
|
|
672 |
|
;; the following macro generates code to check the 'local' environment |
673 |
|
;; for a macro definition for THE SYMBOL <name>. Such a definition would |
674 |
|
;; be set up only by a MACROLET. If a macro definition for <name> is |
675 |
|
;; found, its expander function is returned. |
676 |
|
|
677 |
|
(DEFMACRO FIND-LOCAL-DEFINITION (name local-function-environment) |
678 |
|
`(IF ,local-function-environment |
679 |
|
(LET ((vcell (ticl::LOCF (SYMBOL-FUNCTION ,name)))) |
680 |
|
(DOLIST (frame ,local-function-environment) |
681 |
|
;; <value> is nil or a locative |
682 |
|
(LET ((value (sys::GET-LOCATION-OR-NIL (ticl::LOCF frame) |
683 |
|
vcell))) |
684 |
|
(When value (RETURN (CAR value)))))) |
685 |
|
nil))) |
686 |
|
|
687 |
|
|
688 |
|
;;;Edited by Reed Hastings 13 Jan 88 16:29 |
689 |
|
(defun environment-macro (env macro) |
690 |
|
"returns what macro-function would, ie. the expansion function" |
691 |
|
;;some code picked off macroexpand-1 |
692 |
|
(let* ((local-definitions (cadr env)) |
693 |
|
(local-def (find-local-definition macro local-definitions))) |
694 |
|
(if (macro-def? local-def) |
695 |
|
(cdr local-def)))) |
696 |
|
|
697 |
|
;;;Edited by Reed Hastings 13 Jan 88 16:29 |
698 |
|
;;;Edited by Reed Hastings 7 Mar 88 19:07 |
699 |
|
(defun environment-function (env fn) |
700 |
|
(let* ((local-definitions (cadr env))) |
701 |
|
(dolist (frame local-definitions) |
702 |
|
(let ((val (getf frame |
703 |
|
(ticl::locf (symbol-function fn)) |
704 |
|
:not-found-marker))) |
705 |
|
(cond ((eq val :not-found-marker)) |
706 |
|
((functionp val) (return t)) |
707 |
|
((and (listp val) |
708 |
|
(eq (car val) 'ticl::macro)) |
709 |
|
(return nil)) |
710 |
|
(t |
711 |
|
(error "we are confused"))))))) |
712 |
|
|
713 |
|
|
714 |
|
;;;Edited by Reed Hastings 13 Jan 88 16:29 |
715 |
|
;;;Edited by Reed Hastings 7 Mar 88 19:07 |
716 |
|
(defun with-augmented-environment-internal (env functions macros) |
717 |
|
(let ((local-definitions (cadr env)) |
718 |
|
(new-local-fns-frame |
719 |
|
(mapcan #'(lambda (fn) |
720 |
|
(list (ticl:locf (symbol-function (car fn))) |
721 |
|
#'unbound-lexical-function)) |
722 |
|
functions)) |
723 |
|
(new-local-macros-frame |
724 |
|
(mapcan #'(lambda (m) |
725 |
|
(list (ticl:locf (symbol-function (car m))) (cons 'ticl::macro (cadr m)))) |
726 |
|
macros))) |
727 |
|
(when new-local-fns-frame |
728 |
|
(push new-local-fns-frame local-definitions)) |
729 |
|
(when new-local-macros-frame |
730 |
|
(push new-local-macros-frame local-definitions)) |
731 |
|
`(,(car env) ,local-definitions))) |
732 |
|
|
733 |
|
|
734 |
|
;;;Edited by Reed Hastings 7 Mar 88 19:07 |
735 |
|
(defmacro with-augmented-environment |
736 |
|
((new-env old-env &key functions macros) &body body) |
737 |
|
`(let ((,new-env (with-augmented-environment-internal ,old-env |
738 |
|
,functions |
739 |
|
,macros))) |
740 |
|
,@body)) |
741 |
|
|
742 |
|
);#+TI |
743 |
|
|
744 |
|
|
745 |
|
#+(and dec vax common) |
746 |
|
(progn |
747 |
|
|
748 |
|
(defmacro with-augmented-environment |
749 |
|
((new-env old-env &key functions macros) &body body) |
750 |
|
`(let ((,new-env (with-augmented-environment-internal ,old-env |
751 |
|
,functions |
752 |
|
,macros))) |
753 |
|
,@body)) |
754 |
|
|
755 |
|
(defun with-augmented-environment-internal (env functions macros) |
756 |
|
#'(lambda (op &optional (arg nil arg-p)) |
757 |
|
(cond ((eq op :macro-function) |
758 |
|
(unless arg-p (error "Invalid environment use.")) |
759 |
|
(lookup-macro-function arg env functions macros)) |
760 |
|
(arg-p |
761 |
|
(error "Invalid environment operation: ~S ~S" op arg)) |
762 |
|
(t |
763 |
|
(lookup-macro-function op env functions macros))))) |
764 |
|
|
765 |
|
(defun lookup-macro-function (name env fns macros) |
766 |
|
(let ((m (assoc name macros))) |
767 |
|
(cond (m (cadr m)) |
768 |
|
((assoc name fns) :function) |
769 |
|
(env (funcall env name)) |
770 |
|
(t nil)))) |
771 |
|
|
772 |
|
(defun environment-macro (env macro) |
773 |
|
(let ((m (and env (funcall env macro)))) |
774 |
|
(and (not (eq m :function)) |
775 |
|
m))) |
776 |
|
|
777 |
|
;;; Nobody calls environment-function. What would it return, anyway? |
778 |
|
);#+(and dec vax common) |
779 |
|
|
780 |
|
|
781 |
|
;;; |
782 |
|
;;; In Golden Common Lisp, the macroexpansion environment is just a list |
783 |
|
;;; of environment entries. Unless the car of the list is :compiler-menv |
784 |
|
;;; it is an interpreted environment. The cadr of each element specifies |
785 |
|
;;; the type of the element. The only types that interest us are GCL:MACRO |
786 |
|
;;; and FUNCTION. In these cases the element is interpreted as follows. |
787 |
|
;;; |
788 |
|
;;; Compiled: |
789 |
|
;;; (<function-name> <gensym> macroexpansion-function) |
790 |
|
;;; (<function-name> <fn>) |
791 |
|
;;; |
792 |
|
;;; Interpreted: |
793 |
|
;;; (<function-name> GCL:MACRO macroexpansion-function) |
794 |
|
;;; (<function-name> <fn>) |
795 |
|
;;; |
796 |
|
;;; When in the compiler, <fn> is a gensym which will be |
797 |
|
;;; a variable which bound at run-time to the function. |
798 |
|
;;; When in the interpreter, <fn> is the actual function. |
799 |
|
;;; |
800 |
|
;;; |
801 |
|
#+gclisp |
802 |
|
(progn |
803 |
|
|
804 |
|
(defmacro with-augmented-environment |
805 |
|
((new-env old-env &key functions macros) &body body) |
806 |
|
`(let ((,new-env (with-augmented-environment-internal ,old-env |
807 |
|
,functions |
808 |
|
,macros))) |
809 |
|
,@body)) |
810 |
|
|
811 |
|
(defun with-augmented-environment-internal (env functions macros) |
812 |
|
(let ((new-entries nil)) |
813 |
|
(dolist (f functions) |
814 |
|
(push (cons (car f) nil) new-entries)) |
815 |
|
(dolist (m macros) |
816 |
|
(push (cons (car m) |
817 |
|
(if (eq :compiler-menv (car env)) |
818 |
|
(if (eq (caadr m) 'lisp::lambda) |
819 |
|
`(,(gensym) ,(cadr m)) |
820 |
|
`(,(gensym) ,@(cadr m))) |
821 |
|
`(gclisp:MACRO ,@(cadr m)))) |
822 |
|
new-entries)) |
823 |
|
(if (eq :compiler-menv (car env)) |
824 |
|
`(:compiler-menv ,@new-entries ,@(cdr env)) |
825 |
|
(append new-entries env)))) |
826 |
|
|
827 |
|
(defun environment-function (env fn) |
828 |
|
(let ((entry (lisp::lexical-function fn env))) |
829 |
|
(and entry |
830 |
|
(eq entry 'lisp::lexical-function) |
831 |
|
fn))) |
832 |
|
|
833 |
|
(defun environment-macro (env macro) |
834 |
|
(let ((entry (assoc macro (if (eq :compiler-menv (first env)) |
835 |
|
(rest env) |
836 |
|
env)))) |
837 |
|
(and entry |
838 |
|
(consp entry) |
839 |
|
(symbolp (car entry)) ;name |
840 |
|
(symbolp (cadr entry)) ;gcl:macro or gensym |
841 |
|
(nthcdr 2 entry)))) |
842 |
|
|
843 |
|
);#+gclisp |
844 |
|
|
845 |
|
|
846 |
|
;;;; CMU Common Lisp version of environment frobbing stuff. |
847 |
|
|
848 |
|
;;; In CMU Common Lisp, the environment is represented with a structure |
849 |
|
;;; that holds alists for the functional things, variables, blocks, etc. |
850 |
|
;;; Only the c::lexenv-functions slot is relevent. It holds: |
851 |
|
;;; Alist (name . what), where What is either a Functional (a local function) |
852 |
|
;;; or a list (MACRO . <function>) (a local macro, with the specifier |
853 |
|
;;; expander.) Note that Name may be a (SETF <name>) function. |
854 |
|
|
855 |
|
#+:CMU |
856 |
|
(progn |
857 |
|
|
858 |
|
(defmacro with-augmented-environment |
859 |
|
((new-env old-env &key functions macros) &body body) |
860 |
|
`(let ((,new-env (with-augmented-environment-internal ,old-env |
861 |
|
,functions |
862 |
|
,macros))) |
863 |
|
,@body)) |
864 |
|
|
865 |
|
(defun with-augmented-environment-internal (env functions macros) |
866 |
|
;; Note: In order to record the correct function definition, we would |
867 |
|
;; have to create an interpreted closure, but the with-new-definition |
868 |
|
;; macro down below makes no distinction between flet and labels, so |
869 |
|
;; we have no idea what to use for the environment. So we just blow it |
870 |
|
;; off, 'cause anything real we do would be wrong. We still have to |
871 |
|
;; make an entry so we can tell functions from macros. |
872 |
|
(let ((env (or env (c::make-null-environment)))) |
873 |
|
(c::make-lexenv |
874 |
|
:default env |
875 |
|
:functions |
876 |
|
(append (mapcar #'(lambda (f) |
877 |
|
(cons (car f) (c::make-functional :lexenv env))) |
878 |
|
functions) |
879 |
|
(mapcar #'(lambda (m) |
880 |
|
(list* (car m) 'c::macro |
881 |
|
(coerce (cadr m) 'function))) |
882 |
|
macros))))) |
883 |
|
|
884 |
|
(defun environment-function (env fn) |
885 |
|
(when env |
886 |
|
(let ((entry (assoc fn (c::lexenv-functions env) :test #'equal))) |
887 |
|
(and entry |
888 |
|
(c::functional-p (cdr entry)) |
889 |
|
(cdr entry))))) |
890 |
|
|
891 |
|
(defun environment-macro (env macro) |
892 |
|
(when env |
893 |
|
(let ((entry (assoc macro (c::lexenv-functions env) :test #'eq))) |
894 |
|
(and entry |
895 |
|
(eq (cadr entry) 'c::macro) |
896 |
|
(function-lambda-expression (cddr entry)))))) |
897 |
|
|
898 |
|
); end of #+:CMU |
899 |
|
|
900 |
|
|
901 |
|
|
902 |
|
(defmacro with-new-definition-in-environment |
903 |
|
((new-env old-env macrolet/flet/labels-form) &body body) |
904 |
|
(let ((functions (make-symbol "Functions")) |
905 |
|
(macros (make-symbol "Macros"))) |
906 |
|
`(let ((,functions ()) |
907 |
|
(,macros ())) |
908 |
|
(ecase (car ,macrolet/flet/labels-form) |
909 |
|
((flet labels) |
910 |
|
(dolist (fn (cadr ,macrolet/flet/labels-form)) |
911 |
|
(push fn ,functions))) |
912 |
|
((macrolet) |
913 |
|
(dolist (mac (cadr ,macrolet/flet/labels-form)) |
914 |
|
(push (list (car mac) |
915 |
|
(convert-macro-to-lambda (cadr mac) |
916 |
|
(cddr mac) |
917 |
|
(string (car mac)))) |
918 |
|
,macros)))) |
919 |
|
(with-augmented-environment |
920 |
|
(,new-env ,old-env :functions ,functions :macros ,macros) |
921 |
|
,@body)))) |
922 |
|
|
923 |
|
#-Genera |
924 |
|
(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) |
925 |
|
(let ((gensym (make-symbol name))) |
926 |
|
(eval `(defmacro ,gensym ,llist ,@body)) |
927 |
|
(macro-function gensym))) |
928 |
|
|
929 |
|
#+Genera |
930 |
|
(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) |
931 |
|
(si:defmacro-1 |
932 |
|
'sys:named-lambda 'sys:special (make-symbol name) llist body)) |
933 |
|
|
934 |
|
|
935 |
|
|
936 |
|
|
937 |
|
|
938 |
|
;;; |
939 |
|
;;; Now comes the real walker. |
940 |
|
;;; |
941 |
|
;;; As the walker walks over the code, it communicates information to itself |
942 |
|
;;; about the walk. This information includes the walk function, variable |
943 |
|
;;; bindings, declarations in effect etc. This information is inherently |
944 |
|
;;; lexical, so the walker passes it around in the actual environment the |
945 |
|
;;; walker passes to macroexpansion functions. This is what makes the |
946 |
|
;;; nested-walk-form facility work properly. |
947 |
|
;;; |
948 |
|
(defmacro walker-environment-bind ((var env &rest key-args) |
949 |
|
&body body) |
950 |
|
`(with-augmented-environment |
951 |
|
(,var ,env :macros (walker-environment-bind-1 ,env ,.key-args)) |
952 |
|
.,body)) |
953 |
|
|
954 |
|
(defvar *key-to-walker-environment* (gensym)) |
955 |
|
|
956 |
|
(defun env-lock (env) |
957 |
|
(environment-macro env *key-to-walker-environment*)) |
958 |
|
|
959 |
|
(defun walker-environment-bind-1 (env &key (walk-function nil wfnp) |
960 |
|
(walk-form nil wfop) |
961 |
|
(declarations nil decp) |
962 |
|
(lexical-variables nil lexp)) |
963 |
|
(let ((lock (environment-macro env *key-to-walker-environment*))) |
964 |
|
(list |
965 |
|
(list *key-to-walker-environment* |
966 |
|
(list (if wfnp walk-function (car lock)) |
967 |
|
(if wfop walk-form (cadr lock)) |
968 |
|
(if decp declarations (caddr lock)) |
969 |
|
(if lexp lexical-variables (cadddr lock))))))) |
970 |
|
|
971 |
|
(defun env-walk-function (env) |
972 |
|
(car (env-lock env))) |
973 |
|
|
974 |
|
(defun env-walk-form (env) |
975 |
|
(cadr (env-lock env))) |
976 |
|
|
977 |
|
(defun env-declarations (env) |
978 |
|
(caddr (env-lock env))) |
979 |
|
|
980 |
|
(defun env-lexical-variables (env) |
981 |
|
(cadddr (env-lock env))) |
982 |
|
|
983 |
|
|
984 |
|
(defun note-declaration (declaration env) |
985 |
|
(push declaration (caddr (env-lock env)))) |
986 |
|
|
987 |
|
(defun note-lexical-binding (thing env) |
988 |
|
(push (list thing :lexical-var) (cadddr (env-lock env)))) |
989 |
|
|
990 |
|
(defun VARIABLE-LEXICAL-P (var env) |
991 |
|
(let ((entry (member var (env-lexical-variables env) :key #'car))) |
992 |
|
(when (eq (cadar entry) :lexical-var) |
993 |
|
entry))) |
994 |
|
|
995 |
|
(defun variable-symbol-macro-p (var env) |
996 |
|
(let ((entry (member var (env-lexical-variables env) :key #'car))) |
997 |
|
(when (eq (cadar entry) :macro) |
998 |
|
entry))) |
999 |
|
|
1000 |
|
|
1001 |
|
(defvar *VARIABLE-DECLARATIONS* '(special)) |
1002 |
|
|
1003 |
|
(defun VARIABLE-DECLARATION (declaration var env) |
1004 |
|
(if (not (member declaration *variable-declarations*)) |
1005 |
|
(error "~S is not a recognized variable declaration." declaration) |
1006 |
|
(let ((id (or (variable-lexical-p var env) var))) |
1007 |
|
(dolist (decl (env-declarations env)) |
1008 |
|
(when (and (eq (car decl) declaration) |
1009 |
|
(eq (cadr decl) id)) |
1010 |
|
(return decl)))))) |
1011 |
|
|
1012 |
|
(defun VARIABLE-SPECIAL-P (var env) |
1013 |
|
(or (not (null (variable-declaration 'special var env))) |
1014 |
|
(variable-globally-special-p var))) |
1015 |
|
|
1016 |
|
;;; |
1017 |
|
;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been |
1018 |
|
;;; declared globally special. Any particular CommonLisp implementation |
1019 |
|
;;; should customize this function accordingly and send their customization |
1020 |
|
;;; back. |
1021 |
|
;;; |
1022 |
|
;;; The default version of variable-globally-special-p is probably pretty |
1023 |
|
;;; slow, so it uses *globally-special-variables* as a cache to remember |
1024 |
|
;;; variables that it has already figured out are globally special. |
1025 |
|
;;; |
1026 |
|
;;; This would need to be reworked if an unspecial declaration got added to |
1027 |
|
;;; Common Lisp. |
1028 |
|
;;; |
1029 |
|
;;; Common Lisp nit: |
1030 |
|
;;; variable-globally-special-p should be defined in Common Lisp. |
1031 |
|
;;; |
1032 |
|
#-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs |
1033 |
|
GCLisp TI pyramid) |
1034 |
|
(defvar *globally-special-variables* ()) |
1035 |
|
|
1036 |
|
(defun variable-globally-special-p (symbol) |
1037 |
|
#+Genera (si:special-variable-p symbol) |
1038 |
|
#+Cloe-Runtime (compiler::specialp symbol) |
1039 |
|
#+Lucid (lucid::proclaimed-special-p symbol) |
1040 |
|
#+TI (get symbol 'special) |
1041 |
|
#+Xerox (il:variable-globally-special-p symbol) |
1042 |
|
#+(and dec vax common) (get symbol 'system::globally-special) |
1043 |
|
#+(or KCL IBCL) (si:specialp symbol) |
1044 |
|
#+excl (get symbol 'excl::.globally-special.) |
1045 |
|
#+:CMU (eq (ext:info variable kind symbol) :special) |
1046 |
|
#+HP-HPLabs (member (get symbol 'impl:vartype) |
1047 |
|
'(impl:fluid impl:global) |
1048 |
|
:test #'eq) |
1049 |
|
#+:GCLISP (gclisp::special-p symbol) |
1050 |
|
#+pyramid (or (get symbol 'lisp::globally-special) |
1051 |
|
(get symbol |
1052 |
|
'clc::globally-special-in-compiler)) |
1053 |
|
#+:CORAL (ccl::proclaimed-special-p symbol) |
1054 |
|
#-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs |
1055 |
|
GCLisp TI pyramid :CORAL) |
1056 |
|
(or (not (null (member symbol *globally-special-variables* :test #'eq))) |
1057 |
|
(when (eval `(flet ((ref () ,symbol)) |
1058 |
|
(let ((,symbol '#,(list nil))) |
1059 |
|
(and (boundp ',symbol) (eq ,symbol (ref)))))) |
1060 |
|
(push symbol *globally-special-variables*) |
1061 |
|
t))) |
1062 |
|
|
1063 |
|
|
1064 |
|
;; |
1065 |
|
;;;;;; Handling of special forms (the infamous 24). |
1066 |
|
;; |
1067 |
|
;;; |
1068 |
|
;;; and I quote... |
1069 |
|
;;; |
1070 |
|
;;; The set of special forms is purposely kept very small because |
1071 |
|
;;; any program analyzing program (read code walker) must have |
1072 |
|
;;; special knowledge about every type of special form. Such a |
1073 |
|
;;; program needs no special knowledge about macros... |
1074 |
|
;;; |
1075 |
|
;;; So all we have to do here is a define a way to store and retrieve |
1076 |
|
;;; templates which describe how to walk the 24 special forms and we are all |
1077 |
|
;;; set... |
1078 |
|
;;; |
1079 |
|
;;; Well, its a nice concept, and I have to admit to being naive enough that |
1080 |
|
;;; I believed it for a while, but not everyone takes having only 24 special |
1081 |
|
;;; forms as seriously as might be nice. There are (at least) 3 ways to |
1082 |
|
;;; lose: |
1083 |
|
;; |
1084 |
|
;;; 1 - Implementation x implements a Common Lisp special form as a macro |
1085 |
|
;;; which expands into a special form which: |
1086 |
|
;;; - Is a common lisp special form (not likely) |
1087 |
|
;;; - Is not a common lisp special form (on the 3600 IF --> COND). |
1088 |
|
;;; |
1089 |
|
;;; * We can safe ourselves from this case (second subcase really) by |
1090 |
|
;;; checking to see if there is a template defined for something |
1091 |
|
;;; before we check to see if we we can macroexpand it. |
1092 |
|
;;; |
1093 |
|
;;; 2 - Implementation x implements a Common Lisp macro as a special form. |
1094 |
|
;;; |
1095 |
|
;;; * This is a screw, but not so bad, we save ourselves from it by |
1096 |
|
;;; defining extra templates for the macros which are *likely* to |
1097 |
|
;;; be implemented as special forms. (DO, DO* ...) |
1098 |
|
;;; |
1099 |
|
;;; 3 - Implementation x has a special form which is not on the list of |
1100 |
|
;;; Common Lisp special forms. |
1101 |
|
;;; |
1102 |
|
;;; * This is a bad sort of a screw and happens more than I would like |
1103 |
|
;;; to think, especially in the implementations which provide more |
1104 |
|
;;; than just Common Lisp (3600, Xerox etc.). |
1105 |
|
;;; The fix is not terribly staisfactory, but will have to do for |
1106 |
|
;;; now. There is a hook in get walker-template which can get a |
1107 |
|
;;; template from the implementation's own walker. That template |
1108 |
|
;;; has to be converted, and so it may be that the right way to do |
1109 |
|
;;; this would actually be for that implementation to provide an |
1110 |
|
;;; interface to its walker which looks like the interface to this |
1111 |
|
;;; walker. |
1112 |
|
;;; |
1113 |
|
|
1114 |
|
(eval-when (compile load eval) |
1115 |
|
|
1116 |
|
(defmacro get-walker-template-internal (x) ;Has to be inside eval-when because |
1117 |
|
`(get ,x 'walker-template)) ;Golden Common Lisp doesn't hack |
1118 |
|
;compile time definition of macros |
1119 |
|
;right for setf. |
1120 |
|
|
1121 |
|
(defmacro define-walker-template |
1122 |
|
(name &optional (template '(nil repeat (eval)))) |
1123 |
|
`(eval-when (load eval) |
1124 |
|
(setf (get-walker-template-internal ',name) ',template))) |
1125 |
|
) |
1126 |
|
|
1127 |
|
(defun get-walker-template (x) |
1128 |
|
(cond ((symbolp x) |
1129 |
|
(or (get-walker-template-internal x) |
1130 |
|
(get-implementation-dependent-walker-template x))) |
1131 |
|
((and (listp x) |
1132 |
|
(or (eq (car x) 'lambda) |
1133 |
|
#+cmu17 (eq (car x) 'kernel:instance-lambda))) |
1134 |
|
'(lambda repeat (eval))) |
1135 |
|
(t |
1136 |
|
(error "Can't get template for ~S" x)))) |
1137 |
|
|
1138 |
|
(defun get-implementation-dependent-walker-template (x) |
1139 |
|
(declare (ignore x)) |
1140 |
|
()) |
1141 |
|
|
1142 |
|
|
1143 |
|
;; |
1144 |
|
;;;;;; The actual templates |
1145 |
|
;; |
1146 |
|
|
1147 |
|
(define-walker-template BLOCK (NIL NIL REPEAT (EVAL))) |
1148 |
|
(define-walker-template CATCH (NIL EVAL REPEAT (EVAL))) |
1149 |
|
(define-walker-template COMPILER-LET walk-compiler-let) |
1150 |
|
(define-walker-template DECLARE walk-unexpected-declare) |
1151 |
|
(define-walker-template EVAL-WHEN (NIL QUOTE REPEAT (EVAL))) |
1152 |
|
(define-walker-template FLET walk-flet) |
1153 |
|
(define-walker-template FUNCTION (NIL CALL)) |
1154 |
|
(define-walker-template GO (NIL QUOTE)) |
1155 |
|
(define-walker-template IF walk-if) |
1156 |
|
(define-walker-template LABELS walk-labels) |
1157 |
|
(define-walker-template LAMBDA walk-lambda) |
1158 |
|
(define-walker-template LET walk-let) |
1159 |
|
(define-walker-template LET* walk-let*) |
1160 |
|
(define-walker-template LOCALLY walk-locally) |
1161 |
|
(define-walker-template MACROLET walk-macrolet) |
1162 |
|
(define-walker-template MULTIPLE-VALUE-CALL (NIL EVAL REPEAT (EVAL))) |
1163 |
|
(define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL))) |
1164 |
|
(define-walker-template MULTIPLE-VALUE-SETQ walk-multiple-value-setq) |
1165 |
|
(define-walker-template MULTIPLE-VALUE-BIND walk-multiple-value-bind) |
1166 |
|
(define-walker-template PROGN (NIL REPEAT (EVAL))) |
1167 |
|
(define-walker-template PROGV (NIL EVAL EVAL REPEAT (EVAL))) |
1168 |
|
(define-walker-template QUOTE (NIL QUOTE)) |
1169 |
|
(define-walker-template RETURN-FROM (NIL QUOTE REPEAT (RETURN))) |
1170 |
|
(define-walker-template SETQ walk-setq) |
1171 |
|
(define-walker-template SYMBOL-MACROLET walk-symbol-macrolet) |
1172 |
|
(define-walker-template TAGBODY walk-tagbody) |
1173 |
|
(define-walker-template THE (NIL QUOTE EVAL)) |
1174 |
|
#+cmu(define-walker-template EXT:TRULY-THE (NIL QUOTE EVAL)) |
1175 |
|
(define-walker-template THROW (NIL EVAL EVAL)) |
1176 |
|
(define-walker-template UNWIND-PROTECT (NIL RETURN REPEAT (EVAL))) |
1177 |
|
|
1178 |
|
;;; The new special form. |
1179 |
|
;(define-walker-template pcl::LOAD-TIME-EVAL (NIL EVAL)) |
1180 |
|
|
1181 |
|
;;; |
1182 |
|
;;; And the extra templates... |
1183 |
|
;;; |
1184 |
|
(define-walker-template DO walk-do) |
1185 |
|
(define-walker-template DO* walk-do*) |
1186 |
|
(define-walker-template PROG walk-prog) |
1187 |
|
(define-walker-template PROG* walk-prog*) |
1188 |
|
(define-walker-template COND (NIL REPEAT ((TEST REPEAT (EVAL))))) |
1189 |
|
|
1190 |
|
#+Genera |
1191 |
|
(progn |
1192 |
|
(define-walker-template zl::named-lambda walk-named-lambda) |
1193 |
|
(define-walker-template SCL:LETF walk-let) |
1194 |
|
(define-walker-template SCL:LETF* walk-let*) |
1195 |
|
) |
1196 |
|
|
1197 |
|
#+Lucid |
1198 |
|
(progn |
1199 |
|
(define-walker-template #+LCL3.0 lucid-common-lisp:named-lambda |
1200 |
|
#-LCL3.0 sys:named-lambda walk-named-lambda) |
1201 |
|
) |
1202 |
|
|
1203 |
|
#+(or KCL IBCL) |
1204 |
|
(progn |
1205 |
|
(define-walker-template lambda-block walk-named-lambda);Not really right, |
1206 |
|
;we don't hack block |
1207 |
|
;names anyways. |
1208 |
|
) |
1209 |
|
|
1210 |
|
#+TI |
1211 |
|
(progn |
1212 |
|
(define-walker-template TICL::LET-IF walk-let-if) |
1213 |
|
) |
1214 |
|
|
1215 |
|
#+:Coral |
1216 |
|
(progn |
1217 |
|
(define-walker-template ccl:%stack-block walk-let) |
1218 |
|
) |
1219 |
|
|
1220 |
|
#+cmu17 |
1221 |
|
(progn |
1222 |
|
(define-walker-template kernel:instance-lambda walk-lambda) |
1223 |
|
) |
1224 |
|
|
1225 |
|
|
1226 |
|
|
1227 |
|
(defvar walk-form-expand-macros-p nil) |
1228 |
|
|
1229 |
|
(defun macroexpand-all (form &optional environment) |
1230 |
|
(let ((walk-form-expand-macros-p t)) |
1231 |
|
(walk-form form environment))) |
1232 |
|
|
1233 |
|
(defun WALK-FORM (form |
1234 |
|
&optional environment |
1235 |
|
(walk-function |
1236 |
|
#'(lambda (subform context env) |
1237 |
|
(declare (ignore context env)) |
1238 |
|
subform))) |
1239 |
|
(walker-environment-bind (new-env environment :walk-function walk-function) |
1240 |
|
(walk-form-internal form :eval new-env))) |
1241 |
|
|
1242 |
|
;;; |
1243 |
|
;;; nested-walk-form provides an interface that allows nested macros, each |
1244 |
|
;;; of which must walk their body to just do one walk of the body of the |
1245 |
|
;;; inner macro. That inner walk is done with a walk function which is the |
1246 |
|
;;; composition of the two walk functions. |
1247 |
|
;;; |
1248 |
|
;;; This facility works by having the walker annotate the environment that |
1249 |
|
;;; it passes to macroexpand-1 to know which form is being macroexpanded. |
1250 |
|
;;; If then the &whole argument to the macroexpansion function is eq to |
1251 |
|
;;; the env-walk-form of the environment, nested-walk-form can be certain |
1252 |
|
;;; that there are no intervening layers and that a nested walk is alright. |
1253 |
|
;;; |
1254 |
|
;;; There are some semantic problems with this facility. In particular, if |
1255 |
|
;;; the outer walk function returns T as its walk-no-more-p value, this will |
1256 |
|
;;; prevent the inner walk function from getting a chance to walk the subforms |
1257 |
|
;;; of the form. This is almost never what you want, since it destroys the |
1258 |
|
;;; equivalence between this nested-walk-form function and two seperate |
1259 |
|
;;; walk-forms. |
1260 |
|
;;; |
1261 |
|
(defun NESTED-WALK-FORM (whole |
1262 |
|
form |
1263 |
|
&optional environment |
1264 |
|
(walk-function |
1265 |
|
#'(lambda (subform context env) |
1266 |
|
(declare (ignore context env)) |
1267 |
|
subform))) |
1268 |
|
(if (eq whole (env-walk-form environment)) |
1269 |
|
(let ((outer-walk-function (env-walk-function environment))) |
1270 |
|
(throw whole |
1271 |
|
(walk-form |
1272 |
|
form |
1273 |
|
environment |
1274 |
|
#'(lambda (f c e) |
1275 |
|
;; First loop to make sure the inner walk function |
1276 |
|
;; has done all it wants to do with this form. |
1277 |
|
;; Basically, what we are doing here is providing |
1278 |
|
;; the same contract walk-form-internal normally |
1279 |
|
;; provides to the inner walk function. |
1280 |
|
(let ((inner-result nil) |
1281 |
|
(inner-no-more-p nil) |
1282 |
|
(outer-result nil) |
1283 |
|
(outer-no-more-p nil)) |
1284 |
|
(loop |
1285 |
|
(multiple-value-setq (inner-result inner-no-more-p) |
1286 |
|
(funcall walk-function f c e)) |
1287 |
|
(cond (inner-no-more-p (return)) |
1288 |
|
((not (eq inner-result f))) |
1289 |
|
((not (consp inner-result)) (return)) |
1290 |
|
((get-walker-template (car inner-result)) (return)) |
1291 |
|
(t |
1292 |
|
(multiple-value-bind (expansion macrop) |
1293 |
|
(walker-environment-bind |
1294 |
|
(new-env e :walk-form inner-result) |
1295 |
|
(macroexpand-1 inner-result new-env)) |
1296 |
|
(if macrop |
1297 |
|
(setq inner-result expansion) |
1298 |
|
(return))))) |
1299 |
|
(setq f inner-result)) |
1300 |
|
(multiple-value-setq (outer-result outer-no-more-p) |
1301 |
|
(funcall outer-walk-function |
1302 |
|
inner-result |
1303 |
|
c |
1304 |
|
e)) |
1305 |
|
(values outer-result |
1306 |
|
(and inner-no-more-p outer-no-more-p))))))) |
1307 |
|
(walk-form form environment walk-function))) |
1308 |
|
|
1309 |
|
;;; |
1310 |
|
;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It |
1311 |
|
;;; takes a form and the current context and walks the form calling itself or |
1312 |
|
;;; the appropriate template recursively. |
1313 |
|
;;; |
1314 |
|
;;; "It is recommended that a program-analyzing-program process a form |
1315 |
|
;;; that is a list whose car is a symbol as follows: |
1316 |
|
;;; |
1317 |
|
;;; 1. If the program has particular knowledge about the symbol, |
1318 |
|
;;; process the form using special-purpose code. All of the |
1319 |
|
;;; standard special forms should fall into this category. |
1320 |
|
;;; 2. Otherwise, if macro-function is true of the symbol apply |
1321 |
|
;;; either macroexpand or macroexpand-1 and start over. |
1322 |
|
;;; 3. Otherwise, assume it is a function call. " |
1323 |
|
;;; |
1324 |
|
|
1325 |
|
(defun walk-form-internal (form context env) |
1326 |
|
;; First apply the walk-function to perform whatever translation |
1327 |
|
;; the user wants to this form. If the second value returned |
1328 |
|
;; by walk-function is T then we don't recurse... |
1329 |
|
(catch form |
1330 |
|
(multiple-value-bind (newform walk-no-more-p) |
1331 |
|
(funcall (env-walk-function env) form context env) |
1332 |
|
(catch newform |
1333 |
|
(cond |
1334 |
|
(walk-no-more-p newform) |
1335 |
|
((not (eq form newform)) |
1336 |
|
(walk-form-internal newform context env)) |
1337 |
|
((not (consp newform)) |
1338 |
|
(let ((symmac (car (variable-symbol-macro-p newform env)))) |
1339 |
|
(if symmac |
1340 |
|
(let ((newnewform (walk-form-internal (cddr symmac) |
1341 |
|
context env))) |
1342 |
|
(if (eq newnewform (cddr symmac)) |
1343 |
|
(if walk-form-expand-macros-p newnewform newform) |
1344 |
|
newnewform)) |
1345 |
|
newform))) |
1346 |
|
(t |
1347 |
|
(let* ((fn (car newform)) |
1348 |
|
(template (get-walker-template fn))) |
1349 |
|
(if template |
1350 |
|
(if (symbolp template) |
1351 |
|
(funcall template newform context env) |
1352 |
|
(walk-template newform template context env)) |
1353 |
|
(multiple-value-bind |
1354 |
|
(newnewform macrop) |
1355 |
|
(walker-environment-bind |
1356 |
|
(new-env env :walk-form newform) |
1357 |
|
(macroexpand-1 newform new-env)) |
1358 |
|
(cond |
1359 |
|
(macrop |
1360 |
|
(let ((newnewnewform (walk-form-internal newnewform context |
1361 |
|
env))) |
1362 |
|
(if (eq newnewnewform newnewform) |
1363 |
|
(if walk-form-expand-macros-p newnewform newform) |
1364 |
|
newnewnewform))) |
1365 |
|
((and (symbolp fn) |
1366 |
|
(not (fboundp fn)) |
1367 |
|
#+cmu17 |
1368 |
|
(special-operator-p fn) |
1369 |
|
#-cmu17 |
1370 |
|
(special-form-p fn)) |
1371 |
|
(error |
1372 |
|
"~S is a special form, not defined in the CommonLisp.~%~ |
1373 |
|
manual This code walker doesn't know how to walk it.~%~ |
1374 |
|
Define a template for this special form and try again." |
1375 |
|
fn)) |
1376 |
|
(t |
1377 |
|
;; Otherwise, walk the form as if its just a standard |
1378 |
|
;; functioncall using a template for standard function |
1379 |
|
;; call. |
1380 |
|
(walk-template |
1381 |
|
newnewform '(call repeat (eval)) context env)))))))))))) |
1382 |
|
|
1383 |
|
(defun walk-template (form template context env) |
1384 |
|
(if (atom template) |
1385 |
|
(ecase template |
1386 |
|
((EVAL FUNCTION TEST EFFECT RETURN) |
1387 |
|
(walk-form-internal form :EVAL env)) |
1388 |
|
((QUOTE NIL) form) |
1389 |
|
(SET |
1390 |
|
(walk-form-internal form :SET env)) |
1391 |
|
((LAMBDA CALL) |
1392 |
|
(cond ((or (symbolp form) |
1393 |
|
(and (listp form) |
1394 |
|
(= (length form) 2) |
1395 |
|
(eq (car form) 'setf))) |
1396 |
|
form) |
1397 |
|
#+Lispm |
1398 |
|
((sys:validate-function-spec form) form) |
1399 |
|
(t (walk-form-internal form context env))))) |
1400 |
|
(case (car template) |
1401 |
|
(REPEAT |
1402 |
|
(walk-template-handle-repeat form |
1403 |
|
(cdr template) |
1404 |
|
;; For the case where nothing happens |
1405 |
|
;; after the repeat optimize out the |
1406 |
|
;; call to length. |
1407 |
|
(if (null (cddr template)) |
1408 |
|
() |
1409 |
|
(nthcdr (- (length form) |
1410 |
|
(length |
1411 |
|
(cddr template))) |
1412 |
|
form)) |
1413 |
|
context |
1414 |
|
env)) |
1415 |
|
(IF |
1416 |
|
(walk-template form |
1417 |
|
(if (if (listp (cadr template)) |
1418 |
|
(eval (cadr template)) |
1419 |
|
(funcall (cadr template) form)) |
1420 |
|
(caddr template) |
1421 |
|
(cadddr template)) |
1422 |
|
context |
1423 |
|
env)) |
1424 |
|
(REMOTE |
1425 |
|
(walk-template form (cadr template) context env)) |
1426 |
|
(otherwise |
1427 |
|
(cond ((atom form) form) |
1428 |
|
(t (recons form |
1429 |
|
(walk-template |
1430 |
|
(car form) (car template) context env) |
1431 |
|
(walk-template |
1432 |
|
(cdr form) (cdr template) context env)))))))) |
1433 |
|
|
1434 |
|
(defun walk-template-handle-repeat (form template stop-form context env) |
1435 |
|
(if (eq form stop-form) |
1436 |
|
(walk-template form (cdr template) context env) |
1437 |
|
(walk-template-handle-repeat-1 form |
1438 |
|
template |
1439 |
|
(car template) |
1440 |
|
stop-form |
1441 |
|
context |
1442 |
|
env))) |
1443 |
|
|
1444 |
|
(defun walk-template-handle-repeat-1 (form template repeat-template |
1445 |
|
stop-form context env) |
1446 |
|
(cond ((null form) ()) |
1447 |
|
((eq form stop-form) |
1448 |
|
(if (null repeat-template) |
1449 |
|
(walk-template stop-form (cdr template) context env) |
1450 |
|
(error "While handling repeat: |
1451 |
|
~%~Ran into stop while still in repeat template."))) |
1452 |
|
((null repeat-template) |
1453 |
|
(walk-template-handle-repeat-1 |
1454 |
|
form template (car template) stop-form context env)) |
1455 |
|
(t |
1456 |
|
(recons form |
1457 |
|
(walk-template (car form) (car repeat-template) context env) |
1458 |
|
(walk-template-handle-repeat-1 (cdr form) |
1459 |
|
template |
1460 |
|
(cdr repeat-template) |
1461 |
|
stop-form |
1462 |
|
context |
1463 |
|
env))))) |
1464 |
|
|
1465 |
|
(defun walk-repeat-eval (form env) |
1466 |
|
(and form |
1467 |
|
(recons form |
1468 |
|
(walk-form-internal (car form) :eval env) |
1469 |
|
(walk-repeat-eval (cdr form) env)))) |
1470 |
|
|
1471 |
|
(defun recons (x car cdr) |
1472 |
|
(if (or (not (eq (car x) car)) |
1473 |
|
(not (eq (cdr x) cdr))) |
1474 |
|
(cons car cdr) |
1475 |
|
x)) |
1476 |
|
|
1477 |
|
(defun relist (x &rest args) |
1478 |
|
(if (null args) |
1479 |
|
nil |
1480 |
|
(relist-internal x args nil))) |
1481 |
|
|
1482 |
|
(defun relist* (x &rest args) |
1483 |
|
(relist-internal x args 't)) |
1484 |
|
|
1485 |
|
(defun relist-internal (x args *p) |
1486 |
|
(if (null (cdr args)) |
1487 |
|
(if *p |
1488 |
|
(car args) |
1489 |
|
(recons x (car args) nil)) |
1490 |
|
(recons x |
1491 |
|
(car args) |
1492 |
|
(relist-internal (cdr x) (cdr args) *p)))) |
1493 |
|
|
1494 |
|
|
1495 |
|
;; |
1496 |
|
;;;;;; Special walkers |
1497 |
|
;; |
1498 |
|
|
1499 |
|
(defun walk-declarations (body fn env |
1500 |
|
&optional doc-string-p declarations old-body |
1501 |
|
&aux (form (car body)) macrop new-form) |
1502 |
|
(cond ((and (stringp form) ;might be a doc string |
1503 |
|
(cdr body) ;isn't the returned value |
1504 |
|
(null doc-string-p) ;no doc string yet |
1505 |
|
(null declarations)) ;no declarations yet |
1506 |
|
(recons body |
1507 |
|
form |
1508 |
|
(walk-declarations (cdr body) fn env t))) |
1509 |
|
((and (listp form) (eq (car form) 'declare)) |
1510 |
|
;; Got ourselves a real live declaration. Record it, look for more. |
1511 |
|
(dolist (declaration (cdr form)) |
1512 |
|
(let ((type (car declaration)) |
1513 |
|
(name (cadr declaration)) |
1514 |
|
(args (cddr declaration))) |
1515 |
|
(if (member type *variable-declarations*) |
1516 |
|
(note-declaration `(,type |
1517 |
|
,(or (variable-lexical-p name env) name) |
1518 |
|
,.args) |
1519 |
|
env) |
1520 |
|
(note-declaration declaration env)) |
1521 |
|
(push declaration declarations))) |
1522 |
|
(recons body |
1523 |
|
form |
1524 |
|
(walk-declarations |
1525 |
|
(cdr body) fn env doc-string-p declarations))) |
1526 |
|
((and form |
1527 |
|
(listp form) |
1528 |
|
(null (get-walker-template (car form))) |
1529 |
|
(progn |
1530 |
|
(multiple-value-setq (new-form macrop) |
1531 |
|
(macroexpand-1 form env)) |
1532 |
|
macrop)) |
1533 |
|
;; This form was a call to a macro. Maybe it expanded |
1534 |
|
;; into a declare? Recurse to find out. |
1535 |
|
(walk-declarations (recons body new-form (cdr body)) |
1536 |
|
fn env doc-string-p declarations |
1537 |
|
(or old-body body))) |
1538 |
|
(t |
1539 |
|
;; Now that we have walked and recorded the declarations, |
1540 |
|
;; call the function our caller provided to expand the body. |
1541 |
|
;; We call that function rather than passing the real-body |
1542 |
|
;; back, because we are RECONSING up the new body. |
1543 |
|
(funcall fn (or old-body body) env)))) |
1544 |
|
|
1545 |
|
|
1546 |
|
(defun walk-unexpected-declare (form context env) |
1547 |
|
(declare (ignore context env)) |
1548 |
|
(warn "Encountered declare ~S in a place where a declare was not expected." |
1549 |
|
form) |
1550 |
|
form) |
1551 |
|
|
1552 |
|
(defun walk-arglist (arglist context env &optional (destructuringp nil) |
1553 |
|
&aux arg) |
1554 |
|
(cond ((null arglist) ()) |
1555 |
|
((symbolp (setq arg (car arglist))) |
1556 |
|
(or (member arg lambda-list-keywords) |
1557 |
|
(note-lexical-binding arg env)) |
1558 |
|
(recons arglist |
1559 |
|
arg |
1560 |
|
(walk-arglist (cdr arglist) |
1561 |
|
context |
1562 |
|
env |
1563 |
|
(and destructuringp |
1564 |
|
(not (member arg |
1565 |
|
lambda-list-keywords)))))) |
1566 |
|
((consp arg) |
1567 |
|
(prog1 (recons arglist |
1568 |
|
(if destructuringp |
1569 |
|
(walk-arglist arg context env destructuringp) |
1570 |
|
(relist* arg |
1571 |
|
(car arg) |
1572 |
|
(walk-form-internal (cadr arg) :eval env) |
1573 |
|
(cddr arg))) |
1574 |
|
(walk-arglist (cdr arglist) context env nil)) |
1575 |
|
(if (symbolp (car arg)) |
1576 |
|
(note-lexical-binding (car arg) env) |
1577 |
|
(note-lexical-binding (cadar arg) env)) |
1578 |
|
(or (null (cddr arg)) |
1579 |
|
(not (symbolp (caddr arg))) |
1580 |
|
(note-lexical-binding (caddr arg) env)))) |
1581 |
|
(t |
1582 |
|
(error "Can't understand something in the arglist ~S" arglist)))) |
1583 |
|
|
1584 |
|
(defun walk-let (form context env) |
1585 |
|
(walk-let/let* form context env nil)) |
1586 |
|
|
1587 |
|
(defun walk-let* (form context env) |
1588 |
|
(walk-let/let* form context env t)) |
1589 |
|
|
1590 |
|
(defun walk-prog (form context env) |
1591 |
|
(walk-prog/prog* form context env nil)) |
1592 |
|
|
1593 |
|
(defun walk-prog* (form context env) |
1594 |
|
(walk-prog/prog* form context env t)) |
1595 |
|
|
1596 |
|
(defun walk-do (form context env) |
1597 |
|
(walk-do/do* form context env nil)) |
1598 |
|
|
1599 |
|
(defun walk-do* (form context env) |
1600 |
|
(walk-do/do* form context env t)) |
1601 |
|
|
1602 |
|
(defun walk-let/let* (form context old-env sequentialp) |
1603 |
|
(walker-environment-bind (new-env old-env) |
1604 |
|
(let* ((let/let* (car form)) |
1605 |
|
(bindings (cadr form)) |
1606 |
|
(body (cddr form)) |
1607 |
|
(walked-bindings |
1608 |
|
(walk-bindings-1 bindings |
1609 |
|
old-env |
1610 |
|
new-env |
1611 |
|
context |
1612 |
|
sequentialp)) |
1613 |
|
(walked-body |
1614 |
|
(walk-declarations body #'walk-repeat-eval new-env))) |
1615 |
|
(relist* |
1616 |
|
form let/let* walked-bindings walked-body)))) |
1617 |
|
|
1618 |
|
(defun walk-locally (form context env) |
1619 |
|
(declare (ignore context)) |
1620 |
|
(let* ((locally (car form)) |
1621 |
|
(body (cdr form)) |
1622 |
|
(walked-body |
1623 |
|
(walk-declarations body #'walk-repeat-eval env))) |
1624 |
|
(relist* |
1625 |
|
form locally walked-body))) |
1626 |
|
|
1627 |
|
(defun walk-prog/prog* (form context old-env sequentialp) |
1628 |
|
(walker-environment-bind (new-env old-env) |
1629 |
|
(let* ((possible-block-name (second form)) |
1630 |
|
(blocked-prog (and (symbolp possible-block-name) |
1631 |
|
(not (eq possible-block-name 'nil))))) |
1632 |
|
(multiple-value-bind (let/let* block-name bindings body) |
1633 |
|
(if blocked-prog |
1634 |
|
(values (car form) (cadr form) (caddr form) (cdddr form)) |
1635 |
|
(values (car form) nil (cadr form) (cddr form))) |
1636 |
|
(let* ((walked-bindings |
1637 |
|
(walk-bindings-1 bindings |
1638 |
|
old-env |
1639 |
|
new-env |
1640 |
|
context |
1641 |
|
sequentialp)) |
1642 |
|
(walked-body |
1643 |
|
(walk-declarations |
1644 |
|
body |
1645 |
|
#'(lambda (real-body real-env) |
1646 |
|
(walk-tagbody-1 real-body context real-env)) |
1647 |
|
new-env))) |
1648 |
|
(if block-name |
1649 |
|
(relist* |
1650 |
|
form let/let* block-name walked-bindings walked-body) |
1651 |
|
(relist* |
1652 |
|
form let/let* walked-bindings walked-body))))))) |
1653 |
|
|
1654 |
|
(defun walk-do/do* (form context old-env sequentialp) |
1655 |
|
(walker-environment-bind (new-env old-env) |
1656 |
|
(let* ((do/do* (car form)) |
1657 |
|
(bindings (cadr form)) |
1658 |
|
(end-test (caddr form)) |
1659 |
|
(body (cdddr form)) |
1660 |
|
(walked-bindings (walk-bindings-1 bindings |
1661 |
|
old-env |
1662 |
|
new-env |
1663 |
|
context |
1664 |
|
sequentialp)) |
1665 |
|
(walked-body |
1666 |
|
(walk-declarations body #'walk-repeat-eval new-env))) |
1667 |
|
(relist* form |
1668 |
|
do/do* |
1669 |
|
(walk-bindings-2 bindings walked-bindings context new-env) |
1670 |
|
(walk-template end-test '(test repeat (eval)) context new-env) |
1671 |
|
walked-body)))) |
1672 |
|
|
1673 |
|
(defun walk-let-if (form context env) |
1674 |
|
(let ((test (cadr form)) |
1675 |
|
(bindings (caddr form)) |
1676 |
|
(body (cdddr form))) |
1677 |
|
(walk-form-internal |
1678 |
|
`(let () |
1679 |
|
(declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x)) |
1680 |
|
bindings))) |
1681 |
|
(flet ((.let-if-dummy. () ,@body)) |
1682 |
|
(if ,test |
1683 |
|
(let ,bindings (.let-if-dummy.)) |
1684 |
|
(.let-if-dummy.)))) |
1685 |
|
context |
1686 |
|
env))) |
1687 |
|
|
1688 |
|
(defun walk-multiple-value-setq (form context env) |
1689 |
|
(let ((vars (cadr form))) |
1690 |
|
(if (some #'(lambda (var) |
1691 |
|
(variable-symbol-macro-p var env)) |
1692 |
|
vars) |
1693 |
|
(let* ((temps (mapcar #'(lambda (var) (declare (ignore var)) (gensym)) vars)) |
1694 |
|
(sets (mapcar #'(lambda (var temp) `(setq ,var ,temp)) vars temps)) |
1695 |
|
(expanded `(multiple-value-bind ,temps |
1696 |
|
,(caddr form) |
1697 |
|
,@sets)) |
1698 |
|
(walked (walk-form-internal expanded context env))) |
1699 |
|
(if (eq walked expanded) |
1700 |
|
form |
1701 |
|
walked)) |
1702 |
|
(walk-template form '(nil (repeat (set)) eval) context env)))) |
1703 |
|
|
1704 |
|
(defun walk-multiple-value-bind (form context old-env) |
1705 |
|
(walker-environment-bind (new-env old-env) |
1706 |
|
(let* ((mvb (car form)) |
1707 |
|
(bindings (cadr form)) |
1708 |
|
(mv-form (walk-template (caddr form) 'eval context old-env)) |
1709 |
|
(body (cdddr form)) |
1710 |
|
walked-bindings |
1711 |
|
(walked-body |
1712 |
|
(walk-declarations |
1713 |
|
body |
1714 |
|
#'(lambda (real-body real-env) |
1715 |
|
(setq walked-bindings |
1716 |
|
(walk-bindings-1 bindings |
1717 |
|
old-env |
1718 |
|
new-env |
1719 |
|
context |
1720 |
|
nil)) |
1721 |
|
(walk-repeat-eval real-body real-env)) |
1722 |
|
new-env))) |
1723 |
|
(relist* form mvb walked-bindings mv-form walked-body)))) |
1724 |
|
|
1725 |
|
(defun walk-bindings-1 (bindings old-env new-env context sequentialp) |
1726 |
|
(and bindings |
1727 |
|
(let ((binding (car bindings))) |
1728 |
|
(recons bindings |
1729 |
|
(if (symbolp binding) |
1730 |
|
(prog1 binding |
1731 |
|
(note-lexical-binding binding new-env)) |
1732 |
|
(prog1 (relist* binding |
1733 |
|
(car binding) |
1734 |
|
(walk-form-internal (cadr binding) |
1735 |
|
context |
1736 |
|
(if sequentialp |
1737 |
|
new-env |
1738 |
|
old-env)) |
1739 |
|
(cddr binding)) ;save cddr for DO/DO* |
1740 |
|
;it is the next value |
1741 |
|
;form. Don't walk it |
1742 |
|
;now though. |
1743 |
|
(note-lexical-binding (car binding) new-env))) |
1744 |
|
(walk-bindings-1 (cdr bindings) |
1745 |
|
old-env |
1746 |
|
new-env |
1747 |
|
context |
1748 |
|
sequentialp))))) |
1749 |
|
|
1750 |
|
(defun walk-bindings-2 (bindings walked-bindings context env) |
1751 |
|
(and bindings |
1752 |
|
(let ((binding (car bindings)) |
1753 |
|
(walked-binding (car walked-bindings))) |
1754 |
|
(recons bindings |
1755 |
|
(if (symbolp binding) |
1756 |
|
binding |
1757 |
|
(relist* binding |
1758 |
|
(car walked-binding) |
1759 |
|
(cadr walked-binding) |
1760 |
|
(walk-template (cddr binding) |
1761 |
|
'(eval) |
1762 |
|
context |
1763 |
|
env))) |
1764 |
|
(walk-bindings-2 (cdr bindings) |
1765 |
|
(cdr walked-bindings) |
1766 |
|
context |
1767 |
|
env))))) |
1768 |
|
|
1769 |
|
(defun walk-lambda (form context old-env) |
1770 |
|
(walker-environment-bind (new-env old-env) |
1771 |
|
(let* ((arglist (cadr form)) |
1772 |
|
(body (cddr form)) |
1773 |
|
(walked-arglist (walk-arglist arglist context new-env)) |
1774 |
|
(walked-body |
1775 |
|
(walk-declarations body #'walk-repeat-eval new-env))) |
1776 |
|
(relist* form |
1777 |
|
(car form) |
1778 |
|
walked-arglist |
1779 |
|
walked-body)))) |
1780 |
|
|
1781 |
|
(defun walk-named-lambda (form context old-env) |
1782 |
|
(walker-environment-bind (new-env old-env) |
1783 |
|
(let* ((name (cadr form)) |
1784 |
|
(arglist (caddr form)) |
1785 |
|
(body (cdddr form)) |
1786 |
|
(walked-arglist (walk-arglist arglist context new-env)) |
1787 |
|
(walked-body |
1788 |
|
(walk-declarations body #'walk-repeat-eval new-env))) |
1789 |
|
(relist* form |
1790 |
|
(car form) |
1791 |
|
name |
1792 |
|
walked-arglist |
1793 |
|
walked-body)))) |
1794 |
|
|
1795 |
|
(defun walk-setq (form context env) |
1796 |
|
(if (cdddr form) |
1797 |
|
(let* ((expanded (let ((rforms nil) |
1798 |
|
(tail (cdr form))) |
1799 |
|
(loop (when (null tail) (return (nreverse rforms))) |
1800 |
|
(let ((var (pop tail)) (val (pop tail))) |
1801 |
|
(push `(setq ,var ,val) rforms))))) |
1802 |
|
(walked (walk-repeat-eval expanded env))) |
1803 |
|
(if (eq expanded walked) |
1804 |
|
form |
1805 |
|
`(progn ,@walked))) |
1806 |
|
(let* ((var (cadr form)) |
1807 |
|
(val (caddr form)) |
1808 |
|
(symmac (car (variable-symbol-macro-p var env)))) |
1809 |
|
(if symmac |
1810 |
|
(let* ((expanded `(setf ,(cddr symmac) ,val)) |
1811 |
|
(walked (walk-form-internal expanded context env))) |
1812 |
|
(if (eq expanded walked) |
1813 |
|
form |
1814 |
|
walked)) |
1815 |
|
(relist form 'setq |
1816 |
|
(walk-form-internal var :set env) |
1817 |
|
(walk-form-internal val :eval env)))))) |
1818 |
|
|
1819 |
|
(defun walk-symbol-macrolet (form context old-env) |
1820 |
|
(declare (ignore context)) |
1821 |
|
(let* ((bindings (cadr form))) |
1822 |
|
(walker-environment-bind |
1823 |
|
(new-env old-env |
1824 |
|
:lexical-variables |
1825 |
|
(append (mapcar #'(lambda (binding) |
1826 |
|
`(,(car binding) |
1827 |
|
:macro . ,(cadr binding))) |
1828 |
|
bindings) |
1829 |
|
(env-lexical-variables old-env))) |
1830 |
|
(relist* form 'symbol-macrolet bindings |
1831 |
|
(walk-repeat-eval (cddr form) new-env))))) |
1832 |
|
|
1833 |
|
(defun walk-tagbody (form context env) |
1834 |
|
(recons form (car form) (walk-tagbody-1 (cdr form) context env))) |
1835 |
|
|
1836 |
|
(defun walk-tagbody-1 (form context env) |
1837 |
|
(and form |
1838 |
|
(recons form |
1839 |
|
(walk-form-internal (car form) |
1840 |
|
(if (symbolp (car form)) 'quote context) |
1841 |
|
env) |
1842 |
|
(walk-tagbody-1 (cdr form) context env)))) |
1843 |
|
|
1844 |
|
(defun walk-compiler-let (form context old-env) |
1845 |
|
(declare (ignore context)) |
1846 |
|
(let ((vars ()) |
1847 |
|
(vals ())) |
1848 |
|
(dolist (binding (cadr form)) |
1849 |
|
(cond ((symbolp binding) (push binding vars) (push nil vals)) |
1850 |
|
(t |
1851 |
|
(push (car binding) vars) |
1852 |
|
(push (eval (cadr binding)) vals)))) |
1853 |
|
(relist* form |
1854 |
|
(car form) |
1855 |
|
(cadr form) |
1856 |
|
(progv vars vals (walk-repeat-eval (cddr form) old-env))))) |
1857 |
|
|
1858 |
|
(defun walk-macrolet (form context old-env) |
1859 |
|
(walker-environment-bind (macro-env |
1860 |
|
nil |
1861 |
|
:walk-function (env-walk-function old-env)) |
1862 |
|
(labels ((walk-definitions (definitions) |
1863 |
|
(and definitions |
1864 |
|
(let ((definition (car definitions))) |
1865 |
|
(recons definitions |
1866 |
|
(relist* definition |
1867 |
|
(car definition) |
1868 |
|
(walk-arglist (cadr definition) |
1869 |
|
context |
1870 |
|
macro-env |
1871 |
|
t) |
1872 |
|
(walk-declarations (cddr definition) |
1873 |
|
#'walk-repeat-eval |
1874 |
|
macro-env)) |
1875 |
|
(walk-definitions (cdr definitions))))))) |
1876 |
|
(with-new-definition-in-environment (new-env old-env form) |
1877 |
|
(relist* form |
1878 |
|
(car form) |
1879 |
|
(walk-definitions (cadr form)) |
1880 |
|
(walk-declarations (cddr form) |
1881 |
|
#'walk-repeat-eval |
1882 |
|
new-env)))))) |
1883 |
|
|
1884 |
|
(defun walk-flet (form context old-env) |
1885 |
|
(labels ((walk-definitions (definitions) |
1886 |
|
(if (null definitions) |
1887 |
|
() |
1888 |
|
(recons definitions |
1889 |
|
(walk-lambda (car definitions) context old-env) |
1890 |
|
(walk-definitions (cdr definitions)))))) |
1891 |
|
(recons form |
1892 |
|
(car form) |
1893 |
|
(recons (cdr form) |
1894 |
|
(walk-definitions (cadr form)) |
1895 |
|
(with-new-definition-in-environment (new-env old-env form) |
1896 |
|
(walk-declarations (cddr form) |
1897 |
|
#'walk-repeat-eval |
1898 |
|
new-env)))))) |
1899 |
|
|
1900 |
|
(defun walk-labels (form context old-env) |
1901 |
|
(with-new-definition-in-environment (new-env old-env form) |
1902 |
|
(labels ((walk-definitions (definitions) |
1903 |
|
(if (null definitions) |
1904 |
|
() |
1905 |
|
(recons definitions |
1906 |
|
(walk-lambda (car definitions) context new-env) |
1907 |
|
(walk-definitions (cdr definitions)))))) |
1908 |
|
(recons form |
1909 |
|
(car form) |
1910 |
|
(recons (cdr form) |
1911 |
|
(walk-definitions (cadr form)) |
1912 |
|
(walk-declarations (cddr form) |
1913 |
|
#'walk-repeat-eval |
1914 |
|
new-env)))))) |
1915 |
|
|
1916 |
|
(defun walk-if (form context env) |
1917 |
|
(let ((predicate (cadr form)) |
1918 |
|
(arm1 (caddr form)) |
1919 |
|
(arm2 |
1920 |
|
(if (cddddr form) |
1921 |
|
(progn |
1922 |
|
(warn "In the form:~%~S~%~ |
1923 |
|
IF only accepts three arguments, you are using ~D.~%~ |
1924 |
|
It is true that some Common Lisps support this, but ~ |
1925 |
|
it is not~%~ |
1926 |
|
truly legal Common Lisp. For now, this code ~ |
1927 |
|
walker is interpreting ~%~ |
1928 |
|
the extra arguments as extra else clauses. ~ |
1929 |
|
Even if this is what~%~ |
1930 |
|
you intended, you should fix your source code." |
1931 |
|
form |
1932 |
|
(length (cdr form))) |
1933 |
|
(cons 'progn (cdddr form))) |
1934 |
|
(cadddr form)))) |
1935 |
|
(relist form |
1936 |
|
'if |
1937 |
|
(walk-form-internal predicate context env) |
1938 |
|
(walk-form-internal arm1 context env) |
1939 |
|
(walk-form-internal arm2 context env)))) |
1940 |
|
|
1941 |
|
|
1942 |
|
;;; |
1943 |
|
;;; Tests tests tests |
1944 |
|
;;; |
1945 |
|
|
1946 |
|
#| |
1947 |
|
;;; |
1948 |
|
;;; Here are some examples of the kinds of things you should be able to do |
1949 |
|
;;; with your implementation of the macroexpansion environment hacking |
1950 |
|
;;; mechanism. |
1951 |
|
;;; |
1952 |
|
;;; with-lexical-macros is kind of like macrolet, but it only takes names |
1953 |
|
;;; of the macros and actual macroexpansion functions to use to macroexpand |
1954 |
|
;;; them. The win about that is that for macros which want to wrap several |
1955 |
|
;;; macrolets around their body, they can do this but have the macroexpansion |
1956 |
|
;;; functions be compiled. See the WITH-RPUSH example. |
1957 |
|
;;; |
1958 |
|
;;; If the implementation had a special way of communicating the augmented |
1959 |
|
;;; environment back to the evaluator that would be totally great. It would |
1960 |
|
;;; mean that we could just augment the environment then pass control back |
1961 |
|
;;; to the implementations own compiler or interpreter. We wouldn't have |
1962 |
|
;;; to call the actual walker. That would make this much faster. Since the |
1963 |
|
;;; principal client of this is defmethod it would make compiling defmethods |
1964 |
|
;;; faster and that would certainly be a win. |
1965 |
|
;;; |
1966 |
|
(defmacro with-lexical-macros (macros &body body &environment old-env) |
1967 |
|
(with-augmented-environment (new-env old-env :macros macros) |
1968 |
|
(walk-form (cons 'progn body) :environment new-env))) |
1969 |
|
|
1970 |
|
(defun expand-rpush (form env) |
1971 |
|
`(push ,(caddr form) ,(cadr form))) |
1972 |
|
|
1973 |
|
(defmacro with-rpush (&body body) |
1974 |
|
`(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body)) |
1975 |
|
|
1976 |
|
|
1977 |
|
;;; |
1978 |
|
;;; Unfortunately, I don't have an automatic tester for the walker. |
1979 |
|
;;; Instead there is this set of test cases with a description of |
1980 |
|
;;; how each one should go. |
1981 |
|
;;; |
1982 |
|
(defmacro take-it-out-for-a-test-walk (form) |
1983 |
|
`(take-it-out-for-a-test-walk-1 ',form)) |
1984 |
|
|
1985 |
|
(defun take-it-out-for-a-test-walk-1 (form) |
1986 |
|
(terpri) |
1987 |
|
(terpri) |
1988 |
|
(let ((copy-of-form (copy-tree form)) |
1989 |
|
(result (walk-form form nil |
1990 |
|
#'(lambda (x y env) |
1991 |
|
(format t "~&Form: ~S ~3T Context: ~A" x y) |
1992 |
|
(when (symbolp x) |
1993 |
|
(let ((lexical (variable-lexical-p x env)) |
1994 |
|
(special (variable-special-p x env))) |
1995 |
|
(when lexical |
1996 |
|
(format t ";~3T") |
1997 |
|
(format t "lexically bound")) |
1998 |
|
(when special |
1999 |
|
(format t ";~3T") |
2000 |
|
(format t "declared special")) |
2001 |
|
(when (boundp x) |
2002 |
|
(format t ";~3T") |
2003 |
|
(format t "bound: ~S " (eval x))))) |
2004 |
|
x)))) |
2005 |
|
(cond ((not (equal result copy-of-form)) |
2006 |
|
(format t "~%Warning: Result not EQUAL to copy of start.")) |
2007 |
|
((not (eq result form)) |
2008 |
|
(format t "~%Warning: Result not EQ to copy of start."))) |
2009 |
|
(pprint result) |
2010 |
|
result)) |
2011 |
|
|
2012 |
|
(defmacro foo (&rest ignore) ''global-foo) |
2013 |
|
|
2014 |
|
(defmacro bar (&rest ignore) ''global-bar) |
2015 |
|
|
2016 |
|
(take-it-out-for-a-test-walk (list arg1 arg2 arg3)) |
2017 |
|
(take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5))) |
2018 |
|
|
2019 |
|
(take-it-out-for-a-test-walk (progn (foo) (bar 1))) |
2020 |
|
|
2021 |
|
(take-it-out-for-a-test-walk (block block-name a b c)) |
2022 |
|
(take-it-out-for-a-test-walk (block block-name (list a) b c)) |
2023 |
|
|
2024 |
|
(take-it-out-for-a-test-walk (catch catch-tag (list a) b c)) |
2025 |
|
;;; |
2026 |
|
;;; This is a fairly simple macrolet case. While walking the body of the |
2027 |
|
;;; macro, x should be lexically bound. In the body of the macrolet form |
2028 |
|
;;; itself, x should not be bound. |
2029 |
|
;;; |
2030 |
|
(take-it-out-for-a-test-walk |
2031 |
|
(macrolet ((foo (x) (list x) ''inner)) |
2032 |
|
x |
2033 |
|
(foo 1))) |
2034 |
|
|
2035 |
|
;;; |
2036 |
|
;;; A slightly more complex macrolet case. In the body of the macro x |
2037 |
|
;;; should not be lexically bound. In the body of the macrolet form itself |
2038 |
|
;;; x should be bound. Note that THIS CASE WILL CAUSE AN ERROR when it |
2039 |
|
;;; tries to macroexpand the call to foo. |
2040 |
|
;;; |
2041 |
|
(take-it-out-for-a-test-walk |
2042 |
|
(let ((x 1)) |
2043 |
|
(macrolet ((foo () (list x) ''inner)) |
2044 |
|
x |
2045 |
|
(foo)))) |
2046 |
|
|
2047 |
|
;;; |
2048 |
|
;;; A truly hairy use of compiler-let and macrolet. In the body of the |
2049 |
|
;;; macro x should not be lexically bound. In the body of the macrolet |
2050 |
|
;;; itself x should not be lexically bound. But the macro should expand |
2051 |
|
;;; into 1. |
2052 |
|
;;; |
2053 |
|
(take-it-out-for-a-test-walk |
2054 |
|
(compiler-let ((x 1)) |
2055 |
|
(let ((x 2)) |
2056 |
|
(macrolet ((foo () x)) |
2057 |
|
x |
2058 |
|
(foo))))) |
2059 |
|
|
2060 |
|
|
2061 |
|
(take-it-out-for-a-test-walk |
2062 |
|
(flet ((foo (x) (list x y)) |
2063 |
|
(bar (x) (list x y))) |
2064 |
|
(foo 1))) |
2065 |
|
|
2066 |
|
(take-it-out-for-a-test-walk |
2067 |
|
(let ((y 2)) |
2068 |
|
(flet ((foo (x) (list x y)) |
2069 |
|
(bar (x) (list x y))) |
2070 |
|
(foo 1)))) |
2071 |
|
|
2072 |
|
(take-it-out-for-a-test-walk |
2073 |
|
(labels ((foo (x) (bar x)) |
2074 |
|
(bar (x) (foo x))) |
2075 |
|
(foo 1))) |
2076 |
|
|
2077 |
|
(take-it-out-for-a-test-walk |
2078 |
|
(flet ((foo (x) (foo x))) |
2079 |
|
(foo 1))) |
2080 |
|
|
2081 |
|
(take-it-out-for-a-test-walk |
2082 |
|
(flet ((foo (x) (foo x))) |
2083 |
|
(flet ((bar (x) (foo x))) |
2084 |
|
(bar 1)))) |
2085 |
|
|
2086 |
|
(take-it-out-for-a-test-walk (compiler-let ((a 1) (b 2)) (foo a) b)) |
2087 |
|
(take-it-out-for-a-test-walk (prog () (declare (special a b)))) |
2088 |
|
(take-it-out-for-a-test-walk (let (a b c) |
2089 |
|
(declare (special a b)) |
2090 |
|
(foo a) b c)) |
2091 |
|
(take-it-out-for-a-test-walk (let (a b c) |
2092 |
|
(declare (special a) (special b)) |
2093 |
|
(foo a) b c)) |
2094 |
|
(take-it-out-for-a-test-walk (let (a b c) |
2095 |
|
(declare (special a)) |
2096 |
|
(declare (special b)) |
2097 |
|
(foo a) b c)) |
2098 |
|
(take-it-out-for-a-test-walk (let (a b c) |
2099 |
|
(declare (special a)) |
2100 |
|
(declare (special b)) |
2101 |
|
(let ((a 1)) |
2102 |
|
(foo a) b c))) |
2103 |
|
(take-it-out-for-a-test-walk (eval-when () |
2104 |
|
a |
2105 |
|
(foo a))) |
2106 |
|
(take-it-out-for-a-test-walk (eval-when (eval when load) |
2107 |
|
a |
2108 |
|
(foo a))) |
2109 |
|
|
2110 |
|
(take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b))) |
2111 |
|
(take-it-out-for-a-test-walk (multiple-value-bind (a b) |
2112 |
|
(foo a b) |
2113 |
|
(declare (special a)) |
2114 |
|
(list a b))) |
2115 |
|
(take-it-out-for-a-test-walk (progn (function foo))) |
2116 |
|
(take-it-out-for-a-test-walk (progn a b (go a))) |
2117 |
|
(take-it-out-for-a-test-walk (if a b c)) |
2118 |
|
(take-it-out-for-a-test-walk (if a b)) |
2119 |
|
(take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2)) |
2120 |
|
(take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b)) |
2121 |
|
1 2)) |
2122 |
|
(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c))) |
2123 |
|
(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c))) |
2124 |
|
(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) |
2125 |
|
(declare (special a b)) |
2126 |
|
(list a b c))) |
2127 |
|
(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) |
2128 |
|
(declare (special a b)) |
2129 |
|
(list a b c))) |
2130 |
|
(take-it-out-for-a-test-walk (let ((a 1) (b 2)) |
2131 |
|
(foo bar) |
2132 |
|
(declare (special a)) |
2133 |
|
(foo a b))) |
2134 |
|
(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c)) |
2135 |
|
(take-it-out-for-a-test-walk (multiple-value-prog1 a b c)) |
2136 |
|
(take-it-out-for-a-test-walk (progn a b c)) |
2137 |
|
(take-it-out-for-a-test-walk (progv vars vals a b c)) |
2138 |
|
(take-it-out-for-a-test-walk (quote a)) |
2139 |
|
(take-it-out-for-a-test-walk (return-from block-name a b c)) |
2140 |
|
(take-it-out-for-a-test-walk (setq a 1)) |
2141 |
|
(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3)) |
2142 |
|
(take-it-out-for-a-test-walk (tagbody a b c (go a))) |
2143 |
|
(take-it-out-for-a-test-walk (the foo (foo-form a b c))) |
2144 |
|
(take-it-out-for-a-test-walk (throw tag-form a)) |
2145 |
|
(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f)) |
2146 |
|
|
2147 |
|
(defmacro flet-1 (a b) ''outer) |
2148 |
|
(defmacro labels-1 (a b) ''outer) |
2149 |
|
|
2150 |
|
(take-it-out-for-a-test-walk |
2151 |
|
(flet ((flet-1 (a b) () (flet-1 a b) (list a b))) |
2152 |
|
(flet-1 1 2) |
2153 |
|
(foo 1 2))) |
2154 |
|
(take-it-out-for-a-test-walk |
2155 |
|
(labels ((label-1 (a b) () (label-1 a b)(list a b))) |
2156 |
|
(label-1 1 2) |
2157 |
|
(foo 1 2))) |
2158 |
|
(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b))) |
2159 |
|
(macrolet-1 a b) |
2160 |
|
(foo 1 2))) |
2161 |
|
|
2162 |
|
(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a))) |
2163 |
|
(foo 1))) |
2164 |
|
|
2165 |
|
(take-it-out-for-a-test-walk (progn (bar 1) |
2166 |
|
(macrolet ((bar (a) |
2167 |
|
`(inner-bar-expanded ,a))) |
2168 |
|
(bar 2)))) |
2169 |
|
|
2170 |
|
(take-it-out-for-a-test-walk (progn (bar 1) |
2171 |
|
(macrolet ((bar (s) |
2172 |
|
(bar s) |
2173 |
|
`(inner-bar-expanded ,s))) |
2174 |
|
(bar 2)))) |
2175 |
|
|
2176 |
|
(take-it-out-for-a-test-walk (cond (a b) |
2177 |
|
((foo bar) a (foo a)))) |
2178 |
|
|
2179 |
|
|
2180 |
|
(let ((the-lexical-variables ())) |
2181 |
|
(walk-form '(let ((a 1) (b 2)) |
2182 |
|
#'(lambda (x) (list a b x y))) |
2183 |
|
() |
2184 |
|
#'(lambda (form context env) |
2185 |
|
(when (and (symbolp form) |
2186 |
|
(variable-lexical-p form env)) |
2187 |
|
(push form the-lexical-variables)) |
2188 |
|
form)) |
2189 |
|
(or (and (= (length the-lexical-variables) 3) |
2190 |
|
(member 'a the-lexical-variables) |
2191 |
|
(member 'b the-lexical-variables) |
2192 |
|
(member 'x the-lexical-variables)) |
2193 |
|
(error "Walker didn't do lexical variables of a closure properly."))) |
2194 |
|
|
2195 |
|
|# |
2196 |
|
|
2197 |
|
() |
2198 |
|
|