X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwalk.lisp;h=c8401d43c31febb28f4e37b8dfc029aebc862e82;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=7430d6fc8f6f4d368f61218c4b18236bf632d060;hpb=fcde5281a74cb29e21550f4f979ad6356f149ab9;p=sbcl.git diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 7430d6f..c8401d4 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -1,4 +1,4 @@ -;;;; a simple code walker for PCL +;;;; a simple code walker ;;;; ;;;; The code which implements the macroexpansion environment ;;;; manipulation mechanisms is in the first part of the file, the @@ -27,7 +27,11 @@ ;;;; warranty about the software, its performance or its conformity to any ;;;; specification. -(in-package "SB-WALKER") +(in-package "SB!WALKER") + +;;;; forward references + +(defvar *key-to-walker-environment*) ;;;; environment hacking stuff, necessarily SBCL-specific @@ -76,7 +80,7 @@ ;;; In SBCL, as in CMU CL before it, the environment is represented ;;; with a structure that holds alists for the functional things, ;;; variables, blocks, etc. Except for SYMBOL-MACROLET, only the -;;; SB-C::LEXENV-FUNS slot is relevant. It holds: Alist (Name . What), +;;; SB!C::LEXENV-FUNS slot is relevant. It holds: Alist (Name . What), ;;; where What is either a functional (a local function) or a list ;;; (MACRO . ) (a local macro, with the specifier expander.) ;;; Note that Name may be a (SETF ) function. Accessors are @@ -84,7 +88,7 @@ ;;; ;;; If WITH-AUGMENTED-ENVIRONMENT is called from WALKER-ENVIRONMENT-BIND ;;; this code hides the WALKER version of an environment -;;; inside the SB-C::LEXENV structure. +;;; inside the SB!C::LEXENV structure. ;;; ;;; In CMUCL (and former SBCL), This used to be a list of lists of form ;;; ( MACRO . #) in the :functions slot @@ -96,12 +100,12 @@ ;;; Instead this list was COERCEd to a #! ;;; ;;; Instead, we now use a special sort of "function"-type for that -;;; information, because the functions slot in SB-C::LEXENV is +;;; information, because the functions slot in SB!C::LEXENV is ;;; supposed to have a list of elements. ;;; So, now we hide our bits of interest in the walker-info slot in ;;; our new BOGO-FUN. ;;; -;;; MACROEXPAND-1 and SB-INT:EVAL-IN-LEXENV are the only SBCL +;;; MACROEXPAND-1 and SB!INT:EVAL-IN-LEXENV are the only SBCL ;;; functions that get called with the constructed environment ;;; argument. @@ -146,34 +150,37 @@ ;; environment. So we just blow it off, 'cause anything real we do ;; would be wrong. But we still have to make an entry so we can tell ;; functions from macros. - (let ((lexenv (sb-kernel::coerce-to-lexenv env))) - (sb-c::make-lexenv - :default lexenv - :funs (append (mapcar (lambda (f) - (cons (car f) - (sb-c::make-functional :lexenv lexenv))) - funs) - (mapcar (lambda (m) - (list* (car m) - 'sb-c::macro - (if (eq (car m) - *key-to-walker-environment*) - (walker-info-to-bogo-fun (cadr m)) - (coerce (cadr m) 'function)))) - macros))))) + (let ((lexenv (sb!kernel::coerce-to-lexenv env))) + (sb!c::make-lexenv + :default lexenv + :vars (when (eql (caar macros) *key-to-walker-environment*) + (copy-tree (remove :lexical-var (fourth (cadar macros)) + :key #'cadr))) + :funs (append (mapcar (lambda (f) + (cons (car f) + (sb!c::make-functional :lexenv lexenv))) + funs) + (mapcar (lambda (m) + (list* (car m) + 'sb!c::macro + (if (eq (car m) + *key-to-walker-environment*) + (walker-info-to-bogo-fun (cadr m)) + (coerce (cadr m) 'function)))) + macros))))) (defun environment-function (env fn) (when env - (let ((entry (assoc fn (sb-c::lexenv-funs env) :test #'equal))) + (let ((entry (assoc fn (sb!c::lexenv-funs env) :test #'equal))) (and entry - (sb-c::functional-p (cdr entry)) + (sb!c::functional-p (cdr entry)) (cdr entry))))) (defun environment-macro (env macro) (when env - (let ((entry (assoc macro (sb-c::lexenv-funs env) :test #'eq))) + (let ((entry (assoc macro (sb!c::lexenv-funs env) :test #'eq))) (and entry - (eq (cadr entry) 'sb-c::macro) + (eq (cadr entry) 'sb!c::macro) (if (eq macro *key-to-walker-environment*) (values (bogo-fun-to-walker-info (cddr entry))) (values (function-lambda-expression (cddr entry)))))))) @@ -206,7 +213,7 @@ (defun convert-macro-to-lambda (llist body env &optional (name "dummy macro")) (let ((gensym (make-symbol name))) (eval-in-lexenv `(defmacro ,gensym ,llist ,@body) - (sb-c::make-restricted-lexenv env)) + (sb!c::make-restricted-lexenv env)) (macro-function gensym))) ;;;; the actual walker @@ -232,14 +239,14 @@ (defun walker-environment-bind-1 (env &key (walk-function nil wfnp) (walk-form nil wfop) (declarations nil decp) - (lexical-variables nil lexp)) - (let ((lock (environment-macro env *key-to-walker-environment*))) + (lexical-vars nil lexp)) + (let ((lock (env-lock env))) (list (list *key-to-walker-environment* - (list (if wfnp walk-function (car lock)) - (if wfop walk-form (cadr lock)) - (if decp declarations (caddr lock)) - (if lexp lexical-variables (cadddr lock))))))) + (list (if wfnp walk-function (car lock)) + (if wfop walk-form (cadr lock)) + (if decp declarations (caddr lock)) + (if lexp lexical-vars (cadddr lock))))))) (defun env-walk-function (env) (car (env-lock env))) @@ -266,7 +273,7 @@ (defun variable-symbol-macro-p (var env) (let ((entry (member var (env-lexical-variables env) :key #'car))) - (when (eq (cadar entry) 'sb-sys:macro) + (when (eq (cadar entry) 'sb!sys:macro) entry))) (defvar *var-declarations* '(special)) @@ -316,7 +323,7 @@ ;;; - 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) +;;; * We can save ourselves from this case (second subcase really) ;;; by checking to see whether there is a template defined for ;;; something before we check to see whether we can macroexpand it. ;;; @@ -351,13 +358,19 @@ `(eval-when (:load-toplevel :execute) (setf (get-walker-template-internal ',name) ',template))) -(defun get-walker-template (x) +(defun get-walker-template (x context) (cond ((symbolp x) (get-walker-template-internal x)) ((and (listp x) (eq (car x) 'lambda)) '(lambda repeat (eval))) (t - (error "can't get template for ~S" x)))) + ;; FIXME: In an ideal world we would do something similar to + ;; COMPILER-ERROR here, replacing the form within the walker + ;; with an error-signalling form. This is slightly less + ;; pretty, but informative non the less. Best is the enemy of + ;; good, etc. + (error "Illegal function call in method body:~% ~S" + context)))) ;;;; the actual templates @@ -392,7 +405,10 @@ (define-walker-template unwind-protect (nil return repeat (eval))) ;;; SBCL-only special forms -(define-walker-template sb-ext:truly-the (nil quote eval)) +(define-walker-template sb!ext:truly-the (nil quote eval)) +;;; FIXME: maybe we don't need this one any more, given that +;;; NAMED-LAMBDA now expands into (FUNCTION (NAMED-LAMBDA ...))? +(define-walker-template named-lambda walk-named-lambda) (defvar *walk-form-expand-macros-p* nil) @@ -442,7 +458,7 @@ newform))) (t (let* ((fn (car newform)) - (template (get-walker-template fn))) + (template (get-walker-template fn newform))) (if template (if (symbolp template) (funcall template newform context env) @@ -450,7 +466,7 @@ (multiple-value-bind (newnewform macrop) (walker-environment-bind (new-env env :walk-form newform) - (macroexpand-1 newform new-env)) + (sb-xc:macroexpand-1 newform new-env)) (cond (macrop (let ((newnewnewform (walk-form-internal newnewform @@ -466,7 +482,7 @@ ;; maintained as part of SBCL, so it should know ;; about all the special forms that SBCL knows ;; about. - (error "unexpected special form ~S" fn)) + (bug "unexpected special form ~S" fn)) (t ;; Otherwise, walk the form as if it's just a ;; standard function call using a template for @@ -483,10 +499,7 @@ (set (walk-form-internal form :set env)) ((lambda call) - (cond ((or (symbolp form) - (and (listp form) - (= (length form) 2) - (eq (car form) 'setf))) + (cond ((legal-fun-name-p form) form) (t (walk-form-internal form context env))))) (case (car template) @@ -527,12 +540,8 @@ (defun walk-template-handle-repeat (form template stop-form context env) (if (eq form stop-form) (walk-template form (cdr template) context env) - (walk-template-handle-repeat-1 form - template - (car template) - stop-form - context - env))) + (walk-template-handle-repeat-1 + form template (car template) stop-form context env))) (defun walk-template-handle-repeat-1 (form template repeat-template stop-form context env) @@ -541,7 +550,7 @@ (if (null repeat-template) (walk-template stop-form (cdr template) context env) (error "while handling code walker REPEAT: - ~%ran into STOP while still in REPEAT template"))) + ~%ran into STOP while still in REPEAT template"))) ((null repeat-template) (walk-template-handle-repeat-1 form template (car template) stop-form context env)) @@ -616,10 +625,10 @@ (cdr body) fn env doc-string-p declarations))) ((and form (listp form) - (null (get-walker-template (car form))) + (null (get-walker-template (car form) form)) (progn (multiple-value-setq (new-form macrop) - (macroexpand-1 form env)) + (sb-xc:macroexpand-1 form env)) macrop)) ;; This form was a call to a macro. Maybe it expanded ;; into a declare? Recurse to find out. @@ -702,21 +711,6 @@ (relist* form locally walked-body))) -(defun walk-let-if (form context env) - (let ((test (cadr form)) - (bindings (caddr form)) - (body (cdddr form))) - (walk-form-internal - `(let () - (declare (special ,@(mapcar (lambda (x) (if (listp x) (car x) x)) - bindings))) - (flet ((.let-if-dummy. () ,@body)) - (if ,test - (let ,bindings (.let-if-dummy.)) - (.let-if-dummy.)))) - context - env))) - (defun walk-multiple-value-setq (form context env) (let ((vars (cadr form))) (if (some (lambda (var) @@ -814,6 +808,20 @@ walked-arglist walked-body)))) +(defun walk-named-lambda (form context old-env) + (walker-environment-bind (new-env old-env) + (let* ((name (second form)) + (arglist (third form)) + (body (cdddr form)) + (walked-arglist (walk-arglist arglist context new-env)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) + (relist* form + (car form) + name + walked-arglist + walked-body)))) + (defun walk-setq (form context env) (if (cdddr form) (let* ((expanded (let ((rforms nil) @@ -844,10 +852,10 @@ (body (cddr form))) (walker-environment-bind (new-env old-env - :lexical-variables + :lexical-vars (append (mapcar (lambda (binding) `(,(car binding) - sb-sys:macro . ,(cadr binding))) + sb!sys:macro . ,(cadr binding))) bindings) (env-lexical-variables old-env))) (relist* form 'symbol-macrolet bindings @@ -964,4 +972,4 @@ (defmacro with-rpush (&body body) `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body)) -|# \ No newline at end of file +|#