Support protocol inheritance.

darcs-hash:26e54df381e3bbe213472f6c7b4f2fb11bdd16af

2 files changed, 56 insertions, 32 deletions

diff --git a/example.lisp b/example.lisp
index e2e48d5..39f33b4 100644
--- a/example.lisp
+++ b/example.lisp
@@ -31,22 +31,30 @@
 (defgeneric multiply (x stream))
 (defgeneric invert (x))
 
+
 (defclass a () ())
 
-;; Note the style warnings signalled by the following.
-(implement-protocols a (additive multiplicative serialisable)
-  (defmethod add ((x a) (y a)))
-  (defmethod negate ((x a)))
-  (defmethod multiply ((x a) y)))
+;; The following should signal five style warnings about missing methods.
+(implement-protocols a (serialisable-field))
+
+
+(defclass b () ())
+
+;; Note the two style warnings signalled by the following.
+(implement-protocols b (additive multiplicative serialisable)
+  (defmethod add ((x b) (y b)))
+  (defmethod negate ((x b)))
+  (defmethod multiply ((x b) y)))
 
-(print (conforms-to-p 'a 'additive))
-(print (really-conforms-to-p 'a 'additive))
-(print (conforms-to-p 'a 'multiplicative))
-(print (really-conforms-to-p 'a 'multiplicative))
-(print (conforms-to-p 'a 'printable))
-(print (really-conforms-to-p 'a 'printable))
+(print (conforms-to-p 'b 'additive))
+(print (really-conforms-to-p 'b 'additive))
+(print (conforms-to-p 'b 'multiplicative))
+(print (really-conforms-to-p 'b 'multiplicative))
+(print (conforms-to-p 'b 'printable))
+(print (really-conforms-to-p 'b 'printable))
 
-(implement-protocols a (printable))
+;; The following works because PRINT-OBJECT is specialised over T.
+(implement-protocols b (printable))
 
-(print (conforms-to-p 'a 'printable))
-(print (really-conforms-to-p 'a 'printable))
+(print (conforms-to-p 'b 'printable))
+(print (really-conforms-to-p 'b 'printable))
diff --git a/protocols.lisp b/protocols.lisp
index a5f2102..0634847 100644
--- a/protocols.lisp
+++ b/protocols.lisp
@@ -1,9 +1,6 @@
 (in-package #:mulk.protocols)
 
 
-(declaim (optimize debug safety (speed 0) (space 0)))
-
-
 (defvar *protocols* (make-hash-table))
 
 
@@ -26,7 +23,10 @@
         (real-protocol (typecase protocol
                          (symbol (find-protocol protocol))
                          (t protocol))))
-    (%conforms-to-p real-class real-protocol)))
+    (or (%conforms-to-p real-class real-protocol)
+        (some #'(lambda (superclass)
+                  (conforms-to-p superclass real-protocol))
+              (class-direct-superclasses real-class)))))
 
 
 (defun really-conforms-to-p (class protocol)
@@ -36,7 +36,10 @@
         (real-protocol (typecase protocol
                          (symbol (find-protocol protocol))
                          (t protocol))))
-    (%really-conforms-to-p real-class real-protocol)))
+    (or (%really-conforms-to-p real-class real-protocol)
+        (some #'(lambda (superclass)
+                  (really-conforms-to-p superclass real-protocol))
+              (class-direct-superclasses real-class)))))
 
 
 (defgeneric %conforms-to-p (class protocol))
@@ -88,8 +91,12 @@ methods ::= ((method-name [\\* | class-name]\\*)\\*)"
     (format stream "PROTOCOL ~A" (protocol-name protocol))))
 
 
-(defun ensure-conformance (class-name protocol-name)
-  (let ((protocol (find-protocol protocol-name)))
+(defun ensure-conformance (class-name protocol-designator)
+  (let* ((protocol (typecase protocol-designator
+                     (symbol (find-protocol protocol-designator))
+                     (t protocol-designator)))
+         (protocol-name (protocol-name protocol))
+         (conforming-p nil))
     (with-slots (name superprotocols methods options)
         protocol
       (loop for method in methods
@@ -112,20 +119,29 @@ methods ::= ((method-name [\\* | class-name]\\*)\\*)"
                                                         (first method)
                                                         real-argument-class-list
                                                         (protocol-name protocol))))
-            finally (return (null missing-methods))))))
+            finally (setq conforming-p (null missing-methods)))
+      (let ((really-conforming-p
+             (and conforming-p
+                  (every #'identity
+                         ;; We have to use MAPCAR because we
+                         ;; don't want short-circuiting.
+                         (mapcar #'(lambda (superprotocol)
+                                     (ensure-conformance class-name
+                                                         superprotocol))
+                                 superprotocols)))))
+        (ensure-method #'%conforms-to-p
+                       '(lambda (x y) t)
+                       :specializers (list (intern-eql-specializer (find-class class-name))
+                                           (intern-eql-specializer (find-protocol protocol-name))))
+        (ensure-method #'%really-conforms-to-p
+                       `(lambda (x y) ,really-conforming-p)
+                       :specializers (list (intern-eql-specializer (find-class class-name))
+                                           (intern-eql-specializer (find-protocol protocol-name))))))))
 
 
 (defmacro implement-protocols (class protocols &body definitions)
   `(progn
      ,@definitions
-     ,@(mapcan #'(lambda (protocol)
-                   `((let ((conformance (ensure-conformance ',class ',protocol)))
-                       (defmethod %really-conforms-to-p
-                           ((class (eql (find-class ',class)))
-                            (protocol (eql (find-protocol ',protocol))))
-                         conformance))
-                     (defmethod %conforms-to-p
-                         ((class (eql (find-class ',class)))
-                          (protocol (eql (find-protocol ',protocol))))
-                       t)))
+     ,@(mapcar #'(lambda (protocol)
+                   `(ensure-conformance ',class ',protocol))
                protocols)))