From: Nikodemus Siivola Date: Fri, 12 Mar 2010 12:37:12 +0000 (+0000) Subject: 1.0.36.23: more consistent handling of ignored DX declarations X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=1b6b3e70df90dca341b22f1f3229ca3887c27510;p=sbcl.git 1.0.36.23: more consistent handling of ignored DX declarations * Use COMPILER-STYLE-WARN if the declaration is for an unbound variable or function. * Use COMPILER-NOTIFY is the declaration is free, but the var/function is bound. * Take care not to create an entry in *FREE-VARS* due to processing a DX declaration. Fixed launchpad bug #497321. --- diff --git a/NEWS b/NEWS index cb5bb9b..58a108f 100644 --- a/NEWS +++ b/NEWS @@ -39,6 +39,8 @@ changes relative to sbcl-1.0.36: values instead of signaling an error. (lp#309093) * bug fix: Spurious unused variale warning in a DEFSTRUCT edge case. (lp#528807) + * bug fix: More consistent warnings and notes for ignored DYNAMIC-EXTENT + declarations (lp#497321) changes in sbcl-1.0.36 relative to sbcl-1.0.35: * new feature: SB-EXT:TYPEXPAND-1, SB-EXT:TYPEXPAND, and diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 3b8f1af..9ac65b6 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -228,6 +228,9 @@ (t (find-free-fun name context))))) +(defun maybe-find-free-var (name) + (gethash name *free-vars*)) + ;;; Return the LEAF node for a global variable reference to NAME. If ;;; NAME is already entered in *FREE-VARS*, then we just return the ;;; corresponding value. Otherwise, we make a new leaf using @@ -1346,58 +1349,62 @@ (values)) (defun process-dx-decl (names vars fvars kind) - (flet ((maybe-notify (control &rest args) - (when (policy *lexenv* (> speed inhibit-warnings)) - (apply #'compiler-notify control args)))) - (let ((dx (cond ((eq 'truly-dynamic-extent kind) - :truly) - ((and (eq 'dynamic-extent kind) - *stack-allocate-dynamic-extent*) - t)))) - (if dx - (dolist (name names) - (cond - ((symbolp name) - (let* ((bound-var (find-in-bindings vars name)) - (var (or bound-var - (lexenv-find name vars) - (find-free-var name)))) - (etypecase var - (leaf - (if bound-var - (setf (leaf-dynamic-extent var) dx) - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration for free ~S" - name))) - (cons - (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name)) - (heap-alien-info - (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S" - name))))) - ((and (consp name) - (eq (car name) 'function) - (null (cddr name)) - (valid-function-name-p (cadr name))) - (let* ((fname (cadr name)) - (bound-fun (find fname fvars - :key #'leaf-source-name - :test #'equal))) - (etypecase bound-fun - (leaf - #!+stack-allocatable-closures - (setf (leaf-dynamic-extent bound-fun) dx) - #!-stack-allocatable-closures - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration on a function ~S ~ - (not supported on this platform)." fname)) - (cons - (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname)) - (null - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration for free ~S" - fname))))) - (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) - (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names))))) + (let ((dx (cond ((eq 'truly-dynamic-extent kind) + :truly) + ((and (eq 'dynamic-extent kind) + *stack-allocate-dynamic-extent*) + t)))) + (if dx + (dolist (name names) + (cond + ((symbolp name) + (let* ((bound-var (find-in-bindings vars name)) + (var (or bound-var + (lexenv-find name vars) + (maybe-find-free-var name)))) + (etypecase var + (leaf + (if bound-var + (setf (leaf-dynamic-extent var) dx) + (compiler-notify + "Ignoring free DYNAMIC-EXTENT declaration: ~S" name))) + (cons + (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name)) + (heap-alien-info + (compiler-error "DYNAMIC-EXTENT on alien-variable: ~S" + name)) + (null + (compiler-style-warn + "Unbound variable declared DYNAMIC-EXTENT: ~S" name))))) + ((and (consp name) + (eq (car name) 'function) + (null (cddr name)) + (valid-function-name-p (cadr name))) + (let* ((fname (cadr name)) + (bound-fun (find fname fvars + :key #'leaf-source-name + :test #'equal)) + (fun (or bound-fun (lexenv-find fname funs)))) + (etypecase fun + (leaf + (if bound-fun + #!+stack-allocatable-closures + (setf (leaf-dynamic-extent bound-fun) dx) + #!-stack-allocatable-closures + (compiler-notify + "Ignoring DYNAMIC-EXTENT declaration on function ~S ~ + (not supported on this platform)." fname) + (compiler-notify + "Ignoring free DYNAMIC-EXTENT declaration: ~S" name))) + (cons + (compiler-error "DYNAMIC-EXTENT on macro: ~S" name)) + (null + (compiler-style-warn + "Unbound function declared DYNAMIC-EXTENT: ~S" name))))) + (t + (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) + (when (policy *lexenv* (= speed 3)) + (compiler-notify "Ignoring DYNAMIC-EXTENT declarations: ~S" names))))) ;;; FIXME: This is non-ANSI, so the default should be T, or it should ;;; go away, I think. diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index fec3839..798df7a 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -813,4 +813,25 @@ (flet ((foo (x) (declare (ignore x)))) (let ((bad-boy (bad-boy (vec 2.0 3.0 4.0)))) (assert-no-consing (funcall bad-boy #'foo))))) + +(with-test (:name :bug-497321) + (flet ((test (lambda type) + (let ((n 0)) + (handler-bind ((condition (lambda (c) + (incf n) + (unless (typep c type) + (error "wanted ~S for~% ~S~%got ~S" + type lambda (type-of c)))))) + (compile nil lambda)) + (assert (= n 1))))) + (test `(lambda () (declare (dynamic-extent #'bar))) + 'style-warning) + (test `(lambda () (declare (dynamic-extent bar))) + 'style-warning) + (test `(lambda (bar) (cons bar (lambda () (declare (dynamic-extent bar))))) + 'sb-ext:compiler-note) + (test `(lambda () + (flet ((bar () t)) + (cons #'bar (lambda () (declare (dynamic-extent #'bar)))))) + 'sb-ext:compiler-note))) diff --git a/version.lisp-expr b/version.lisp-expr index 6ef80a7..cfbafdf 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".) -"1.0.36.22" +"1.0.36.23"