X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwalk.lisp;h=e8eb3827a1c158c7fef2f99bf0fa60a77dded09b;hb=HEAD;hp=1a7bf6f68e0337a9c5e9a3b321093b74f9337e05;hpb=4ff2057326cb82db04380aae96493bd5fcb3c203;p=sbcl.git diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 1a7bf6f..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,13 +269,18 @@ (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) @@ -281,10 +298,16 @@ (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))))) + (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) @@ -465,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)) @@ -482,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 @@ -633,7 +661,7 @@ ,(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 @@ -644,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. @@ -668,16 +696,15 @@ &aux arg) (cond ((null arglist) ()) ((symbolp (setq arg (car arglist))) - (or (member arg lambda-list-keywords :test #'eq) - (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 @@ -688,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)))) @@ -707,16 +734,21 @@ (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 old-env) (declare (ignore context)) @@ -775,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) @@ -787,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 @@ -854,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