[armedbear-cvs] r14014 - trunk/abcl/src/org/armedbear/lisp

[rschlatte at common-lisp.net]

Author: rschlatte
Date: Sat Jul 21 07:02:32 2012
New Revision: 14014

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

Modified:
   trunk/abcl/src/org/armedbear/lisp/clos.lisp
   trunk/abcl/src/org/armedbear/lisp/defstruct.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Fri Jul 20 05:54:34 2012	(r14013)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sat Jul 21 07:02:32 2012	(r14014)
@@ -3176,16 +3176,16 @@
   (%set-class-documentation x new-value))
 
 (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)))
   (generic-function-documentation x))
@@ -3218,7 +3218,26 @@
   (%set-documentation x doc-type new-value))
 
 (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
 

Modified: trunk/abcl/src/org/armedbear/lisp/defstruct.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/defstruct.lisp	Fri Jul 20 05:54:34 2012	(r14013)
+++ trunk/abcl/src/org/armedbear/lisp/defstruct.lisp	Sat Jul 21 07:02:32 2012	(r14014)
@@ -125,6 +125,7 @@
 (defvar *dd-direct-slots*)
 (defvar *dd-slots*)
 (defvar *dd-inherited-accessors*)
+(defvar *dd-documentation*)
 
 (defun keywordify (symbol)
   (intern (symbol-name symbol) +keyword-package+))
@@ -514,7 +515,8 @@
                                 print-object
                                 direct-slots
                                 slots
-                                inherited-accessors)
+                                inherited-accessors
+                                documentation)
   (setf (get name 'structure-definition)
         (make-defstruct-description :name name
                                     :conc-name conc-name
@@ -531,8 +533,12 @@
                                     :direct-slots direct-slots
                                     :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))))
 
@@ -552,7 +558,8 @@
         (*dd-print-object* nil)
         (*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)
                                 name-and-options))
@@ -564,7 +571,7 @@
             (return)))
         (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)))
              (reader (if *dd-conc-name*
@@ -656,7 +663,8 @@
                              ,@(if *dd-print-object* `(:print-object ',*dd-print-object*))
                              :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)
        ,@(define-access-functions)