X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fpcl%2Fstd-class.lisp;h=6b09912bbeeba15fdf28a4aba0542e04dc63146a;hb=3b6e07c0fcb050fa86c7c42db33f49107e3097e6;hp=a602fe715eb83cf257aeafa8d35c6511417fb71d;hpb=a682f4c392bc874a6a898632889319ebdd8821fc;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index a602fe7..6b09912 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -617,7 +617,8 @@
     (values defstruct-form constructor reader-names writer-names)))
 
 (defun make-defstruct-allocation-function (class)
-  (let ((dd (get-structure-dd (class-name class))))
+  ;; FIXME: Why don't we go class->layout->info == dd
+  (let ((dd (find-defstruct-description (class-name class))))
     (lambda ()
       (sb-kernel::%make-instance-with-layout
        (sb-kernel::compiler-layout-or-lose (dd-name dd))))))
@@ -697,7 +698,7 @@
   (fix-slot-accessors class dslotds 'remove))
 
 (defun fix-slot-accessors (class dslotds add/remove)
-  (flet ((fix (gfspec name r/w)
+  (flet ((fix (gfspec name r/w doc)
            (let ((gf (cond ((eq add/remove 'add)
                             (or (find-generic-function gfspec nil)
                                 (ensure-generic-function
@@ -709,17 +710,18 @@
              (when gf
                (case r/w
                  (r (if (eq add/remove 'add)
-                        (add-reader-method class gf name)
+                        (add-reader-method class gf name doc)
                         (remove-reader-method class gf)))
                  (w (if (eq add/remove 'add)
-                        (add-writer-method class gf name)
+                        (add-writer-method class gf name doc)
                         (remove-writer-method class gf))))))))
     (dolist (dslotd dslotds)
-      (let ((slot-name (slot-definition-name dslotd)))
+      (let ((slot-name (slot-definition-name dslotd))
+            (slot-doc (%slot-definition-documentation dslotd)))
         (dolist (r (slot-definition-readers dslotd))
-          (fix r slot-name 'r))
+          (fix r slot-name 'r slot-doc))
         (dolist (w (slot-definition-writers dslotd))
-          (fix w slot-name 'w))))))
+          (fix w slot-name 'w slot-doc))))))
 
 (defun add-direct-subclasses (class supers)
   (dolist (super supers)
@@ -1110,14 +1112,14 @@
   (declare (ignore direct-slot initargs))
   (find-class 'standard-reader-method))
 
-(defmethod add-reader-method ((class slot-class) generic-function slot-name)
+(defmethod add-reader-method ((class slot-class) generic-function slot-name slot-documentation)
   (add-method generic-function
               (make-a-method 'standard-reader-method
                              ()
                              (list (or (class-name class) 'object))
                              (list class)
                              (make-reader-method-function class slot-name)
-                             "automatically generated reader method"
+                             (or slot-documentation "automatically generated reader method")
                              :slot-name slot-name
                              :object-class class
                              :method-class-function #'reader-method-class)))
@@ -1126,19 +1128,19 @@
   (declare (ignore direct-slot initargs))
   (find-class 'standard-writer-method))
 
-(defmethod add-writer-method ((class slot-class) generic-function slot-name)
+(defmethod add-writer-method ((class slot-class) generic-function slot-name slot-documentation)
   (add-method generic-function
               (make-a-method 'standard-writer-method
                              ()
                              (list 'new-value (or (class-name class) 'object))
                              (list *the-class-t* class)
                              (make-writer-method-function class slot-name)
-                             "automatically generated writer method"
+                             (or slot-documentation "automatically generated writer method")
                              :slot-name slot-name
                              :object-class class
                              :method-class-function #'writer-method-class)))
 
-(defmethod add-boundp-method ((class slot-class) generic-function slot-name)
+(defmethod add-boundp-method ((class slot-class) generic-function slot-name slot-documentation)
   (add-method generic-function
               (make-a-method (constantly (find-class 'standard-boundp-method))
                              class
@@ -1146,7 +1148,7 @@
                              (list (or (class-name class) 'object))
                              (list class)
                              (make-boundp-method-function class slot-name)
-                             "automatically generated boundp method"
+                             (or slot-documentation "automatically generated boundp method")
                              slot-name)))
 
 (defmethod remove-reader-method ((class slot-class) generic-function)
@@ -1520,7 +1522,9 @@
       ;; layout-depthoid).  Is there any way we can provide a useful
       ;; error message?  -- CSR, 2005-05-03
       (eq s *the-class-file-stream*) (eq s *the-class-string-stream*)
-      ;; TODO
+      ;; This probably shouldn't be mixed in with certain other
+      ;; classes, too, but it seems to work both with STANDARD-OBJECT
+      ;; and FUNCALLABLE-STANDARD-OBJECT
       (eq s *the-class-sequence*)))
 
 ;;; Some necessary methods for FORWARD-REFERENCED-CLASS