diff options
| -rw-r--r-- | conditions.lisp | 13 | ||||
| -rw-r--r-- | example.lisp | 52 | ||||
| -rw-r--r-- | package.lisp | 9 | ||||
| -rw-r--r-- | protocols.asd | 10 | ||||
| -rw-r--r-- | protocols.lisp | 131 |
5 files changed, 215 insertions, 0 deletions
diff --git a/conditions.lisp b/conditions.lisp new file mode 100644 index 0000000..4d9ea4e --- /dev/null +++ b/conditions.lisp @@ -0,0 +1,13 @@ +(in-package #:mulk.protocols) + + +(define-condition simple-style-warning (style-warning) + ((format-control :initarg :format-control + :reader format-control) + (format-arguments :initarg :format-arguments + :reader format-arguments)) + (:report (lambda (condition stream) + (apply #'format + stream + (format-control condition) + (format-arguments condition))))) diff --git a/example.lisp b/example.lisp new file mode 100644 index 0000000..e2e48d5 --- /dev/null +++ b/example.lisp @@ -0,0 +1,52 @@ +(defpackage #:mulk.protocols-examples + (:nicknames #:protocols-examples) + (:use #:cl #:protocols)) + + +(in-package #:mulk.protocols-examples) + + +(define-protocol printable () + ((print-object * stream))) + +(define-protocol serialisable () + ((serialise * stream))) + +(define-protocol additive () + ((add * *) + (negate *))) + +(define-protocol multiplicative () + ((multiply * *) + (invert *))) + +(define-protocol field (additive multiplicative) ()) + +(define-protocol serialisable-field (serialisable field) ()) + + +(defgeneric serialise (x stream)) +(defgeneric add (x y)) +(defgeneric negate (x)) +(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))) + +(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)) + +(implement-protocols a (printable)) + +(print (conforms-to-p 'a 'printable)) +(print (really-conforms-to-p 'a 'printable)) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..91369e0 --- /dev/null +++ b/package.lisp @@ -0,0 +1,9 @@ +(defpackage #:mulk.protocols + (:nicknames #:protocols) + (:use #:cl #:c2mop) + (:export #:define-protocol + #:implement-protocols + #:conforms-to-p + #:really-conforms-to-p + #:protocol-name + #:find-protocol)) diff --git a/protocols.asd b/protocols.asd new file mode 100644 index 0000000..0265721 --- /dev/null +++ b/protocols.asd @@ -0,0 +1,10 @@ +(defsystem "protocols" + :description "Protocol enforcement for CLOS classes." + :version "0.0.1" + :author "Matthias Benkard <matthias@benkard.de>" + :licence "GNU Lesser General Public License, version 3 or higher" + :depends-on (#:closer-mop) + :components + ((:file "package") + (:file "conditions" :depends-on ("package")) + (:file "protocols" :depends-on ("package")))) diff --git a/protocols.lisp b/protocols.lisp new file mode 100644 index 0000000..a5f2102 --- /dev/null +++ b/protocols.lisp @@ -0,0 +1,131 @@ +(in-package #:mulk.protocols) + + +(declaim (optimize debug safety (speed 0) (space 0))) + + +(defvar *protocols* (make-hash-table)) + + +(defun find-protocol (name &optional (errorp t)) + (let ((protocol (gethash name *protocols* nil))) + (when (and errorp (null protocol)) + (error "There is no protocol named ~A." name)) + protocol)) + + +(defun (setf find-protocol) (protocol name &optional errorp) + (declare (ignore errorp)) + (setf (gethash name *protocols*) protocol)) + + +(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)))) + (%conforms-to-p real-class real-protocol))) + + +(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)))) + (%really-conforms-to-p real-class real-protocol))) + + +(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) + + +(defclass protocol () + ((name :initarg :name + :reader protocol-name) + (superprotocols :initarg :superprotocols + :reader protocol-superprotocols) + (methods :initarg :methods + :reader protocol-methods) + (options :initarg :options + :reader protocol-options))) + + +(defmacro define-protocol (name superprotocols methods &rest options) + "Define a new protocol. + +superprotocols ::= (*name*\\*) + +methods ::= ((method-name [\\* | class-name]\\*)\\*)" + `(progn + (when (find-protocol ',name nil) + (warn (make-condition 'simple-style-warning + :format-control "Redefining protocol ~A." + :format-arguments (list ',name)))) + (setf (find-protocol ',name) + (make-instance 'protocol + :name ',name + :superprotocols (mapcar #'find-protocol ',superprotocols) + :methods ',methods + :options ',options)))) + + +(defmethod print-object ((protocol protocol) stream) + (print-unreadable-object (protocol stream) + (format stream "PROTOCOL ~A" (protocol-name protocol)))) + + +(defun ensure-conformance (class-name protocol-name) + (let ((protocol (find-protocol protocol-name))) + (with-slots (name superprotocols methods options) + protocol + (loop for method in methods + for (name . raw-argument-class-list) = method + for argument-class-list = (substitute class-name + '* + raw-argument-class-list) + for real-argument-class-list = (mapcar #'find-class + argument-class-list) + when (null (funcall #'compute-applicable-methods-using-classes + (fdefinition name) + real-argument-class-list)) + collect method into missing-methods + and do (warn (make-condition 'simple-style-warning + :format-control "Class ~A does not implement ~ + method ~A with argument types ~ + ~A as required by ~ + protocol ~A." + :format-arguments (list class-name + (first method) + real-argument-class-list + (protocol-name protocol)))) + finally (return (null missing-methods)))))) + + +(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))) + protocols))) |