0.8.17.10: stricter DEFCLASS option checking

            * as reported by Bruno Haible, an error should be
              signalled if a class-option appears multiple times.

diff --git a/NEWS b/NEWS
index 3aabb52..ae049a1 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -10,6 +10,9 @@ changes in sbcl-0.8.18 relative to sbcl-0.8.17:
     (backtraces from throws to unknown catch tags.)
   * bug fix: lambda-list parsing is now stricter vrt. order and number
     of lambda-list keywords.
+  * bug fix: as specified by AMOP, an error is signalled if a
+    class-option appears multiple times in a DEFCLASS form. (reported
+    by Bruno Haible)
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** INCF, DECF and REMF evaluate their place form as specified in
        CLtS 5.1.3.

diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index 8dc0529..cf7562a 100644 (file)
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -117,21 +117,21 @@
                  ,defclass-form))))))))
 
 (defun canonize-defclass-options (class-name options)
-  (macrolet ((assert-single (option)
-               `(when ,option
-                  (error "Multiple ~A options in DEFCLASS ~S."
-                         ,(intern (string option) :keyword)
-                         class-name))))
-    (let (metaclass 
-          default-initargs
-          documentation
-          canonized-options)
+  (maplist (lambda (sublist)
+             (let ((option-name (first (pop sublist))))
+               (when (member option-name sublist :key #'first)
+                 (error "Multiple ~S options in DEFCLASS ~S." 
+                        option-name class-name))))
+           options)
+  (let (metaclass 
+        default-initargs
+        documentation
+        canonized-options)
       (dolist (option options)
         (unless (listp option)
           (error "~S is not a legal defclass option." option))
         (case (first option)
           (:metaclass 
-           (assert-single metaclass)
            (let ((maybe-metaclass (second option)))
              (unless (and maybe-metaclass (legal-class-name-p maybe-metaclass))
                (error "~@<The value of the :metaclass option (~S) ~
@@ -139,14 +139,13 @@
                       maybe-metaclass))
              (setf metaclass maybe-metaclass)))
           (:default-initargs
-           (assert-single default-initargs)
            (let (initargs arg-names)
              (doplist (key val) (cdr option)
                (when (member key arg-names)
                  (error 'simple-program-error 
                         :format-control "~@<Duplicate initialization argument ~
-                                         name ~S in :DEFAULT-INITARGS of ~
-                                         DEFCLASS ~S.~:>" 
+                                           name ~S in :DEFAULT-INITARGS of ~
+                                           DEFCLASS ~S.~:>" 
                         :format-arguments (list key class-name)))
                (push key arg-names)
                (push ``(,',key ,,(make-initfunction val) ,',val) initargs))
@@ -154,14 +153,13 @@
              (push `(:direct-default-initargs (list ,@(nreverse initargs))) 
                    canonized-options)))
           (:documentation
-           (assert-single documentation)
            (unless (stringp (second option))
              (error "~S is not a legal :documentation value" (second option)))
            (setf documentation t)
            (push `(:documentation ,(second option)) canonized-options))
           (otherwise
            (push `(',(car option) ',(cdr option)) canonized-options))))
-      (values (or metaclass 'standard-class) (nreverse canonized-options)))))
+      (values (or metaclass 'standard-class) (nreverse canonized-options))))
 
 (defun canonize-defclass-slots (class-name slots env)
   (let (canonized-specs)

diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp
index c510eb1..28fccf3 100644 (file)
--- a/tests/mop.impure.lisp
+++ b/tests/mop.impure.lisp
@@ -383,6 +383,20 @@
   (assert (= 1 (length subs)))
   (assert (eq (car subs) (find-class 'bug-331-sub))))
 
+;;; detection of multiple class options in defclass, reported by Bruno Haible
+(defclass option-class (standard-class)
+  ((option :accessor cl-option :initarg :my-option)))
+(defmethod sb-pcl:validate-superclass ((c1 option-class) (c2 standard-class))
+  t)
+(multiple-value-bind (result error)
+    (ignore-errors (eval '(defclass option-class-instance ()
+                           ()
+                           (:my-option bar)
+                           (:my-option baz)
+                           (:metaclass option-class))))
+  (assert (not result))
+  (assert error))
+                         
 \f
 ;;;; success
 (sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 8c0088c..7a34c68 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".)
-"0.8.17.9"
+"0.8.17.10"