Changeset 13877


Ignore:
Timestamp:
02/24/12 04:20:52 (9 years ago)
Author:
rschlatte
Message:

Implement the dependent maintenance protocol (AMOP Sec. 5.5.6)

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13876 r13877  
    211211  (std-function-keywords method))
    212212
    213 
     213(declaim (notinline map-dependents))
     214(defun map-dependents (metaobject function)
     215  ;; stub, will be redefined later
     216  (declare (ignore metaobject function))
     217  nil)
    214218
    215219(defmacro push-on-end (value location)
     
    14241428        (dolist (method (generic-function-initial-methods gf))
    14251429          (if (typep gf 'standard-generic-function)
    1426               (std-remove-method gf method)
     1430              (progn
     1431                (std-remove-method gf method)
     1432                (map-dependents gf
     1433                                #'(lambda (dep)
     1434                                    (update-dependent gf dep
     1435                                                      'remove-method method))))
    14271436              (remove-method gf method)))
    14281437        (setf (generic-function-initial-methods gf) '()))))
     
    17921801               (apply #'make-instance (generic-function-method-class gf) all-keys))))
    17931802      (if (eq (generic-function-method-class gf) +the-standard-method-class+)
    1794           (std-add-method gf method)
     1803          (progn
     1804            (std-add-method gf method)
     1805            (map-dependents gf
     1806                            #'(lambda (dep)
     1807                                (update-dependent gf dep 'add-method method))))
    17951808          (add-method gf method))
    17961809      method)))
     
    25472560                      initargs))))
    25482561      (if (eq (class-of gf) +the-standard-generic-function-class+)
    2549           (std-add-method gf method)
     2562          (progn
     2563            (std-add-method gf method)
     2564            (map-dependents gf
     2565                            #'(lambda (dep)
     2566                                (update-dependent gf dep 'add-method method))))
    25502567          (add-method gf method))
    25512568      method)))
     
    25922609                      initargs))))
    25932610      (if (eq (class-of gf) +the-standard-generic-function-class+)
    2594           (std-add-method gf method)
     2611          (progn
     2612            (std-add-method gf method)
     2613            (map-dependents gf
     2614                            #'(lambda (dep)
     2615                                (update-dependent gf dep 'add-method method))))
    25952616          (add-method gf method))
    25962617      method)))
     
    33913412                  class t all-keys
    33923413                  nil 'reinitialize-instance)
    3393   (apply #'std-after-initialization-for-classes class all-keys))
     3414  (apply #'std-after-initialization-for-classes class all-keys)
     3415  (map-dependents class #'(lambda (dep) (update-dependent class dep all-keys))))
     3416
     3417(defmethod reinitialize-instance :after ((class funcallable-standard-class)
     3418                                         &rest all-keys)
     3419  (remhash class *make-instance-initargs-cache*)
     3420  (remhash class *reinitialize-instance-initargs-cache*)
     3421  (%make-instances-obsolete class)
     3422  (setf (class-finalized-p class) nil)
     3423  (check-initargs (list #'allocate-instance
     3424                        #'initialize-instance)
     3425                  (list* class all-keys)
     3426                  class t all-keys
     3427                  nil 'reinitialize-instance)
     3428  (apply #'std-after-initialization-for-classes class all-keys)
     3429  (map-dependents class #'(lambda (dep) (update-dependent class dep all-keys))))
     3430
     3431(defmethod reinitialize-instance :after ((gf standard-generic-function)
     3432                                         &rest all-keys)
     3433  (map-dependents gf #'(lambda (dep) (update-dependent gf dep all-keys))))
    33943434
    33953435;;; Finalize inheritance
     
    36873727  (std-add-method generic-function method))
    36883728
     3729(defmethod add-method :after ((generic-function standard-generic-function)
     3730                              (method method))
     3731  (map-dependents generic-function
     3732                  #'(lambda (dep) (update-dependent generic-function dep
     3733                                                    'add-method method))))
     3734
    36893735(defgeneric remove-method (generic-function method))
    36903736
    3691 (defmethod remove-method ((generic-function standard-generic-function) method)
     3737(defmethod remove-method ((generic-function standard-generic-function)
     3738                          (method method))
    36923739  (std-remove-method generic-function method))
     3740
     3741(defmethod remove-method :after ((generic-function standard-generic-function)
     3742                                 (method method))
     3743  (map-dependents generic-function
     3744                  #'(lambda (dep) (update-dependent generic-function dep
     3745                                                    'remove-method method))))
    36933746
    36943747;; See describe.lisp.
     
    38203873          (remove method (slot-value specializer 'direct-methods)))))
    38213874
     3875;;; The Dependent Maintenance Protocol (AMOP pg. 160ff.)
     3876
     3877(defvar *dependents* (make-hash-table :test 'eq :weakness :key))
     3878
     3879;;; AMOP pg. 164
     3880(defgeneric add-dependent (metaobject dependent))
     3881(defmethod add-dependent ((metaobject standard-class) dependent)
     3882  (pushnew dependent (gethash metaobject *dependents* nil)))
     3883(defmethod add-dependent ((metaobject funcallable-standard-class) dependent)
     3884  (pushnew dependent (gethash metaobject *dependents* nil)))
     3885(defmethod add-dependent ((metaobject standard-generic-function) dependent)
     3886  (pushnew dependent (gethash metaobject *dependents* nil)))
     3887
     3888;;; AMOP pg. 225
     3889(defgeneric remove-dependent (metaobject dependent))
     3890(defmethod remove-dependent ((metaobject standard-class) dependent)
     3891  (setf (gethash metaobject *dependents*)
     3892        (delete dependent (gethash metaobject *dependents* nil) :test #'eq)))
     3893(defmethod remove-dependent ((metaobject funcallable-standard-class) dependent)
     3894  (setf (gethash metaobject *dependents*)
     3895        (delete dependent (gethash metaobject *dependents* nil) :test #'eq)))
     3896(defmethod remove-dependent ((metaobject standard-generic-function) dependent)
     3897  (setf (gethash metaobject *dependents*)
     3898        (delete dependent (gethash metaobject *dependents* nil) :test #'eq)))
     3899
     3900;;; AMOP pg. 210
     3901(atomic-defgeneric map-dependents (metaobject function)
     3902  (:method ((metaobject standard-class) function)
     3903    (dolist (dependent (gethash metaobject *dependents* nil))
     3904      (funcall function dependent)))
     3905  (:method ((metaobject funcallable-standard-class) function)
     3906    (dolist (dependent (gethash metaobject *dependents* nil))
     3907      (funcall function dependent)))
     3908  (:method ((metaobject standard-generic-function) function)
     3909    (dolist (dependent (gethash metaobject *dependents* nil))
     3910      (funcall function dependent))))
     3911
     3912;;; AMOP pg. 239
     3913(defgeneric update-dependent (metaobject dependent &rest initargs))
     3914
     3915
    38223916;;; SLIME compatibility functions.
    38233917
  • trunk/abcl/src/org/armedbear/lisp/mop.lisp

    r13837 r13877  
    8383          extract-lambda-list
    8484          extract-specializer-names
    85           ))
     85
     86          add-dependent
     87          remove-dependent
     88          map-dependents
     89          update-dependent))
    8690
    8791(provide 'mop)
Note: See TracChangeset for help on using the changeset viewer.