Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/pcl boot.lisp, 1.146, 1.147 braid.lisp, 1.71, 1.72 generic-functions.lisp, 1.37, 1.38 std-class.lisp, 1.120, 1.121
|
From: Nikodemus S. <de...@us...> - 2008-01-21 14:45:12
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv7021/src/pcl Modified Files: boot.lisp braid.lisp generic-functions.lisp std-class.lisp Log Message: 1.0.13.49: save source-locations for accessor methods defined via DEFCLASS * Just pass source-location / definition-source along the necessary code-paths -- all the required infra is already in place. * Also get the source locations for PCL itself: it would be embarassing not to have the source location for SB-PCL::DEFINITION-SOURCE. :) Index: boot.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v retrieving revision 1.146 retrieving revision 1.147 diff -u -d -r1.146 -r1.147 --- boot.lisp 8 Sep 2007 15:15:45 -0000 1.146 +++ boot.lisp 21 Jan 2008 14:44:45 -0000 1.147 @@ -2266,7 +2266,8 @@ 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 @@ -2307,13 +2308,15 @@ 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))) @@ -2329,6 +2332,7 @@ (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 @@ -2387,7 +2391,9 @@ (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 @@ -2401,7 +2407,8 @@ (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)))) Index: braid.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v retrieving revision 1.71 retrieving revision 1.72 diff -u -d -r1.71 -r1.72 --- braid.lisp 12 Nov 2007 17:14:51 -0000 1.71 +++ braid.lisp 21 Jan 2008 14:44:45 -0000 1.72 @@ -413,9 +413,10 @@ 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 @@ -449,28 +450,33 @@ 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)))) @@ -596,8 +602,8 @@ (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) Index: generic-functions.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/generic-functions.lisp,v retrieving revision 1.37 retrieving revision 1.38 diff -u -d -r1.37 -r1.38 --- generic-functions.lisp 18 Jun 2007 16:15:54 -0000 1.37 +++ generic-functions.lisp 21 Jan 2008 14:44:45 -0000 1.38 @@ -411,12 +411,6 @@ ;;;; 4 arguments -(defgeneric add-boundp-method (class generic-function slot-name slot-documentation)) - -(defgeneric add-reader-method (class generic-function slot-name slot-documentation)) - -(defgeneric add-writer-method (class generic-function slot-name slot-documentation)) - (defgeneric make-method-lambda (proto-generic-function proto-method lambda-expression environment)) @@ -427,6 +421,14 @@ ;;;; 5 arguments +;;; FIXME: This is currently unused -- where should we call it? Or should we just +;;; delete it. +(defgeneric add-boundp-method (class generic-function slot-name slot-documentation source-location)) + +(defgeneric add-reader-method (class generic-function slot-name slot-documentation source-location)) + +(defgeneric add-writer-method (class generic-function slot-name slot-documentation source-location)) + (defgeneric make-method-initargs-form (proto-generic-function proto-method lambda-expression lambda-list environment)) Index: std-class.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v retrieving revision 1.120 retrieving revision 1.121 diff -u -d -r1.120 -r1.121 --- std-class.lisp 15 Jan 2008 18:10:46 -0000 1.120 +++ std-class.lisp 21 Jan 2008 14:44:45 -0000 1.121 @@ -393,7 +393,8 @@ ((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 @@ -445,7 +446,7 @@ ;; 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) @@ -666,7 +667,8 @@ ((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) @@ -723,7 +725,7 @@ (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)) @@ -732,13 +734,13 @@ (defmethod finalize-inheritance ((class structure-class)) nil) ; always finalized -(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) @@ -751,10 +753,10 @@ (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)) @@ -1152,7 +1154,7 @@ (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 () @@ -1162,13 +1164,14 @@ (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 () @@ -1178,9 +1181,10 @@ (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 @@ -1189,7 +1193,8 @@ (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))) |