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 (file)
--- 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 (file)
--- 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 (file)
--- 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)))
 \f

diff --git a/version.lisp-expr b/version.lisp-expr
index 6ef80a7..cfbafdf 100644 (file)
--- 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"