/[gcl]/gcl/pcl/gcl_pcl_walk.lisp
ViewVC logotype

Diff of /gcl/pcl/gcl_pcl_walk.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Fri May 6 21:56:56 2005 UTC revision 1.2 by camm, Sat May 7 02:52:30 2005 UTC
# Line 0  Line 1 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26