From 9b2e67a5b9f0d9e1e5eba1f57f3a94c1863e368a Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Sun, 30 Apr 2006 03:48:20 +0100
Subject: [PATCH] mop: Implement a class which automatically defines a
 predicate.

I've found myself typing

  (defgeneric foop (thing)
    (:method (((thing foo)) t))
    (:method (((thing t)) nil)))

too many times.  Now I just put `(:predicate foop)' in the class
definition and forget about it.
---
 mdw-mop.lisp | 43 ++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 42 insertions(+), 1 deletion(-)

diff --git a/mdw-mop.lisp b/mdw-mop.lisp
index dee8ca4..0766e38 100644
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -33,6 +33,7 @@
 	   #:filtered-slot-class-mixin
 	     #:filtered-direct-slot-definition
 	     #:filtered-effective-slot-definition
+	   #:predicate-class-mixin
 	   #:abstract-class-mixin #:instantiate-abstract-class
 	   #:mdw-class #:abstract-class
 	   #:print-object-with-slots))
@@ -176,6 +177,40 @@
 		    class object slot))
 
 ;;;--------------------------------------------------------------------------
+;;; Predicates.
+
+(defclass predicate-class-mixin (compatible-class)
+  ((predicates :type list :initarg :predicate :initform nil
+	       :documentation "Predicate generic function to create."))
+  (:documentation
+   "Class which can automatically generate a predicate generic function.
+    Adds the `:predicate' class option, which takes a single symbol argument
+    FUNC.  If specified, and non-nil, a generic function FUNC with one
+    argument will be defined (if it doesn't already exist) with a default
+    method returning nil, and a method added specialized on this class
+    returning a non-nil value."))
+
+(defmethod shared-initialize :after
+    ((class predicate-class-mixin) slot-names &key &allow-other-keys)
+  (declare (ignore slot-names))
+  (with-slots (predicates) class
+    (dolist (predicate predicates)
+      (let ((lambda-list '(thing)))
+	(let ((gf (if (fboundp predicate)
+		      (fdefinition predicate)
+		      (let ((gf (ensure-generic-function
+				 predicate :lambda-list lambda-list)))
+			(add-method gf (make-instance
+					'standard-method
+					:specializers (list (find-class 't))
+					:lambda-list lambda-list
+					:function (constantly nil)))))))
+	  (add-method gf (make-instance 'standard-method
+					:specializers (list class)
+					:lambda-list lambda-list
+					:function (constantly t))))))))
+
+;;;--------------------------------------------------------------------------
 ;;; Abstract classes.
 
 (defclass abstract-class-mixin (compatible-class)
@@ -202,8 +237,14 @@
 ;;; Useful classes.
 
 (defclass mdw-class (filtered-slot-class-mixin
+		     predicate-class-mixin
 		     compatible-class)
-  ())
+  ()
+  (:documentation
+   "A generally useful metaclass with handy features.  If I've done the
+    hacking right, there shouldn't be a significant cost to using this
+    metaclass for all your classes if you don't use any of its fancy
+    features."))
 
 (defclass abstract-class (mdw-class abstract-class-mixin) ())
 
-- 
2.11.0