1.0.13.40: CLASS-SLOTS signals an error for unfinalized classes

 * AMOP requirement, reported by Levente Meszaros on
   sbcl-devel 2007-04-20.

 * New condition class for convenience:
   SB-INT:SIMPLE-REFERENCE-ERROR.

diff --git a/NEWS b/NEWS
index ad29cd8..74b5bbd 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,8 @@ changes in sbcl-1.0.14 relative to sbcl-1.0.13:
     Maciej Katafiasz)
   * bug fix: sb-aclrepl now correctly understands how to inspect
     single-floats on 64-bit platforms where single-floats are not boxed.
+  * bug fix: SB-MOP:CLASS-SLOTS now signals an error if the class has not
+    yet been finalized. (reported by Levente Meszaros)
   * DESCRIBE and (DOCUMENTATION ... 'OPTIMIZE) describe meaning of
     SBCL-specific optimize qualities.
 

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 4833596..f69ef45 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -853,7 +853,9 @@ possibly temporariliy, because it might be used internally."
                "INTERPRETED-PROGRAM-ERROR"
                "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR"
                "SIMPLE-PARSE-ERROR" "SIMPLE-PROGRAM-ERROR"
-               "SIMPLE-READER-ERROR" "SIMPLE-READER-PACKAGE-ERROR"
+               "SIMPLE-READER-ERROR"
+               "SIMPLE-READER-PACKAGE-ERROR"
+               "SIMPLE-REFERENCE-CONDITION"
                "SIMPLE-STREAM-ERROR"
                "SIMPLE-STORAGE-CONDITION"
                "SIMPLE-STYLE-WARNING"

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index d2762ec..594b3ac 100644 (file)
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -900,6 +900,9 @@
           (unless (null (cdr rs))
             (terpri s)))))))
 
+(define-condition simple-reference-error (reference-condition simple-error)
+  ())
+
 (define-condition duplicate-definition (reference-condition warning)
   ((name :initarg :name :reader duplicate-definition-name))
   (:report (lambda (c s)

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index e301b76..5532c12 100644 (file)
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -1280,8 +1280,8 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                       (writer (cadr specializers))))
              (specl-cpl (if early-p
                             (early-class-precedence-list specl)
-                            (and (class-finalized-p specl)
-                                 (class-precedence-list specl))))
+                            (when (class-finalized-p specl)
+                              (class-precedence-list specl))))
              (so-p (member *the-class-standard-object* specl-cpl))
              (slot-name (if (consp method)
                             (and (early-method-standard-accessor-p method)
@@ -1296,17 +1296,14 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
         ;; all of its subclasses. If either SPECL or one of the subclasses
         ;; is not a standard-class, bail out.
         (labels ((aux (class)
-                   ;; FIND-SLOT-DEFINITION might not be defined yet
-                   (let ((slotd (find-if (lambda (x)
-                                           (eq (sb-pcl::slot-definition-name x)
-                                               slot-name))
-                                         (sb-pcl::class-slots class))))
+                   (let ((slotd (find-slot-definition class slot-name)))
                      (when slotd
-                       (unless (or early-p
-                                   (slot-accessor-std-p slotd type))
+                       (unless (or early-p (slot-accessor-std-p slotd type))
                          (return-from make-accessor-table nil))
                        (push (cons specl slotd) (gethash class table))))
                    (dolist (subclass (sb-pcl::class-direct-subclasses class))
+                     (unless (class-finalized-p subclass)
+                       (return-from make-accessor-table nil))
                      (aux subclass))))
           (aux specl))))
     (maphash (lambda (class specl+slotd-list)

diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index f406c6f..b6282b9 100644 (file)
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -465,3 +465,10 @@
   (declare (ignore initargs))
   (error "Cannot allocate an instance of ~S." class)) ; So sayeth AMOP
 
+;;; AMOP says that CLASS-SLOTS signals an error for unfinalized classes.
+(defmethod class-slots :before ((class slot-class))
+  (unless (class-finalized-p class)
+    (error 'simple-reference-error
+           :format-control "~S called on ~S, which is not yet finalized."
+           :format-arguments (list 'class-slots class)
+           :references (list '(:amop :generic-function class-slots)))))

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index f8e62f9..ebfe865 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -99,7 +99,8 @@
                                        type gf)
   (let* ((name (slot-value slotd 'name))
          (class (slot-value slotd '%class))
-         (old-slotd (find-slot-definition class name))
+         (old-slotd (when (class-finalized-p class)
+                      (find-slot-definition class name)))
          (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
     (multiple-value-bind (function std-p)
         (if (eq *boot-state* 'complete)

diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 8b27b70..7be8b14 100644 (file)
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -96,11 +96,11 @@
                              (backtrace (member (caar frame-specs) full-backtrace
                                                 :key #'car
                                                 :test #'equal)))
-                        
+
                         (setf result condition)
 
                         (unless backtrace
-                          (format t "~&//~S not in backtrace:~%   ~S~%" 
+                          (format t "~&//~S not in backtrace:~%   ~S~%"
                                   (caar frame-specs)
                                   full-backtrace)
                           (setf result nil))

diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp
index f4c181d..6a49d02 100644 (file)
--- a/tests/mop.impure.lisp
+++ b/tests/mop.impure.lisp
@@ -519,5 +519,12 @@
               :metaclass 'funcallable-standard-class)
 (assert (eq (class-of (find-class 'better-be-standard-class))
             (find-class 'standard-class)))
+
+;;; CLASS-SLOTS should signal an error for classes that are not yet
+;;; finalized. Reported by Levente Meszaros on sbcl-devel.
+(defclass has-slots-but-isnt-finalized () (a b c))
+(let ((class (find-class 'has-slots-but-isnt-finalized)))
+  (assert (not (sb-mop:class-finalized-p class)))
+  (assert (raises-error? (sb-mop:class-slots class))))
 \f
 ;;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index ec4f357..a731868 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.13.39"
+"1.0.13.40"