Changeset 14014

Timestamp:

07/21/12 14:02:32 (9 years ago)

Author:

rschlatte

Message:

fixes for (documentation x 'type) and (documentation x 'structure)

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• clos.lisp (modified) (2 diffs)
• defstruct.lisp (modified) (6 diffs)

trunk/abcl/src/org/armedbear/lisp/clos.lisp

@@ -3177 +3177 @@
 
 (defmethod documentation ((x structure-class) (doc-type (eql 't)))
-  (%documentation x doc-type))
+  (%documentation x t))
 
 (defmethod documentation ((x structure-class) (doc-type (eql 'type)))
-  (%documentation x doc-type))
+  (%documentation x t))
 
 (defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't)))
-  (%set-documentation x doc-type new-value))
+  (%set-documentation x t new-value))
 
 (defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type)))
-  (%set-documentation x doc-type new-value))
+  (%set-documentation x t new-value))
 
 (defmethod documentation ((x standard-generic-function) (doc-type (eql 't)))
@@ -3219 +3219 @@
 
 (defmethod documentation ((x symbol) (doc-type (eql 'function)))
-  (%documentation x doc-type))
+  (%documentation x 'function))
+
+(defmethod documentation ((x symbol) (doc-type (eql 'type)))
+  (let ((class (find-class x nil)))
+    (if class
+        (documentation class t)
+        (%documentation x 'type))))
+
+(defmethod documentation ((x symbol) (doc-type (eql 'structure)))
+  (%documentation x 'structure))
+
+(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
+  (let ((class (find-class x nil)))
+    (if class
+        (setf (documentation class t) new-value)
+        (%set-documentation x 'type new-value))))
+
+(defmethod (setf documentation) (new-value (x symbol)
+                                 (doc-type (eql 'structure)))
+  (%set-documentation x 'structure new-value))
 
 ;;; Applicable methods

trunk/abcl/src/org/armedbear/lisp/defstruct.lisp

@@ -126 +126 @@
 (defvar *dd-slots*)
 (defvar *dd-inherited-accessors*)
+(defvar *dd-documentation*)
 
 (defun keywordify (symbol)
@@ -515 +516 @@
                                 direct-slots
                                 slots
-                                inherited-accessors)
+                                inherited-accessors
+                                documentation)
   (setf (get name 'structure-definition)
         (make-defstruct-description :name name
@@ -532 +534 @@
                                     :slots slots
                                     :inherited-accessors inherited-accessors))
+  (%set-documentation name 'structure documentation)
   (when (or (null type) named)
-    (make-structure-class name direct-slots slots (car include)))
+    (let ((structure-class
+            (make-structure-class name direct-slots slots (car include))))
+      (%set-documentation name 'type documentation)
+      (%set-documentation structure-class t documentation)))
   (when default-constructor
     (proclaim `(ftype (function * t) ,default-constructor))))
@@ -553 +559 @@
         (*dd-direct-slots* ())
         (*dd-slots* ())
-        (*dd-inherited-accessors* ()))
+        (*dd-inherited-accessors* ())
+        (*dd-documentation* nil))
     (parse-name-and-options (if (atom name-and-options)
                                 (list name-and-options)
@@ -565 +572 @@
         (setf *dd-default-constructor* (default-constructor-name)))
     (when (stringp (car slots))
-      (%set-documentation *dd-name* 'structure (pop slots)))
+      (setf *dd-documentation* (pop slots)))
     (dolist (slot slots)
       (let* ((name (if (atom slot) slot (car slot)))
@@ -657 +664 @@
                              :direct-slots ',*dd-direct-slots*
                              :slots ',*dd-slots*
-                             :inherited-accessors ',*dd-inherited-accessors*))
+                             :inherited-accessors ',*dd-inherited-accessors*
+                             :documentation ',*dd-documentation*))
        ,@(define-constructors)
        ,@(define-predicate)