X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwalk.lisp;h=3f6d209120447bad06a3f5f53a92465fa6ddac94;hb=d25e3478acccec70402ff32554669a982be8e281;hp=ff5c160354b2bb8c91bfd25f9c129539f4e9d5f3;hpb=81ce38f2e03e4f569d7a95bb18efb25bb16fc269;p=sbcl.git diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index ff5c160..3f6d209 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -257,6 +257,11 @@ (defun env-declarations (env) (caddr (env-lock env))) +(defun env-var-type (var env) + (dolist (decl (env-declarations env) t) + (when (and (eq 'type (car decl)) (member var (cddr decl) :test 'eq)) + (return (cadr decl))))) + (defun env-lexical-variables (env) (cadddr (env-lock env))) @@ -267,32 +272,48 @@ (push (list thing :lexical-var) (cadddr (env-lock env)))) (defun var-lexical-p (var env) - (let ((entry (member var (env-lexical-variables env) :key #'car))) + (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq))) (when (eq (cadar entry) :lexical-var) entry))) (defun variable-symbol-macro-p (var env) - (let ((entry (member var (env-lexical-variables env) :key #'car))) + (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq))) (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 @@ -449,12 +470,17 @@ ((not (consp newform)) (let ((symmac (car (variable-symbol-macro-p newform env)))) (if symmac - (let ((newnewform (walk-form-internal (cddr symmac) - context - env))) - (if (eq newnewform (cddr symmac)) - (if *walk-form-expand-macros-p* newnewform newform) - newnewform)) + (let* ((newnewform (walk-form-internal (cddr symmac) + context + env)) + (resultform + (if (eq newnewform (cddr symmac)) + (if *walk-form-expand-macros-p* newnewform newform) + newnewform)) + (type (env-var-type newform env))) + (if (eq t type) + resultform + `(the ,type ,resultform))) newform))) (t (let* ((fn (car newform)) @@ -612,12 +638,12 @@ (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) env) - (note-declaration declaration env)) + (note-declaration (sb!c::canonized-decl-spec declaration) env)) (push declaration declarations))) (recons body form @@ -652,7 +678,7 @@ &aux arg) (cond ((null arglist) ()) ((symbolp (setq arg (car arglist))) - (or (member arg lambda-list-keywords) + (or (member arg sb!xc:lambda-list-keywords :test #'eq) (note-lexical-binding arg env)) (recons arglist arg @@ -660,8 +686,7 @@ context env (and destructuringp - (not (member arg - lambda-list-keywords)))))) + (not (member arg sb!xc:lambda-list-keywords)))))) ((consp arg) (prog1 (recons arglist (if destructuringp @@ -702,14 +727,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))) @@ -837,7 +863,10 @@ (val (caddr form)) (symmac (car (variable-symbol-macro-p var env)))) (if symmac - (let* ((expanded `(setf ,(cddr symmac) ,val)) + (let* ((type (env-var-type var env)) + (expanded (if (eq t type) + `(setf ,(cddr symmac) ,val) + `(setf ,(cddr symmac) `(the ,type ,val)))) (walked (walk-form-internal expanded context env))) (if (eq expanded walked) form @@ -873,62 +902,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