From: Christophe Rhodes <csr21@cantab.net>
Date: Fri, 20 Dec 2013 18:55:02 +0000 (+0000)
Subject: get SPECIALIZER-DIRECT-METHODS (and -GENERIC-FUNCTIONS) right
X-Git-Tag: els2014-submission~18
X-Git-Url: http://christophe.rhodes.io/gitweb/?a=commitdiff_plain;h=10e470a1cb09d5a30ba370be445974634c549da0;p=specializable.git

get SPECIALIZER-DIRECT-METHODS (and -GENERIC-FUNCTIONS) right

we can do what we need by having SB-MOP:ADD-DIRECT-METHODS and
SB-MOP:REMOVE-DIRECT-METHODS maintain a per-class table, indexed by
the specializers under SB-PCL::SAME-SPECIALIZER-P, of direct methods.
This then is agnostic to whether the specializers are interned or
freshly generated.
---

diff --git a/specializable.lisp b/specializable.lisp
index c69f786..d1bd688 100644
--- a/specializable.lisp
+++ b/specializable.lisp
@@ -20,9 +20,27 @@
 (in-package "SPECIALIZABLE")
 
 (defclass extended-specializer (sb-mop:specializer)
-  ((direct-methods :initform nil
-                   :accessor %specializer-direct-methods
-                   :reader specializer-direct-methods)))
+  ((direct-methods-table :allocation :class
+                         :initform nil :accessor direct-methods-table)))
+
+(defmethod sb-mop:add-direct-method ((specializer extended-specializer) method)
+  (let* ((table (direct-methods-table specializer))
+         (cell (assoc specializer table :test #'sb-pcl::same-specializer-p)))
+    (unless cell
+      (setf cell (cons specializer nil))
+      (push cell (direct-methods-table specializer)))
+    (push method (cdr cell))))
+
+(defmethod sb-mop:remove-direct-method ((specializer extended-specializer) method)
+  (let* ((table (direct-methods-table specializer))
+         (cell (assoc specializer table :test #'sb-pcl::same-specializer-p)))
+    (setf (cdr cell) (remove method (cdr cell)))))
+
+(defmethod sb-mop:specializer-direct-methods ((specializer extended-specializer))
+  (cdr (assoc specializer (direct-methods-table specializer)
+              :test #'sb-pcl::same-specializer-p)))
+(defmethod sb-mop:specializer-direct-generic-functions ((specializer extended-specializer))
+  (remove-duplicates (mapcar #'sb-mop:method-generic-function (sb-mop:specializer-direct-methods specializer))))
 
 (defclass specializable-generic-function (standard-generic-function)
   ((extended-specializers :initform (make-hash-table :test 'equal)
@@ -66,13 +84,6 @@
 	   '|This is not a generic function| ;fixme, see comment above
 	   args)))
 
-(defmethod sb-mop:add-direct-method ((specializer extended-specializer) method)
-  (pushnew method (%specializer-direct-methods specializer)))
-
-(defmethod sb-mop:remove-direct-method ((specializer extended-specializer) method)
-  (setf (%specializer-direct-methods specializer)
-        (remove method (specializer-direct-methods specializer))))
-
 ;;; from SBCL:
 
 (defmethod sb-pcl:parse-specializer-using-class