X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwalk.lisp;h=e8eb3827a1c158c7fef2f99bf0fa60a77dded09b;hb=de3bfc084239fa962ef001eaa68e5b6f4b9bbf81;hp=ff5c160354b2bb8c91bfd25f9c129539f4e9d5f3;hpb=81ce38f2e03e4f569d7a95bb18efb25bb16fc269;p=sbcl.git diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index ff5c160..e8eb382 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -149,13 +149,25 @@ ;; FLET and LABELS, so we have no idea what to use for the ;; 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. + ;; functions from macros -- same for telling variables apart from + ;; symbol 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))) + (copy-tree (mapcar (lambda (b) + (let ((name (car b)) + (info (cadr b))) + (if (eq info :lexical-var) + (cons name + (if (var-special-p name env) + (sb!c::make-global-var + :kind :special + :%source-name name) + (sb!c::make-lambda-var + :%source-name name))) + b))) + (fourth (cadar macros))))) :funs (append (mapcar (lambda (f) (cons (car f) (sb!c::make-functional :lexenv lexenv))) @@ -257,42 +269,69 @@ (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))) (defun note-declaration (declaration env) (push declaration (caddr (env-lock env)))) -(defun note-lexical-binding (thing env) +(defun note-var-binding (thing env) (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) - (if (not (member declaration *var-declarations*)) - (error "~S is not a recognized variable declaration." declaration) - (let ((id (or (var-lexical-p var env) var))) +(defun %var-declaration (declaration var env) + (let ((id (or (var-lexical-p var env) var))) + (if (eq 'special declaration) + (dolist (decl (env-declarations env)) + (when (and (eq (car decl) declaration) + (or (member var (cdr decl)) + (and id (member id (cdr decl))))) + (return decl))) (dolist (decl (env-declarations env)) (when (and (eq (car decl) declaration) (eq (cadr decl) id)) (return decl)))))) +(defun var-declaration (declaration var env) + (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 +488,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)) @@ -466,7 +510,7 @@ (multiple-value-bind (newnewform macrop) (walker-environment-bind (new-env env :walk-form newform) - (sb-xc:macroexpand-1 newform new-env)) + (%macroexpand-1 newform new-env)) (cond (macrop (let ((newnewnewform (walk-form-internal newnewform @@ -612,12 +656,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 @@ -628,7 +672,7 @@ (null (get-walker-template (car form) form)) (progn (multiple-value-setq (new-form macrop) - (sb-xc:macroexpand-1 form env)) + (%macroexpand-1 form env)) macrop)) ;; This form was a call to a macro. Maybe it expanded ;; into a declare? Recurse to find out. @@ -652,16 +696,15 @@ &aux arg) (cond ((null arglist) ()) ((symbolp (setq arg (car arglist))) - (or (member arg lambda-list-keywords) - (note-lexical-binding arg env)) + (or (member arg sb!xc:lambda-list-keywords :test #'eq) + (note-var-binding arg env)) (recons arglist arg (walk-arglist (cdr arglist) 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 @@ -672,11 +715,11 @@ (cddr arg))) (walk-arglist (cdr arglist) context env nil)) (if (symbolp (car arg)) - (note-lexical-binding (car arg) env) - (note-lexical-binding (cadar arg) env)) + (note-var-binding (car arg) env) + (note-var-binding (cadar arg) env)) (or (null (cddr arg)) (not (symbolp (caddr arg))) - (note-lexical-binding (caddr arg) env)))) + (note-var-binding (caddr arg) env)))) (t (error "can't understand something in the arglist ~S" arglist)))) @@ -691,25 +734,31 @@ (let* ((let/let* (car form)) (bindings (cadr form)) (body (cddr form)) - (walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - sequentialp)) + walked-bindings (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) + (walk-declarations + body + (lambda (real-body real-env) + (setf walked-bindings + (walk-bindings-1 bindings + old-env + new-env + context + sequentialp)) + (walk-repeat-eval real-body real-env)) + new-env))) (relist* - form let/let* walked-bindings walked-body)))) + 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))) @@ -758,7 +807,7 @@ (recons bindings (if (symbolp binding) (prog1 binding - (note-lexical-binding binding new-env)) + (note-var-binding binding new-env)) (prog1 (relist* binding (car binding) (walk-form-internal (cadr binding) @@ -770,7 +819,7 @@ ;; the next value form. Don't ;; walk it now, though. (cddr binding)) - (note-lexical-binding (car binding) new-env))) + (note-var-binding (car binding) new-env))) (walk-bindings-1 (cdr bindings) old-env new-env @@ -837,7 +886,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 +925,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