From 4d90efd9af94b39aecc4557c1138780f1a270e08 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Thu, 21 Feb 2008 21:44:09 +0100
Subject: Correctly determine conformance again.

darcs-hash:2b4ba01df66cf80650325ae89c1fe17988f5d0f9
---
 protocols.lisp | 96 ++++++++++++++++++++++++++++++++++------------------------
 1 file changed, 56 insertions(+), 40 deletions(-)

(limited to 'protocols.lisp')

diff --git a/protocols.lisp b/protocols.lisp
index 8a8f809..685afd1 100644
--- a/protocols.lisp
+++ b/protocols.lisp
@@ -17,43 +17,43 @@
   (class-name protocol))
 
 
+(defvar *alleged-conformance* (make-hash-table :test 'equal))
+(defvar *actual-conformance* (make-hash-table :test 'equal))
+
+
 (defun conforms-to-p (class protocol)
-  (let ((real-class (typecase class
-                      (symbol (find-class class))
-                      (t class)))
-        (real-protocol (typecase protocol
-                         (symbol (find-protocol protocol))
-                         (t protocol))))
-    (or (%conforms-to-p real-class real-protocol)
-        (some #'(lambda (superclass)
-                  (conforms-to-p superclass real-protocol))
-              (class-direct-superclasses real-class)))))
+  (let ((class (etypecase class
+                 (class class)
+                 (symbol (find-class class))))
+        (protocol (etypecase protocol
+                    (protocol protocol)
+                    (symbol (find-protocol protocol)))))
+    (or (gethash (cons class protocol) *alleged-conformance* nil)
+        (some #'(lambda (x) (conforms-to-p x protocol))
+              (class-direct-superclasses class)))))
 
 
 (defun really-conforms-to-p (class protocol)
-  (let ((real-class (typecase class
-                      (symbol (find-class class))
-                      (t class)))
-        (real-protocol (typecase protocol
-                         (symbol (find-protocol protocol))
-                         (t 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)))))
+  (let ((class (etypecase class
+                 (class class)
+                 (symbol (find-class class))))
+        (protocol (etypecase protocol
+                    (protocol protocol)
+                    (symbol (find-protocol protocol)))))
+    (or (gethash (cons class protocol) *actual-conformance* nil)
+        (some #'(lambda (x) (really-conforms-to-p x protocol))
+              (class-direct-superclasses class)))))
 
 
 (defgeneric %conforms-to-p (class protocol))
 
 (defmethod %conforms-to-p ((class t) (protocol t))
-  (declare (ignore class protocol))
   nil)
 
 
 (defgeneric %really-conforms-to-p (class protocol))
 
 (defmethod %really-conforms-to-p ((class t) (protocol t))
-  (declare (ignore class protocol))
   nil)
 
 
@@ -70,13 +70,17 @@
   t)
 
 
+(defmethod validate-superclass ((class protocol) (superclass standard-class))
+  t)
+
+
 (defmacro define-protocol (name superprotocols methods &rest options)
   "Define a new protocol.
 
 superprotocols ::= (*name*\\*)
 
 methods ::= ((method-name [\\* | class-name]\\*)\\*)"
-  `(defclass ,name ,(or superprotocols '(t))
+  `(defclass ,name ,superprotocols
         ()
      (:metaclass protocol)
      (:methods ,@methods)
@@ -87,7 +91,6 @@ methods ::= ((method-name [\\* | class-name]\\*)\\*)"
   (let* ((protocol (typecase protocol-designator
                      (symbol (find-protocol protocol-designator))
                      (t protocol-designator)))
-         (protocol-name (protocol-name protocol))
          (conforming-p nil))
     (with-accessors ((name protocol-name)
                      (superprotocols class-direct-superclasses)
@@ -140,24 +143,37 @@ methods ::= ((method-name [\\* | class-name]\\*)\\*)"
                                          (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))))
+        (setf (gethash (cons (find-class class-name) protocol)
+                       *alleged-conformance*)
+              t)
+        (setf (gethash (cons (find-class class-name) protocol)
+                       *actual-conformance*)
+              really-conforming-p)
         (let ((original-class (find-class class-name)))
           (unless (subtypep original-class protocol)
-            (let ((new-class-name (gensym (symbol-name class-name))))
-              (setf (class-name original-class) new-class-name)
-              (setf (find-class new-class-name) original-class)
-              (setf (find-class class-name)
-                    (ensure-class
-                         class-name
-                         :direct-superclasses (list original-class protocol)
-                         :metaclass (class-of original-class))))))))))
+            (handler-case
+                (let* ((new-class-name (gensym (symbol-name class-name)))
+                       (temporary-class-name (gensym (symbol-name class-name)))
+                       (new-class
+                        (ensure-class
+                             temporary-class-name
+                             :direct-superclasses (list original-class protocol)
+                             :metaclass (class-of original-class))))
+                  (setf (class-name original-class) new-class-name)
+                  (setf (class-name new-class) class-name)
+                  (setf (find-class new-class-name) original-class)
+                  (setf (find-class class-name) new-class))
+              (serious-condition ()
+                  (warn (make-condition
+                             'simple-style-warning
+                             :format-control "Could not add protocol ~A ~
+                                              as a superclass of ~A. ~
+                                              Most probably, the metaclasses ~
+                                              are incompatible.  (See the MOP ~
+                                              specification, specifically the ~
+                                              part about VALIDATE-SUPERCLASS.)"
+                             :format-arguments (list protocol
+                                                     original-class)))))))))))
 
 
 (defmacro implement-protocols (class protocols &body definitions)
-- 
cgit v1.2.3