[Sbcl-commits] CVS: sbcl/src/pcl dfun.lisp, 1.63, 1.64 slots.lisp, 1.34, 1.35 std-class.lisp, 1.119, 1.120

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv3579/src/pcl

Modified Files:
	dfun.lisp slots.lisp std-class.lisp 
Log Message:
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.


Index: dfun.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/dfun.lisp,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -d -r1.63 -r1.64
--- dfun.lisp	14 Nov 2007 15:57:28 -0000	1.63
+++ dfun.lisp	15 Jan 2008 18:10:45 -0000	1.64
@@ -1280,8 +1280,8 @@
                       (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 @@
         ;; 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)

Index: slots.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots.lisp,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -d -r1.34 -r1.35
--- slots.lisp	8 Sep 2007 17:35:47 -0000	1.34
+++ slots.lisp	15 Jan 2008 18:10:46 -0000	1.35
@@ -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)))))

Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.119
retrieving revision 1.120
diff -u -d -r1.119 -r1.120
--- std-class.lisp	10 Sep 2007 14:29:38 -0000	1.119
+++ std-class.lisp	15 Jan 2008 18:10:46 -0000	1.120
@@ -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)