;;;-*- Mode:LISP; Package:(WALK LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation. All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox Artifical Intelligence Systems ;;; 2400 Hanover St. ;;; Palo Alto, CA 94303 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; A simple code walker, based IN PART on: (roll the credits) ;;; Larry Masinter's Masterscope ;;; Moon's Common Lisp code walker ;;; Gary Drescher's code walker ;;; Larry Masinter's simple code walker ;;; . ;;; . ;;; boy, thats fair (I hope). ;;; ;;; For now at least, this code walker really only does what PCL needs it to ;;; do. Maybe it will grow up someday. ;;; ;;; ;;; This code walker used to be completely portable. Now it is just "Real ;;; easy to port". This change had to happen because the hack that made it ;;; completely portable kept breaking in different releases of different ;;; Common Lisps, and in addition it never worked entirely anyways. So, ;;; its now easy to port. To port this walker, all you have to write is one ;;; simple macro and two simple functions. These macros and functions are ;;; used by the walker to manipluate the macroexpansion environments of ;;; the Common Lisp it is running in. ;;; ;;; The code which implements the macroexpansion environment manipulation ;;; mechanisms is in the first part of the file, the real walker follows it. ;;; (in-package 'walk) (export '(define-walker-template walk-form variable-lexical-p variable-special-p )) ;;; ;;; On the following pages are implementations of the implementation specific ;;; environment hacking functions for each of the implementations this walker ;;; has been ported to. If you add a new one, so this walker can run in a new ;;; implementation of Common Lisp, please send the changes back to us so that ;;; others can also use this walker in that implementation of Common Lisp. ;;; ;;; This code just hacks 'macroexpansion environments'. That is, it is only ;;; concerned with the function binding of symbols in the environment. The ;;; walker needs to be able to tell if the symbol names a lexical macro or ;;; function, and it needs to be able to build environments which contain ;;; lexical macro or function bindings. It must be able, when walking a ;;; macrolet, flet or labels form to construct an environment which reflects ;;; the bindings created by that form. Note that the environment created ;;; does NOT have to be sufficient to evaluate the body, merely to walk its ;;; body. This means that definitions do not have to be supplied for lexical ;;; functions, only the fact that that function is bound is important. For ;;; macros, the macroexpansion function must be supplied. ;;; ;;; This code is organized in a way that lets it work in implementations that ;;; stack cons their environments. That is reflected in the fact that the ;;; only operation that lets a user build a new environment is a with-body ;;; macro which executes its body with the specified symbol bound to the new ;;; environment. No code in this walker or in PCL will hold a pointer to ;;; these environments after the body returns. Other user code is free to do ;;; so in implementations where it works, but that code is not considered ;;; portable. ;;; ;;; There are 3 environment hacking tools. One macro which is used for ;;; creating new environments, and two functions which are used to access the ;;; bindings of existing environments. ;;; ;;; WITH-AUGMENTED-ENVIRONMENT ;;; ;;; ENVIRONMENT-FUNCTION ;;; ;;; ENVIRONMENT-MACRO ;;; (defun unbound-lexical-function (&rest args) (declare (ignore args)) (error "The evaluator was called to evaluate a form in a macroexpansion~%~ environment constructed by the PCL portable code walker. These~%~ environments are only useful for macroexpansion, they cannot be~%~ used for evaluation.~%~ This error should never occur when using PCL.~%~ This most likely source of this error is a program which tries to~%~ to use the PCL portable code walker to build its own evaluator.")) ;;; ;;; In Coral Common Lisp, the macroexpansion environment is just a list ;;; of environment entries. The cadr of each element specifies the type ;;; of the element. The only types that interest us are CCL::MACRO and ;;; FUNCTION. In these cases the element is interpreted as follows. ;;; ;;; ( CCL::MACRO . macroexpansion-function) ;;; ;;; ( FUNCTION . ) ;;; ;;; When in the compiler, is a gensym which will be ;;; a variable which bound at run-time to the function. ;;; When in the interpreter, is the actual function. ;;; ;;; #+:Coral (progn (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) ,@body)) (defun with-augmented-environment-internal (env functions macros) (dolist (f functions) (push (list* f 'function (gensym)) env)) (dolist (m macros) (push (list* (car m) 'ccl::macro (cadr m)) env)) env) (defun environment-function (env fn) (let ((entry (assoc fn env :test #'equal))) (and entry (eq (cadr entry) 'function) (cddr entry)))) (defun environment-macro (env macro) (let ((entry (assoc macro env :test #'equal))) (and entry (eq (cadr entry) 'ccl::macro) (cddr entry)))) );#+:Coral ;;; ;;; Franz Common Lisp is a lot like Coral Lisp. The macroexpansion ;;; environment is just a list of entries. The cadr of each element ;;; specifies the type of the element. The types that interest us ;;; are FUNCTION, EXCL::MACRO, and COMPILER::FUNCTION-VALUE. These ;;; are interpreted as follows: ;;; ;;; ( FUNCTION . ) ;;; ;;; This happens in the interpreter with lexically ;;; bound functions. ;;; ;;; ( COMPILER::FUNCTION-VALUE . ) ;;; ;;; This happens in the compiler. The gensym represents ;;; a variable which will be bound at run time to the ;;; function object. ;;; ;;; ( EXCL::MACRO . ) ;;; ;;; In both interpreter and compiler, this is the ;;; representation used for macro definitions. ;;; ;;; #+:ExCL (progn (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) ,@body)) (defun with-augmented-environment-internal (env functions macros) (dolist (f functions) (push (list* f 'function #'unbound-lexical-function) env)) (dolist (m macros) (push (list* (car m) 'excl::macro (cadr m)) env)) env) (defun environment-function (env fn) (let ((entry (assoc fn env :test #'equal))) (and entry (or (eq (cadr entry) 'function) (eq (cadr entry) 'compiler::function-value)) (cddr entry)))) (defun environment-macro (env macro) (let ((entry (assoc macro env :test #'equal))) (and entry (eq (cadr entry) 'excl::macro) (cddr entry)))) );#+:ExCL #+Lucid (progn (defun %alphalex-p (object) (eq (cadddr (cddddr object)) 'lucid::%alphalex)) (defconstant function-contour 1) (defconstant macrolet-contour 5) (defstruct contour type elements) (defun add-contour-to-env-shape (contour-type elements env-shape) (cons (make-contour :type contour-type :elements elements) env-shape)) (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let* ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) ,@body)) ;;; ;;; with-augmented-environment-internal is where the real work of augmenting ;;; the environment happens. Before it gets there, env had better not be NIL ;;; anymore because we have to know what kind of environment we are supposed ;;; to be building up. This is probably never a real concern in practice. ;;; It better not be because we don't do anything about it. ;;; (defun with-augmented-environment-internal (env functions macros) (dolist (f functions) (if (%alphalex-p env) (setq env (lucid::augment-lexenv-flet-vars env (list f) '() (list #'unbound-lexical-function))) (setq env (add-contour-to-env-shape function-contour (list f) env)))) (dolist (m macros) (if (%alphalex-p env) (setq env (lucid::augment-lexenv-mvars env (list (car m)) (list (cadr m)))) (setq env (add-contour-to-env-shape macrolet-contour (list (cons (car m) (cadr m))) env)))) env) (defun environment-function (env fn) (break)) (defun environment-macro (env macro) (break)) );#+Lucid ;;; ;;; On the 3600, the documentation for how the environments are represented ;;; is in sys:sys;eval.lisp. That total information is not repeated here. ;;; The important points are that: ;;; si:env-variables returns a list of which each element is: ;;; ;;; (symbol value) ;;; or (symbol . locative) ;;; ;;; The first form is for lexical variables, the second for ;;; special and instance variables. In either case CADR of ;;; the entry is the value and SETF of CADR is used to change ;;; the value. Variables are looked up with ASSQ. ;;; ;;; si:env-functions returns a list of which each element is: ;;; ;;; (symbol definition) ;;; ;;; where definition is anything that could go in a function cell. ;;; This is used for both local functions and local macros. ;;; ;;; The 3600 stack conses its environments (at least in the interpreter). ;;; This means that code written using this walker and running on the 3600 ;;; must not hold on to the environment after the walk-function returns. ;;; No code in this walker or in PCL does that. ;;; #+Symbolics (progn (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) (let ((funs (make-symbol "FNS")) (macs (make-symbol "MACROS")) (new (make-symbol "NEW"))) `(let ((,funs ,functions) (,macs ,macros) (,new ())) (dolist (f ,funs) (push `(,(car f) ,#'unbound-lexical-function) ,new)) (dolist (m ,macs) (push `(,(car m) (special ,(cadr m))) ,new)) (si:with-interpreter-environment (,new-env ,old-env () ,new () () ()) ,@body)))) (defun environment-function (env fn) (let ((entry (assoc fn (si:env-functions env) :test #'equal))) ;Some specs ;are lists! (if (and entry (or (not (listp (cadr entry))) (not (eq (caadr entry) 'special)))) (values (cadr entry) t) (values nil nil)))) (defun environment-macro (env macro) (let ((entry (assoc macro (si:env-functions env) :test #'equal))) (if (and entry (listp (cadr entry)) (eq (caadr entry) 'special)) (values (cadr entry) t) (values nil nil)))) );#+Symbolics ;;; ;;; In Xerox Lisp, the compiler and interpreter use different structures for ;;; the environment. This doesn't cause a serious problem, the parts of the ;;; environments we are concerned with are fairly similar. ;;; #+:Xerox (progn (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let* ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) ,@body)) ;;; ;;; with-augmented-environment-internal is where the real work of augmenting ;;; the environment happens. Before it gets there, env had better not be NIL ;;; anymore because we have to know what kind of environment we are supposed ;;; to be building up. This is probably never a real concern in practice. ;;; It better not be because we don't do anything about it. ;;; (defun with-augmented-environment-internal (env functions macros) (if (cond ((compiler::env-p env) t) ((il:environment-p env) nil) (t (setq env (il:\\make-environment)) nil)) (progn (dolist (f functions) (setq env (compiler::copy-env-with-function env f :function))) (dolist (m macros) (setq env (compiler::copy-env-with-function env (car m) :macro (cadr m))))) (progn (dolist (f functions) (push (list f :function #'unbound-lexical-function) (il:environment-functions env))) (dolist (m macros) (push (list (car m) :macro (cadr m)) (il:environment-functions env))))) env) (defun environment-function (env fn) (dolist (e (cond ((compiler::env-p env) (compiler::env-fenv env)) ((il:environment-p env) (il:environment-functions env)) (t nil))) (when (and (eq (car e) fn) (eq (cadr e) ':function)) (return t)))) (defun environment-macro (env macro) (dolist (e (cond ((compiler::env-p env) (compiler::env-fenv env)) ((il:environment-p env) (il:environment-functions env)) (t nil))) (when (and (eq (car e) macro) (eq (cadr e) ':macro)) (return (caddr e))))) );#+:Xerox (defmacro with-new-lexical-environment ((new-env old-env macrolet/flet/labels-form) &body body) (let ((functions (make-symbol "Functions")) (macros (make-symbol "Macros"))) `(let ((,functions ()) (,macros ())) (ecase (car form) ((flet labels) (dolist (fn (cadr ,macrolet/flet/labels-form)) (push fn ,functions))) ((macrolet) (dolist (mac (cadr ,macrolet/flet/labels-form)) (push (list (car mac) (convert-macro-to-lambda (cadr mac) (cddr mac) (string (car mac)))) ,macros)))) (with-augmented-environment (,new-env ,old-env :functions ,functions :macros ,macros) ,@body)))) ;;; ;;; Now comes the real walker. ;;; ;;; *walk-function* is the function being called on each sub-form as we walk. ;;; Normally it is supplied using the :walk-function keyword argument to ;;; walk-form, but it is OK to bind it around a call to walk-form-internal. (defvar *walk-function*) ;;; *walk-form* is used by the IF template. When the first argument to the ;;; if template is a list it will be evaluated with *walk-form* bound to the ;;; form currently being walked. (defvar *walk-form*) ;;; *declarations* is a list of the declarations currently in effect. (defvar *declarations*) ;;; *lexical-variables* is a list of the variables bound in the current ;;; contour. In *lexical-variables* the cons whose car is the variable is ;;; meaningful in the sense that the cons whose car is the variable can be ;;; used to keep track of which contour the variable is bound in. ;;; ;;; Now isn't that just the cats pajamas. ;;; (defvar *lexical-variables*) ;;; An environment of the kind that macroexpand-1 gets as its second ;;; argument. See with-augmented-lexical-environment for more details. ;;; (defvar *environment*) ;;; ;;; With new contour is used to enter a new lexical binding contour which ;;; inherits from the exisiting one. I admit that using with-new-contour is ;;; often overkill. It would suffice for the the walker to rebind ;;; *lexical-variables* and *declarations* when walking LET and rebind ;;; *environment* and *declarations* when walking MACROLET etc. ;;; WITH-NEW-CONTOUR is much more convenient and just as correct. ;;; (defmacro with-new-contour (&body body) `(let ((*declarations* ()) ;If Common Lisp got an ;unspecial declaration ;this would need to be ;re-worked. (*lexical-variables* *lexical-variables*) (*environment* *environment*)) . ,body)) (defmacro note-lexical-binding (thing) `(push ,thing *lexical-variables*)) (defmacro note-declaration (declaration) `(push ,declaration *declarations*)) (defun variable-lexically-boundp (var) (if (not (boundp '*walk-function*)) :unsure (values (member var *lexical-variables* :test (function eq)) (variable-special-p var) 't))) (defun variable-lexical-p (var) (if (not (boundp '*walk-function*)) :unsure (and (not (eq (variable-special-p var) 't)) (member var *lexical-variables* :test (function eq))))) (defun variable-special-p (var) (if (not (boundp '*walk-function*)) (or (variable-globally-special-p var) :unsure) (or (dolist (decl *declarations*) (and (eq (car decl) 'special) (member var (cdr decl) :test #'eq) (return t))) (variable-globally-special-p var)))) ;;; ;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been ;;; declared globally special. Any particular CommonLisp implementation ;;; should customize this function accordingly and send their customization ;;; back. ;;; ;;; The default version of variable-globally-special-p is probably pretty ;;; slow, so it uses *globally-special-variables* as a cache to remember ;;; variables that it has already figured out are globally special. ;;; ;;; This would need to be reworked if an unspecial declaration got added to ;;; Common Lisp. ;;; ;;; Common Lisp nit: ;;; variable-globally-special-p should be defined in Common Lisp. ;;; #-(or Symbolics Lucid Xerox Excl KCL (and dec vax common) :CMU HP GCLisp TI pyramid) (defvar *globally-special-variables* ()) (defun variable-globally-special-p (symbol) #+Symbolics (si:special-variable-p symbol) #+Lucid (lucid::proclaimed-special-p symbol) #+TI (get symbol 'special) #+Xerox (il:variable-globally-special-p symbol) #+(and dec vax common) (get symbol 'system::globally-special) #+KCL (si:specialp symbol) #+excl (get symbol 'excl::.globally-special.) #+:CMU (or (get symbol 'lisp::globally-special) (get symbol 'clc::globally-special-in-compiler)) #+HP (member (get symbol 'impl:vartype) '(impl:fluid impl:global) :test #'eq) #+:GCLISP (gclisp::special-p symbol) #+pyramid (or (get symbol 'lisp::globally-special) (get symbol 'clc::globally-special-in-compiler)) #-(or Symbolics Lucid Xerox Excl KCL (and dec vax common) :CMU HP GCLisp TI pyramid) (or (not (null (member symbol *globally-special-variables* :test #'eq))) (when (eval `(flet ((ref () ,symbol)) (let ((,symbol '#,(list nil))) (and (boundp ',symbol) (eq ,symbol (ref)))))) (push symbol *globally-special-variables*) t))) ;; ;;;;;; Handling of special forms (the infamous 24). ;; ;;; ;;; and I quote... ;;; ;;; The set of special forms is purposely kept very small because ;;; any program analyzing program (read code walker) must have ;;; special knowledge about every type of special form. Such a ;;; program needs no special knowledge about macros... ;;; ;;; So all we have to do here is a define a way to store and retrieve ;;; templates which describe how to walk the 24 special forms and we are all ;;; set... ;;; ;;; Well, its a nice concept, and I have to admit to being naive enough that ;;; I believed it for a while, but not everyone takes having only 24 special ;;; forms as seriously as might be nice. There are (at least) 3 ways to ;;; lose: ;; ;;; 1 - Implementation x implements a Common Lisp special form as a macro ;;; which expands into a special form which: ;;; - Is a common lisp special form (not likely) ;;; - Is not a common lisp special form (on the 3600 IF --> COND). ;;; ;;; * We can safe ourselves from this case (second subcase really) by ;;; checking to see if there is a template defined for something ;;; before we check to see if we we can macroexpand it. ;;; ;;; 2 - Implementation x implements a Common Lisp macro as a special form. ;;; ;;; * This is a screw, but not so bad, we save ourselves from it by ;;; defining extra templates for the macros which are *likely* to ;;; be implemented as special forms. (DO, DO* ...) ;;; ;;; 3 - Implementation x has a special form which is not on the list of ;;; Common Lisp special forms. ;;; ;;; * This is a bad sort of a screw and happens more than I would like ;;; to think, especially in the implementations which provide more ;;; than just Common Lisp (3600, Xerox etc.). ;;; The fix is not terribly staisfactory, but will have to do for ;;; now. There is a hook in get walker-template which can get a ;;; template from the implementation's own walker. That template ;;; has to be converted, and so it may be that the right way to do ;;; this would actually be for that implementation to provide an ;;; interface to its walker which looks like the interface to this ;;; walker. ;;; (eval-when (compile load eval) (defmacro get-walker-template-internal (x) ;Has to be inside eval-when because `(get ,x 'walker-template)) ;Golden Common Lisp doesn't hack ;compile time definition of macros ;right for setf. (defmacro define-walker-template (name template) `(eval-when (load eval) (setf (get-walker-template-internal ',name) ',template))) ) (defun get-walker-template (x) (cond ((symbolp x) (or (get-walker-template-internal x) (get-implementation-dependent-walker-template x))) ((and (listp x) (eq (car x) 'lambda)) '(lambda repeat (eval))) ((and (listp x) (eq (car x) 'lambda)) '(call repeat (eval))))) (defun get-implementation-dependent-walker-template (x) (declare (ignore x)) ()) ;; ;;;;;; The actual templates ;; (define-walker-template BLOCK (NIL NIL REPEAT (EVAL))) (define-walker-template CATCH (NIL EVAL REPEAT (EVAL))) (define-walker-template COMPILER-LET walk-compiler-let) (define-walker-template DECLARE walk-unexpected-declare) (define-walker-template EVAL-WHEN (NIL QUOTE REPEAT (EVAL))) (define-walker-template FLET walk-flet) (define-walker-template FUNCTION (NIL CALL)) (define-walker-template GO (NIL QUOTE)) (define-walker-template IF (NIL TEST RETURN RETURN)) (define-walker-template LABELS walk-labels) (define-walker-template LAMBDA walk-lambda) (define-walker-template LET walk-let) (define-walker-template LET* walk-let*) (define-walker-template MACROLET walk-macrolet) (define-walker-template MULTIPLE-VALUE-CALL (NIL EVAL REPEAT (EVAL))) (define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL))) (define-walker-template MULTIPLE-VALUE-SETQ (NIL (REPEAT (SET)) EVAL)) (define-walker-template MULTIPLE-VALUE-BIND walk-multiple-value-bind) (define-walker-template PROGN (NIL REPEAT (EVAL))) (define-walker-template PROGV (NIL EVAL EVAL REPEAT (EVAL))) (define-walker-template QUOTE (NIL QUOTE)) (define-walker-template RETURN-FROM (NIL QUOTE REPEAT (RETURN))) (define-walker-template SETQ (NIL REPEAT (SET EVAL))) (define-walker-template TAGBODY walk-tagbody) (define-walker-template THE (NIL QUOTE EVAL)) (define-walker-template THROW (NIL EVAL EVAL)) (define-walker-template UNWIND-PROTECT (NIL RETURN REPEAT (EVAL))) ;;; The new special form. ;(define-walker-template pcl::LOAD-TIME-EVAL (NIL EVAL)) ;;; ;;; And the extra templates... ;;; (define-walker-template DO walk-do) (define-walker-template DO* walk-do*) (define-walker-template PROG walk-prog) (define-walker-template PROG* walk-prog*) (define-walker-template COND (NIL REPEAT ((TEST REPEAT (EVAL))))) ;; ;;;;;; WALK-FORM ;; ;;; ;;; The main entry-point is walk-form, calls back in should use walk-form-internal. ;;; (defun walk-form (form &key ((:declarations *declarations*) ()) ((:lexical-variables *lexical-variables*) ()) ((:environment *environment*) ()) ((:walk-function *walk-function*) #'(lambda (x y) (declare (ignore y)) x))) (walk-form-internal form :eval)) ;;; ;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It ;;; takes a form and the current context and walks the form calling itself or ;;; the appropriate template recursively. ;;; ;;; "It is recommended that a program-analyzing-program process a form ;;; that is a list whose car is a symbol as follows: ;;; ;;; 1. If the program has particular knowledge about the symbol, ;;; process the form using special-purpose code. All of the ;;; standard special forms should fall into this category. ;;; 2. Otherwise, if macro-function is true of the symbol apply ;;; either macroexpand or macroexpand-1 and start over. ;;; 3. Otherwise, assume it is a function call. " ;;; (defun walk-form-internal (form context &aux newform newnewform walk-no-more-p macrop fn template) ;; First apply the *walk-function* to perform whatever translation ;; the user wants to to this form. If the second value returned ;; by *walk-function* is T then we don't recurse... (multiple-value-setq (newform walk-no-more-p) (funcall *walk-function* form context)) (cond (walk-no-more-p newform) ((not (eq form newform)) (walk-form-internal newform context)) ((not (consp newform)) newform) ((setq template (get-walker-template (setq fn (car newform)))) (if (symbolp template) (funcall template newform context) (walk-template newform template context))) ((progn (multiple-value-setq (newnewform macrop) (macroexpand-1 newform *environment*)) macrop) (walk-form-internal newnewform context)) ((and (symbolp fn) (not (fboundp fn)) (special-form-p fn)) (error "~S is a special form, not defined in the CommonLisp manual.~%~ This code walker doesn't know how to walk it. Please define a~%~ template for this special form and try again." fn)) (t ;; Otherwise, walk the form as if its just a standard function ;; call using a template for standard function call. (walk-template newform '(call repeat (eval)) context)))) (defun walk-template (form template context) (if (atom template) (ecase template ((QUOTE NIL) form) ((EVAL FUNCTION TEST EFFECT RETURN) (walk-form-internal form :EVAL)) (SET (walk-form-internal form :SET)) ((LAMBDA CALL) (if (symbolp form) form (walk-lambda form context)))) (case (car template) (IF (let ((*walk-form* form)) (walk-template form (if (if (listp (cadr template)) (eval (cadr template)) (funcall (cadr template) form)) (caddr template) (cadddr template)) context))) (REPEAT (walk-template-handle-repeat form (cdr template) ;; For the case where nothing happens ;; after the repeat optimize out the ;; call to length. (if (null (cddr template)) () (nthcdr (- (length form) (length (cddr template))) form)) context)) (REMOTE (walk-template form (cadr template) context)) (otherwise (cond ((atom form) form) (t (recons form (walk-template (car form) (car template) context) (walk-template (cdr form) (cdr template) context)))))))) (defun walk-template-handle-repeat (form template stop-form context) (if (eq form stop-form) (walk-template form (cdr template) context) (walk-template-handle-repeat-1 form template (car template) stop-form context))) (defun walk-template-handle-repeat-1 (form template repeat-template stop-form context) (cond ((null form) ()) ((eq form stop-form) (if (null repeat-template) (walk-template stop-form (cdr template) context) (error "While handling repeat: ~%~Ran into stop while still in repeat template."))) ((null repeat-template) (walk-template-handle-repeat-1 form template (car template) stop-form context)) (t (recons form (walk-template (car form) (car repeat-template) context) (walk-template-handle-repeat-1 (cdr form) template (cdr repeat-template) stop-form context))))) (defun recons (x car cdr) (if (or (not (eq (car x) car)) (not (eq (cdr x) cdr))) (cons car cdr) x)) (defun relist* (x &rest args) (relist*-internal x args)) (defun relist*-internal (x args) (if (null (cdr args)) (car args) (recons x (car args) (relist*-internal (cdr x) (cdr args))))) ;; ;;;;;; Special walkers ;; (defun walk-declarations (body fn &optional doc-string-p declarations old-body &aux (form (car body)) macrop new-form) (cond ((and (stringp form) ;might be a doc string (cdr body) ;isn't the returned value (null doc-string-p) ;no doc string yet (null declarations)) ;no declarations yet (recons body form (walk-declarations (cdr body) fn t))) ((and (listp form) (eq (car form) 'declare)) ;; Got ourselves a real live declaration. Record it, look for more. (dolist (declaration (cdr form)) (note-declaration declaration) (push declaration declarations)) (recons body form (walk-declarations (cdr body) fn doc-string-p declarations))) ((and form (listp form) (null (get-walker-template (car form))) (progn (multiple-value-setq (new-form macrop) (macroexpand-1 (car form) *environment*)) macrop)) ;; This form was a call to a macro. Maybe it expanded ;; into a declare? Recurse to find out. (walk-declarations (recons body new-form (cdr body)) fn doc-string-p declarations (or old-body body))) (t ;; Now that we have walked and recorded the declarations, ;; call the function our caller provided to expand the body. ;; We call that function rather than passing the real-body ;; back, because we are RECONSING up the new body. (funcall fn (or old-body body))))) (defun walk-unexpected-declare (form context) (declare (ignore context)) (warn "Encountered declare ~S in a place where a declare was not expected." form) form) (defun walk-arglist (arglist context &optional (destructuringp nil) &aux arg) (cond ((null arglist) ()) ((symbolp (setq arg (car arglist))) (or (member arg lambda-list-keywords :test #'eq) (note-lexical-binding arg)) (recons arglist arg (walk-arglist (cdr arglist) context (and destructuringp (not (member arg lambda-list-keywords :test #'eq)))))) ((consp arg) (prog1 (if destructuringp (walk-arglist arg context destructuringp) (recons arglist (relist* arg (car arg) (walk-form-internal (cadr arg) :eval) (cddr arg)) (walk-arglist (cdr arglist) context nil))) (if (symbolp (car arg)) (note-lexical-binding (car arg)) (note-lexical-binding (cadar arg))) (or (null (cddr arg)) (not (symbolp (caddr arg))) (note-lexical-binding (caddr arg))))) (t (error "Can't understand something in the arglist ~S" arglist)))) (defun walk-let (form context) (walk-let/let* form context nil)) (defun walk-let* (form context) (walk-let/let* form context t)) (defun walk-prog (form context) (walk-let/let* form context nil)) (defun walk-prog* (form context) (walk-let/let* form context t)) (defun walk-do (form context) (walk-do/do* form context nil)) (defun walk-do* (form context) (walk-do/do* form context t)) (defun walk-let/let* (form context sequentialp) (let ((old-declarations *declarations*) (old-lexical-variables *lexical-variables*)) (with-new-contour (let* ((let/let* (car form)) (bindings (cadr form)) (body (cddr form)) walked-bindings (walked-body (walk-declarations body #'(lambda (real-body) (setq walked-bindings (walk-bindings-1 bindings old-declarations old-lexical-variables context sequentialp)) (walk-template real-body '(repeat (eval)) context))))) (relist* form let/let* walked-bindings walked-body))))) (defun walk-do/do* (form context sequentialp) (let ((old-declarations *declarations*) (old-lexical-variables *lexical-variables*)) (with-new-contour (let* ((do/do* (car form)) (bindings (cadr form)) (end-test (caddr form)) (body (cdddr form)) walked-bindings (walked-body (walk-declarations body #'(lambda (real-body) (setq walked-bindings (walk-bindings-1 bindings old-declarations old-lexical-variables context sequentialp)) (walk-template real-body '(repeat (eval)) context))))) (relist* form do/do* (walk-bindings-2 bindings walked-bindings context) (walk-template end-test '(test repeat (eval)) context) walked-body))))) (defun walk-multiple-value-bind (form context) (let ((old-declarations *declarations*) (old-lexical-variables *lexical-variables*)) (with-new-contour (let* ((mvb (car form)) (bindings (cadr form)) (mv-form (walk-template (caddr form) :eval context)) (body (cdddr form)) walked-bindings (walked-body (walk-declarations body #'(lambda (real-body) (setq walked-bindings (walk-bindings-1 bindings old-declarations old-lexical-variables context nil)) (walk-template real-body '(repeat (eval)) context))))) (relist* form mvb walked-bindings mv-form walked-body))))) (defun walk-bindings-1 (bindings old-declarations old-lexical-variables context sequentialp) (and bindings (let ((binding (car bindings))) (recons bindings (if (symbolp binding) (prog1 binding (note-lexical-binding binding)) (prog1 (let ((*declarations* old-declarations) (*lexical-variables* (if sequentialp *lexical-variables* old-lexical-variables))) (relist* binding (car binding) (walk-form-internal (cadr binding) context) (cddr binding))) ;save cddr for DO/DO* ;it is the next value ;form. Don't walk it ;now though. (note-lexical-binding (car binding)))) (walk-bindings-1 (cdr bindings) old-declarations old-lexical-variables context sequentialp))))) (defun walk-bindings-2 (bindings walked-bindings context) (and bindings (let ((binding (car bindings)) (walked-binding (car walked-bindings))) (recons bindings (if (symbolp binding) binding (relist* binding (car walked-binding) (cadr walked-binding) (walk-template (cddr binding) '(eval) context))) (walk-bindings-2 (cdr bindings) (cdr walked-bindings) context))))) (defun walk-lambda (form context) (with-new-contour (let* ((arglist (cadr form)) (body (cddr form)) (walked-arglist nil) (walked-body (walk-declarations body #'(lambda (real-body) (setq walked-arglist (walk-arglist arglist context)) (walk-template real-body '(repeat (eval)) context))))) (relist* form (car form) walked-arglist walked-body)))) (defun walk-tagbody (form context) (recons form (car form) (walk-tagbody-1 (cdr form) context))) (defun walk-tagbody-1 (form context) (and form (recons form (walk-form-internal (car form) (if (symbolp (car form)) 'quote context)) (walk-tagbody-1 (cdr form) context)))) (defun walk-compiler-let (form context) (with-new-contour (let ((vars ()) (vals ())) (dolist (binding (cadr form)) (cond ((symbolp binding) (push binding vars) (push nil vals)) (t (push (car binding) vars) (push (eval (cadr binding)) vals)))) (relist* form (car form) (cadr form) (progv vars vals (note-declaration (cons 'special vars)) (walk-template (cddr form) '(repeat (eval)) context)))))) (defun walk-macrolet (form context) (labels ((walk-definitions (definitions) (and (not (null definitions)) (let ((definition (car definitions))) (recons definitions (with-new-contour (relist* definition (car definition) (walk-arglist (cadr definition) context t) (walk-declarations (cddr definition) #'(lambda (real-body) (walk-template real-body '(repeat (eval)) context))))) (walk-definitions (cdr definitions))))))) (with-new-contour (relist* form (car form) (walk-definitions (cadr form)) (with-new-lexical-environment (*environment* *environment* form) (walk-declarations (cddr form) #'(lambda (real-body) (walk-template real-body '(repeat (eval)) context)))))))) (defun walk-flet (form context) (with-new-contour (labels ((walk-definitions (definitions) (if (null definitions) () (recons definitions (walk-lambda (car definitions) context) (walk-definitions (cdr definitions)))))) (recons form (car form) (recons (cdr form) (walk-definitions (cadr form)) (with-new-lexical-environment (*environment* *environment* form) (walk-declarations (cddr form) #'(lambda (real-body) (walk-template real-body '(repeat (eval)) context))))))))) (defun walk-labels (form context) (with-new-contour (labels ((walk-definitions (definitions) (if (null definitions) () (recons definitions (walk-lambda (car definitions) context) (walk-definitions (cdr definitions)))))) (recons form (car form) (with-new-lexical-environment (*environment* *environment* form) (recons (cdr form) (walk-definitions (cadr form)) (walk-declarations (cddr form) #'(lambda (real-body) (walk-template real-body '(repeat (eval)) context))))))))) ;;; ;;; Some facilities for handling the destructuring that complex Common Lisp ;;; macro lambda lists provide. ;;; (defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) (let ((gensym (make-symbol name))) (eval `(defmacro ,gensym ,llist ,@body)) (macro-function gensym)))