Changeset 13590


Ignore:
Timestamp:
Apr 10, 2010, 6:13:11 AM (9 years ago)
Author:
rme
Message:

Don't generate duplicate accessors for inherited slots. (See ticket:390)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/defstruct.lisp

    r13344 r13590  
    111111                              print-function)))
    112112
     113(defun sd-refname-in-included-struct-p (sd name &optional env)
     114  (dolist (included-type (cdr (sd-superclasses sd)))
     115    (let ((sub-sd (or (let ((defenv (definition-environment env)))
     116                        (when defenv (%cdr (assq included-type
     117                                                 (defenv.structures
     118                                                     defenv)))))
     119                      (gethash included-type %defstructs%))))
     120      (when sub-sd
     121        (if (member name (sd-refnames sub-sd) :test 'eq)
     122          (return t))))))
    113123
    114124(defun sd-refname-pos-in-included-struct (sd name)
     
    137147            (let ((offset (ssd-offset slot)))
    138148              (unless (eql pos offset)
    139                 ; This should be a style-warning
     149                ;; This should be a style-warning
    140150                (warn "Accessor ~s at different position than in included structure"
    141151                      accessor)))
    142             (let ((fn (slot-accessor-fn slot accessor env)))
    143               (push
    144                `(progn
    145                   ,.fn
    146                   (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot))
    147                   (record-source-file ',accessor 'structure-accessor))
    148                stuff))))))
     152            (unless (sd-refname-in-included-struct-p sd accessor env)
     153              (let ((fn (slot-accessor-fn slot accessor env)))
     154                (push
     155                 `(progn
     156                    ,.fn
     157                    (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot))
     158                    (record-source-file ',accessor 'structure-accessor))
     159                 stuff)))))))
    149160    (nreverse stuff)))
    150161
Note: See TracChangeset for help on using the changeset viewer.