arg-info)))
(defun early-make-a-method (class qualifiers arglist specializers initargs doc
- &key slot-name object-class method-class-function)
+ &key slot-name object-class method-class-function
+ definition-source)
(let ((parsed ())
(unparsed ()))
;; Figure out whether we got class objects or class names as the
initargs doc)
(when slot-name
(list :slot-name slot-name :object-class object-class
- :method-class-function method-class-function))))))
+ :method-class-function method-class-function))
+ (list :definition-source definition-source)))))
(initialize-method-function initargs result)
result)))
(defun real-make-a-method
(class qualifiers lambda-list specializers initargs doc
- &rest args &key slot-name object-class method-class-function)
+ &rest args &key slot-name object-class method-class-function
+ definition-source)
(if method-class-function
(let* ((object-class (if (classp object-class) object-class
(find-class object-class)))
(apply #'make-instance
(apply method-class-function object-class slot-definition
initargs)
+ :definition-source definition-source
initargs)))
(apply #'make-instance class :qualifiers qualifiers
:lambda-list lambda-list :specializers specializers
(setf (fifth (fifth early-method)) new-value))
(defun early-add-named-method (generic-function-name qualifiers
- specializers arglist &rest initargs)
+ specializers arglist &rest initargs
+ &key documentation definition-source
+ &allow-other-keys)
(let* (;; we don't need to deal with the :generic-function-class
;; argument here because the default,
;; STANDARD-GENERIC-FUNCTION, is right for all early generic
(setf (getf (getf initargs 'plist) :name)
(make-method-spec gf qualifiers specializers))
(let ((new (make-a-method 'standard-method qualifiers arglist
- specializers initargs (getf initargs :documentation))))
+ specializers initargs documentation
+ :definition-source definition-source)))
(when existing (remove-method gf existing))
(add-method gf new))))
slot-name
readers
writers
- nil)))))))))
+ nil
+ (ecd-source-location definition))))))))))
-(defun !bootstrap-accessor-definition (class-name accessor-name slot-name type)
+(defun !bootstrap-accessor-definition (class-name accessor-name slot-name type source-location)
(multiple-value-bind (accessor-class make-method-function arglist specls doc)
(ecase type
(reader (values 'standard-reader-method
doc
:slot-name slot-name
:object-class class-name
- :method-class-function (constantly (find-class accessor-class))))))))
+ :method-class-function (constantly (find-class accessor-class))
+ :definition-source source-location))))))
(defun !bootstrap-accessor-definitions1 (class-name
- slot-name
- readers
- writers
- boundps)
+ slot-name
+ readers
+ writers
+ boundps
+ source-location)
(flet ((do-reader-definition (reader)
(!bootstrap-accessor-definition class-name
reader
slot-name
- 'reader))
+ 'reader
+ source-location))
(do-writer-definition (writer)
(!bootstrap-accessor-definition class-name
writer
slot-name
- 'writer))
+ 'writer
+ source-location))
(do-boundp-definition (boundp)
(!bootstrap-accessor-definition class-name
boundp
slot-name
- 'boundp)))
+ 'boundp
+ source-location)))
(dolist (reader readers) (do-reader-definition reader))
(dolist (writer writers) (do-writer-definition writer))
(dolist (boundp boundps) (do-boundp-definition boundp))))
(defun make-class-predicate (class name)
(let* ((gf (ensure-generic-function name :lambda-list '(object)))
(mlist (if (eq *boot-state* 'complete)
- (generic-function-methods gf)
- (early-gf-methods gf))))
+ (early-gf-methods gf)
+ (generic-function-methods gf))))
(unless mlist
(unless (eq class *the-class-t*)
(let* ((default-method-function #'constantly-nil)
((class std-class) slot-names &key
(direct-superclasses nil direct-superclasses-p)
(direct-slots nil direct-slots-p)
- (direct-default-initargs nil direct-default-initargs-p))
+ (direct-default-initargs nil direct-default-initargs-p)
+ definition-source)
(cond (direct-superclasses-p
(setq direct-superclasses
(or direct-superclasses
;; required by AMOP, "Reinitialization of Class Metaobjects"
(finalize-inheritance class)
(update-class class nil))
- (add-slot-accessors class direct-slots)
+ (add-slot-accessors class direct-slots definition-source)
(make-preliminary-layout class))
(defmethod shared-initialize :after ((class forward-referenced-class)
((class structure-class) slot-names &key
(direct-superclasses nil direct-superclasses-p)
(direct-slots nil direct-slots-p)
- direct-default-initargs)
+ direct-default-initargs
+ definition-source)
(declare (ignore slot-names direct-default-initargs))
(if direct-superclasses-p
(setf (slot-value class 'direct-superclasses)
(setf (slot-value class 'wrapper) layout)
(setf (layout-slot-table layout) (make-slot-table class slots))))
(setf (slot-value class 'finalized-p) t)
- (add-slot-accessors class direct-slots)))
+ (add-slot-accessors class direct-slots definition-source)))
(defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
(declare (ignore initargs))
(defmethod finalize-inheritance ((class structure-class))
nil) ; always finalized
\f
-(defun add-slot-accessors (class dslotds)
- (fix-slot-accessors class dslotds 'add))
+(defun add-slot-accessors (class dslotds &optional source-location)
+ (fix-slot-accessors class dslotds 'add source-location))
(defun remove-slot-accessors (class dslotds)
(fix-slot-accessors class dslotds 'remove))
-(defun fix-slot-accessors (class dslotds add/remove)
+(defun fix-slot-accessors (class dslotds add/remove &optional source-location)
(flet ((fix (gfspec name r/w doc)
(let ((gf (cond ((eq add/remove 'add)
(or (find-generic-function gfspec nil)
(when gf
(case r/w
(r (if (eq add/remove 'add)
- (add-reader-method class gf name doc)
+ (add-reader-method class gf name doc source-location)
(remove-reader-method class gf)))
(w (if (eq add/remove 'add)
- (add-writer-method class gf name doc)
+ (add-writer-method class gf name doc source-location)
(remove-writer-method class gf))))))))
(dolist (dslotd dslotds)
(let ((slot-name (slot-definition-name dslotd))
(declare (ignore direct-slot initargs))
(find-class 'standard-reader-method))
-(defmethod add-reader-method ((class slot-class) generic-function slot-name slot-documentation)
+(defmethod add-reader-method ((class slot-class) generic-function slot-name slot-documentation source-location)
(add-method generic-function
(make-a-method 'standard-reader-method
()
(or slot-documentation "automatically generated reader method")
:slot-name slot-name
:object-class class
- :method-class-function #'reader-method-class)))
+ :method-class-function #'reader-method-class
+ :definition-source source-location)))
(defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
(declare (ignore direct-slot initargs))
(find-class 'standard-writer-method))
-(defmethod add-writer-method ((class slot-class) generic-function slot-name slot-documentation)
+(defmethod add-writer-method ((class slot-class) generic-function slot-name slot-documentation source-location)
(add-method generic-function
(make-a-method 'standard-writer-method
()
(or slot-documentation "automatically generated writer method")
:slot-name slot-name
:object-class class
- :method-class-function #'writer-method-class)))
+ :method-class-function #'writer-method-class
+ :definition-source source-location)))
-(defmethod add-boundp-method ((class slot-class) generic-function slot-name slot-documentation)
+(defmethod add-boundp-method ((class slot-class) generic-function slot-name slot-documentation source-location)
(add-method generic-function
(make-a-method (constantly (find-class 'standard-boundp-method))
class
(list class)
(make-boundp-method-function class slot-name)
(or slot-documentation "automatically generated boundp method")
- slot-name)))
+ :slot-name slot-name
+ :definition-source source-location)))
(defmethod remove-reader-method ((class slot-class) generic-function)
(let ((method (get-method generic-function () (list class) nil)))
projects / sbcl.git / commitdiff