(reason (eql :h))
sequencer)
(with-slots ((class %class) chain-head chain-tail) vtptr
- (sequence-output (stream sequencer)
- ((class :ichain chain-head :slots)
- (format stream " const struct ~A *_vt;~%"
- (vtable-struct-tag chain-tail chain-head))))))
+ (when (eq class chain-tail)
+ (sequence-output (stream sequencer)
+ ((class :ichain chain-head :slots)
+ (format stream " const struct ~A *_vt;~%"
+ (vtable-struct-tag chain-tail chain-head)))))))
(defmethod hook-output progn ((islots islots) (reason (eql :h)) sequencer)
(with-slots ((class %class) subclass slots) islots
- (sequence-output (stream sequencer)
- ((subclass :ichain (sod-class-chain-head class) :slots)
- (format stream " struct ~A ~A;~%"
- (islots-struct-tag class)
- (sod-class-nickname class))))))
+ (let ((head (sod-class-chain-head class)))
+ (when (eq head (sod-class-chain-head subclass))
+ (sequence-output (stream sequencer)
+ ((subclass :ichain (sod-class-chain-head class) :slots)
+ (format stream " struct ~A ~A;~%"
+ (islots-struct-tag class)
+ (sod-class-nickname class))))))))
;;;--------------------------------------------------------------------------
;;; Vtable structure.
(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
(with-slots ((class %class) subclass chain-head chain-tail) vtmsgs
- (sequence-output (stream sequencer)
- ((subclass :vtable chain-head :slots)
- (format stream " struct ~A ~A;~%"
- (vtmsgs-struct-tag subclass class)
- (sod-class-nickname class))))))
+ (when (eq subclass chain-tail)
+ (sequence-output (stream sequencer)
+ ((subclass :vtable chain-head :slots)
+ (format stream " struct ~A ~A;~%"
+ (vtmsgs-struct-tag subclass class)
+ (sod-class-nickname class)))))))
(defmethod hook-output progn
((vtmsgs vtmsgs) (reason (eql 'vtmsgs)) sequencer)
(defmethod hook-output progn
((cptr class-pointer) (reason (eql :h)) sequencer)
(with-slots ((class %class) chain-head metaclass meta-chain-head) cptr
- (sequence-output (stream sequencer)
- ((class :vtable chain-head :slots)
- (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
- metaclass
- (and (sod-class-direct-superclasses meta-chain-head)
- (sod-class-nickname meta-chain-head)))))))
+ (when (eq chain-head (sod-class-chain-head class))
+ (sequence-output (stream sequencer)
+ ((class :vtable chain-head :slots)
+ (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
+ metaclass
+ (and (sod-class-direct-superclasses meta-chain-head)
+ (sod-class-nickname meta-chain-head))))))))
(defmethod hook-output progn ((boff base-offset) (reason (eql :h)) sequencer)
(with-slots ((class %class) chain-head) boff
- (sequence-output (stream sequencer)
- ((class :vtable chain-head :slots)
- (write-line " size_t _base;" stream)))))
+ (when (eq chain-head (sod-class-chain-head class))
+ (sequence-output (stream sequencer)
+ ((class :vtable chain-head :slots)
+ (write-line " size_t _base;" stream))))))
(defmethod hook-output progn
((choff chain-offset) (reason (eql :h)) sequencer)
(with-slots ((class %class) chain-head target-head) choff
- (sequence-output (stream sequencer)
- ((class :vtable chain-head :slots)
- (format stream " ptrdiff_t _off_~A;~%"
- (sod-class-nickname target-head))))))
+ (when (eq chain-head (sod-class-chain-head class))
+ (sequence-output (stream sequencer)
+ ((class :vtable chain-head :slots)
+ (format stream " ptrdiff_t _off_~A;~%"
+ (sod-class-nickname target-head)))))))
;;;--------------------------------------------------------------------------
;;; Implementation output.
(pushnew function (sequencer-item-functions item))))
(defmethod invoke-sequencer-items ((sequencer sequencer) &rest arguments)
- (dolist (item (merge-lists (reverse (sequencer-constraints sequencer))))
- (dolist (function (reverse (sequencer-item-functions item)))
- (apply function arguments))))
+ (let ((seen (make-hash-table)))
+ (dolist (item (merge-lists (reverse (sequencer-constraints sequencer))))
+ (setf (gethash item seen) t)
+ (dolist (function (reverse (sequencer-item-functions item)))
+ (apply function arguments)))
+ (maphash (lambda (name item)
+ (unless (gethash item seen)
+ (warn "Unused output item ~S" name)))
+ (sequencer-table sequencer))))
;;;----- That's all, folks --------------------------------------------------