From e768e8944cce654692468dae63f819ea1aa520a5 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 28 Nov 2011 13:59:34 +0200
Subject: [PATCH] stricter handling of declarations in DEFGENERIC

  Warn about unrecognized declarations.

  lp#894202
---
 NEWS                   |    2 ++
 src/pcl/boot.lisp      |   48 ++++++++++++++++++++++++++++--------------------
 tests/clos.impure.lisp |   10 ++++++++++
 3 files changed, 40 insertions(+), 20 deletions(-)

diff --git a/NEWS b/NEWS
index 3349f19..2f27a07 100644
--- a/NEWS
+++ b/NEWS
@@ -19,6 +19,8 @@ changes relative to sbcl-1.0.54:
   * bug fix: condition slot accessors no longer cause undefined function
     style-warnings when used in the :REPORT clause of the DEFINE-CONDITION
     form that defines them. (lp#896379)
+  * bug fix: DEFGENERIC warns about unsupported declarations, as specified
+    by ANSI. (lp#894202)
 
 changes in sbcl-1.0.54 relative to sbcl-1.0.53:
   * minor incompatible changes:
diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 7e58e0a..c794df4 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -171,25 +171,33 @@ bootstrapping.
           (let ((car-option (car option)))
             (case car-option
               (declare
-               (when (and
-                      (consp (cadr option))
-                      (member (first (cadr option))
-                              ;; FIXME: this list is slightly weird.
-                              ;; ANSI (on the DEFGENERIC page) in one
-                              ;; place allows only OPTIMIZE; in
-                              ;; another place gives this list of
-                              ;; disallowed declaration specifiers.
-                              ;; This seems to be the only place where
-                              ;; the FUNCTION declaration is
-                              ;; mentioned; TYPE seems to be missing.
-                              ;; Very strange.  -- CSR, 2002-10-21
-                              '(declaration ftype function
-                                inline notinline special)))
-                 (error 'simple-program-error
-                        :format-control "The declaration specifier ~S ~
+               (dolist (spec (cdr option))
+                 (unless (consp spec)
+                   (error 'simple-program-error
+                          :format-control "~@<Invalid declaration specifier in ~
+                                           DEFGENERIC: ~S~:@>"
+                          :format-arguments (list spec)))
+                 (when (member (first spec)
+                               ;; FIXME: this list is slightly weird.
+                               ;; ANSI (on the DEFGENERIC page) in one
+                               ;; place allows only OPTIMIZE; in
+                               ;; another place gives this list of
+                               ;; disallowed declaration specifiers.
+                               ;; This seems to be the only place where
+                               ;; the FUNCTION declaration is
+                               ;; mentioned; TYPE seems to be missing.
+                               ;; Very strange.  -- CSR, 2002-10-21
+                               '(declaration ftype function
+                                 inline notinline special))
+                   (error 'simple-program-error
+                          :format-control "The declaration specifier ~S ~
                                          is not allowed inside DEFGENERIC."
-                        :format-arguments (list (cadr option))))
-               (push (cadr option) (initarg :declarations)))
+                          :format-arguments (list spec)))
+                 (if (or (eq 'optimize (first spec))
+                         (info :declaration :recognized (first spec)))
+                     (push spec (initarg :declarations))
+                     (warn "Ignoring unrecognized declaration in DEFGENERIC: ~S"
+                           spec))))
               (:method-combination
                (when (initarg car-option)
                  (duplicate-option car-option))
@@ -239,8 +247,8 @@ bootstrapping.
            (compile-or-load-defgeneric ',fun-name))
          (load-defgeneric ',fun-name ',lambda-list
                           (sb-c:source-location) ,@initargs)
-        ,@(mapcar #'expand-method-definition methods)
-        (fdefinition ',fun-name)))))
+         ,@(mapcar #'expand-method-definition methods)
+         (fdefinition ',fun-name)))))
 
 (defun compile-or-load-defgeneric (fun-name)
   (proclaim-as-fun-name fun-name)
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index cf876d9..1e383cd 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1901,4 +1901,14 @@
                    (sb-pcl::generic-function-pretty-arglist
                     #'generic-function-pretty-arglist-optional-and-key)))))
 
+(with-test (:name :bug-894202)
+  (assert (eq :good
+              (handler-case
+                  (let ((name (gensym "FOO"))
+                        (decl (gensym "BAR")))
+                    (eval `(defgeneric ,name ()
+                             (declare (,decl)))))
+                (warning ()
+                  :good)))))
+
 ;;;; success
-- 
1.7.10.4