CVS: sbcl/src/pcl generic-functions.lisp,1.23,1.24 std-class.lisp,1.63,1.64

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

Modified Files:
        generic-functions.lisp std-class.lisp 
Log Message:
0.8.12.16:
        Fix BUG #334
        ... do bookkeeping behind the user's back for 
                effective-slot-defitions generated by the user
        ... for :class slots, allocate a location and place it in the
                class' class-slot-cells;
        ... for :class / :instance slots, set the slot-definition-class
                slot to the new class;
        ... add minimal test for reasonable behaviour.


Index: generic-functions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/generic-functions.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- generic-functions.lisp      26 Aug 2003 16:15:57 -0000      1.23
+++ generic-functions.lisp      2 Jul 2004 08:14:02 -0000       1.24
@@ -317,6 +317,8 @@
 
 (defgeneric add-method (generic-function method))
 
+(defgeneric (setf class-slot-cells) (new-value class))
+
 (defgeneric class-slot-value (class slot-name))
 
 (defgeneric compatible-meta-class-change-p (class proto-new-class))

Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -d -r1.63 -r1.64
--- std-class.lisp      29 Jun 2004 12:42:56 -0000      1.63
+++ std-class.lisp      2 Jul 2004 08:14:02 -0000       1.64
@@ -141,6 +141,8 @@
 
 (defmethod class-slot-cells ((class std-class))
   (plist-value class 'class-slot-cells))
+(defmethod (setf class-slot-cells) (new-value (class std-class))
+  (setf (plist-value class 'class-slot-cells) new-value))
 
 ;;;; class accessors that are even a little bit more complicated than those
 ;;;; above. These have a protocol for updating them, we must implement that
@@ -1040,8 +1042,20 @@
               (incf location))
              (:class
               (let* ((name (slot-definition-name eslotd))
-                     (from-class (slot-definition-allocation-class eslotd))
-                     (cell (assq name (class-slot-cells from-class))))
+                     (from-class 
+                      (or 
+                       (slot-definition-allocation-class eslotd)
+                       ;; we get here if the user adds an extra slot
+                       ;; himself...
+                       (setf (slot-definition-allocation-class eslotd) 
+                             class)))
+                     ;; which raises the question of what we should
+                     ;; do if we find that said user has added a slot
+                     ;; with the same name as another slot...
+                     (cell (or (assq name (class-slot-cells from-class))
+                               (setf (class-slot-cells from-class)
+                                     (cons (cons name +slot-unbound+)
+                                           (class-slot-cells from-class))))))
                 (aver (consp cell))
                 (if (eq +slot-unbound+ (cdr cell))
                     ;; We may have inherited an initfunction
@@ -1050,6 +1064,8 @@
                           (rplacd cell (funcall initfun))
                           cell))
                     cell)))))
+      (unless (slot-definition-class eslotd)
+       (setf (slot-definition-class eslotd) class))
       (initialize-internal-slot-functions eslotd))))
 
 (defmethod compute-slots ((class funcallable-standard-class))



-------------------------------------------------------
This SF.Net email sponsored by Black Hat Briefings & Training.
Attend Black Hat Briefings & Training, Las Vegas July 24-29 - 
digital self defense, top technical experts, no vendor pitches, 
unmatched networking opportunities. Visit www.blackhat.com