add signum specializer example

[specializable.git] / specializable.lisp

diff --git a/specializable.lisp b/specializable.lisp
index c9f34adbae1669883e6dadd3a0871cbedf8ca916..ebe4794a44bdbe7d51212df995df3a599101f17b 100644 (file)
--- a/specializable.lisp
+++ b/specializable.lisp
@@ -13,15 +13,35 @@
 
            "GENERALIZER-OF-USING-CLASS"
            "COMPUTE-APPLICABLE-METHODS-USING-GENERALIZERS"
+           "GENERALIZER-EQUAL-HASH-KEY"
            
            "DEFINE-EXTENDED-SPECIALIZER"))
 
 (in-package "SPECIALIZABLE")
 
 (defclass extended-specializer (sb-mop:specializer)
-  ((direct-methods :initform nil
-                   :accessor %specializer-direct-methods
-                   :reader specializer-direct-methods)))
+  ;; FIXME: this doesn't actually do quite what I wanted.
+  ((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)
@@ -51,12 +71,6 @@
 ;;;             gf
 ;;;             args))))
 
-;;; FIXME: this (and add/remove-direct-method) don't actually work
-;;; together, because two distinct calls to make-extended-specializer
-;;; return two distinct specializer objects.  We need either to make
-;;; the extended specializers be interned, or to have them be
-;;; arbitrarily ephemeral but adjust specializer-direct-methods (and
-;;; implement specializer-direct-generic-functions) accordingly.
 (defun make-extended-specializer (sname)
   (destructuring-bind (kind &rest args) sname
     (apply (or (get kind 'extended-specializer-parser)
@@ -65,13 +79,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
@@ -109,17 +116,23 @@
       (error "Too few arguments to generic function ~S." gf))
     (subseq args 0 number-required)))
 
+(defgeneric generalizer-equal-hash-key (generic-function generalizer))
+(defmethod generalizer-equal-hash-key
+    ((gf specializable-generic-function) (g class))
+  (sb-pcl::class-wrapper g))
+
 ;;; FIXME: in some kind of order, the discriminating function needs to handle:
 ;;; - argument count checking;
-;;; - keyword argument validity;
+;;; - DONE (in effective method) keyword argument validity;
 ;;; - DONE flushing the emf cache on method addition/removal
-;;; - flushing the cache on class redefinition;
+;;; - DONE (sort of, using wrappers/g-e-h-k) flushing the cache on class redefinition;
 ;;; - cache thread-safety.
 (defmethod sb-mop:compute-discriminating-function ((gf specializable-generic-function))
   (lambda (&rest args)
     (let* ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
                                  (required-portion gf args)))
-          (emfun (gethash generalizers (emf-table gf) nil)))
+           (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers))
+          (emfun (gethash keys (emf-table gf) nil)))
       (if emfun
          (sb-pcl::invoke-emf emfun args)
          (slow-method-lookup gf args generalizers)))))
@@ -133,15 +146,17 @@
       (compute-applicable-methods-using-generalizers gf generalizers)
     (if definitivep
        (let* ((emfun
-               (compute-effective-method-function gf applicable-methods)))
-         (setf (gethash generalizers (emf-table gf)) emfun)
+                (compute-effective-method-function gf applicable-methods))
+               (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers)))
+         (setf (gethash keys (emf-table gf)) emfun)
          (sb-pcl::invoke-emf emfun args))
-       (sb-pcl::invoke-emf (compute-effective-method-function
+        (sb-pcl::invoke-emf (compute-effective-method-function
                              gf (sb-mop:compute-applicable-methods gf args))
                             args))))
 
 (defun compute-effective-method-function (gf methods)
   (let* ((mc (sb-mop:generic-function-method-combination gf))
+         (sb-pcl::*applicable-methods* methods)
          (em (sb-mop:compute-effective-method gf mc methods)))
     (sb-pcl::make-effective-method-function gf em)))
 
@@ -227,7 +242,7 @@
       (let ((cpl (sb-mop:class-precedence-list generalizer)))
        (if (find s2 (cdr (member s1 cpl)))
            '<
-           nil))))
+            '>))))
 (defmethod specializer<
     ((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 sb-mop:eql-specializer) generalizer)
   (declare (ignore generalizer))