rs@uunet.UU.NET (Rich Salz) (08/03/87)
Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM>
Posting-number: Volume 10, Issue 83
Archive-name: comobj.lisp/Part09
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 9 (of 13)."
# Contents: walk.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'walk.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'walk.l'\"
else
echo shar: Extracting \"'walk.l'\" \(33372 characters\)
sed "s/^X//" >'walk.l' <<'END_OF_FILE'
X;;;-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; A simple code walker, based IN PART on: (roll the credits)
X;;; Larry Masinter's Masterscope
X;;; Moon's Common Lisp code walker
X;;; Gary Drescher's code walker
X;;; Larry Masinter's simple code walker
X;;; .
X;;; .
X;;; boy, thats fair (I hope).
X;;;
X;;; For now at least, this code walker really only does what PCL needs it to
X;;; do. Maybe it will grow up someday.
X;;;
X
X(in-package 'walker)
X
X(export '(define-walker-template
X walk-form
X variable-lexical-p
X variable-special-p
X ))
X
X;;; *walk-function* is the function being called on each sub-form as we walk.
X;;; Normally it is supplied using the :walk-function keyword argument to
X;;; walk-form, but it is OK to bind it around a call to walk-form-internal.
X(defvar *walk-function*)
X
X;;; *walk-form* is used by the IF template. When the first argument to the
X;;; if template is a list it will be evaluated with *walk-form* bound to the
X;;; form currently being walked.
X(defvar *walk-form*)
X
X;;; *declarations* is a list of the declarations currently in effect.
X(defvar *declarations*)
X
X;;; *lexical-variables* is a list of the variables bound in the current
X;;; contour. In *lexical-variables* the cons whose car is the variable is
X;;; meaningful in the sense that the cons whose car is the variable can be
X;;; used to keep track of which contour the variable is bound in.
X;;;
X;;; Now isn't that just the cats pajamas.
X;;;
X(defvar *lexical-variables*)
X
X;;; An environment of the kind that macroexpand-1 gets as its second
X;;; argument. In fact, that is exactly where it comes from. This is kind of
X;;; kludgy since Common Lisp is somewhat screwed up in this respect.
X;;; Hopefully Common Lisp will fix this soon. For more info see:
X;;; MAKE-LEXICAL-ENVIRONMENT
X(defvar *environment*)
X
X;;;
X;;; With new contour is used to enter a new lexical binding contour which
X;;; inherits from the exisiting one. I admit that using with-new-contour is
X;;; often overkill. It would suffice for the the walker to rebind
X;;; *lexical-variables* and *declarations* when walking LET and rebind
X;;; *environment* and *declarations* when walking MACROLET etc.
X;;; WITH-NEW-CONTOUR is much more convenient and just as correct.
X;;;
X(defmacro with-new-contour (&body body)
X `(let ((*declarations* ()) ;If Common Lisp got an
X ;unspecial declaration
X ;this would need to be
X ;re-worked.
X (*lexical-variables* *lexical-variables*)
X (*environment* *environment*))
X . ,body))
X
X(defmacro note-lexical-binding (thing)
X `(push ,thing *lexical-variables*))
X
X(defmacro note-declaration (declaration)
X `(push ,declaration *declarations*))
X
X
X(defun variable-lexically-boundp (var)
X (if (not (boundp '*walk-function*))
X :unsure
X (values (member var *lexical-variables* :test (function eq))
X (variable-special-p var) 't)))
X
X(defun variable-lexical-p (var)
X (if (not (boundp '*walk-function*))
X :unsure
X (and (not (eq (variable-special-p var) 't))
X (member var *lexical-variables* :test (function eq)))))
X
X(defun variable-special-p (var)
X (if (not (boundp '*walk-function*))
X (or (variable-globally-special-p var) :unsure)
X (or (dolist (decl *declarations*)
X (and (eq (car decl) 'special)
X (member var (cdr decl) :test #'eq)
X (return t)))
X (variable-globally-special-p var))))
X
X;;;
X;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been
X;;; declared globally special. Any particular CommonLisp implementation
X;;; should customize this function accordingly and send their customization
X;;; back.
X;;;
X;;; The default version of variable-globally-special-p is probably pretty
X;;; slow, so it uses *globally-special-variables* as a cache to remember
X;;; variables that it has already figured out are globally special.
X;;;
X;;; This would need to be reworked if an unspecial declaration got added to
X;;; Common Lisp.
X;;;
X;;; Common Lisp nit:
X;;; variable-globally-special-p should be defined in Common Lisp.
X;;;
X#-(or Symbolics Xerox TI VaxLisp KCL LMI excl)
X(defvar *globally-special-variables* ())
X
X(defun variable-globally-special-p (symbol)
X #+Symbolics (si:special-variable-p symbol)
X #+(or Lucid TI LMI) (get symbol 'special)
X #+Xerox (il:variable-globally-special-p symbol)
X #+VaxLisp (get symbol 'system::globally-special)
X #+KCL (si:specialp symbol)
X #+excl (get symbol 'excl::.globally-special.)
X #+HP (member (get symbol 'impl:vartype)
X '(impl:fluid impl:global)
X :test #'eq)
X #-(or Symbolics Lucid TI LMI Xerox VaxLisp KCL excl HP)
X (or (not (null (member symbol *globally-special-variables* :test #'eq)))
X (when (eval `(flet ((ref () ,symbol))
X (let ((,symbol '#,(list nil)))
X (and (boundp ',symbol) (eq ,symbol (ref))))))
X (push symbol *globally-special-variables*)
X t)))
X
X
X ;;
X;;;;;; Handling of special forms (the infamous 24).
X ;;
X;;;
X;;; and I quote...
X;;;
X;;; The set of special forms is purposely kept very small because
X;;; any program analyzing program (read code walker) must have
X;;; special knowledge about every type of special form. Such a
X;;; program needs no special knowledge about macros...
X;;;
X;;; So all we have to do here is a define a way to store and retrieve
X;;; templates which describe how to walk the 24 special forms and we are all
X;;; set...
X;;;
X;;; Well, its a nice concept, and I have to admit to being naive enough that
X;;; I believed it for a while, but not everyone takes having only 24 special
X;;; forms as seriously as might be nice. There are (at least) 3 ways to
X;;; lose:
X;;
X;;; 1 - Implementation x implements a Common Lisp special form as a macro
X;;; which expands into a special form which:
X;;; - Is a common lisp special form (not likely)
X;;; - Is not a common lisp special form (on the 3600 IF --> COND).
X;;;
X;;; * We can safe ourselves from this case (second subcase really) by
X;;; checking to see if there is a template defined for something
X;;; before we check to see if we we can macroexpand it.
X;;;
X;;; 2 - Implementation x implements a Common Lisp macro as a special form.
X;;;
X;;; * This is a screw, but not so bad, we save ourselves from it by
X;;; defining extra templates for the macros which are *likely* to
X;;; be implemented as special forms. (DO, DO* ...)
X;;;
X;;; 3 - Implementation x has a special form which is not on the list of
X;;; Common Lisp special forms.
X;;;
X;;; * This is a bad sort of a screw and happens more than I would like
X;;; to think, especially in the implementations which provide more
X;;; than just Common Lisp (3600, Xerox etc.).
X;;; The fix is not terribly staisfactory, but will have to do for
X;;; now. There is a hook in get walker-template which can get a
X;;; template from the implementation's own walker. That template
X;;; has to be converted, and so it may be that the right way to do
X;;; this would actually be for that implementation to provide an
X;;; interface to its walker which looks like the interface to this
X;;; walker.
X;;;
X(defmacro get-walker-template-internal (x)
X `(get ,x 'walker-template))
X
X(defun get-walker-template (x)
X (cond ((symbolp x)
X (or (get-walker-template-internal x)
X (get-implementation-dependent-walker-template x)))
X ((and (listp x) (eq (car x) 'lambda))
X '(lambda repeat (eval)))
X ((and (listp x) (eq (car x) 'lambda))
X '(call repeat (eval)))))
X
X(defun get-implementation-dependent-walker-template (x)
X (declare (ignore x))
X ())
X
X(eval-when (compile load eval)
X(defmacro define-walker-template (name template)
X `(eval-when (load eval)
X (setf (get-walker-template-internal ',name) ',template)))
X)
X
X
X ;;
X;;;;;; The actual templates
X ;;
X
X(define-walker-template BLOCK (NIL NIL REPEAT (EVAL)))
X(define-walker-template CATCH (NIL EVAL REPEAT (EVAL)))
X(define-walker-template COMPILER-LET walk-compiler-let)
X(define-walker-template DECLARE walk-unexpected-declare)
X(define-walker-template EVAL-WHEN (NIL QUOTE REPEAT (EVAL)))
X(define-walker-template FLET walk-flet/labels)
X(define-walker-template FUNCTION (NIL CALL))
X(define-walker-template GO (NIL QUOTE))
X(define-walker-template IF (NIL TEST RETURN RETURN))
X(define-walker-template LABELS walk-flet/labels)
X(define-walker-template LAMBDA walk-lambda)
X(define-walker-template LET walk-let)
X(define-walker-template LET* walk-let*)
X(define-walker-template MACROLET walk-macrolet)
X(define-walker-template MULTIPLE-VALUE-CALL (NIL EVAL REPEAT (EVAL)))
X(define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL)))
X(define-walker-template MULTIPLE-VALUE-SETQ (NIL (REPEAT (SET)) EVAL))
X(define-walker-template PROGN (NIL REPEAT (EVAL)))
X(define-walker-template PROGV (NIL EVAL EVAL REPEAT (EVAL)))
X(define-walker-template QUOTE (NIL QUOTE))
X(define-walker-template RETURN-FROM (NIL QUOTE REPEAT (RETURN)))
X(define-walker-template SETQ (NIL REPEAT (SET EVAL)))
X(define-walker-template TAGBODY walk-tagbody)
X(define-walker-template THE (NIL QUOTE EVAL))
X(define-walker-template THROW (NIL EVAL EVAL))
X(define-walker-template UNWIND-PROTECT (NIL RETURN REPEAT (EVAL)))
X
X;;; The new special form.
X;(define-walker-template pcl::LOAD-TIME-EVAL (NIL EVAL))
X
X;;;
X;;; And the extra templates...
X;;;
X(define-walker-template DO walk-do)
X(define-walker-template DO* walk-do*)
X(define-walker-template PROG walk-let)
X(define-walker-template PROG* walk-let*)
X(define-walker-template COND (NIL REPEAT ((TEST REPEAT (EVAL)))))
X
X
X ;;
X;;;;;; WALK-FORM
X ;;
X;;;
X;;; The main entry-point is walk-form, calls back in should use walk-form-internal.
X;;;
X
X(defun walk-form (form &key ((:declarations *declarations*) ())
X ((:lexical-variables *lexical-variables*) ())
X ((:environment *environment*) ())
X ((:walk-function *walk-function*) #'(lambda (x y)
X y x)))
X (walk-form-internal form 'eval))
X
X;;;
X;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It
X;;; takes a form and the current context and walks the form calling itself or
X;;; the appropriate template recursively.
X;;;
X;;; "It is recommended that a program-analyzing-program process a form
X;;; that is a list whose car is a symbol as follows:
X;;;
X;;; 1. If the program has particular knowledge about the symbol,
X;;; process the form using special-purpose code. All of the
X;;; standard special forms should fall into this category.
X;;; 2. Otherwise, if macro-function is true of the symbol apply
X;;; either macroexpand or macroexpand-1 and start over.
X;;; 3. Otherwise, assume it is a function call. "
X;;;
X
X(defun walk-form-internal (form context
X &aux newform newnewform
X walk-no-more-p macrop
X fn template)
X ;; First apply the *walk-function* to perform whatever translation
X ;; the user wants to to this form. If the second value returned
X ;; by *walk-function* is T then we don't recurse...
X (multiple-value-setq (newform walk-no-more-p)
X (funcall *walk-function* form context))
X (cond (walk-no-more-p newform)
X ((not (eq form newform)) (walk-form-internal newform context))
X ((not (consp newform)) newform)
X ((setq template (get-walker-template (setq fn (car newform))))
X (if (symbolp template)
X (funcall template newform context)
X (walk-template newform template context)))
X ((progn (multiple-value-setq (newnewform macrop)
X (macroexpand-1 newform *environment*))
X macrop)
X (walk-form-internal newnewform context))
X ((and (symbolp fn)
X (not (fboundp fn))
X (special-form-p fn))
X (error
X "~S is a special form, not defined in the CommonLisp manual.~%~
X This code walker doesn't know how to walk it. Please define a~%~
X template for this special form and try again."
X fn))
X (t
X ;; Otherwise, walk the form as if its just a standard function
X ;; call using a template for standard function call.
X (walk-template newform '(call repeat (eval)) context))))
X
X(defun walk-template (form template context)
X (if (atom template)
X (ecase template
X ((QUOTE NIL) form)
X ((EVAL FUNCTION TEST EFFECT RETURN)
X (walk-form-internal form :EVAL))
X (SET
X (walk-form-internal form :SET))
X ((LAMBDA CALL)
X (if (symbolp form)
X form
X (walk-lambda form context))))
X (case (car template)
X (IF
X (let ((*walk-form* form))
X (walk-template form
X (if (if (listp (cadr template))
X (eval (cadr template))
X (funcall (cadr template) form))
X (caddr template)
X (cadddr template))
X context)))
X (REPEAT
X (walk-template-handle-repeat form
X (cdr template)
X ;; For the case where nothing happens
X ;; after the repeat optimize out the
X ;; call to length.
X (if (null (cddr template))
X ()
X (nthcdr (- (length form)
X (length
X (cddr template)))
X form))
X context))
X (REMOTE
X (walk-template form (cadr template) context))
X (otherwise
X (cond ((atom form) form)
X (t (recons form
X (walk-template
X (car form) (car template) context)
X (walk-template
X (cdr form) (cdr template) context))))))))
X
X(defun walk-template-handle-repeat (form template stop-form context)
X (if (eq form stop-form)
X (walk-template form (cdr template) context)
X (walk-template-handle-repeat-1 form
X template
X (car template)
X stop-form
X context)))
X
X(defun walk-template-handle-repeat-1 (form template repeat-template
X stop-form context)
X (cond ((null form) ())
X ((eq form stop-form)
X (if (null repeat-template)
X (walk-template stop-form (cdr template) context)
X (error "While handling repeat:
X ~%~Ran into stop while still in repeat template.")))
X ((null repeat-template)
X (walk-template-handle-repeat-1
X form template (car template) stop-form context))
X (t
X (recons form
X (walk-template (car form) (car repeat-template) context)
X (walk-template-handle-repeat-1 (cdr form)
X template
X (cdr repeat-template)
X stop-form
X context)))))
X
X(defun recons (x car cdr)
X (if (or (not (eq (car x) car))
X (not (eq (cdr x) cdr)))
X (cons car cdr)
X x))
X
X(defun relist* (x &rest args)
X (relist*-internal x args))
X
X(defun relist*-internal (x args)
X (if (null (cdr args))
X (car args)
X (recons x (car args) (relist*-internal (cdr x) (cdr args)))))
X
X
X ;;
X;;;;;; Special walkers
X ;;
X
X(defun walk-declarations (body fn
X &optional doc-string-p declarations old-body
X &aux (form (car body)))
X (cond ((and (stringp form) ;might be a doc string
X (cdr body) ;isn't the returned value
X (null doc-string-p) ;no doc string yet
X (null declarations)) ;no declarations yet
X (recons body
X form
X (walk-declarations (cdr body) fn t)))
X ((and (listp form) (eq (car form) 'declare))
X ;; Got ourselves a real live declaration. Record it, look for more.
X (dolist (declaration (cdr form))
X (note-declaration declaration)
X (push declaration declarations))
X (recons body
X form
X (walk-declarations
X (cdr body) fn doc-string-p declarations)))
X ((and form
X (listp form)
X (null (get-walker-template (car form)))
X (not (eq form (setq form (macroexpand-1 form *environment*)))))
X ;; When we macroexpanded this form we got something else back.
X ;; Maybe this is a macro which expanded into a declare?
X ;; Recurse to find out.
X (walk-declarations
X (cons form (cdr body)) fn doc-string-p declarations (or old-body
X body)))
X (t
X ;; Now that we have walked and recorded the declarations, call the
X ;; function our caller provided to expand the body. We call that
X ;; function rather than passing the real-body back, because we are
X ;; RECONSING up the new body.
X (funcall fn (or old-body body)))))
X
X(defun fix-lucid-1.2 (x) x)
X
X(defun walk-unexpected-declare (form context)
X (declare (ignore context))
X (warn "Encountered declare ~S in a place where a declare was not expected."
X form)
X form)
X
X(defun walk-arglist (arglist context &optional (destructuringp nil) &aux arg)
X (cond ((null arglist) ())
X ((symbolp (setq arg (car arglist)))
X (or (member arg lambda-list-keywords :test #'eq)
X (note-lexical-binding arg))
X (recons arglist
X arg
X (walk-arglist (cdr arglist)
X context
X (and destructuringp
X (not (member arg lambda-list-keywords
X :test #'eq))))))
X ((consp arg)
X (prog1 (if destructuringp
X (walk-arglist arg context destructuringp)
X (recons arglist
X (relist* arg
X (car arg)
X (walk-form-internal (cadr arg) 'eval)
X (cddr arg))
X (walk-arglist (cdr arglist) context nil)))
X (if (symbolp (car arg))
X (note-lexical-binding (car arg))
X (note-lexical-binding (cadar arg)))
X (or (null (cddr arg))
X (not (symbolp (caddr arg)))
X (note-lexical-binding arg))))
X (t
X (error "Can't understand something in the arglist ~S" arglist))))
X
X(defun walk-let (form context)
X (walk-let/let* form context nil))
X
X(defun walk-let* (form context)
X (walk-let/let* form context t))
X
X(defun walk-do (form context)
X (walk-do/do* form context nil))
X
X(defun walk-do* (form context)
X (walk-do/do* form context t))
X
X(defun walk-let/let* (form context sequentialp)
X (let ((old-declarations *declarations*)
X (old-lexical-variables *lexical-variables*))
X (with-new-contour
X (let* ((let/let* (car form))
X (bindings (cadr form))
X (body (cddr form))
X walked-bindings
X (walked-body
X (walk-declarations
X body
X #'(lambda (real-body)
X (setq walked-bindings
X (walk-bindings-1 bindings
X old-declarations
X old-lexical-variables
X context
X sequentialp))
X (walk-template real-body '(repeat (eval)) context)))))
X (relist*
X form let/let* (fix-lucid-1.2 walked-bindings) walked-body)))))
X
X(defun walk-do/do* (form context sequentialp)
X (let ((old-declarations *declarations*)
X (old-lexical-variables *lexical-variables*))
X (with-new-contour
X (let* ((do/do* (car form))
X (bindings (cadr form))
X (end-test (caddr form))
X (body (cdddr form))
X walked-bindings
X (walked-body
X (walk-declarations
X body
X #'(lambda (real-body)
X (setq walked-bindings
X (walk-bindings-1 bindings
X old-declarations
X old-lexical-variables
X context
X sequentialp))
X (walk-template real-body '(repeat (eval)) context)))))
X (relist* form
X do/do*
X (walk-bindings-2 bindings walked-bindings context)
X (walk-template end-test '(test repeat (eval)) context)
X walked-body)))))
X
X(defun walk-bindings-1 (bindings old-declarations old-lexical-variables
X context sequentialp)
X (and bindings
X (let ((binding (car bindings)))
X (recons bindings
X (if (symbolp binding)
X (prog1 binding
X (note-lexical-binding binding))
X (prog1 (let ((*declarations* old-declarations)
X (*lexical-variables*
X (if sequentialp
X *lexical-variables*
X old-lexical-variables)))
X (relist* binding
X (car binding)
X (walk-form-internal (cadr binding)
X context)
X (cddr binding))) ;save cddr for DO/DO*
X ;it is the next value
X ;form. Don't walk it
X ;now though.
X (note-lexical-binding (car binding))))
X (walk-bindings-1 (cdr bindings)
X old-declarations old-lexical-variables
X context sequentialp)))))
X
X(defun walk-bindings-2 (bindings walked-bindings context)
X (and bindings
X (let ((binding (car bindings))
X (walked-binding (car walked-bindings)))
X (recons bindings
X (if (symbolp binding)
X binding
X (relist* binding
X (car walked-binding)
X (cadr walked-binding)
X (walk-template (cddr binding) '(eval) context)))
X (walk-bindings-2 (cdr bindings)
X (cdr walked-bindings)
X context)))))
X
X(defun walk-lambda (form context)
X (with-new-contour
X (let* ((arglist (cadr form))
X (body (cddr form))
X (walked-arglist nil)
X (walked-body
X (walk-declarations body
X #'(lambda (real-body)
X (setq walked-arglist (walk-arglist arglist context))
X (walk-template real-body '(repeat (eval)) context)))))
X (relist* form
X (car form)
X (fix-lucid-1.2 walked-arglist)
X walked-body))))
X
X(defun walk-tagbody (form context)
X (recons form (car form) (walk-tagbody-1 (cdr form) context)))
X
X(defun walk-tagbody-1 (form context)
X (and form
X (recons form
X (walk-form-internal (car form)
X (if (symbolp (car form)) 'quote context))
X (walk-tagbody-1 (cdr form) context))))
X
X(defun walk-compiler-let (form context)
X (with-new-contour
X (let ((vars ())
X (vals ()))
X (dolist (binding (cadr form))
X (cond ((symbolp binding) (push binding vars) (push nil vals))
X (t
X (push (car binding) vars)
X (push (eval (cadr binding)) vals))))
X (relist* form
X (car form)
X (cadr form)
X (progv vars vals
X (note-declaration (cons 'special vars))
X (walk-template (cddr form) '(repeat (eval)) context))))))
X
X(defun walk-macrolet (form context)
X (labels ((walk-definitions (definitions)
X (and (not (null definitions))
X (let ((definition (car definitions)))
X (recons definitions
X (with-new-contour
X (relist* definition
X (car definition)
X (walk-arglist (cadr definition)
X context t)
X (walk-declarations (cddr definition)
X #'(lambda (real-body)
X (walk-template
X real-body
X '(repeat (eval))
X context)))))
X (walk-definitions (cdr definitions)))))))
X (with-new-contour
X (relist* form
X (car form)
X (walk-definitions (cadr form))
X (progn (setq *environment*
X (make-lexical-environment form *environment*))
X (walk-declarations (cddr form)
X #'(lambda (real-body)
X (walk-template real-body
X '(repeat (eval))
X context))))))))
X
X(defun walk-flet/labels (form context)
X (with-new-contour
X (labels ((walk-definitions (definitions)
X (if (null definitions)
X ()
X (recons definitions
X (walk-lambda (car definitions) context)
X (walk-definitions (cdr definitions)))))
X (update-environment ()
X (setq *environment*
X (make-lexical-environment form *environment*))))
X (relist* form
X (car form)
X (ecase (car form)
X (flet
X (prog1 (walk-definitions (cadr form))
X (update-environment)))
X (labels
X (update-environment)
X (walk-definitions (cadr form))))
X (walk-declarations (cddr form)
X #'(lambda (real-body)
X (walk-template real-body '(repeat (eval)) context)))))))
X
X;;; make-lexical-environemnt is kind of gross. It would be less gross if
X;;; EVAL took an environment argument.
X;;;
X;;; Common Lisp nit:
X;;; if Common Lisp should provide mechanisms for playing with
X;;; environments explicitly. making them, finding out what
X;;; functions are bound in them etc. Maybe compile should
X;;; take an environment argument too?
X;;;
X
X(defun make-lexical-environment (macrolet/flet/labels-form environment)
X (evalhook (list (car macrolet/flet/labels-form)
X (cadr macrolet/flet/labels-form)
X (list 'make-lexical-environment-2))
X 'make-lexical-environment-1
X ()
X environment))
X
X(defun make-lexical-environment-1 (form env)
X (setq form (macroexpand form #-excl env
X #+excl (cadr env)))
X (evalhook form 'make-lexical-environment-1 nil env))
X
X(defmacro make-lexical-environment-2 (&environment env)
X (list 'quote (copy-tree env)))
X
X ;;
X;;;;;; Tests tests tests
X ;;
X
X#|
X
X(defmacro take-it-out-for-a-test-walk (form)
X `(progn
X (terpri)
X (terpri)
X (let ((copy-of-form (copy-tree ',form))
X (result (walk-form ',form :walk-function
X '(lambda (x y)
X (format t "~&Form: ~S ~3T Context: ~A" x y)
X (when (symbolp x)
X (multiple-value-bind (lexical special)
X (variable-lexically-boundp x)
X (when lexical
X (format t ";~3T")
X (format t "lexically bound"))
X (when special
X (format t ";~3T")
X (format t "declared special"))
X (when (boundp x)
X (format t ";~3T")
X (format t "bound: ~S " (eval x)))))
X x))))
X (cond ((not (equal result copy-of-form))
X (format t "~%Warning: Result not EQUAL to copy of start."))
X ((not (eq result ',form))
X (format t "~%Warning: Result not EQ to copy of start.")))
X (#+Symbolics zl:grind-top-level
X #-Symbolics print
X result)
X result)))
X
X(defun foo (&rest ignore) ())
X
X(defmacro bar (x) `'(global-bar-expanded ,x))
X
X(defun baz (&rest ignore) ())
X
X(take-it-out-for-a-test-walk (foo arg1 arg2 arg3))
X(take-it-out-for-a-test-walk (foo (baz 1 2) (baz 3 4 5)))
X
X(take-it-out-for-a-test-walk (block block-name a b c))
X(take-it-out-for-a-test-walk (block block-name (foo a) b c))
X
X(take-it-out-for-a-test-walk (catch catch-tag (foo a) b c))
X(take-it-out-for-a-test-walk (compiler-let ((a 1) (b 2)) (foo a) b))
X(take-it-out-for-a-test-walk (prog () (declare (special a b))))
X(take-it-out-for-a-test-walk (let (a b c)
X (declare (special a b))
X (foo a) b c))
X(take-it-out-for-a-test-walk (let (a b c)
X (declare (special a) (special b))
X (foo a) b c))
X(take-it-out-for-a-test-walk (let (a b c)
X (declare (special a))
X (declare (special b))
X (foo a) b c))
X(take-it-out-for-a-test-walk (let (a b c)
X (declare (special a))
X (declare (special b))
X (let ((a 1))
X (foo a) b c)))
X(take-it-out-for-a-test-walk (eval-when ()
X a
X (foo a)))
X(take-it-out-for-a-test-walk (eval-when (eval when load)
X a
X (foo a)))
X(take-it-out-for-a-test-walk (progn (function foo)))
X(take-it-out-for-a-test-walk (progn a b (go a)))
X(take-it-out-for-a-test-walk (if a b c))
X(take-it-out-for-a-test-walk (if a b))
X(take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))
X(take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b))
X 1 2))
X(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c)))
X(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))
X(take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
X (declare (special a b))
X (list a b c)))
X(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
X (declare (special a b))
X (list a b c)))
X(take-it-out-for-a-test-walk (let ((a 1) (b 2))
X (foo bar)
X (declare (special a))
X (foo a b)))
X(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))
X(take-it-out-for-a-test-walk (multiple-value-prog1 a b c))
X(take-it-out-for-a-test-walk (progn a b c))
X(take-it-out-for-a-test-walk (progv vars vals a b c))
X(take-it-out-for-a-test-walk (quote a))
X(take-it-out-for-a-test-walk (return-from block-name a b c))
X(take-it-out-for-a-test-walk (setq a 1))
X(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))
X(take-it-out-for-a-test-walk (tagbody a b c (go a)))
X(take-it-out-for-a-test-walk (the foo (foo-form a b c)))
X(take-it-out-for-a-test-walk (throw tag-form a))
X(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))
X
X
X(take-it-out-for-a-test-walk (flet ((flet-1 (a b) (list a b)))
X (flet-1 1 2)
X (foo 1 2)))
X(take-it-out-for-a-test-walk (labels ((label-1 (a b) (list a b)))
X (label-1 1 2)
X (foo 1 2)))
X(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
X (macrolet-1 a b)
X (foo 1 2)))
X
X(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
X (foo 1)))
X
X(take-it-out-for-a-test-walk (progn (bar 1)
X (macrolet ((bar (a)
X `(inner-bar-expanded ,a)))
X (bar 1))))
X
X(take-it-out-for-a-test-walk (progn (bar 1)
X (macrolet ((bar (s)
X (bar s)
X `(inner-bar-expanded ,s)))
X (bar 2))))
X
X(take-it-out-for-a-test-walk (cond (a b)
X ((foo bar) a (foo a))))
X
X
X(let ((the-lexical-variables ()))
X (walk-form '(let ((a 1) (b 2))
X #'(lambda (x) (list a b x y)))
X :walk-function #'(lambda (form context)
X (when (and (symbolp form)
X (variable-lexical-p form))
X (push form the-lexical-variables))
X form))
X (or (and (= (length the-lexical-variables) 3)
X (member 'a the-lexical-variables)
X (member 'b the-lexical-variables)
X (member 'x the-lexical-variables))
X (error "Walker didn't do lexical variables of a closure properly.")))
X
X|#
X
X()
X
END_OF_FILE
if test 33372 -ne `wc -c <'walk.l'`; then
echo shar: \"'walk.l'\" unpacked with wrong size!
fi
# end of 'walk.l'
fi
echo shar: End of archive 9 \(of 13\).
cp /dev/null ark9isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 13 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
Rich $alz "Anger is an energy"
Cronus Project, BBN Labs rsalz@bbn.com
Moderator, comp.sources.unix sources@uunet.uu.net