Changeset 13837 for trunk/abcl/src/org/armedbear/lisp/clos.lisp

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:

• trunk/abcl/src/org/armedbear/lisp/clos.lisp (modified) (5 diffs)

trunk/abcl/src/org/armedbear/lisp/clos.lisp

@@ -1182 +1182 @@
             (let ((instance (std-allocate-instance (find-class 'eql-specializer))))
               (setf (std-slot-value instance 'sys::object) object)
+              (setf (std-slot-value instance 'direct-methods) nil)
               instance))))
 
@@ -1777 +1778 @@
     method))
 
+;;; To be redefined as generic functions later
+(declaim (notinline add-direct-method))
+(defun add-direct-method (specializer method)
+  (if (typep specializer 'eql-specializer)
+      (pushnew method (std-slot-value specializer 'direct-methods))
+      (pushnew method (class-direct-methods specializer))))
+
+(declaim (notinline remove-direct-method))
+(defun remove-direct-method (specializer method)
+  (if (typep specializer 'eql-specializer)
+      (setf (std-slot-value specializer 'direct-methods)
+            (remove method (std-slot-value specializer 'direct-methods)))
+      (setf (class-direct-methods specializer)
+            (remove method (class-direct-methods specializer)))))
+
 (defun std-add-method (gf method)
   (when (and (method-generic-function method)
@@ -1791 +1807 @@
   (push method (generic-function-methods gf))
   (dolist (specializer (method-specializers method))
-    ;; FIXME use add-direct-method here (AMOP pg. 165))
-    (when (typep specializer 'class)
-      (pushnew method (class-direct-methods specializer))))
+    (add-direct-method specializer method))
   (finalize-standard-generic-function gf)
   gf)
@@ -1802 +1816 @@
   (setf (std-slot-value method 'generic-function) nil)
   (dolist (specializer (method-specializers method))
-    ;; FIXME use remove-direct-method here (AMOP pg. 227)
-    (when (typep specializer 'class)
-      (setf (class-direct-methods specializer)
-            (remove method (class-direct-methods specializer)))))
+    (remove-direct-method specializer method))
   (finalize-standard-generic-function gf)
   gf)
@@ -3728 +3739 @@
     (std-accessor-method-slot-definition method)))
 
+;;; specializer-direct-method and friends.
+
+;;; AMOP pg. 237
+(defgeneric specializer-direct-generic-functions (specializer))
+
+(defmethod specializer-direct-generic-functions ((specializer class))
+  (delete-duplicates (mapcar #'method-generic-function
+                             (class-direct-methods specializer))))
+
+(defmethod specializer-direct-generic-functions ((specializer eql-specializer))
+  (delete-duplicates (mapcar #'method-generic-function
+                             (slot-value specializer 'direct-methods))))
+
+;;; AMOP pg. 238
+(defgeneric specializer-direct-methods (specializer))
+
+(defmethod specializer-direct-methods ((specializer class))
+  (class-direct-methods specializer))
+
+(defmethod specializer-direct-methods ((specializer eql-specializer))
+  (slot-value specializer 'direct-methods))
+
+;;; AMOP pg. 165
+(atomic-defgeneric add-direct-method (specializer method)
+  (:method ((specializer class) (method method))
+    (pushnew method (class-direct-methods specializer)))
+  (:method ((specializer eql-specializer) (method method))
+    (pushnew method (slot-value specializer 'direct-methods))))
+
+
+;;; AMOP pg. 227
+(atomic-defgeneric remove-direct-method (specializer method)
+  (:method ((specializer class) (method method))
+    (setf (class-direct-methods specializer)
+          (remove method (class-direct-methods specializer))))
+  (:method ((specializer eql-specializer) (method method))
+    (setf (slot-value specializer 'direct-methods)
+          (remove method (slot-value specializer 'direct-methods)))))
+
 ;;; SLIME compatibility functions.