X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwalk.lisp;h=30906c755e5604b1361c50927945fd1ebf573a03;hb=4ec46046e59ce00abe3e53bce16fdfb2c4c57362;hp=ff5c160354b2bb8c91bfd25f9c129539f4e9d5f3;hpb=81ce38f2e03e4f569d7a95bb18efb25bb16fc269;p=sbcl.git diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index ff5c160..30906c7 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -276,23 +276,39 @@ (when (eq (cadar entry) 'sb!sys:macro) entry))) -(defvar *var-declarations* '(special)) +(defun walked-var-declaration-p (declaration) + (member declaration '(sb!pcl::%class sb!pcl::%variable-rebinding special))) + +(defun %var-declaration (declaration var env) + (let ((id (or (var-lexical-p var env) var))) + (dolist (decl (env-declarations env)) + (when (and (eq (car decl) declaration) + (eq (cadr decl) id)) + (return decl))))) (defun var-declaration (declaration var env) - (if (not (member declaration *var-declarations*)) - (error "~S is not a recognized variable declaration." declaration) - (let ((id (or (var-lexical-p var env) var))) - (dolist (decl (env-declarations env)) - (when (and (eq (car decl) declaration) - (eq (cadr decl) id)) - (return decl)))))) + (if (walked-var-declaration-p declaration) + (%var-declaration declaration var env) + (error "Not a variable declaration the walker cares about: ~S" declaration))) + +#-sb-xc-host +(define-compiler-macro var-declaration (&whole form declaration var env + &environment lexenv) + (if (sb!xc:constantp declaration lexenv) + (let ((decl (constant-form-value declaration lexenv))) + (if (walked-var-declaration-p decl) + `(%var-declaration ,declaration ,var ,env) + form)) + form)) (defun var-special-p (var env) - (or (not (null (var-declaration 'special var env))) - (var-globally-special-p var))) + (and (or (var-declaration 'special var env) + (var-globally-special-p var)) + t)) (defun var-globally-special-p (symbol) (eq (info :variable :kind symbol) :special)) + ;;;; handling of special forms @@ -612,7 +628,7 @@ (let ((type (car declaration)) (name (cadr declaration)) (args (cddr declaration))) - (if (member type *var-declarations*) + (if (walked-var-declaration-p type) (note-declaration `(,type ,(or (var-lexical-p name env) name) ,.args) @@ -702,14 +718,15 @@ (relist* form let/let* walked-bindings walked-body)))) -(defun walk-locally (form context env) +(defun walk-locally (form context old-env) (declare (ignore context)) - (let* ((locally (car form)) - (body (cdr form)) - (walked-body - (walk-declarations body #'walk-repeat-eval env))) - (relist* - form locally walked-body))) + (walker-environment-bind (new-env old-env) + (let* ((locally (car form)) + (body (cdr form)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) + (relist* + form locally walked-body)))) (defun walk-multiple-value-setq (form context env) (let ((vars (cadr form))) @@ -873,62 +890,65 @@ (walk-tagbody-1 (cdr form) context env)))) (defun walk-macrolet (form context old-env) - (walker-environment-bind (macro-env - nil - :walk-function (env-walk-function old-env)) - (labels ((walk-definitions (definitions) - (and definitions - (let ((definition (car definitions))) - (recons definitions - (relist* definition - (car definition) - (walk-arglist (cadr definition) - context - macro-env - t) - (walk-declarations (cddr definition) - #'walk-repeat-eval - macro-env)) - (walk-definitions (cdr definitions))))))) - (with-new-definition-in-environment (new-env old-env form) - (relist* form - (car form) - (walk-definitions (cadr form)) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) + (walker-environment-bind (old-env old-env) + (walker-environment-bind (macro-env + nil + :walk-function (env-walk-function old-env)) + (labels ((walk-definitions (definitions) + (and definitions + (let ((definition (car definitions))) + (recons definitions + (relist* definition + (car definition) + (walk-arglist (cadr definition) + context + macro-env + t) + (walk-declarations (cddr definition) + #'walk-repeat-eval + macro-env)) + (walk-definitions (cdr definitions))))))) + (with-new-definition-in-environment (new-env old-env form) + (relist* form + (car form) + (walk-definitions (cadr form)) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env))))))) (defun walk-flet (form context old-env) - (labels ((walk-definitions (definitions) - (if (null definitions) - () - (recons definitions - (walk-lambda (car definitions) context old-env) - (walk-definitions (cdr definitions)))))) - (recons form - (car form) - (recons (cdr form) - (walk-definitions (cadr form)) - (with-new-definition-in-environment (new-env old-env form) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) - -(defun walk-labels (form context old-env) - (with-new-definition-in-environment (new-env old-env form) + (walker-environment-bind (old-env old-env) (labels ((walk-definitions (definitions) (if (null definitions) () (recons definitions - (walk-lambda (car definitions) context new-env) + (walk-lambda (car definitions) context old-env) (walk-definitions (cdr definitions)))))) (recons form (car form) (recons (cdr form) (walk-definitions (cadr form)) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) + (with-new-definition-in-environment (new-env old-env form) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env))))))) + +(defun walk-labels (form context old-env) + (walker-environment-bind (old-env old-env) + (with-new-definition-in-environment (new-env old-env form) + (labels ((walk-definitions (definitions) + (if (null definitions) + () + (recons definitions + (walk-lambda (car definitions) context new-env) + (walk-definitions (cdr definitions)))))) + (recons form + (car form) + (recons (cdr form) + (walk-definitions (cadr form)) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env))))))) (defun walk-if (form context env) (destructuring-bind (if predicate arm1 &optional arm2) form