summaryrefslogtreecommitdiff
path: root/protocols.lisp
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2008-02-21 22:54:47 +0100
committerMatthias Benkard <code@mail.matthias.benkard.de>2008-02-21 22:54:47 +0100
commit10a557db78474e81ba7ad39701a3611c65db0a8a (patch)
treedc052e0bcafd1eb04ec88e03a26aeb580dccf4b1 /protocols.lisp
parent85b983a0eb9c3aec7fc59c560c441ed28c10b85d (diff)
Add a strictness option to protocols.
darcs-hash:28dd5077fc8cd98403f72f76668046a5b79bef21
Diffstat (limited to 'protocols.lisp')
-rw-r--r--protocols.lisp33
1 files changed, 29 insertions, 4 deletions
diff --git a/protocols.lisp b/protocols.lisp
index 685afd1..0bb1fa6 100644
--- a/protocols.lisp
+++ b/protocols.lisp
@@ -4,6 +4,15 @@
(defvar *protocols* (make-hash-table))
+(defclass protocol (standard-class)
+ ((methods :initarg :methods
+ :reader protocol-methods)
+ (strictness :initarg :strictness
+ :reader protocol-strictness
+ :initform '(nil)
+ :documentation "Only tag classes with this protocol if they actually (rather than allegedly) conform to it.")))
+
+
(defun find-protocol (name &optional (errorp t))
(find-class name errorp))
@@ -57,9 +66,23 @@
nil)
-(defclass protocol (standard-class)
- ((methods :initarg :methods
- :reader protocol-methods)))
+(defmethod initialize-instance :around ((protocol protocol)
+ &rest initargs
+ &key (strictness
+ '(nil)
+ strictness-supplied-p)
+ direct-superclasses
+ &allow-other-keys)
+ (declare (ignore strictness))
+ (let ((new-initargs (copy-list initargs)))
+ (unless strictness-supplied-p
+ (setf (getf new-initargs :strictness)
+ (list (some #'protocol-strictp direct-superclasses))))
+ (apply #'call-next-method protocol new-initargs)))
+
+
+(defun protocol-strictp (protocol)
+ (car (protocol-strictness protocol)))
(defmethod validate-superclass (class (superclass protocol))
@@ -150,7 +173,9 @@ methods ::= ((method-name [\\* | class-name]\\*)\\*)"
*actual-conformance*)
really-conforming-p)
(let ((original-class (find-class class-name)))
- (unless (subtypep original-class protocol)
+ (unless (or (subtypep original-class protocol)
+ (and (not really-conforming-p)
+ (protocol-strictp protocol)))
(handler-case
(let* ((new-class-name (gensym (symbol-name class-name)))
(temporary-class-name (gensym (symbol-name class-name)))