Changeset 12933 for trunk/abcl/src/org


Ignore:
Timestamp:
10/01/10 21:22:10 (11 years ago)
Author:
ehuelsmann
Message:

Fix #106: DEFSTRUCT :include with :conc-name.

File:
1 edited

Legend:

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

    r12113 r12933  
    5050(defmacro dd-direct-slots (x)        `(aref ,x 12))
    5151(defmacro dd-slots (x)               `(aref ,x 13))
     52(defmacro dd-inherited-accessors (x) `(aref ,x 14))
    5253
    5354(defun make-defstruct-description (&key name
     
    6465                                        print-object
    6566                                        direct-slots
    66                                         slots)
    67   (let ((dd (make-array 14)))
     67                                        slots
     68                                        inherited-accessors)
     69  (let ((dd (make-array 15)))
    6870    (setf (dd-name dd) name
    6971          (dd-conc-name dd) conc-name
     
    7981          (dd-print-object dd) print-object
    8082          (dd-direct-slots dd) direct-slots
    81           (dd-slots dd) slots)
     83          (dd-slots dd) slots
     84          (dd-inherited-accessors dd) inherited-accessors)
    8285    dd))
    8386
     
    122125(defvar *dd-direct-slots*)
    123126(defvar *dd-slots*)
     127(defvar *dd-inherited-accessors*)
    124128
    125129(defun keywordify (symbol)
     
    327331
    328332(defun define-reader (slot)
    329   (let ((accessor-name (if *dd-conc-name*
    330                            (intern (concatenate 'string
    331                                                 (symbol-name *dd-conc-name*)
    332                                                 (symbol-name (dsd-name slot))))
    333                            (dsd-name slot)))
     333  (let ((accessor-name (dsd-reader slot))
    334334        (index (dsd-index slot))
    335335        (type (dsd-type slot)))
     
    354354
    355355(defun define-writer (slot)
    356   (let ((accessor-name (if *dd-conc-name*
    357                            (intern (concatenate 'string
    358                                                 (symbol-name *dd-conc-name*)
    359                                                 (symbol-name (dsd-name slot))))
    360                            (dsd-name slot)))
     356  (let ((accessor-name (dsd-reader slot))
    361357        (index (dsd-index slot)))
    362358    (cond ((eq *dd-type* 'list)
     
    379375  (let ((result ()))
    380376    (dolist (slot *dd-slots*)
    381       (setf result (nconc result (define-reader slot)))
    382       (unless (dsd-read-only slot)
    383         (setf result (nconc result (define-writer slot)))))
     377      (let ((accessor-name (dsd-reader slot)))
     378        (unless (assoc accessor-name *dd-inherited-accessors*)
     379          (setf result (nconc result (define-reader slot)))
     380          (unless (dsd-read-only slot)
     381            (setf result (nconc result (define-writer slot)))))))
    384382    result))
    385383
     
    477475                                print-object
    478476                                direct-slots
    479                                 slots)
     477                                slots
     478                                inherited-accessors)
    480479  (setf (get name 'structure-definition)
    481480        (make-defstruct-description :name name
     
    492491                                    :print-object print-object
    493492                                    :direct-slots direct-slots
    494                                     :slots slots))
     493                                    :slots slots
     494                                    :inherited-accessors inherited-accessors))
    495495  (when (or (null type) named)
    496496    (make-structure-class name direct-slots slots (car include)))
     
    513513        (*dd-print-object* nil)
    514514        (*dd-direct-slots* ())
    515         (*dd-slots* ()))
     515        (*dd-slots* ())
     516        (*dd-inherited-accessors* ()))
    516517    (parse-name-and-options (if (atom name-and-options)
    517518                                (list name-and-options)
     
    557558            ;; MUST COPY SLOT DESCRIPTION!
    558559            (setf dsd (copy-seq dsd))
    559             (setf (dsd-index dsd) index)
     560            (setf (dsd-index dsd) index
     561                  (dsd-reader dsd)
     562                  (if *dd-conc-name*
     563                      (intern (concatenate 'string
     564                                           (symbol-name *dd-conc-name*)
     565                                           (symbol-name (dsd-name dsd))))
     566                      (dsd-name dsd)))
    560567            (push dsd *dd-slots*)
    561             (incf index)))
     568            (incf index))
     569          (setf *dd-inherited-accessors* (dd-inherited-accessors dd))
     570          (dolist (dsd (dd-direct-slots dd))
     571            (push (cons (dsd-reader dsd) (dsd-name dsd))
     572                  *dd-inherited-accessors*)))
    562573        (when (cdr *dd-include*)
    563574          (dolist (slot (cdr *dd-include*))
     
    606617                             ,@(if *dd-print-object* `(:print-object ',*dd-print-object*))
    607618                             :direct-slots ',*dd-direct-slots*
    608                              :slots ',*dd-slots*))
     619                             :slots ',*dd-slots*
     620                             :inherited-accessors ',*dd-inherited-accessors*))
    609621       ,@(define-constructors)
    610622       ,@(define-predicate)
Note: See TracChangeset for help on using the changeset viewer.