Changeset 14014
- Timestamp:
- 07/21/12 14:02:32 (9 years ago)
- Location:
- trunk/abcl/src/org/armedbear/lisp
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r14012 r14014 3177 3177 3178 3178 (defmethod documentation ((x structure-class) (doc-type (eql 't))) 3179 (%documentation x doc-type))3179 (%documentation x t)) 3180 3180 3181 3181 (defmethod documentation ((x structure-class) (doc-type (eql 'type))) 3182 (%documentation x doc-type))3182 (%documentation x t)) 3183 3183 3184 3184 (defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't))) 3185 (%set-documentation x doc-typenew-value))3185 (%set-documentation x t new-value)) 3186 3186 3187 3187 (defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type))) 3188 (%set-documentation x doc-typenew-value))3188 (%set-documentation x t new-value)) 3189 3189 3190 3190 (defmethod documentation ((x standard-generic-function) (doc-type (eql 't))) … … 3219 3219 3220 3220 (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)) 3222 3241 3223 3242 ;;; Applicable methods -
trunk/abcl/src/org/armedbear/lisp/defstruct.lisp
r13451 r14014 126 126 (defvar *dd-slots*) 127 127 (defvar *dd-inherited-accessors*) 128 (defvar *dd-documentation*) 128 129 129 130 (defun keywordify (symbol) … … 515 516 direct-slots 516 517 slots 517 inherited-accessors) 518 inherited-accessors 519 documentation) 518 520 (setf (get name 'structure-definition) 519 521 (make-defstruct-description :name name … … 532 534 :slots slots 533 535 :inherited-accessors inherited-accessors)) 536 (%set-documentation name 'structure documentation) 534 537 (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))) 536 542 (when default-constructor 537 543 (proclaim `(ftype (function * t) ,default-constructor)))) … … 553 559 (*dd-direct-slots* ()) 554 560 (*dd-slots* ()) 555 (*dd-inherited-accessors* ())) 561 (*dd-inherited-accessors* ()) 562 (*dd-documentation* nil)) 556 563 (parse-name-and-options (if (atom name-and-options) 557 564 (list name-and-options) … … 565 572 (setf *dd-default-constructor* (default-constructor-name))) 566 573 (when (stringp (car slots)) 567 ( %set-documentation *dd-name* 'structure(pop slots)))574 (setf *dd-documentation* (pop slots))) 568 575 (dolist (slot slots) 569 576 (let* ((name (if (atom slot) slot (car slot))) … … 657 664 :direct-slots ',*dd-direct-slots* 658 665 :slots ',*dd-slots* 659 :inherited-accessors ',*dd-inherited-accessors*)) 666 :inherited-accessors ',*dd-inherited-accessors* 667 :documentation ',*dd-documentation*)) 660 668 ,@(define-constructors) 661 669 ,@(define-predicate)
Note: See TracChangeset
for help on using the changeset viewer.