Ignore:
Timestamp:
01/31/12 23:01:45 (9 years ago)
Author:
rschlatte
Message:

Implement specializer-method--related protocol.

Add add-direct-method, remove-direct-method, specializer-direct-methods,
specializer-direct-generic-functions

File:
1 edited

Legend:

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

    r13830 r13837  
    11821182            (let ((instance (std-allocate-instance (find-class 'eql-specializer))))
    11831183              (setf (std-slot-value instance 'sys::object) object)
     1184              (setf (std-slot-value instance 'direct-methods) nil)
    11841185              instance))))
    11851186
     
    17771778    method))
    17781779
     1780;;; To be redefined as generic functions later
     1781(declaim (notinline add-direct-method))
     1782(defun add-direct-method (specializer method)
     1783  (if (typep specializer 'eql-specializer)
     1784      (pushnew method (std-slot-value specializer 'direct-methods))
     1785      (pushnew method (class-direct-methods specializer))))
     1786
     1787(declaim (notinline remove-direct-method))
     1788(defun remove-direct-method (specializer method)
     1789  (if (typep specializer 'eql-specializer)
     1790      (setf (std-slot-value specializer 'direct-methods)
     1791            (remove method (std-slot-value specializer 'direct-methods)))
     1792      (setf (class-direct-methods specializer)
     1793            (remove method (class-direct-methods specializer)))))
     1794
    17791795(defun std-add-method (gf method)
    17801796  (when (and (method-generic-function method)
     
    17911807  (push method (generic-function-methods gf))
    17921808  (dolist (specializer (method-specializers method))
    1793     ;; FIXME use add-direct-method here (AMOP pg. 165))
    1794     (when (typep specializer 'class)
    1795       (pushnew method (class-direct-methods specializer))))
     1809    (add-direct-method specializer method))
    17961810  (finalize-standard-generic-function gf)
    17971811  gf)
     
    18021816  (setf (std-slot-value method 'generic-function) nil)
    18031817  (dolist (specializer (method-specializers method))
    1804     ;; FIXME use remove-direct-method here (AMOP pg. 227)
    1805     (when (typep specializer 'class)
    1806       (setf (class-direct-methods specializer)
    1807             (remove method (class-direct-methods specializer)))))
     1818    (remove-direct-method specializer method))
    18081819  (finalize-standard-generic-function gf)
    18091820  gf)
     
    37283739    (std-accessor-method-slot-definition method)))
    37293740
     3741;;; specializer-direct-method and friends.
     3742
     3743;;; AMOP pg. 237
     3744(defgeneric specializer-direct-generic-functions (specializer))
     3745
     3746(defmethod specializer-direct-generic-functions ((specializer class))
     3747  (delete-duplicates (mapcar #'method-generic-function
     3748                             (class-direct-methods specializer))))
     3749
     3750(defmethod specializer-direct-generic-functions ((specializer eql-specializer))
     3751  (delete-duplicates (mapcar #'method-generic-function
     3752                             (slot-value specializer 'direct-methods))))
     3753
     3754;;; AMOP pg. 238
     3755(defgeneric specializer-direct-methods (specializer))
     3756
     3757(defmethod specializer-direct-methods ((specializer class))
     3758  (class-direct-methods specializer))
     3759
     3760(defmethod specializer-direct-methods ((specializer eql-specializer))
     3761  (slot-value specializer 'direct-methods))
     3762
     3763;;; AMOP pg. 165
     3764(atomic-defgeneric add-direct-method (specializer method)
     3765  (:method ((specializer class) (method method))
     3766    (pushnew method (class-direct-methods specializer)))
     3767  (:method ((specializer eql-specializer) (method method))
     3768    (pushnew method (slot-value specializer 'direct-methods))))
     3769
     3770
     3771;;; AMOP pg. 227
     3772(atomic-defgeneric remove-direct-method (specializer method)
     3773  (:method ((specializer class) (method method))
     3774    (setf (class-direct-methods specializer)
     3775          (remove method (class-direct-methods specializer))))
     3776  (:method ((specializer eql-specializer) (method method))
     3777    (setf (slot-value specializer 'direct-methods)
     3778          (remove method (slot-value specializer 'direct-methods)))))
     3779
    37303780;;; SLIME compatibility functions.
    37313781
Note: See TracChangeset for help on using the changeset viewer.