1;;;; a simple code walker 2;;;; 3;;;; The code which implements the macroexpansion environment 4;;;; manipulation mechanisms is in the first part of the file, the 5;;;; real walker follows it. 6 7;;;; This software is part of the SBCL system. See the README file for 8;;;; more information. 9 10;;;; This software is derived from software originally released by Xerox 11;;;; Corporation. Copyright and release statements follow. Later modifications 12;;;; to the software are in the public domain and are provided with 13;;;; absolutely no warranty. See the COPYING and CREDITS files for more 14;;;; information. 15 16;;;; copyright information from original PCL sources: 17;;;; 18;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. 19;;;; All rights reserved. 20;;;; 21;;;; Use and copying of this software and preparation of derivative works based 22;;;; upon this software are permitted. Any distribution of this software or 23;;;; derivative works must comply with all applicable United States export 24;;;; control laws. 25;;;; 26;;;; This software is made available AS IS, and Xerox Corporation makes no 27;;;; warranty about the software, its performance or its conformity to any 28;;;; specification. 29 30(in-package "SB!WALKER") 31 32;;;; forward references 33 34(defvar *key-to-walker-environment*) 35 36;;;; environment hacking stuff, necessarily SBCL-specific 37 38;;; Here in the original PCL were implementations of the 39;;; implementation-specific environment hacking functions for each of 40;;; the implementations this walker had been ported to. This 41;;; functionality was originally factored out in order to make PCL 42;;; portable from one Common Lisp to another. As of 19981107, that 43;;; portability was fairly stale and (because of the scarcity of CLTL1 44;;; implementations and the strong interdependence of the rest of ANSI 45;;; Common Lisp on the CLOS system) fairly irrelevant. It was fairly 46;;; thoroughly put out of its misery by WHN in his quest to clean up 47;;; the system enough that it can be built from scratch using any ANSI 48;;; Common Lisp. 49;;; 50;;; This code just hacks 'macroexpansion environments'. That is, it is 51;;; only concerned with the function binding of symbols in the 52;;; environment. The walker needs to be able to tell if the symbol 53;;; names a lexical macro or function, and it needs to be able to 54;;; build environments which contain lexical macro or function 55;;; bindings. It must be able, when walking a MACROLET, FLET or LABELS 56;;; form to construct an environment which reflects the bindings 57;;; created by that form. Note that the environment created does NOT 58;;; have to be sufficient to evaluate the body, merely to walk its 59;;; body. This means that definitions do not have to be supplied for 60;;; lexical functions, only the fact that that function is bound is 61;;; important. For macros, the macroexpansion function must be 62;;; supplied. 63;;; 64;;; This code is organized in a way that lets it work in 65;;; implementations that stack cons their environments. That is 66;;; reflected in the fact that the only operation that lets a user 67;;; build a new environment is a WITH-BODY macro which executes its 68;;; body with the specified symbol bound to the new environment. No 69;;; code in this walker or in PCL will hold a pointer to these 70;;; environments after the body returns. Other user code is free to do 71;;; so in implementations where it works, but that code is not 72;;; considered portable. 73;;; 74;;; There are 3 environment hacking tools. One macro, 75;;; WITH-AUGMENTED-ENVIRONMENT, which is used to create new 76;;; environments, and two functions, ENVIRONMENT-FUNCTION and 77;;; ENVIRONMENT-MACRO, which are used to access the bindings of 78;;; existing environments 79 80;;; In SBCL, as in CMU CL before it, the environment is represented 81;;; with a structure that holds alists for the functional things, 82;;; variables, blocks, etc. Except for SYMBOL-MACROLET, only the 83;;; SB!C::LEXENV-FUNS slot is relevant. It holds: Alist (Name . What), 84;;; where What is either a functional (a local function) or a list 85;;; (MACRO . <function>) (a local macro, with the specifier expander.) 86;;; Note that Name may be a (SETF <name>) function. Accessors are 87;;; defined below, eg (ENV-WALK-FUNCTION ENV). 88;;; 89;;; If WITH-AUGMENTED-ENVIRONMENT is called from WALKER-ENVIRONMENT-BIND 90;;; this code hides the WALKER version of an environment 91;;; inside the SB!C::LEXENV structure. 92;;; 93;;; In CMUCL (and former SBCL), This used to be a list of lists of form 94;;; (<gensym-name> MACRO . #<interpreted-function>) in the :functions slot 95;;; in a C::LEXENV. 96;;; This form was accepted by the compiler, but this was a crude hack, 97;;; because the <interpreted-function> was used as a structure to hold the 98;;; bits of interest, {function, form, declarations, lexical-variables}, 99;;; a list, which was not really an interpreted function. 100;;; Instead this list was COERCEd to a #<FUNCTION ...>! 101;;; 102;;; Instead, we now use a special sort of "function"-type for that 103;;; information, because the functions slot in SB!C::LEXENV is 104;;; supposed to have a list of <Name MACRO . #<function> elements. 105;;; So, now we hide our bits of interest in the walker-info slot in 106;;; our new BOGO-FUN. 107;;; 108;;; MACROEXPAND-1 and SB!INT:EVAL-IN-LEXENV are the only SBCL 109;;; functions that get called with the constructed environment 110;;; argument. 111 112(/show "walk.lisp 108") 113 114(defmacro with-augmented-environment 115 ((new-env old-env &key functions macros) &body body) 116 `(let ((,new-env (with-augmented-environment-internal ,old-env 117 ,functions 118 ,macros))) 119 ,@body)) 120 121;;; a unique tag to show that we're the intended caller of BOGO-FUN 122(defvar *bogo-fun-magic-tag* 123 '(:bogo-fun-magic-tag)) 124 125;;; The interface of BOGO-FUNs (previously implemented as 126;;; FUNCALLABLE-INSTANCEs) is just these two operations, so we can do 127;;; them with ordinary closures. 128;;; 129;;; KLUDGE: BOGO-FUNs are sorta weird, and MNA and I have both hacked 130;;; on this code without quite figuring out what they're for. (He 131;;; changed them to work after some changes in the IR1 interpreter 132;;; made functions not be built lazily, and I changed them so that 133;;; they don't need FUNCALLABLE-INSTANCE stuff, so that the F-I stuff 134;;; can become less general.) There may be further simplifications or 135;;; clarifications which could be done. -- WHN 2001-10-19 136(defun walker-info-to-bogo-fun (walker-info) 137 (lambda (magic-tag &rest rest) 138 (aver (not rest)) ; else someone is using me in an unexpected way 139 (aver (eql magic-tag *bogo-fun-magic-tag*)) ; else ditto 140 walker-info)) 141(defun bogo-fun-to-walker-info (bogo-fun) 142 (declare (type function bogo-fun)) 143 (funcall bogo-fun *bogo-fun-magic-tag*)) 144 145(defun with-augmented-environment-internal (env funs macros) 146 ;; Note: In order to record the correct function definition, we 147 ;; would have to create an interpreted closure, but the 148 ;; WITH-NEW-DEFINITION macro down below makes no distinction between 149 ;; FLET and LABELS, so we have no idea what to use for the 150 ;; environment. So we just blow it off, 'cause anything real we do 151 ;; would be wrong. But we still have to make an entry so we can tell 152 ;; functions from macros -- same for telling variables apart from 153 ;; symbol macros. 154 (let ((lexenv (sb!kernel:coerce-to-lexenv env))) 155 (sb!c::make-lexenv 156 :default lexenv 157 :vars (when (eql (caar macros) *key-to-walker-environment*) 158 (copy-tree (mapcar (lambda (b) 159 (let ((name (car b)) 160 (info (cadr b))) 161 (if (eq info :lexical-var) 162 (cons name 163 (if (var-special-p name env) 164 (sb!c::make-global-var 165 :kind :special 166 :%source-name name) 167 (sb!c::make-lambda-var 168 :%source-name name))) 169 b))) 170 (fourth (cadar macros))))) 171 :funs (append (mapcar (lambda (f) 172 (cons (car f) 173 (sb!c::make-functional :lexenv lexenv))) 174 funs) 175 (mapcar (lambda (m) 176 (list* (car m) 177 'sb!c::macro 178 (if (eq (car m) 179 *key-to-walker-environment*) 180 (walker-info-to-bogo-fun (cadr m)) 181 (coerce (cadr m) 'function)))) 182 macros))))) 183 184(defun environment-function (env fn) 185 (when env 186 (let ((entry (assoc fn (sb!c::lexenv-funs env) :test #'equal))) 187 (and entry 188 (sb!c::functional-p (cdr entry)) 189 (cdr entry))))) 190 191(defun environment-macro (env macro) 192 (when env 193 (let ((entry (assoc macro (sb!c::lexenv-funs env) :test #'eq))) 194 (and entry 195 (eq (cadr entry) 'sb!c::macro) 196 (if (eq macro *key-to-walker-environment*) 197 (values (bogo-fun-to-walker-info (cddr entry))) 198 (values (function-lambda-expression (cddr entry)))))))) 199 200;;;; other environment hacking, not so SBCL-specific as the 201;;;; environment hacking in the previous section 202 203(defmacro with-new-definition-in-environment 204 ((new-env old-env macrolet/flet/labels-form) &body body) 205 (let ((functions (make-symbol "Functions")) 206 (macros (make-symbol "Macros"))) 207 `(let ((,functions ()) 208 (,macros ())) 209 (ecase (car ,macrolet/flet/labels-form) 210 ((flet labels) 211 (dolist (fn (cadr ,macrolet/flet/labels-form)) 212 (push fn ,functions))) 213 ((macrolet) 214 (dolist (mac (cadr ,macrolet/flet/labels-form)) 215 (push (list (car mac) 216 (convert-macro-to-lambda (cadr mac) 217 (cddr mac) 218 ,old-env 219 (string (car mac)))) 220 ,macros)))) 221 (with-augmented-environment 222 (,new-env ,old-env :functions ,functions :macros ,macros) 223 ,@body)))) 224 225(defun convert-macro-to-lambda (llist body env &optional (name "dummy macro")) 226 (declare (ignorable llist body env name)) 227 #+sb-xc-host (error "CONVERT-MACRO-TO-LAMBDA called") ; no EVAL-IN-LEXENV 228 #-sb-xc-host 229 (let ((gensym (make-symbol name))) 230 (eval-in-lexenv `(defmacro ,gensym ,llist ,@body) 231 (sb!c::make-restricted-lexenv env)) 232 (macro-function gensym))) 233 234;;;; the actual walker 235 236;;; As the walker walks over the code, it communicates information to 237;;; itself about the walk. This information includes the walk 238;;; function, variable bindings, declarations in effect etc. This 239;;; information is inherently lexical, so the walker passes it around 240;;; in the actual environment the walker passes to macroexpansion 241;;; functions. 242(defmacro walker-environment-bind ((var env &rest key-args) 243 &body body) 244 `(with-augmented-environment 245 (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args)) 246 .,body)) 247 248(defvar *key-to-walker-environment* (gensym)) 249 250(defun env-lock (env) 251 (environment-macro env *key-to-walker-environment*)) 252 253(defun walker-environment-bind-1 (env &key (walk-function nil wfnp) 254 (walk-form nil wfop) 255 (declarations nil decp) 256 (lexical-vars nil lexp)) 257 (let ((lock (env-lock env))) 258 (list 259 (list *key-to-walker-environment* 260 (list (if wfnp walk-function (car lock)) 261 (if wfop walk-form (cadr lock)) 262 (if decp declarations (caddr lock)) 263 (if lexp lexical-vars (cadddr lock))))))) 264 265(defun env-walk-function (env) 266 (car (env-lock env))) 267 268(defun env-walk-form (env) 269 (cadr (env-lock env))) 270 271(defun env-declarations (env) 272 (caddr (env-lock env))) 273 274(defun env-var-type (var env) 275 (dolist (decl (env-declarations env) t) 276 (when (and (eq 'type (car decl)) (member var (cddr decl) :test 'eq)) 277 (return (cadr decl))))) 278 279(defun env-lexical-variables (env) 280 (cadddr (env-lock env))) 281 282(defun note-declaration (declaration env) 283 (push declaration (caddr (env-lock env)))) 284 285(defun note-var-binding (thing env) 286 (push (list thing :lexical-var) (cadddr (env-lock env)))) 287 288(defun var-lexical-p (var env) 289 (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq))) 290 (when (eq (cadar entry) :lexical-var) 291 (return-from var-lexical-p entry))) 292 ;; if we're finding something in the real lexenv, we don't have a 293 ;; bound declaration and so we specifically don't want to return 294 ;; a special object that declarations can attach to, just the name. 295 (and env (find var (mapcar #'car (sb!c::lexenv-vars env))))) 296 297(defun variable-symbol-macro-p (var env) 298 ;; FIXME: crufty return convention 299 (let ((entry (or (member var (env-lexical-variables env) :key #'car :test #'eq) 300 (and env (member var (sb!c::lexenv-vars env) :key #'car :test #'eq))))) 301 (when (and (consp (cdar entry)) (eq (cadar entry) 'sb!sys:macro)) 302 (return-from variable-symbol-macro-p entry)) 303 (unless entry 304 (when (var-globally-symbol-macro-p var) 305 (list (list* var 'sb!sys:macro (info :variable :macro-expansion var))))))) 306 307(defun var-globally-symbol-macro-p (var) 308 (eq (info :variable :kind var) :macro)) 309 310(defun walked-var-declaration-p (declaration) 311 (member declaration '(sb!pcl::%class sb!pcl::%variable-rebinding special))) 312 313(defun %var-declaration (declaration var env) 314 (let ((id (or (var-lexical-p var env) var))) 315 (if (eq 'special declaration) 316 (dolist (decl (env-declarations env)) 317 (when (and (eq (car decl) declaration) 318 (or (member var (cdr decl)) 319 (and id (member id (cdr decl))))) 320 (return decl))) 321 (dolist (decl (env-declarations env)) 322 (when (and (eq (car decl) declaration) 323 (eq (cadr decl) id)) 324 (return decl)))))) 325 326(defun var-declaration (declaration var env) 327 (if (walked-var-declaration-p declaration) 328 (%var-declaration declaration var env) 329 (error "Not a variable declaration the walker cares about: ~S" declaration))) 330 331#-sb-xc-host 332(define-compiler-macro var-declaration (&whole form declaration var env 333 &environment lexenv) 334 (if (sb!xc:constantp declaration lexenv) 335 (let ((decl (constant-form-value declaration lexenv))) 336 (if (walked-var-declaration-p decl) 337 `(%var-declaration ,declaration ,var ,env) 338 form)) 339 form)) 340 341(defun var-special-p (var env) 342 (and (or (var-declaration 'special var env) 343 (var-globally-special-p var)) 344 t)) 345 346(defun var-globally-special-p (symbol) 347 (eq (info :variable :kind symbol) :special)) 348 349 350;;;; handling of special forms 351 352;;; Here are some comments from the original PCL on the difficulty of 353;;; doing this portably across different CLTL1 implementations. This 354;;; is no longer directly relevant because this code now only runs on 355;;; SBCL, but the comments are retained for culture: they might help 356;;; explain some of the design decisions which were made in the code. 357;;; 358;;; and I quote... 359;;; 360;;; The set of special forms is purposely kept very small because 361;;; any program analyzing program (read code walker) must have 362;;; special knowledge about every type of special form. Such a 363;;; program needs no special knowledge about macros... 364;;; 365;;; So all we have to do here is a define a way to store and retrieve 366;;; templates which describe how to walk the 24 special forms and we 367;;; are all set... 368;;; 369;;; Well, its a nice concept, and I have to admit to being naive 370;;; enough that I believed it for a while, but not everyone takes 371;;; having only 24 special forms as seriously as might be nice. There 372;;; are (at least) 3 ways to lose: 373;; 374;;; 1 - Implementation x implements a Common Lisp special form as 375;;; a macro which expands into a special form which: 376;;; - Is a common lisp special form (not likely) 377;;; - Is not a common lisp special form (on the 3600 IF --> COND). 378;;; 379;;; * We can save ourselves from this case (second subcase really) 380;;; by checking to see whether there is a template defined for 381;;; something before we check to see whether we can macroexpand it. 382;;; 383;;; 2 - Implementation x implements a Common Lisp macro as a special form. 384;;; 385;;; * This is a screw, but not so bad, we save ourselves from it by 386;;; defining extra templates for the macros which are *likely* to 387;;; be implemented as special forms. [Note: As of sbcl-0.6.9, these 388;;; extra templates have been deleted, since this is not a problem 389;;; in SBCL and we no longer try to make this walker portable 390;;; across other possibly-broken CL implementations.] 391;;; 392;;; 3 - Implementation x has a special form which is not on the list of 393;;; Common Lisp special forms. 394;;; 395;;; * This is a bad sort of a screw and happens more than I would 396;;; like to think, especially in the implementations which provide 397;;; more than just Common Lisp (3600, Xerox etc.). 398;;; The fix is not terribly satisfactory, but will have to do for 399;;; now. There is a hook in get walker-template which can get a 400;;; template from the implementation's own walker. That template 401;;; has to be converted, and so it may be that the right way to do 402;;; this would actually be for that implementation to provide an 403;;; interface to its walker which looks like the interface to this 404;;; walker. 405 406(defmacro get-walker-template-internal (x) 407 `(get ,x 'walker-template)) 408 409(defmacro define-walker-template (name 410 &optional (template '(nil repeat (eval)))) 411 `(setf (get-walker-template-internal ',name) ',template)) 412 413(defun get-walker-template (x context) 414 (cond ((symbolp x) 415 (get-walker-template-internal x)) 416 ((and (listp x) (eq (car x) 'lambda)) 417 '(lambda repeat (eval))) 418 (t 419 ;; FIXME: In an ideal world we would do something similar to 420 ;; COMPILER-ERROR here, replacing the form within the walker 421 ;; with an error-signalling form. This is slightly less 422 ;; pretty, but informative non the less. Best is the enemy of 423 ;; good, etc. 424 (error "Illegal function call in method body:~% ~S" 425 context)))) 426 427;;;; the actual templates 428 429;;; ANSI special forms 430(define-walker-template block (nil nil repeat (eval))) 431(define-walker-template catch (nil eval repeat (eval))) 432(define-walker-template declare walk-unexpected-declare) 433(define-walker-template eval-when (nil quote repeat (eval))) 434(define-walker-template flet walk-flet) 435(define-walker-template function (nil call)) 436(define-walker-template go (nil quote)) 437(define-walker-template if walk-if) 438(define-walker-template labels walk-labels) 439(define-walker-template lambda walk-lambda) 440(define-walker-template let walk-let) 441(define-walker-template let* walk-let*) 442(define-walker-template load-time-value walk-load-time-value) 443(define-walker-template locally walk-locally) 444(define-walker-template macrolet walk-macrolet) 445(define-walker-template multiple-value-call (nil eval repeat (eval))) 446(define-walker-template multiple-value-prog1 (nil return repeat (eval))) 447(define-walker-template multiple-value-setq walk-multiple-value-setq) 448(define-walker-template multiple-value-bind walk-multiple-value-bind) 449(define-walker-template progn (nil repeat (eval))) 450(define-walker-template progv (nil eval eval repeat (eval))) 451(define-walker-template quote (nil quote)) 452(define-walker-template return-from (nil quote repeat (return))) 453(define-walker-template setq walk-setq) 454(define-walker-template symbol-macrolet walk-symbol-macrolet) 455(define-walker-template tagbody walk-tagbody) 456(define-walker-template the (nil quote eval)) 457(define-walker-template throw (nil eval eval)) 458(define-walker-template unwind-protect (nil return repeat (eval))) 459 460;;; SBCL-only special forms 461(define-walker-template truly-the (nil quote eval)) 462;;; FIXME: maybe we don't need this one any more, given that 463;;; NAMED-LAMBDA now expands into (FUNCTION (NAMED-LAMBDA ...))? 464(define-walker-template named-lambda walk-named-lambda) 465 466(defvar *walk-form-expand-macros-p* nil) 467 468(defun walk-form (form 469 &optional environment 470 (walk-function 471 (lambda (subform context env) 472 (declare (ignore context env)) 473 subform))) 474 #!+(and sb-fasteval (host-feature sb-xc)) 475 (when (typep environment 'sb!interpreter:basic-env) 476 (setq environment (sb!interpreter:lexenv-from-env environment))) 477 (walker-environment-bind (new-env environment :walk-function walk-function) 478 (walk-form-internal form :eval new-env))) 479 480;;; WALK-FORM-INTERNAL is the main driving function for the code 481;;; walker. It takes a form and the current context and walks the form 482;;; calling itself or the appropriate template recursively. 483;;; 484;;; "It is recommended that a program-analyzing-program process a form 485;;; that is a list whose car is a symbol as follows: 486;;; 487;;; 1. If the program has particular knowledge about the symbol, 488;;; process the form using special-purpose code. All of the 489;;; standard special forms should fall into this category. 490;;; 2. Otherwise, if MACRO-FUNCTION is true of the symbol apply 491;;; either MACROEXPAND or MACROEXPAND-1 and start over. 492;;; 3. Otherwise, assume it is a function call. " 493(defun walk-form-internal (form context env) 494 (declare (type (member :eval :set) context)) 495 ;; First apply the walk-function to perform whatever translation 496 ;; the user wants to this form. If the second value returned 497 ;; by walk-function is T then we don't recurse... 498 (catch form 499 (multiple-value-bind (newform walk-no-more-p) 500 (funcall (env-walk-function env) form context env) 501 (catch newform 502 (cond 503 (walk-no-more-p newform) 504 ((not (eq form newform)) 505 (walk-form-internal newform context env)) 506 ((and (not (consp newform)) 507 (or (eql context :eval) 508 (eql context :set))) 509 (let ((symmac (car (variable-symbol-macro-p newform env)))) 510 (if symmac 511 (let* ((newnewform (walk-form-internal (cddr symmac) 512 context 513 env)) 514 (resultform 515 (if (eq newnewform (cddr symmac)) 516 (if *walk-form-expand-macros-p* newnewform newform) 517 newnewform)) 518 (type (env-var-type newform env))) 519 (if (eq t type) 520 resultform 521 `(the ,type ,resultform))) 522 newform))) 523 ((eql context :set) newform) 524 (t 525 (let* ((fn (car newform)) 526 (template (get-walker-template fn newform))) 527 (if template 528 (if (symbolp template) 529 (funcall template newform context env) 530 (walk-template newform template context env)) 531 (multiple-value-bind (newnewform macrop) 532 (walker-environment-bind 533 (new-env env :walk-form newform) 534 (%macroexpand-1 newform new-env)) 535 (cond 536 (macrop 537 (let ((newnewnewform (walk-form-internal newnewform 538 context 539 env))) 540 (if (eq newnewnewform newnewform) 541 (if *walk-form-expand-macros-p* newnewform newform) 542 newnewnewform))) 543 ((and (symbolp fn) 544 (special-operator-p fn)) 545 ;; This shouldn't happen, since this walker is now 546 ;; maintained as part of SBCL, so it should know 547 ;; about all the special forms that SBCL knows 548 ;; about. 549 (bug "unexpected special form ~S" fn)) 550 (t 551 ;; Otherwise, walk the form as if it's just a 552 ;; standard function call using a template for 553 ;; standard function call. 554 (walk-template 555 newnewform '(call repeat (eval)) context env)))))))))))) 556 557(defun walk-template (form template context env) 558 (if (atom template) 559 (ecase template 560 ((eval function test effect return) 561 (walk-form-internal form :eval env)) 562 ((quote nil) form) 563 (set 564 (walk-form-internal form :set env)) 565 ((lambda call) 566 (cond ((legal-fun-name-p form) 567 form) 568 (t (walk-form-internal form context env))))) 569 (case (car template) 570 (repeat 571 (walk-template-handle-repeat form 572 (cdr template) 573 ;; For the case where nothing 574 ;; happens after the repeat 575 ;; optimize away the call to 576 ;; LENGTH. 577 (if (null (cddr template)) 578 () 579 (nthcdr (- (length form) 580 (length 581 (cddr template))) 582 form)) 583 context 584 env)) 585 (if 586 (walk-template form 587 (if (if (listp (cadr template)) 588 (eval (cadr template)) 589 (funcall (cadr template) form)) 590 (caddr template) 591 (cadddr template)) 592 context 593 env)) 594 (remote 595 (walk-template form (cadr template) context env)) 596 (otherwise 597 (cond ((atom form) form) 598 (t (recons form 599 (walk-template 600 (car form) (car template) context env) 601 (walk-template 602 (cdr form) (cdr template) context env)))))))) 603 604(defun walk-template-handle-repeat (form template stop-form context env) 605 (if (eq form stop-form) 606 (walk-template form (cdr template) context env) 607 (walk-template-handle-repeat-1 608 form template (car template) stop-form context env))) 609 610(defun walk-template-handle-repeat-1 (form template repeat-template 611 stop-form context env) 612 (cond ((null form) ()) 613 ((eq form stop-form) 614 (if (null repeat-template) 615 (walk-template stop-form (cdr template) context env) 616 (error "while handling code walker REPEAT: 617 ~%ran into STOP while still in REPEAT template"))) 618 ((null repeat-template) 619 (walk-template-handle-repeat-1 620 form template (car template) stop-form context env)) 621 (t 622 (recons form 623 (walk-template (car form) (car repeat-template) context env) 624 (walk-template-handle-repeat-1 (cdr form) 625 template 626 (cdr repeat-template) 627 stop-form 628 context 629 env))))) 630 631(defun walk-repeat-eval (form env) 632 (and form 633 (recons form 634 (walk-form-internal (car form) :eval env) 635 (walk-repeat-eval (cdr form) env)))) 636 637(defun recons (x car cdr) 638 (if (or (not (eq (car x) car)) 639 (not (eq (cdr x) cdr))) 640 (cons car cdr) 641 x)) 642 643(defun relist (x &rest args) 644 (if (null args) 645 nil 646 (relist-internal x args nil))) 647 648(defun relist* (x &rest args) 649 (relist-internal x args t)) 650 651(defun relist-internal (x args *p) 652 (if (null (cdr args)) 653 (if *p 654 (car args) 655 (recons x (car args) nil)) 656 (recons x 657 (car args) 658 (relist-internal (cdr x) (cdr args) *p)))) 659 660;;;; special walkers 661 662(defun walk-declarations (body fn env 663 &optional doc-string-p declarations old-body 664 &aux (form (car body)) macrop new-form) 665 (cond ((and (stringp form) ;might be a doc string 666 (cdr body) ;isn't the returned value 667 (null doc-string-p) ;no doc string yet 668 (null declarations)) ;no declarations yet 669 (recons body 670 form 671 (walk-declarations (cdr body) fn env t))) 672 ((and (listp form) (eq (car form) 'declare)) 673 ;; We got ourselves a real live declaration. Record it, look 674 ;; for more. 675 (dolist (declaration (cdr form)) 676 (let ((type (car declaration)) 677 (name (cadr declaration)) 678 (args (cddr declaration))) 679 (if (walked-var-declaration-p type) 680 (note-declaration `(,type 681 ,(or (var-lexical-p name env) name) 682 ,.args) 683 env) 684 (note-declaration (sb!c::canonized-decl-spec declaration) env)) 685 (push declaration declarations))) 686 (recons body 687 form 688 (walk-declarations 689 (cdr body) fn env doc-string-p declarations))) 690 ((and form 691 (listp form) 692 (null (get-walker-template (car form) form)) 693 (progn 694 (multiple-value-setq (new-form macrop) 695 (%macroexpand-1 form env)) 696 macrop)) 697 ;; This form was a call to a macro. Maybe it expanded 698 ;; into a declare? Recurse to find out. 699 (walk-declarations (recons body new-form (cdr body)) 700 fn env doc-string-p declarations 701 (or old-body body))) 702 (t 703 ;; Now that we have walked and recorded the declarations, 704 ;; call the function our caller provided to expand the body. 705 ;; We call that function rather than passing the real-body 706 ;; back, because we are RECONSING up the new body. 707 (funcall fn (or old-body body) env)))) 708 709(defun walk-unexpected-declare (form context env) 710 (declare (ignore context env)) 711 (warn "encountered ~S ~_in a place where a DECLARE was not expected" 712 form) 713 form) 714 715(defun walk-arglist (arglist context env &optional (destructuringp nil) 716 &aux arg) 717 (cond ((null arglist) ()) 718 ((symbolp (setq arg (car arglist))) 719 (or (member arg sb!xc:lambda-list-keywords :test #'eq) 720 (note-var-binding arg env)) 721 (recons arglist 722 arg 723 (walk-arglist (cdr arglist) 724 context 725 env 726 (and destructuringp 727 (not (member arg sb!xc:lambda-list-keywords)))))) 728 ((consp arg) 729 (prog1 (recons arglist 730 (if destructuringp 731 (walk-arglist arg context env destructuringp) 732 (relist* arg 733 (car arg) 734 (walk-form-internal (cadr arg) :eval env) 735 (cddr arg))) 736 (walk-arglist (cdr arglist) context env nil)) 737 (if (symbolp (car arg)) 738 (note-var-binding (car arg) env) 739 (note-var-binding (cadar arg) env)) 740 (or (null (cddr arg)) 741 (not (symbolp (caddr arg))) 742 (note-var-binding (caddr arg) env)))) 743 (t 744 (error "can't understand something in the arglist ~S" arglist)))) 745 746(defun walk-let (form context env) 747 (walker-environment-bind (new-env env) 748 (let* ((let (car form)) 749 (bindings (cadr form)) 750 (body (cddr form)) 751 walked-bindings 752 (walked-body 753 (walk-declarations 754 body 755 (lambda (real-body real-env) 756 (setf walked-bindings 757 (walk-bindings-1 bindings env new-env context)) 758 (walk-repeat-eval real-body real-env)) 759 new-env))) 760 (relist* form let walked-bindings walked-body)))) 761 762(defun let*-binding-name (binding) 763 (if (symbolp binding) 764 binding 765 (car binding))) 766 767(defun let*-binding-init (binding) 768 (if (or (symbolp binding) 769 (null (cdr binding))) 770 'no-init 771 (cadr binding))) 772 773(defun let*-bindings (bindings &aux names inits (seen (make-hash-table))) 774 (dolist (binding (reverse bindings) (values names inits)) 775 (let ((name (let*-binding-name binding))) 776 (push (cons name (gethash name seen)) names) 777 (setf (gethash name seen) t) 778 (push (let*-binding-init binding) inits)))) 779 780(defun walk-let* (form context env) 781 (walker-environment-bind (new-env env) 782 (let ((let* (car form)) 783 (bindings (cadr form)) 784 (body (cddr form))) 785 (multiple-value-bind (names inits) (let*-bindings bindings) 786 (multiple-value-bind (newbody decls doc) (parse-body body nil) 787 (declare (ignore newbody)) 788 (aver (null doc)) 789 (labels ((maybe-process-and-munge-declaration (name declaration env) 790 (if (walked-var-declaration-p (car declaration)) 791 (case (car declaration) 792 (special (if (find name (cdr declaration)) 793 (progn 794 (note-declaration `(special ,(var-lexical-p name env)) env) 795 (cons 'special (remove name (cdr declaration)))) 796 declaration)) 797 (t (if (eql name (cadr declaration)) 798 (progn 799 (note-declaration `(,(car declaration) 800 ,(var-lexical-p name env) 801 ,@(cddr declaration)) 802 env) 803 nil) 804 declaration))) 805 declaration)) 806 (walk-let*-bindings (bindings names inits) 807 (when bindings 808 (recons bindings 809 (let ((name (car names)) 810 (init (car inits))) 811 (prog1 812 (if (eql init 'no-init) 813 (prog1 (car bindings) 814 (note-var-binding (car name) new-env)) 815 (prog1 816 (relist (car bindings) 817 (caar bindings) 818 (walk-form-internal init context new-env)) 819 (note-var-binding (car name) new-env))) 820 (unless (cdr name) 821 (setf decls (mapcar (lambda (d) 822 (cons 'declare 823 (mapcar (lambda (dd) (maybe-process-and-munge-declaration (car name) dd new-env)) 824 (cdr d)))) 825 decls))))) 826 (walk-let*-bindings (cdr bindings) (cdr names) (cdr inits)))))) 827 (relist* form let* 828 (walk-let*-bindings bindings names inits) 829 (walk-declarations body (lambda (form env) (walk-repeat-eval form env)) new-env)))))))) 830 831(defun walk-load-time-value (form context env) 832 (destructuring-bind (ltv val &optional read-only-p) form 833 (declare (ignore ltv)) 834 (relist form 835 'load-time-value 836 ;; this is wrong: VAL is handled differently depending on 837 ;; whether we're in EVAL, COMPILE or COMPILE-FILE, and 838 ;; (after macroexpansion) is evaluated in the null lexical 839 ;; environment. The macro semantics are the same in each 840 ;; case, but VAR-LEXICAL-P can be tricked into giving the 841 ;; wrong answer. 842 (walk-form-internal val context env) 843 (walk-form-internal read-only-p context env)))) 844 845(defun walk-locally (form context env) 846 (declare (ignore context)) 847 (walker-environment-bind (new-env env) 848 (let* ((locally (car form)) 849 (body (cdr form)) 850 (walked-body 851 (walk-declarations body #'walk-repeat-eval new-env))) 852 (relist* 853 form locally walked-body)))) 854 855(defun walk-multiple-value-setq (form context env) 856 (let ((vars (cadr form))) 857 (if (some (lambda (var) 858 (variable-symbol-macro-p var env)) 859 vars) 860 (let* ((temps (mapcar (lambda (var) 861 (declare (ignore var)) 862 (gensym)) 863 vars)) 864 (sets (mapcar (lambda (var temp) `(setq ,var ,temp)) 865 vars 866 temps)) 867 (expanded `(multiple-value-bind ,temps ,(caddr form) 868 ,@sets)) 869 (walked (walk-form-internal expanded context env))) 870 (if (eq walked expanded) 871 form 872 walked)) 873 (walk-template form '(nil (repeat (set)) eval) context env)))) 874 875(defun walk-multiple-value-bind (form context old-env) 876 (walker-environment-bind (new-env old-env) 877 (let* ((mvb (car form)) 878 (bindings (cadr form)) 879 (mv-form (walk-template (caddr form) 'eval context old-env)) 880 (body (cdddr form)) 881 walked-bindings 882 (walked-body 883 (walk-declarations 884 body 885 (lambda (real-body real-env) 886 (setq walked-bindings 887 (walk-bindings-1 bindings old-env new-env context)) 888 (walk-repeat-eval real-body real-env)) 889 new-env))) 890 (relist* form mvb walked-bindings mv-form walked-body)))) 891 892(defun walk-bindings-1 (bindings old-env new-env context) 893 (and bindings 894 (let ((binding (car bindings))) 895 (recons bindings 896 (if (symbolp binding) 897 (prog1 binding 898 (note-var-binding binding new-env)) 899 (prog1 (relist binding 900 (car binding) 901 (walk-form-internal 902 (cadr binding) context old-env)) 903 (note-var-binding (car binding) new-env))) 904 (walk-bindings-1 (cdr bindings) old-env new-env context))))) 905 906(defun walk-lambda (form context old-env) 907 (walker-environment-bind (new-env old-env) 908 (let* ((arglist (cadr form)) 909 (body (cddr form)) 910 (walked-arglist (walk-arglist arglist context new-env)) 911 (walked-body 912 (walk-declarations body #'walk-repeat-eval new-env))) 913 (relist* form 914 (car form) 915 walked-arglist 916 walked-body)))) 917 918(defun walk-named-lambda (form context old-env) 919 (walker-environment-bind (new-env old-env) 920 (let* ((name (second form)) 921 (arglist (third form)) 922 (body (cdddr form)) 923 (walked-arglist (walk-arglist arglist context new-env)) 924 (walked-body 925 (walk-declarations body #'walk-repeat-eval new-env))) 926 (relist* form 927 (car form) 928 name 929 walked-arglist 930 walked-body)))) 931 932(defun walk-setq (form context env) 933 (if (cdddr form) 934 (let* ((expanded (let ((rforms nil) 935 (tail (cdr form))) 936 (loop (when (null tail) (return (nreverse rforms))) 937 (let ((var (pop tail)) (val (pop tail))) 938 (push `(setq ,var ,val) rforms))))) 939 (walked (walk-repeat-eval expanded env))) 940 (if (eq expanded walked) 941 form 942 `(progn ,@walked))) 943 (let* ((var (cadr form)) 944 (val (caddr form)) 945 (symmac (car (variable-symbol-macro-p var env)))) 946 (if symmac 947 (let* ((type (env-var-type var env)) 948 (expanded (if (eq t type) 949 `(setf ,(cddr symmac) ,val) 950 `(setf ,(cddr symmac) (the ,type ,val)))) 951 (walked (walk-form-internal expanded context env))) 952 (if (eq expanded walked) 953 form 954 walked)) 955 (relist form 'setq 956 (walk-form-internal var :set env) 957 (walk-form-internal val :eval env)))))) 958 959(defun walk-symbol-macrolet (form context old-env) 960 (declare (ignore context)) 961 (let* ((bindings (cadr form)) 962 (body (cddr form))) 963 (walker-environment-bind 964 (new-env old-env 965 :lexical-vars 966 (append (mapcar (lambda (binding) 967 `(,(car binding) 968 sb!sys:macro . ,(cadr binding))) 969 bindings) 970 (env-lexical-variables old-env))) 971 (relist* form 'symbol-macrolet bindings 972 (walk-declarations body #'walk-repeat-eval new-env))))) 973 974(defun walk-tagbody (form context env) 975 (recons form (car form) (walk-tagbody-1 (cdr form) context env))) 976 977(defun walk-tagbody-1 (form context env) 978 (and form 979 (recons form 980 (if (or (symbolp (car form)) (integerp (car form))) 981 (walk-template (car form) 'quote context env) 982 (walk-form-internal (car form) context env)) 983 (walk-tagbody-1 (cdr form) context env)))) 984 985(defun walk-macrolet (form context old-env) 986 (walker-environment-bind (old-env old-env) 987 (walker-environment-bind (macro-env 988 nil 989 :walk-function (env-walk-function old-env)) 990 (labels ((walk-definitions (definitions) 991 (and definitions 992 (let ((definition (car definitions))) 993 (recons definitions 994 (relist* definition 995 (car definition) 996 (walk-arglist (cadr definition) 997 context 998 macro-env 999 t) 1000 (walk-declarations (cddr definition) 1001 #'walk-repeat-eval 1002 macro-env)) 1003 (walk-definitions (cdr definitions))))))) 1004 (with-new-definition-in-environment (new-env old-env form) 1005 (relist* form 1006 (car form) 1007 (walk-definitions (cadr form)) 1008 (walk-declarations (cddr form) 1009 #'walk-repeat-eval 1010 new-env))))))) 1011 1012(defun walk-flet (form context old-env) 1013 (walker-environment-bind (old-env old-env) 1014 (labels ((walk-definitions (definitions) 1015 (if (null definitions) 1016 () 1017 (recons definitions 1018 (walk-lambda (car definitions) context old-env) 1019 (walk-definitions (cdr definitions)))))) 1020 (recons form 1021 (car form) 1022 (recons (cdr form) 1023 (walk-definitions (cadr form)) 1024 (with-new-definition-in-environment (new-env old-env form) 1025 (walk-declarations (cddr form) 1026 #'walk-repeat-eval 1027 new-env))))))) 1028 1029(defun walk-labels (form context old-env) 1030 (walker-environment-bind (old-env old-env) 1031 (with-new-definition-in-environment (new-env old-env form) 1032 (labels ((walk-definitions (definitions) 1033 (if (null definitions) 1034 () 1035 (recons definitions 1036 (walk-lambda (car definitions) context new-env) 1037 (walk-definitions (cdr definitions)))))) 1038 (recons form 1039 (car form) 1040 (recons (cdr form) 1041 (walk-definitions (cadr form)) 1042 (walk-declarations (cddr form) 1043 #'walk-repeat-eval 1044 new-env))))))) 1045 1046(defun walk-if (form context env) 1047 (destructuring-bind (if predicate arm1 &optional arm2) form 1048 (declare (ignore if)) ; should be 'IF 1049 (relist form 1050 'if 1051 (walk-form-internal predicate context env) 1052 (walk-form-internal arm1 context env) 1053 (walk-form-internal arm2 context env)))) 1054 1055;;;; examples 1056 1057#| 1058;;; Here are some examples of the kinds of things you should be able 1059;;; to do with your implementation of the macroexpansion environment 1060;;; hacking mechanism. 1061;;; 1062;;; WITH-LEXICAL-MACROS is kind of like MACROLET, but it only takes 1063;;; names of the macros and actual macroexpansion functions to use to 1064;;; macroexpand them. The win about that is that for macros which want 1065;;; to wrap several MACROLETs around their body, they can do this but 1066;;; have the macroexpansion functions be compiled. See the WITH-RPUSH 1067;;; example. 1068;;; 1069;;; If the implementation had a special way of communicating the 1070;;; augmented environment back to the evaluator that would be totally 1071;;; great. It would mean that we could just augment the environment 1072;;; then pass control back to the implementations own compiler or 1073;;; interpreter. We wouldn't have to call the actual walker. That 1074;;; would make this much faster. Since the principal client of this is 1075;;; defmethod it would make compiling defmethods faster and that would 1076;;; certainly be a win. 1077 1078(defmacro with-lexical-macros (macros &body body &environment old-env) 1079 (with-augmented-environment (new-env old-env :macros macros) 1080 (walk-form (cons 'progn body) :environment new-env))) 1081 1082(defun expand-rpush (form env) 1083 (declare (ignore env)) 1084 `(push ,(caddr form) ,(cadr form))) 1085 1086(defmacro with-rpush (&body body) 1087 `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body)) 1088|# 1089