1.0.13.49: save source-locations for accessor methods defined via DEFCLASS
authorNikodemus Siivola <nikodemus@random-state.net>
Mon, 21 Jan 2008 14:44:45 +0000 (21 14:44 +0000)
committerNikodemus Siivola <nikodemus@random-state.net>
Mon, 21 Jan 2008 14:44:45 +0000 (21 14:44 +0000)
 * 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. :)

src/pcl/boot.lisp
src/pcl/braid.lisp
src/pcl/generic-functions.lisp
src/pcl/std-class.lisp
version.lisp-expr

index bfa56ce..e600694 100644 (file)
@@ -2266,7 +2266,8 @@ bootstrapping.
             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 @@ bootstrapping.
                         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 @@ bootstrapping.
           (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 @@ bootstrapping.
   (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 @@ bootstrapping.
     (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 ae39f21..ab4588a 100644 (file)
                  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)
index 5712219..7d37d62 100644 (file)
 \f
 ;;;; 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))
 
 \f
 ;;;; 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 ebfe865..ef3f7e3 100644 (file)
     ((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)))
index 430c274..0fb8615 100644 (file)
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.13.48"
+"1.0.13.49"