0.7.9.58:

	Some more error-checking at DEFCLASS
	... duplicate :METACLASS, :DEFAULT-INITARGS options
	... :READER and :INITARG options to slots must be symbols
	Fix up error messages
	... add some spaces to previous commit
	... CLASS is not what you think it is in ENSURE-CLASS-VALUES

diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp
index 7975e13..e312ba9 100644 (file)
--- a/src/pcl/defcombin.lisp
+++ b/src/pcl/defcombin.lisp
@@ -385,8 +385,8 @@
     ;; name of a &WHOLE parameter, if any.
     (when (member '&whole (rest args-lambda-list))
       (error 'simple-program-error
-            :format-control "~@<The value of the :ARGUMENTS option of~
-                DEFINE-METHOD-COMBINATION is~2I~_~S,~I~_but &WHOLE may~
+            :format-control "~@<The value of the :ARGUMENTS option of ~
+                DEFINE-METHOD-COMBINATION is~2I~_~S,~I~_but &WHOLE may ~
                 only appear first in the lambda list.~:>"
             :format-arguments (list args-lambda-list)))
     (loop with state = 'required
@@ -472,4 +472,4 @@
                         (t list))))
            (return (nconc (frob required nr nreq)
                           (frob optional no nopt)
-                          values)))))
\ No newline at end of file
+                          values)))))

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index a34f739..adb1282 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -382,34 +382,66 @@
     ;; However, after playing around a little, I couldn't find that
     ;; way, so I've left it as is, but if someone does come up with a
     ;; better way... -- CSR, 2002-09-08
-    (loop for (slot . more) on (getf initargs :direct-slots)
-         for slot-name = (getf slot :name)
-         if (some (lambda (s) (eq slot-name (getf s :name))) more) 
-         ;; FIXME: It's quite possible that we ought to define an
-         ;; SB-INT:PROGRAM-ERROR function to signal these and other
-         ;; errors throughout the code base that are required to be
-         ;; of type PROGRAM-ERROR.
-         do (error 'simple-program-error 
-                   :format-control "More than one direct slot with name ~S."
-                   :format-arguments (list slot-name))
-         else 
-         do (loop for (option value . more) on slot by #'cddr
-                  when (and (member option 
-                                    '(:allocation :type 
+    (do ((direct-slots (getf initargs :direct-slots) (cdr direct-slots)))
+       ((endp direct-slots) nil)
+      (destructuring-bind (slot &rest more) direct-slots
+       (let ((slot-name (getf slot :name)))
+         (when (some (lambda (s) (eq slot-name (getf s :name))) more)
+           ;; FIXME: It's quite possible that we ought to define an
+           ;; SB-INT:PROGRAM-ERROR function to signal these and other
+           ;; errors throughout the codebase that are required to be
+           ;; of type PROGRAM-ERROR.
+           (error 'simple-program-error
+                  :format-control "~@<There is more than one direct slot ~
+                                   with name ~S.~:>"
+                  :format-arguments (list slot-name)))
+         (do ((stuff slot (cddr stuff)))
+             ((endp stuff) nil)
+           (destructuring-bind (option value &rest more) stuff
+             (cond
+               ((and (member option '(:allocation :type
                                       :initform :documentation))
-                            (not (eq unsupplied
-                                     (getf more option unsupplied)))) 
-                  do (error 'simple-program-error 
-                            :format-control "Duplicate slot option ~S for slot ~S."
-                            :format-arguments (list option slot-name))))
+                     (not (eq unsupplied
+                              (getf more option unsupplied))))
+                (error 'simple-program-error
+                       :format-control "~@<Duplicate slot option ~S for ~
+                                        slot named ~S.~:>"
+                       :format-arguments (list option slot-name)))
+               ((and (eq option :readers)
+                     (notevery #'symbolp value))
+                (error 'simple-program-error
+                       :format-control "~@<Slot reader names for slot ~
+                                        named ~S must be symbols.~:>"
+                       :format-arguments (list slot-name)))
+               ((and (eq option :initargs)
+                     (notevery #'symbolp value))
+                (error 'simple-program-error
+                       :format-control "~@<Slot initarg names for slot ~
+                                        named ~S must be symbols.~:>"
+                       :format-arguments (list slot-name)))))))))
     (loop for (initarg . more) on (getf initargs :direct-default-initargs)
          for name = (car initarg) 
          when (some (lambda (a) (eq (car a) name)) more) 
          do (error 'simple-program-error 
-                   :format-control "Duplicate initialization argument ~
-                                     name ~S in :default-initargs of class ~A."
+                   :format-control "~@<Duplicate initialization argument ~
+                                    name ~S in :DEFAULT-INITARGS.~:>"
                    :format-arguments (list name class)))
-    (loop (unless (remf initargs :metaclass) (return)))
+    (let ((metaclass 0)
+         (default-initargs 0))
+      (do ((args initargs (cddr args)))
+         ((endp args) nil)
+       (case (car args)
+         (:metaclass
+          (when (> (incf metaclass) 1)
+            (error 'simple-program-error
+                   :format-control "~@<More than one :METACLASS ~
+                                    option specified.~:>")))
+         (:direct-default-initargs
+          (when (> (incf default-initargs) 1)
+            (error 'simple-program-error
+                   :format-control "~@<More than one :DEFAULT-INITARGS ~
+                                    option specified.~:>"))))))
+    (remf initargs :metaclass)
     (loop (unless (remf initargs :direct-superclasses) (return)))
     (loop (unless (remf initargs :direct-slots) (return)))
     (values meta

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 7b80f6b..03a3ee0 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -293,12 +293,24 @@
   (assert-program-error (defclass foo004 ()
                          ((a :silly t))))
   ;; and some more, found by Wolfhard Buss and fixed for cmucl by Gerd
-  ;; Moellmann in 0.7.8.x:
+  ;; Moellmann in sbcl-0.7.8.x:
   (assert-program-error (progn
                          (defmethod odd-key-args-checking (&key (key 42)) key)
                          (odd-key-args-checking 3)))
   (assert (= (odd-key-args-checking) 42))
-  (assert (eq (odd-key-args-checking :key t) t)))
+  (assert (eq (odd-key-args-checking :key t) t))
+  ;; yet some more, fixed in sbcl-0.7.9.xx
+  (assert-program-error (defclass foo005 ()
+                         (:metaclass sb-pcl::funcallable-standard-class)
+                         (:metaclass 1)))
+  (assert-program-error (defclass foo006 ()
+                         ((a :reader (setf a)))))
+  (assert-program-error (defclass foo007 ()
+                         ((a :initarg 1))))
+  (assert-program-error (defclass foo008 ()
+                         (a :initarg :a)
+                         (:default-initargs :a 1)
+                         (:default-initargs :a 2))))
 \f
 ;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully
 ;;; preserved through the bootstrap process until sbcl-0.7.8.39.

diff --git a/version.lisp-expr b/version.lisp-expr
index 1dcebb6..0f13d33 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.57"
+"0.7.9.58"