Changeset 14057


Ignore:
Timestamp:
Jul 27, 2010, 2:14:33 AM (9 years ago)
Author:
gz
Message:

Couple defstruct fixes from trunk (r13590, r13788)

Location:
branches/qres/ccl
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • branches/qres/ccl

  • branches/qres/ccl/lib/defstruct-lds.lisp

    r13070 r14057  
    249249       (remove-structure-defs  ',struct-name) ; lose any previous defs
    250250        ,.(defstruct-slot-defs sd refnames env)
    251         ,.(if constructor (list (defstruct-constructor sd constructor)))
    252         ,.(defstruct-boa-constructors sd boa-constructors)
    253251        ,.(if copier (defstruct-copier sd copier env))
    254252        ,.(if predicate (defstruct-predicate sd named predicate env))
     
    264262         ,.(if documentation (list documentation)))
    265263        ,.(%defstruct-compile sd refnames env)
     264        ,.(defstruct-boa-constructors sd boa-constructors)
     265        ,.(if constructor (list (defstruct-constructor sd constructor)))
    266266       ;; Wait until slot accessors are defined, to avoid
    267267       ;; undefined function warnings in the print function/method.
  • branches/qres/ccl/lib/defstruct.lisp

    r13363 r14057  
    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.