home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part09 / walk.l
Encoding:
Text File  |  1987-08-01  |  32.6 KB  |  877 lines
  1. ;;;-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  5. ;;;
  6. ;;; Use and copying of this software and preparation of derivative works
  7. ;;; based upon this software are permitted.  Any distribution of this
  8. ;;; software or derivative works must comply with all applicable United
  9. ;;; States export control laws.
  10. ;;; 
  11. ;;; This software is made available AS IS, and Xerox Corporation makes no
  12. ;;; warranty about the software, its performance or its conformity to any
  13. ;;; specification.
  14. ;;; 
  15. ;;; Any person obtaining a copy of this software is requested to send their
  16. ;;; name and post office or electronic mail address to:
  17. ;;;   CommonLoops Coordinator
  18. ;;;   Xerox Artifical Intelligence Systems
  19. ;;;   2400 Hanover St.
  20. ;;;   Palo Alto, CA 94303
  21. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  22. ;;;
  23. ;;; Suggestions, comments and requests for improvements are also welcome.
  24. ;;; *************************************************************************
  25. ;;; 
  26. ;;; A simple code walker, based IN PART on: (roll the credits)
  27. ;;;   Larry Masinter's Masterscope
  28. ;;;   Moon's Common Lisp code walker
  29. ;;;   Gary Drescher's code walker
  30. ;;;   Larry Masinter's simple code walker
  31. ;;;   .
  32. ;;;   .
  33. ;;;   boy, thats fair (I hope).
  34. ;;;
  35. ;;; For now at least, this code walker really only does what PCL needs it to
  36. ;;; do.  Maybe it will grow up someday.
  37. ;;;
  38.  
  39. (in-package 'walker)
  40.  
  41. (export '(define-walker-template
  42.       walk-form
  43.       variable-lexical-p
  44.       variable-special-p
  45.       ))
  46.  
  47. ;;; *walk-function* is the function being called on each sub-form as we walk.
  48. ;;; Normally it is supplied using the :walk-function keyword argument to
  49. ;;; walk-form, but it is OK to bind it around a call to walk-form-internal.
  50. (defvar *walk-function*)
  51.  
  52. ;;; *walk-form* is used by the IF template.  When the first argument to the
  53. ;;; if template is a list it will be evaluated with *walk-form* bound to the 
  54. ;;; form currently being walked.
  55. (defvar *walk-form*)
  56.  
  57. ;;; *declarations* is a list of the declarations currently in effect.
  58. (defvar *declarations*)
  59.     
  60. ;;; *lexical-variables* is a list of the variables bound in the current
  61. ;;; contour. In *lexical-variables* the cons whose car is the variable is
  62. ;;; meaningful in the sense that the cons whose car is the variable can be
  63. ;;; used to keep track of which contour the variable is bound in.
  64. ;;;
  65. ;;; Now isn't that just the cats pajamas.
  66. ;;;
  67. (defvar *lexical-variables*)
  68.  
  69. ;;; An environment of the kind that macroexpand-1 gets as its second
  70. ;;; argument.  In fact, that is exactly where it comes from.  This is kind of
  71. ;;; kludgy since Common Lisp is somewhat screwed up in this respect.
  72. ;;; Hopefully Common Lisp will fix this soon.  For more info see:
  73. ;;; MAKE-LEXICAL-ENVIRONMENT
  74. (defvar *environment*)
  75.  
  76. ;;;
  77. ;;; With new contour is used to enter a new lexical binding contour which
  78. ;;; inherits from the exisiting one.  I admit that using with-new-contour is
  79. ;;; often overkill.  It would suffice for the the walker to rebind
  80. ;;; *lexical-variables* and *declarations* when walking LET and rebind
  81. ;;; *environment* and *declarations* when walking MACROLET etc.
  82. ;;; WITH-NEW-CONTOUR is much more convenient and just as correct.
  83. ;;; 
  84. (defmacro with-new-contour (&body body)
  85.   `(let ((*declarations* ())            ;If Common Lisp got an
  86.                         ;unspecial declaration
  87.                         ;this would need to be
  88.                         ;re-worked.
  89.          (*lexical-variables* *lexical-variables*)
  90.          (*environment* *environment*))
  91.      . ,body))
  92.  
  93. (defmacro note-lexical-binding (thing)
  94.   `(push ,thing *lexical-variables*))
  95.  
  96. (defmacro note-declaration (declaration)
  97.   `(push ,declaration *declarations*))
  98.  
  99.  
  100. (defun variable-lexically-boundp (var)
  101.   (if (not (boundp '*walk-function*))
  102.       :unsure
  103.       (values (member var *lexical-variables* :test (function eq))
  104.           (variable-special-p var) 't)))
  105.  
  106. (defun variable-lexical-p (var)
  107.   (if (not (boundp '*walk-function*))
  108.       :unsure
  109.       (and (not (eq (variable-special-p var) 't))
  110.        (member var *lexical-variables* :test (function eq)))))
  111.  
  112. (defun variable-special-p (var)
  113.   (if (not (boundp '*walk-function*))
  114.       (or (variable-globally-special-p var) :unsure)
  115.       (or (dolist (decl *declarations*)
  116.         (and (eq (car decl) 'special)
  117.          (member var (cdr decl) :test #'eq)
  118.          (return t)))
  119.       (variable-globally-special-p var))))
  120.  
  121. ;;;
  122. ;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been
  123. ;;; declared globally special.  Any particular CommonLisp implementation
  124. ;;; should customize this function accordingly and send their customization
  125. ;;; back.
  126. ;;;
  127. ;;; The default version of variable-globally-special-p is probably pretty
  128. ;;; slow, so it uses *globally-special-variables* as a cache to remember
  129. ;;; variables that it has already figured out are globally special.
  130. ;;;
  131. ;;; This would need to be reworked if an unspecial declaration got added to
  132. ;;; Common Lisp.
  133. ;;;
  134. ;;; Common Lisp nit:
  135. ;;;   variable-globally-special-p should be defined in Common Lisp.
  136. ;;;
  137. #-(or Symbolics Xerox TI VaxLisp KCL LMI excl)
  138. (defvar *globally-special-variables* ())
  139.  
  140. (defun variable-globally-special-p (symbol)
  141.   #+Symbolics                   (si:special-variable-p symbol)
  142.   #+(or Lucid TI LMI)           (get symbol 'special)
  143.   #+Xerox                       (il:variable-globally-special-p symbol)
  144.   #+VaxLisp                     (get symbol 'system::globally-special)
  145.   #+KCL                    (si:specialp symbol)
  146.   #+excl                        (get symbol 'excl::.globally-special.)
  147.   #+HP                          (member (get symbol 'impl:vartype)
  148.                     '(impl:fluid impl:global)
  149.                     :test #'eq)
  150.   #-(or Symbolics Lucid TI LMI Xerox VaxLisp KCL excl HP)
  151.   (or (not (null (member symbol *globally-special-variables* :test #'eq)))
  152.       (when (eval `(flet ((ref () ,symbol))
  153.              (let ((,symbol '#,(list nil)))
  154.                (and (boundp ',symbol) (eq ,symbol (ref))))))
  155.     (push symbol *globally-special-variables*)
  156.     t)))
  157.  
  158.  
  159.   ;;   
  160. ;;;;;; Handling of special forms (the infamous 24).
  161.   ;;
  162. ;;;
  163. ;;; and I quote...
  164. ;;; 
  165. ;;;     The set of special forms is purposely kept very small because
  166. ;;;     any program analyzing program (read code walker) must have
  167. ;;;     special knowledge about every type of special form. Such a
  168. ;;;     program needs no special knowledge about macros...
  169. ;;;
  170. ;;; So all we have to do here is a define a way to store and retrieve
  171. ;;; templates which describe how to walk the 24 special forms and we are all
  172. ;;; set...
  173. ;;;
  174. ;;; Well, its a nice concept, and I have to admit to being naive enough that
  175. ;;; I believed it for a while, but not everyone takes having only 24 special
  176. ;;; forms as seriously as might be nice.  There are (at least) 3 ways to
  177. ;;; lose:
  178. ;;
  179. ;;;   1 - Implementation x implements a Common Lisp special form as a macro
  180. ;;;       which expands into a special form which:
  181. ;;;         - Is a common lisp special form (not likely)
  182. ;;;         - Is not a common lisp special form (on the 3600 IF --> COND).
  183. ;;;
  184. ;;;     * We can safe ourselves from this case (second subcase really) by
  185. ;;;       checking to see if there is a template defined for something
  186. ;;;       before we check to see if we we can macroexpand it.
  187. ;;;
  188. ;;;   2 - Implementation x implements a Common Lisp macro as a special form.
  189. ;;;
  190. ;;;     * This is a screw, but not so bad, we save ourselves from it by
  191. ;;;       defining extra templates for the macros which are *likely* to
  192. ;;;       be implemented as special forms.  (DO, DO* ...)
  193. ;;;
  194. ;;;   3 - Implementation x has a special form which is not on the list of
  195. ;;;       Common Lisp special forms.
  196. ;;;
  197. ;;;     * This is a bad sort of a screw and happens more than I would like
  198. ;;;       to think, especially in the implementations which provide more
  199. ;;;       than just Common Lisp (3600, Xerox etc.).
  200. ;;;       The fix is not terribly staisfactory, but will have to do for
  201. ;;;       now.  There is a hook in get walker-template which can get a
  202. ;;;       template from the implementation's own walker.  That template
  203. ;;;       has to be converted, and so it may be that the right way to do
  204. ;;;       this would actually be for that implementation to provide an
  205. ;;;       interface to its walker which looks like the interface to this
  206. ;;;       walker.
  207. ;;;
  208. (defmacro get-walker-template-internal (x)
  209.   `(get ,x 'walker-template))
  210.  
  211. (defun get-walker-template (x)
  212.   (cond ((symbolp x)
  213.      (or (get-walker-template-internal x)
  214.          (get-implementation-dependent-walker-template x)))
  215.     ((and (listp x) (eq (car x) 'lambda))
  216.      '(lambda repeat (eval)))
  217.     ((and (listp x) (eq (car x) 'lambda))
  218.      '(call repeat (eval)))))
  219.  
  220. (defun get-implementation-dependent-walker-template (x)
  221.   (declare (ignore x))
  222.   ())
  223.  
  224. (eval-when (compile load eval)
  225. (defmacro define-walker-template (name template)
  226.   `(eval-when (load eval)
  227.      (setf (get-walker-template-internal ',name) ',template)))
  228. )
  229.  
  230.  
  231.   ;;   
  232. ;;;;;; The actual templates
  233.   ;;   
  234.  
  235. (define-walker-template BLOCK                (NIL NIL REPEAT (EVAL)))
  236. (define-walker-template CATCH                (NIL EVAL REPEAT (EVAL)))
  237. (define-walker-template COMPILER-LET         walk-compiler-let)
  238. (define-walker-template DECLARE              walk-unexpected-declare)
  239. (define-walker-template EVAL-WHEN            (NIL QUOTE REPEAT (EVAL)))
  240. (define-walker-template FLET                 walk-flet/labels)
  241. (define-walker-template FUNCTION             (NIL CALL))
  242. (define-walker-template GO                   (NIL QUOTE))
  243. (define-walker-template IF                   (NIL TEST RETURN RETURN))
  244. (define-walker-template LABELS               walk-flet/labels)
  245. (define-walker-template LAMBDA               walk-lambda)
  246. (define-walker-template LET                  walk-let)
  247. (define-walker-template LET*                 walk-let*)
  248. (define-walker-template MACROLET             walk-macrolet)
  249. (define-walker-template MULTIPLE-VALUE-CALL  (NIL EVAL REPEAT (EVAL)))
  250. (define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL)))
  251. (define-walker-template MULTIPLE-VALUE-SETQ  (NIL (REPEAT (SET)) EVAL))
  252. (define-walker-template PROGN                (NIL REPEAT (EVAL)))
  253. (define-walker-template PROGV                (NIL EVAL EVAL REPEAT (EVAL)))
  254. (define-walker-template QUOTE                (NIL QUOTE))
  255. (define-walker-template RETURN-FROM          (NIL QUOTE REPEAT (RETURN)))
  256. (define-walker-template SETQ                 (NIL REPEAT (SET EVAL)))
  257. (define-walker-template TAGBODY              walk-tagbody)
  258. (define-walker-template THE                  (NIL QUOTE EVAL))
  259. (define-walker-template THROW                (NIL EVAL EVAL))
  260. (define-walker-template UNWIND-PROTECT       (NIL RETURN REPEAT (EVAL)))
  261.  
  262. ;;; The new special form.
  263. ;(define-walker-template pcl::LOAD-TIME-EVAL       (NIL EVAL))
  264.  
  265. ;;;
  266. ;;; And the extra templates...
  267. ;;;
  268. (define-walker-template DO      walk-do)
  269. (define-walker-template DO*     walk-do*)
  270. (define-walker-template PROG    walk-let)
  271. (define-walker-template PROG*   walk-let*)
  272. (define-walker-template COND    (NIL REPEAT ((TEST REPEAT (EVAL)))))
  273.  
  274.  
  275.   ;;   
  276. ;;;;;; WALK-FORM
  277.   ;;   
  278. ;;;
  279. ;;; The main entry-point is walk-form, calls back in should use walk-form-internal.
  280. ;;; 
  281.  
  282. (defun walk-form (form &key ((:declarations *declarations*) ())
  283.                 ((:lexical-variables *lexical-variables*) ())
  284.                 ((:environment *environment*) ())
  285.                 ((:walk-function *walk-function*) #'(lambda (x y)
  286.                                   y x)))
  287.   (walk-form-internal form 'eval))
  288.  
  289. ;;;
  290. ;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It
  291. ;;; takes a form and the current context and walks the form calling itself or
  292. ;;; the appropriate template recursively.
  293. ;;;
  294. ;;;   "It is recommended that a program-analyzing-program process a form
  295. ;;;    that is a list whose car is a symbol as follows:
  296. ;;;
  297. ;;;     1. If the program has particular knowledge about the symbol,
  298. ;;;        process the form using special-purpose code.  All of the
  299. ;;;        standard special forms should fall into this category.
  300. ;;;     2. Otherwise, if macro-function is true of the symbol apply
  301. ;;;        either macroexpand or macroexpand-1 and start over.
  302. ;;;     3. Otherwise, assume it is a function call. "
  303. ;;;     
  304.  
  305. (defun walk-form-internal (form context
  306.                &aux newform newnewform
  307.                 walk-no-more-p macrop
  308.                 fn template)
  309.   ;; First apply the *walk-function* to perform whatever translation
  310.   ;; the user wants to to this form.  If the second value returned
  311.   ;; by *walk-function* is T then we don't recurse...
  312.   (multiple-value-setq (newform walk-no-more-p)
  313.     (funcall *walk-function* form context))
  314.   (cond (walk-no-more-p newform)
  315.     ((not (eq form newform)) (walk-form-internal newform context))
  316.     ((not (consp newform)) newform)
  317.     ((setq template (get-walker-template (setq fn (car newform))))
  318.          (if (symbolp template)
  319.              (funcall template newform context)
  320.              (walk-template newform template context)))
  321.     ((progn (multiple-value-setq (newnewform macrop)
  322.           (macroexpand-1 newform *environment*))
  323.         macrop)
  324.      (walk-form-internal newnewform context))
  325.     ((and (symbolp fn)
  326.           (not (fboundp fn))
  327.           (special-form-p fn))
  328.      (error
  329.        "~S is a special form, not defined in the CommonLisp manual.~%~
  330.             This code walker doesn't know how to walk it.  Please define a~%~
  331.             template for this special form and try again."
  332.        fn))
  333.     (t
  334.          ;; Otherwise, walk the form as if its just a standard function
  335.          ;; call using a template for standard function call.
  336.          (walk-template newform '(call repeat (eval)) context))))
  337.  
  338. (defun walk-template (form template context)
  339.   (if (atom template)
  340.       (ecase template
  341.         ((QUOTE NIL) form)
  342.         ((EVAL FUNCTION TEST EFFECT RETURN)
  343.          (walk-form-internal form :EVAL))
  344.         (SET
  345.           (walk-form-internal form :SET))
  346.         ((LAMBDA CALL)
  347.      (if (symbolp form)
  348.          form
  349.          (walk-lambda form context))))
  350.       (case (car template)
  351.         (IF
  352.           (let ((*walk-form* form))
  353.             (walk-template form
  354.                (if (if (listp (cadr template))
  355.                    (eval (cadr template))
  356.                    (funcall (cadr template) form))
  357.                    (caddr template)
  358.                    (cadddr template))
  359.                context)))
  360.         (REPEAT
  361.           (walk-template-handle-repeat form
  362.                                        (cdr template)
  363.                        ;; For the case where nothing happens
  364.                        ;; after the repeat optimize out the
  365.                        ;; call to length.
  366.                        (if (null (cddr template))
  367.                        ()
  368.                        (nthcdr (- (length form)
  369.                               (length
  370.                             (cddr template)))
  371.                            form))
  372.                                        context))
  373.         (REMOTE
  374.           (walk-template form (cadr template) context))
  375.         (otherwise
  376.           (cond ((atom form) form)
  377.                 (t (recons form
  378.                            (walk-template
  379.                  (car form) (car template) context)
  380.                            (walk-template
  381.                  (cdr form) (cdr template) context))))))))
  382.  
  383. (defun walk-template-handle-repeat (form template stop-form context)
  384.   (if (eq form stop-form)
  385.       (walk-template form (cdr template) context)
  386.       (walk-template-handle-repeat-1 form
  387.                      template
  388.                      (car template)
  389.                      stop-form
  390.                      context)))
  391.  
  392. (defun walk-template-handle-repeat-1 (form template repeat-template
  393.                        stop-form context)
  394.   (cond ((null form) ())
  395.         ((eq form stop-form)
  396.          (if (null repeat-template)
  397.              (walk-template stop-form (cdr template) context)       
  398.              (error "While handling repeat:
  399.                      ~%~Ran into stop while still in repeat template.")))
  400.         ((null repeat-template)
  401.          (walk-template-handle-repeat-1
  402.        form template (car template) stop-form context))
  403.         (t
  404.          (recons form
  405.                  (walk-template (car form) (car repeat-template) context)
  406.                  (walk-template-handle-repeat-1 (cdr form)
  407.                         template
  408.                         (cdr repeat-template)
  409.                         stop-form
  410.                         context)))))
  411.  
  412. (defun recons (x car cdr)
  413.   (if (or (not (eq (car x) car))
  414.           (not (eq (cdr x) cdr)))
  415.       (cons car cdr)
  416.       x))
  417.  
  418. (defun relist* (x &rest args)
  419.   (relist*-internal x args))
  420.  
  421. (defun relist*-internal (x args)
  422.   (if (null (cdr args))
  423.       (car args)
  424.       (recons x (car args) (relist*-internal (cdr x) (cdr args)))))
  425.  
  426.  
  427.   ;;   
  428. ;;;;;; Special walkers
  429.   ;;
  430.  
  431. (defun walk-declarations (body fn
  432.                    &optional doc-string-p declarations old-body
  433.                    &aux (form (car body)))
  434.   (cond ((and (stringp form)            ;might be a doc string
  435.               (cdr body)            ;isn't the returned value
  436.               (null doc-string-p)        ;no doc string yet
  437.               (null declarations))        ;no declarations yet
  438.          (recons body
  439.                  form
  440.                  (walk-declarations (cdr body) fn t)))
  441.         ((and (listp form) (eq (car form) 'declare))
  442.          ;; Got ourselves a real live declaration.  Record it, look for more.
  443.          (dolist (declaration (cdr form))
  444.            (note-declaration declaration)
  445.            (push declaration declarations))
  446.          (recons body
  447.                  form
  448.                  (walk-declarations
  449.            (cdr body) fn doc-string-p declarations)))
  450.         ((and form
  451.           (listp form)
  452.           (null (get-walker-template (car form)))
  453.           (not (eq form (setq form (macroexpand-1 form *environment*)))))
  454.          ;; When we macroexpanded this form we got something else back.
  455.          ;; Maybe this is a macro which expanded into a declare?
  456.      ;; Recurse to find out.
  457.          (walk-declarations
  458.        (cons form (cdr body)) fn doc-string-p declarations (or old-body
  459.                                    body)))
  460.         (t
  461.          ;; Now that we have walked and recorded the declarations, call the
  462.      ;; function our caller provided to expand the body.  We call that
  463.      ;; function rather than passing the real-body back, because we are
  464.      ;; RECONSING up the new body.
  465.          (funcall fn (or old-body body)))))
  466.  
  467. (defun fix-lucid-1.2 (x) x)
  468.  
  469. (defun walk-unexpected-declare (form context)
  470.   (declare (ignore context))
  471.   (warn "Encountered declare ~S in a place where a declare was not expected."
  472.     form)
  473.   form)
  474.  
  475. (defun walk-arglist (arglist context &optional (destructuringp nil) &aux arg)
  476.   (cond ((null arglist) ())
  477.         ((symbolp (setq arg (car arglist)))
  478.          (or (member arg lambda-list-keywords :test #'eq)
  479.              (note-lexical-binding arg))
  480.          (recons arglist
  481.                  arg
  482.                  (walk-arglist (cdr arglist)
  483.                                context
  484.                                (and destructuringp
  485.                     (not (member arg lambda-list-keywords
  486.                          :test #'eq))))))
  487.         ((consp arg)
  488.          (prog1 (if destructuringp
  489.                     (walk-arglist arg context destructuringp)
  490.                     (recons arglist
  491.                             (relist* arg
  492.                                      (car arg)
  493.                                      (walk-form-internal (cadr arg) 'eval)
  494.                                      (cddr arg))
  495.                             (walk-arglist (cdr arglist) context nil)))
  496.                 (if (symbolp (car arg))
  497.                     (note-lexical-binding (car arg))
  498.                     (note-lexical-binding (cadar arg)))
  499.                 (or (null (cddr arg))
  500.                     (not (symbolp (caddr arg)))
  501.                     (note-lexical-binding arg))))
  502.           (t
  503.        (error "Can't understand something in the arglist ~S" arglist))))
  504.  
  505. (defun walk-let (form context)
  506.   (walk-let/let* form context nil))
  507.  
  508. (defun walk-let* (form context)
  509.   (walk-let/let* form context t))
  510.  
  511. (defun walk-do (form context)
  512.   (walk-do/do* form context nil))
  513.  
  514. (defun walk-do* (form context)
  515.   (walk-do/do* form context t))
  516.  
  517. (defun walk-let/let* (form context sequentialp)
  518.   (let ((old-declarations *declarations*)
  519.     (old-lexical-variables *lexical-variables*))
  520.     (with-new-contour
  521.       (let* ((let/let* (car form))
  522.              (bindings (cadr form))
  523.              (body (cddr form))
  524.              walked-bindings
  525.              (walked-body
  526.                (walk-declarations 
  527.                  body
  528.                  #'(lambda (real-body)
  529.                      (setq walked-bindings
  530.                            (walk-bindings-1 bindings
  531.                         old-declarations
  532.                         old-lexical-variables
  533.                         context
  534.                         sequentialp))
  535.                      (walk-template real-body '(repeat (eval)) context)))))
  536.         (relist*
  537.       form let/let* (fix-lucid-1.2 walked-bindings) walked-body)))))
  538.  
  539. (defun walk-do/do* (form context sequentialp)
  540.   (let ((old-declarations *declarations*)
  541.     (old-lexical-variables *lexical-variables*))
  542.     (with-new-contour
  543.       (let* ((do/do* (car form))
  544.              (bindings (cadr form))
  545.              (end-test (caddr form))
  546.              (body (cdddr form))
  547.              walked-bindings
  548.              (walked-body
  549.                (walk-declarations
  550.                  body
  551.                  #'(lambda (real-body)
  552.                      (setq walked-bindings
  553.                            (walk-bindings-1 bindings
  554.                         old-declarations
  555.                         old-lexical-variables
  556.                         context
  557.                         sequentialp))
  558.                      (walk-template real-body '(repeat (eval)) context)))))
  559.         (relist* form
  560.                  do/do*
  561.                  (walk-bindings-2 bindings walked-bindings context)
  562.                  (walk-template end-test '(test repeat (eval)) context)
  563.                  walked-body)))))
  564.                             
  565. (defun walk-bindings-1 (bindings old-declarations old-lexical-variables
  566.                  context sequentialp)
  567.   (and bindings
  568.        (let ((binding (car bindings)))
  569.          (recons bindings
  570.                  (if (symbolp binding)
  571.                      (prog1 binding
  572.                             (note-lexical-binding binding))
  573.                      (prog1 (let ((*declarations* old-declarations)
  574.                   (*lexical-variables*
  575.                     (if sequentialp
  576.                     *lexical-variables*
  577.                     old-lexical-variables)))
  578.                               (relist* binding
  579.                                        (car binding)
  580.                                        (walk-form-internal (cadr binding)
  581.                                context)
  582.                                        (cddr binding)))    ;save cddr for DO/DO*
  583.                                 ;it is the next value
  584.                                 ;form. Don't walk it
  585.                                 ;now though.
  586.                             (note-lexical-binding (car binding))))
  587.                  (walk-bindings-1 (cdr bindings)
  588.                   old-declarations old-lexical-variables
  589.                   context sequentialp)))))
  590.  
  591. (defun walk-bindings-2 (bindings walked-bindings context)
  592.   (and bindings
  593.        (let ((binding (car bindings))
  594.              (walked-binding (car walked-bindings)))
  595.          (recons bindings
  596.          (if (symbolp binding)
  597.              binding
  598.              (relist* binding
  599.                   (car walked-binding)
  600.                   (cadr walked-binding)
  601.                   (walk-template (cddr binding) '(eval) context)))         
  602.                  (walk-bindings-2 (cdr bindings)
  603.                   (cdr walked-bindings)
  604.                   context)))))
  605.  
  606. (defun walk-lambda (form context)
  607.   (with-new-contour    
  608.     (let* ((arglist (cadr form))
  609.            (body (cddr form))
  610.            (walked-arglist nil)
  611.            (walked-body
  612.              (walk-declarations body
  613.            #'(lambda (real-body)
  614.            (setq walked-arglist (walk-arglist arglist context))
  615.            (walk-template real-body '(repeat (eval)) context)))))
  616.       (relist* form
  617.                (car form)
  618.                (fix-lucid-1.2 walked-arglist)
  619.                walked-body))))
  620.  
  621. (defun walk-tagbody (form context)
  622.   (recons form (car form) (walk-tagbody-1 (cdr form) context)))
  623.  
  624. (defun walk-tagbody-1 (form context)
  625.   (and form
  626.        (recons form
  627.                (walk-form-internal (car form)
  628.                    (if (symbolp (car form)) 'quote context))
  629.                (walk-tagbody-1 (cdr form) context))))
  630.  
  631. (defun walk-compiler-let (form context)
  632.   (with-new-contour
  633.     (let ((vars ())
  634.       (vals ()))
  635.       (dolist (binding (cadr form))
  636.     (cond ((symbolp binding) (push binding vars) (push nil vals))
  637.           (t
  638.            (push (car binding) vars)
  639.            (push (eval (cadr binding)) vals))))
  640.       (relist* form
  641.                (car form)
  642.                (cadr form)
  643.                (progv vars vals
  644.                  (note-declaration (cons 'special vars))
  645.                  (walk-template (cddr form) '(repeat (eval)) context))))))
  646.  
  647. (defun walk-macrolet (form context)
  648.   (labels ((walk-definitions (definitions)
  649.              (and (not (null definitions))
  650.                   (let ((definition (car definitions)))
  651.                     (recons definitions
  652.                             (with-new-contour
  653.                               (relist* definition
  654.                                        (car definition)
  655.                                        (walk-arglist (cadr definition)
  656.                              context t)
  657.                                        (walk-declarations (cddr definition)
  658.                      #'(lambda (real-body)
  659.                          (walk-template
  660.                            real-body
  661.                            '(repeat (eval))
  662.                            context)))))
  663.                             (walk-definitions (cdr definitions)))))))
  664.     (with-new-contour
  665.       (relist* form
  666.                (car form)
  667.                (walk-definitions (cadr form))
  668.                (progn (setq *environment*
  669.                 (make-lexical-environment form *environment*))
  670.                       (walk-declarations (cddr form)
  671.             #'(lambda (real-body)
  672.                 (walk-template real-body
  673.                             '(repeat (eval))
  674.                             context))))))))
  675.  
  676. (defun walk-flet/labels (form context)
  677.   (with-new-contour
  678.     (labels ((walk-definitions (definitions)
  679.                (if (null definitions)
  680.                    ()
  681.                    (recons definitions
  682.                            (walk-lambda (car definitions) context)
  683.                            (walk-definitions (cdr definitions)))))
  684.              (update-environment ()
  685.                (setq *environment*
  686.              (make-lexical-environment form *environment*))))
  687.       (relist* form
  688.                (car form)
  689.                (ecase (car form)
  690.                  (flet
  691.                    (prog1 (walk-definitions (cadr form))
  692.                           (update-environment)))
  693.                  (labels
  694.                    (update-environment)
  695.                    (walk-definitions (cadr form))))
  696.                (walk-declarations (cddr form)
  697.          #'(lambda (real-body)
  698.              (walk-template real-body '(repeat (eval)) context)))))))
  699.  
  700. ;;; make-lexical-environemnt is kind of gross.  It would be less gross if
  701. ;;; EVAL took an environment argument.
  702. ;;;
  703. ;;; Common Lisp nit:
  704. ;;;    if Common Lisp should provide mechanisms for playing with
  705. ;;;    environments explicitly.  making them, finding out what
  706. ;;;    functions are bound in them etc.  Maybe compile should
  707. ;;;    take an environment argument too?
  708. ;;;    
  709.  
  710. (defun make-lexical-environment (macrolet/flet/labels-form environment)
  711.   (evalhook (list (car macrolet/flet/labels-form)
  712.                   (cadr macrolet/flet/labels-form)
  713.                   (list 'make-lexical-environment-2))
  714.             'make-lexical-environment-1
  715.             ()
  716.             environment))
  717.  
  718. (defun make-lexical-environment-1 (form env)
  719.   (setq form (macroexpand form #-excl env
  720.                    #+excl (cadr env)))
  721.   (evalhook form  'make-lexical-environment-1 nil env))
  722.  
  723. (defmacro make-lexical-environment-2 (&environment env)
  724.   (list 'quote (copy-tree env)))
  725.  
  726.   ;;   
  727. ;;;;;; Tests tests tests
  728.   ;;
  729.  
  730. #|
  731.  
  732. (defmacro take-it-out-for-a-test-walk (form)
  733.   `(progn 
  734.      (terpri)
  735.      (terpri)
  736.      (let ((copy-of-form (copy-tree ',form))
  737.            (result (walk-form ',form :walk-function
  738.                               '(lambda (x y)
  739.                                  (format t "~&Form: ~S ~3T Context: ~A" x y)
  740.                                  (when (symbolp x)
  741.                    (multiple-value-bind (lexical special)
  742.                        (variable-lexically-boundp x)
  743.                                      (when lexical
  744.                                        (format t ";~3T")
  745.                                        (format t "lexically bound"))
  746.                                      (when special
  747.                                        (format t ";~3T")
  748.                                        (format t "declared special"))
  749.                                      (when (boundp x)
  750.                                        (format t ";~3T")
  751.                                        (format t "bound: ~S " (eval x)))))
  752.                                  x))))
  753.        (cond ((not (equal result copy-of-form))
  754.               (format t "~%Warning: Result not EQUAL to copy of start."))
  755.              ((not (eq result ',form))
  756.               (format t "~%Warning: Result not EQ to copy of start.")))
  757.        (#+Symbolics zl:grind-top-level
  758.         #-Symbolics print
  759.                                   result)
  760.        result)))
  761.  
  762. (defun foo (&rest ignore) ())
  763.  
  764. (defmacro bar (x) `'(global-bar-expanded ,x))
  765.  
  766. (defun baz (&rest ignore) ())
  767.  
  768. (take-it-out-for-a-test-walk (foo arg1 arg2 arg3))
  769. (take-it-out-for-a-test-walk (foo (baz 1 2) (baz 3 4 5)))
  770.  
  771. (take-it-out-for-a-test-walk (block block-name a b c))
  772. (take-it-out-for-a-test-walk (block block-name (foo a) b c))
  773.  
  774. (take-it-out-for-a-test-walk (catch catch-tag (foo a) b c))
  775. (take-it-out-for-a-test-walk (compiler-let ((a 1) (b 2)) (foo a) b))
  776. (take-it-out-for-a-test-walk (prog () (declare (special a b))))
  777. (take-it-out-for-a-test-walk (let (a b c)
  778.                                (declare (special a b))
  779.                                (foo a) b c))
  780. (take-it-out-for-a-test-walk (let (a b c)
  781.                                (declare (special a) (special b))
  782.                                (foo a) b c))
  783. (take-it-out-for-a-test-walk (let (a b c)
  784.                                (declare (special a))
  785.                                (declare (special b))
  786.                                (foo a) b c))
  787. (take-it-out-for-a-test-walk (let (a b c)
  788.                                (declare (special a))
  789.                                (declare (special b))
  790.                                (let ((a 1))
  791.                                  (foo a) b c)))
  792. (take-it-out-for-a-test-walk (eval-when ()
  793.                                a
  794.                                (foo a)))
  795. (take-it-out-for-a-test-walk (eval-when (eval when load)
  796.                                a
  797.                                (foo a)))
  798. (take-it-out-for-a-test-walk (progn (function foo)))
  799. (take-it-out-for-a-test-walk (progn a b (go a)))
  800. (take-it-out-for-a-test-walk (if a b c))
  801. (take-it-out-for-a-test-walk (if a b))
  802. (take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))
  803. (take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b))
  804.                   1 2))
  805. (take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c)))
  806. (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))
  807. (take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
  808.                                (declare (special a b))
  809.                                (list a b c)))
  810. (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
  811.                                (declare (special a b))
  812.                                (list a b c)))
  813. (take-it-out-for-a-test-walk (let ((a 1) (b 2))
  814.                                (foo bar)
  815.                                (declare (special a))
  816.                                (foo a b)))
  817. (take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))
  818. (take-it-out-for-a-test-walk (multiple-value-prog1 a b c))
  819. (take-it-out-for-a-test-walk (progn a b c))
  820. (take-it-out-for-a-test-walk (progv vars vals a b c))
  821. (take-it-out-for-a-test-walk (quote a))
  822. (take-it-out-for-a-test-walk (return-from block-name a b c))
  823. (take-it-out-for-a-test-walk (setq a 1))
  824. (take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))
  825. (take-it-out-for-a-test-walk (tagbody a b c (go a)))
  826. (take-it-out-for-a-test-walk (the foo (foo-form a b c)))
  827. (take-it-out-for-a-test-walk (throw tag-form a))
  828. (take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))
  829.  
  830.  
  831. (take-it-out-for-a-test-walk (flet ((flet-1 (a b) (list a b)))
  832.                                (flet-1 1 2)
  833.                                (foo 1 2)))
  834. (take-it-out-for-a-test-walk (labels ((label-1 (a b) (list a b)))
  835.                                (label-1 1 2)
  836.                                (foo 1 2)))
  837. (take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
  838.                                (macrolet-1 a b)
  839.                                (foo 1 2)))
  840.  
  841. (take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
  842.                                (foo 1)))
  843.  
  844. (take-it-out-for-a-test-walk (progn (bar 1)
  845.                                     (macrolet ((bar (a)
  846.                          `(inner-bar-expanded ,a)))
  847.                                       (bar 1))))
  848.  
  849. (take-it-out-for-a-test-walk (progn (bar 1)
  850.                                     (macrolet ((bar (s)
  851.                          (bar s)
  852.                          `(inner-bar-expanded ,s)))
  853.                                       (bar 2))))
  854.  
  855. (take-it-out-for-a-test-walk (cond (a b)
  856.                                    ((foo bar) a (foo a))))
  857.  
  858.  
  859. (let ((the-lexical-variables ()))
  860.   (walk-form '(let ((a 1) (b 2))
  861.         #'(lambda (x) (list a b x y)))
  862.          :walk-function #'(lambda (form context)
  863.                 (when (and (symbolp form)
  864.                        (variable-lexical-p form))
  865.                   (push form the-lexical-variables))
  866.                 form))
  867.   (or (and (= (length the-lexical-variables) 3)
  868.        (member 'a the-lexical-variables)
  869.        (member 'b the-lexical-variables)
  870.        (member 'x the-lexical-variables))
  871.       (error "Walker didn't do lexical variables of a closure properly.")))
  872.  
  873. |#
  874.  
  875. ()
  876.  
  877.