From: Juho Snellman Date: Fri, 15 Apr 2005 13:57:49 +0000 (+0000) Subject: 0.8.21.42: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ffa9a31f62e3e2abab8ebcbb3bfdab9725feaf7f;p=sbcl.git 0.8.21.42: Fix bug in scoping of free special declarations. CLHS 3.3.4: "The scope of free declarations specifically does not include initialization forms for bindings established by the form containing the declarations." * Add a :BINDING-FORM-P parameter to PROCESS-DECLS. If true, return a list of the VARs created by PROCESS-SPECIAL-DECL for free bindings instead of adding them into the lexenv immediately. * PROCESSING-DECLS optionally uses :BINDING-FORM-P and binds the list to a supplied variable in the PROCESSING-DECLS body. * Calls to PROCESS-DECLS / PROCESSING-DECLS related to binding forms use the above changes. * The VAR list is threaded through a bunch of IR1 lambda translation utility functions, all of which sooner or later end up calling IR1-CONVERT-AUX-BINDINGS. * Before IR1-CONVERT-AUX-BINDINGS converts the body, add the variables in the list to the lexenv. --- diff --git a/NEWS b/NEWS index f82dc62..8b51c9d 100644 --- a/NEWS +++ b/NEWS @@ -71,6 +71,8 @@ changes in sbcl-0.8.22 relative to sbcl-0.8.21: resulting in GC crashes. ** MISC.548: type check weakening can convert required type into optional. + ** initialization forms for bindings are not in scope of free special + declarations. changes in sbcl-0.8.21 (0.9alpha.1?) relative to sbcl-0.8.20: * incompatible change: thread support for non-NPTL systems has diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 2c36fb6..b33ca52 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -70,7 +70,7 @@ (sb!c::process-decls decls vars nil - lexenv)))) + :lexenv lexenv)))) (eval-progn-body body lexenv)))) (defun eval (original-exp) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 95d5748..e89af4d 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -586,10 +586,12 @@ (binding* ((ctran (make-ctran)) (fun-lvar (make-lvar)) ((next result) - (processing-decls (decls vars nil next result) + (processing-decls (decls vars nil next result + post-binding-lexenv) (let ((fun (ir1-convert-lambda-body forms vars + :post-binding-lexenv post-binding-lexenv :debug-name (debug-name 'let bindings)))) (reference-leaf start ctran fun-lvar fun)) (values next result)))) @@ -607,13 +609,14 @@ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (multiple-value-bind (vars values) (extract-let-vars bindings 'let*) - (processing-decls (decls vars nil start next) + (processing-decls (decls vars nil start next post-binding-lexenv) (ir1-convert-aux-bindings start next result forms vars - values)))) + values + post-binding-lexenv)))) (compiler-error "Malformed LET* bindings: ~S." bindings))) ;;; logic shared between IR1 translators for LOCALLY, MACROLET, diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index f4fd597..862f8ae 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -202,17 +202,20 @@ ;;; FIXME: This could and probably should be converted to use ;;; SOURCE-NAME and DEBUG-NAME. But I (WHN) don't use &AUX bindings, ;;; so I'm not motivated. Patches will be accepted... -(defun ir1-convert-aux-bindings (start next result body aux-vars aux-vals) +(defun ir1-convert-aux-bindings (start next result body aux-vars aux-vals + post-binding-lexenv) (declare (type ctran start next) (type (or lvar null) result) (list body aux-vars aux-vals)) (if (null aux-vars) - (ir1-convert-progn-body start next result body) + (let ((*lexenv* (make-lexenv :vars (copy-list post-binding-lexenv)))) + (ir1-convert-progn-body start next result body)) (let ((ctran (make-ctran)) (fun-lvar (make-lvar)) (fun (ir1-convert-lambda-body body (list (first aux-vars)) :aux-vars (rest aux-vars) :aux-vals (rest aux-vals) + :post-binding-lexenv post-binding-lexenv :debug-name (debug-name '&aux-bindings aux-vars)))) @@ -233,12 +236,13 @@ ;;; to start a block outside of this cleanup, causing cleanup code to ;;; be emitted when the scope is exited. (defun ir1-convert-special-bindings - (start next result body aux-vars aux-vals svars) + (start next result body aux-vars aux-vals svars post-binding-lexenv) (declare (type ctran start next) (type (or lvar null) result) (list body aux-vars aux-vals svars)) (cond ((null svars) - (ir1-convert-aux-bindings start next result body aux-vars aux-vals)) + (ir1-convert-aux-bindings start next result body aux-vars aux-vals + post-binding-lexenv)) (t (ctran-starts-block next) (let ((cleanup (make-cleanup :kind :special-bind)) @@ -252,7 +256,8 @@ (ir1-convert bind-ctran cleanup-ctran nil '(%cleanup-point)) (ir1-convert-special-bindings cleanup-ctran next result body aux-vars aux-vals - (rest svars)))))) + (rest svars) + post-binding-lexenv))))) (values)) ;;; Create a lambda node out of some code, returning the result. The @@ -279,7 +284,8 @@ aux-vals (source-name '.anonymous.) debug-name - (note-lexical-bindings t)) + (note-lexical-bindings t) + post-binding-lexenv) (declare (list body vars aux-vars aux-vals)) ;; We're about to try to put new blocks into *CURRENT-COMPONENT*. @@ -348,7 +354,8 @@ (use-ctran bind postbind-ctran) (ir1-convert-special-bindings postbind-ctran result-ctran result-lvar body - aux-vars aux-vals (svars)))))) + aux-vars aux-vals (svars) + post-binding-lexenv))))) (link-blocks (component-head *current-component*) (node-block bind)) (push lambda (component-new-functionals *current-component*)) @@ -421,7 +428,7 @@ vars supplied-p-p body aux-vars aux-vals source-name debug-name - force) + force post-binding-lexenv) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals vars body aux-vars aux-vals)) @@ -441,7 +448,7 @@ (list* t arg-name entry-vals) (rest vars) t body aux-vars aux-vals source-name debug-name - force) + force post-binding-lexenv) (ir1-convert-hairy-args res (cons arg default-vars) @@ -450,7 +457,7 @@ (cons arg-name entry-vals) (rest vars) supplied-p-p body aux-vars aux-vals source-name debug-name - force)))) + force post-binding-lexenv)))) ;; We want to delay converting the entry, but there exist ;; problems: hidden references should not be established to @@ -470,7 +477,7 @@ (convert-optional-entry (force ep) default-vars default-vals defaults - name) + name) res)))))) ;;; Create the MORE-ENTRY function for the OPTIONAL-DISPATCH RES. @@ -624,7 +631,7 @@ (defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals rest more-context more-count keys supplied-p-p body aux-vars aux-vals - source-name debug-name) + source-name debug-name post-binding-lexenv) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals keys body aux-vars aux-vals)) @@ -684,6 +691,7 @@ body (main-vars) :aux-vars (append (bind-vars) aux-vars) :aux-vals (append (bind-vals) aux-vals) + :post-binding-lexenv post-binding-lexenv :debug-name (debug-name 'varargs-entry name))) (last-entry (convert-optional-entry main-entry default-vars (main-vals) () name))) @@ -738,7 +746,7 @@ vars supplied-p-p body aux-vars aux-vals source-name debug-name - force) + force post-binding-lexenv) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals vars body aux-vars aux-vals)) @@ -748,12 +756,14 @@ (ir1-convert-more res default-vars default-vals entry-vars entry-vals nil nil nil vars supplied-p-p body aux-vars - aux-vals source-name debug-name) + aux-vals source-name debug-name + post-binding-lexenv) (let* ((name (or debug-name source-name)) (fun (ir1-convert-lambda-body body (reverse default-vars) :aux-vars aux-vars :aux-vals aux-vals + :post-binding-lexenv post-binding-lexenv :debug-name (debug-name 'hairy-arg-processor name)))) (setf (optional-dispatch-main-entry res) fun) @@ -773,7 +783,7 @@ (ir1-convert-hairy-args res nvars nvals nvars nvals (rest vars) nil body aux-vars aux-vals source-name debug-name - nil))) + nil post-binding-lexenv))) (t (let* ((arg (first vars)) (info (lambda-var-arg-info arg)) @@ -785,7 +795,7 @@ entry-vars entry-vals vars supplied-p-p body aux-vars aux-vals source-name debug-name - force))) + force post-binding-lexenv))) ;; See GENERATE-OPTIONAL-DEFAULT-ENTRY. (push (if (lambda-p ep) (register-entry-point @@ -804,18 +814,21 @@ entry-vars entry-vals arg nil nil (rest vars) supplied-p-p body aux-vars aux-vals - source-name debug-name)) + source-name debug-name + post-binding-lexenv)) (:more-context (ir1-convert-more res default-vars default-vals entry-vars entry-vals nil arg (second vars) (cddr vars) supplied-p-p body aux-vars aux-vals - source-name debug-name)) + source-name debug-name + post-binding-lexenv)) (:keyword (ir1-convert-more res default-vars default-vals entry-vars entry-vals nil nil nil vars supplied-p-p body aux-vars - aux-vals source-name debug-name))))))) + aux-vals source-name debug-name + post-binding-lexenv))))))) ;;; This function deals with the case where we have to make an ;;; OPTIONAL-DISPATCH to represent a LAMBDA. We cons up the result and @@ -823,6 +836,7 @@ ;;; figure out the MIN-ARGS and MAX-ARGS. (defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals &key + post-binding-lexenv (source-name '.anonymous.) (debug-name (debug-name '&optional-dispatch vars))) @@ -839,7 +853,7 @@ (aver-live-component *current-component*) (push res (component-new-functionals *current-component*)) (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals - source-name debug-name nil) + source-name debug-name nil post-binding-lexenv) (setf (optional-dispatch-min-args res) min) (setf (optional-dispatch-max-args res) (+ (1- (length (optional-dispatch-entry-points res))) min)) @@ -866,8 +880,9 @@ (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) (make-lambda-vars (cadr form)) (multiple-value-bind (forms decls) (parse-body (cddr form)) - (binding* (((*lexenv* result-type) - (process-decls decls (append aux-vars vars) nil)) + (binding* (((*lexenv* result-type post-binding-lexenv) + (process-decls decls (append aux-vars vars) nil + :binding-form-p t)) (forms (if (and *allow-instrumenting* (policy *lexenv* (>= insert-debug-catch 2))) `((catch (locally @@ -882,11 +897,13 @@ (ir1-convert-hairy-lambda forms vars keyp allow-other-keys aux-vars aux-vals + :post-binding-lexenv post-binding-lexenv :source-name source-name :debug-name debug-name) (ir1-convert-lambda-body forms vars :aux-vars aux-vars :aux-vals aux-vals + :post-binding-lexenv post-binding-lexenv :source-name source-name :debug-name debug-name)))) (setf (functional-inline-expansion res) form) @@ -946,7 +963,7 @@ `(() () () . ,(cdr fun))) (let ((*lexenv* (make-lexenv :default (process-decls decls nil nil - (make-null-lexenv)) + :lexenv (make-null-lexenv)) :vars (copy-list symbol-macros) :funs (mapcar (lambda (x) `(,(car x) . diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 5f37066..a603854 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -50,6 +50,8 @@ the efficiency of stable code.") (defvar *fun-names-in-this-file* nil) + +(defvar *post-binding-variable-lexenv* nil) ;;;; namespace management utilities @@ -1006,8 +1008,9 @@ ;;; Process a special declaration, returning a new LEXENV. A non-bound ;;; special declaration is instantiated by throwing a special variable -;;; into the variables. -(defun process-special-decl (spec res vars) +;;; into the variables if BINDING-FORM-P is NIL, or otherwise into +;;; *POST-BINDING-VARIABLE-LEXENV*. +(defun process-special-decl (spec res vars binding-form-p) (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) @@ -1029,11 +1032,16 @@ (setf (lambda-var-specvar var) (specvar-for-binding name))) (null - (unless (assoc name (new-venv) :test #'eq) + (unless (or (assoc name (new-venv) :test #'eq)) (new-venv (cons name (specvar-for-binding name)))))))) - (if (new-venv) - (make-lexenv :default res :vars (new-venv)) - res))) + (cond (binding-form-p + (setf *post-binding-variable-lexenv* + (append (new-venv) *post-binding-variable-lexenv*)) + res) + ((new-venv) + (make-lexenv :default res :vars (new-venv))) + (t + res)))) ;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP ;;; (and TYPE if notinline), plus type-restrictions from the lexenv. @@ -1181,14 +1189,14 @@ ;;; Process a single declaration spec, augmenting the specified LEXENV ;;; RES. Return RES and result type. VARS and FVARS are as described ;;; PROCESS-DECLS. -(defun process-1-decl (raw-spec res vars fvars) +(defun process-1-decl (raw-spec res vars fvars binding-form-p) (declare (type list raw-spec vars fvars)) (declare (type lexenv res)) (let ((spec (canonized-decl-spec raw-spec)) (result-type *wild-type*)) (values (case (first spec) - (special (process-special-decl spec res vars)) + (special (process-special-decl spec res vars binding-form-p)) (ftype (unless (cdr spec) (compiler-error "no type specified in FTYPE declaration: ~S" spec)) @@ -1242,45 +1250,56 @@ ;;; filling in slots in the leaf structures, we return a new LEXENV, ;;; which reflects pervasive special and function type declarations, ;;; (NOT)INLINE declarations and OPTIMIZE declarations, and type of -;;; VALUES declarations. +;;; VALUES declarations. If BINDING-FORM-P is true, the third return +;;; value is a list of VARs that should not apply to the lexenv of the +;;; initialization forms for the bindings, but should apply to the body. ;;; ;;; This is also called in main.lisp when PROCESS-FORM handles a use ;;; of LOCALLY. -(defun process-decls (decls vars fvars &optional (env *lexenv*)) +(defun process-decls (decls vars fvars &key (lexenv *lexenv*) + (binding-form-p nil)) (declare (list decls vars fvars)) - (let ((result-type *wild-type*)) + (let ((result-type *wild-type*) + (*post-binding-variable-lexenv* nil)) (dolist (decl decls) (dolist (spec (rest decl)) (unless (consp spec) (compiler-error "malformed declaration specifier ~S in ~S" spec decl)) (multiple-value-bind (new-env new-result-type) - (process-1-decl spec env vars fvars) - (setq env new-env) + (process-1-decl spec lexenv vars fvars binding-form-p) + (setq lexenv new-env) (unless (eq new-result-type *wild-type*) (setq result-type (values-type-intersection result-type new-result-type)))))) - (values env result-type))) + (values lexenv result-type *post-binding-variable-lexenv*))) -(defun %processing-decls (decls vars fvars ctran lvar fun) - (multiple-value-bind (*lexenv* result-type) - (process-decls decls vars fvars) +(defun %processing-decls (decls vars fvars ctran lvar binding-form-p fun) + (multiple-value-bind (*lexenv* result-type post-binding-lexenv) + (process-decls decls vars fvars :binding-form-p binding-form-p) (cond ((eq result-type *wild-type*) - (funcall fun ctran lvar)) + (funcall fun ctran lvar post-binding-lexenv)) (t (let ((value-ctran (make-ctran)) (value-lvar (make-lvar))) (multiple-value-prog1 - (funcall fun value-ctran value-lvar) + (funcall fun value-ctran value-lvar post-binding-lexenv) (let ((cast (make-cast value-lvar result-type (lexenv-policy *lexenv*)))) (link-node-to-previous-ctran cast value-ctran) (setf (lvar-dest value-lvar) cast) (use-continuation cast ctran lvar)))))))) -(defmacro processing-decls ((decls vars fvars ctran lvar) &body forms) +(defmacro processing-decls ((decls vars fvars ctran lvar + &optional post-binding-lexenv) + &body forms) (check-type ctran symbol) (check-type lvar symbol) - `(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar - (lambda (,ctran ,lvar) ,@forms))) + (let ((post-binding-lexenv-p (not (null post-binding-lexenv))) + (post-binding-lexenv (or post-binding-lexenv (gensym)))) + `(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar + ,post-binding-lexenv-p + (lambda (,ctran ,lvar ,post-binding-lexenv) + (declare (ignorable ,post-binding-lexenv)) + ,@forms)))) ;;; Return the SPECVAR for NAME to use when we see a local SPECIAL ;;; declaration. If there is a global variable of that name, then diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 4bc68b9..4325bd2 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1768,3 +1768,14 @@ (declare (optimize (speed 2) (safety 1) (debug 3) (space 2))) (atom (the (member f assoc-if write-line t w) p1)))) t))) + +;;; Free special bindings only apply to the body of the binding form, not +;;; the initialization forms. +(assert (eq :good + (funcall (compile 'nil + (lambda () + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + ((lambda (&optional (y x)) + (declare (special x)) y))))))))) diff --git a/version.lisp-expr b/version.lisp-expr index 5db653f..6fbb56f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.21.41" +"0.8.21.42"