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

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

File:
1 edited

Legend:

Unmodified
Added
Removed
  • 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.