Changeset 14014


Ignore:
Timestamp:
07/21/12 14:02:32 (8 years ago)
Author:
rschlatte
Message:

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

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r14012 r14014  
    31773177
    31783178(defmethod documentation ((x structure-class) (doc-type (eql 't)))
    3179   (%documentation x doc-type))
     3179  (%documentation x t))
    31803180
    31813181(defmethod documentation ((x structure-class) (doc-type (eql 'type)))
    3182   (%documentation x doc-type))
     3182  (%documentation x t))
    31833183
    31843184(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't)))
    3185   (%set-documentation x doc-type new-value))
     3185  (%set-documentation x t new-value))
    31863186
    31873187(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type)))
    3188   (%set-documentation x doc-type new-value))
     3188  (%set-documentation x t new-value))
    31893189
    31903190(defmethod documentation ((x standard-generic-function) (doc-type (eql 't)))
     
    32193219
    32203220(defmethod documentation ((x symbol) (doc-type (eql 'function)))
    3221   (%documentation x doc-type))
     3221  (%documentation x 'function))
     3222
     3223(defmethod documentation ((x symbol) (doc-type (eql 'type)))
     3224  (let ((class (find-class x nil)))
     3225    (if class
     3226        (documentation class t)
     3227        (%documentation x 'type))))
     3228
     3229(defmethod documentation ((x symbol) (doc-type (eql 'structure)))
     3230  (%documentation x 'structure))
     3231
     3232(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
     3233  (let ((class (find-class x nil)))
     3234    (if class
     3235        (setf (documentation class t) new-value)
     3236        (%set-documentation x 'type new-value))))
     3237
     3238(defmethod (setf documentation) (new-value (x symbol)
     3239                                 (doc-type (eql 'structure)))
     3240  (%set-documentation x 'structure new-value))
    32223241
    32233242;;; Applicable methods
  • trunk/abcl/src/org/armedbear/lisp/defstruct.lisp

    r13451 r14014  
    126126(defvar *dd-slots*)
    127127(defvar *dd-inherited-accessors*)
     128(defvar *dd-documentation*)
    128129
    129130(defun keywordify (symbol)
     
    515516                                direct-slots
    516517                                slots
    517                                 inherited-accessors)
     518                                inherited-accessors
     519                                documentation)
    518520  (setf (get name 'structure-definition)
    519521        (make-defstruct-description :name name
     
    532534                                    :slots slots
    533535                                    :inherited-accessors inherited-accessors))
     536  (%set-documentation name 'structure documentation)
    534537  (when (or (null type) named)
    535     (make-structure-class name direct-slots slots (car include)))
     538    (let ((structure-class
     539            (make-structure-class name direct-slots slots (car include))))
     540      (%set-documentation name 'type documentation)
     541      (%set-documentation structure-class t documentation)))
    536542  (when default-constructor
    537543    (proclaim `(ftype (function * t) ,default-constructor))))
     
    553559        (*dd-direct-slots* ())
    554560        (*dd-slots* ())
    555         (*dd-inherited-accessors* ()))
     561        (*dd-inherited-accessors* ())
     562        (*dd-documentation* nil))
    556563    (parse-name-and-options (if (atom name-and-options)
    557564                                (list name-and-options)
     
    565572        (setf *dd-default-constructor* (default-constructor-name)))
    566573    (when (stringp (car slots))
    567       (%set-documentation *dd-name* 'structure (pop slots)))
     574      (setf *dd-documentation* (pop slots)))
    568575    (dolist (slot slots)
    569576      (let* ((name (if (atom slot) slot (car slot)))
     
    657664                             :direct-slots ',*dd-direct-slots*
    658665                             :slots ',*dd-slots*
    659                              :inherited-accessors ',*dd-inherited-accessors*))
     666                             :inherited-accessors ',*dd-inherited-accessors*
     667                             :documentation ',*dd-documentation*))
    660668       ,@(define-constructors)
    661669       ,@(define-predicate)
Note: See TracChangeset for help on using the changeset viewer.