X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/25760fe1230ce92a676207997419755cf03de420..67b41ed338b6050f40bf9de24804502e96f84104:/mdw-mop.lisp

diff --git a/mdw-mop.lisp b/mdw-mop.lisp
index dee8ca4..d578f51 100644
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -27,19 +27,113 @@
 ;;; Packages.
 
 (defpackage #:mdw.mop
-  (:use #:common-lisp #+cmu #:pcl)
-  (:export #:compatible-class
+  (:use #:common-lisp #:mdw.base #+(or cmu clisp) #:mop #+ecl #:clos)
+  (:export #:copy-instance #:copy-instance-using-class
+	   #:with-slot-variables
+	   #:compatible-class
 	   #:initargs-for-effective-slot #:make-effective-slot
 	   #: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
+	   #:singleton-class-mixin
+	   #:mdw-class #:abstract-class #:singleton-class
 	   #:print-object-with-slots))
 
 (in-package #:mdw.mop)
 
 ;;;--------------------------------------------------------------------------
+;;; Copying instances.
+
+(defgeneric copy-instance-using-class (class object &rest initargs)
+  (:documentation
+   "Does the donkey-work behind copy-instance."))
+
+(defmethod copy-instance-using-class
+    ((class standard-class) object &rest initargs)
+  (let ((new (apply #'allocate-instance class initargs)))
+    (dolist (slot (class-slots class))
+      (setf (slot-value-using-class class new slot)
+	    (slot-value-using-class class object slot)))
+    (apply #'shared-initialize new nil initargs)
+    new))
+
+(defun copy-instance (object &rest initargs)
+  "Make a copy of OBJECT, modifying it by setting slots as requested by
+   INITARGS."
+  (apply #'copy-instance-using-class (class-of object) object initargs))
+
+;;;--------------------------------------------------------------------------
+;;; Handy macros.
+
+(defmacro with-slot-variables (slots instance &body body)
+  "A copy-out-and-write-back variant of with-slots.
+
+   The SLOTS argument is a list of slot specifications, each of which has the
+   form (NAME &key :update :variable).  VARIABLE defaults to NAME, and
+   :update defaults to nil.
+
+   The INSTANCE argument has the form (INSTANCE &key :class), but an atom may
+   be used in place of a singleton list.  If the CLASS is specified, then two
+   good things happen: firstly the INSTANCE is declared to be a member of the
+   CLASS, and secondly all the slot variables are declared to have the
+   appropriate types, as dredged up from the class's effective slot
+   definitions.
+
+   The effect of all this is to return the result of evaluating BODY in an
+   environment where the VARIABLEs are bound to the values of the NAMEd slots
+   of the given INSTANCE.  If BODY completes successfully (rather than
+   throwing out, restarting, or anything like that) then the final values of
+   VARIABLEs for which UPDATE was set non-nil are written back to their
+   corresponding slots.
+
+   This stands a good chance of being rather faster than with-slots.  It
+   does, however, run the risk of leaving things in an inconsistent state if
+   BODY escapes half-way through.  Also, this requires recompilation if a
+   class's slots change type."
+  (multiple-value-bind (instance class)
+      (destructuring-bind
+	  (instance &key class)
+	  (listify instance)
+	(values instance (and class (find-class class))))
+    (let ((slots (mapcar (lambda (slot)
+			   (destructuring-bind
+			       (name &key update (variable name))
+			       (listify slot)
+			     (list name variable update)))
+			 (if slots
+			     (listify slots)
+			     (mapcar #'slot-definition-name
+				     (class-slots class))))))
+      (with-parsed-body (body decls) body
+	(with-gensyms (instvar)
+	  `(let ((,instvar ,instance))
+	     ,@(and class `((declare (type ,(class-name class) ,instvar))))
+	     (let ,(loop for (name var update) in slots
+			 collect `(,var (slot-value ,instvar ',name)))
+	       ,@(and class
+		      `((declare
+			 ,@(loop
+			    for (name var update) in slots
+			    for slot = (or (find name
+						 (class-slots class)
+						 :key #'slot-definition-name)
+					   (error
+					    "Slot ~S not found in class ~S."
+					    name (class-name class)))
+			    collect `(type
+				      ,(slot-definition-type slot)
+				      ,name)))))
+	       ,@decls
+	       (multiple-value-prog1
+		   (progn ,@body)
+		 ,@(loop for (name var update) in slots
+			 when update
+			 collect `(setf (slot-value ,instvar ',name)
+				   ,var))))))))))
+
+;;;--------------------------------------------------------------------------
 ;;; Basic stuff.
 
 (defclass compatible-class (standard-class)
@@ -99,6 +193,7 @@
   (defmethod compute-effective-slot-definition
       ((class compatible-class) slot-name direct-slots)
     "Construct an effective slot definition for the given slot."
+    (declare (ignore slot-name))
     ;;
     ;; Ideally we don't want to mess with a slot if it's entirely handled by
     ;; the implementation.  This check seems to work OK.
@@ -151,7 +246,7 @@
       (call-next-method)))
 
 (defmethod initialize-instance :after
-    ((slot filtered-direct-slot-definition) &key &allow-other-keys)
+    ((slot filtered-direct-slot-definition) &key)
   (with-slots (filter) slot
     (when (and (consp filter)
 	       (or (eq (car filter) 'function)
@@ -176,6 +271,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)
+  (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)
@@ -199,20 +328,43 @@
   (error 'instantiate-abstract-class :class class))
 
 ;;;--------------------------------------------------------------------------
+;;; Singleton classes.
+
+(defclass singleton-class-mixin (compatible-class)
+  ((instance :initform nil :type (or null standard-object)))
+  (:documentation
+   "A class which has only one instance.  All calls to `make-instance' return
+    the same object."))
+
+(defmethod allocate-instance ((class singleton-class-mixin) &key)
+  "If the class already has an instance, return it; otherwise allocate one,
+   store it away, and return that."
+  (with-slots (instance) class
+    (or instance
+	(setf instance (call-next-method)))))
+
+;;;--------------------------------------------------------------------------
 ;;; 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) ())
+(defclass singleton-class (mdw-class singleton-class-mixin) ())
 
 ;;;--------------------------------------------------------------------------
 ;;; Printing things.
 
 (defun print-object-with-slots (obj stream)
   "Prints objects in a pleasant way.  Not too clever about circularity."
-  (let ((class (pcl:class-of obj))
+  (let ((class (class-of obj))
         (magic (cons 'magic nil)))
     (print-unreadable-object (obj stream)
       (pprint-logical-block
@@ -223,8 +375,8 @@
                            (if (slot-boundp-using-class class obj slot)
                                (slot-value-using-class class obj slot)
                                magic)))
-                   (pcl:class-slots class)))
-        (format stream "~S" (pcl:class-name class))
+                   (class-slots class)))
+        (format stream "~S" (class-name class))
         (let ((sep nil))
           (loop
             (pprint-exit-if-list-exhausted)
@@ -233,7 +385,7 @@
                 (progn (format stream " ~@_~:I") (setf sep t)))
             (let ((name (pprint-pop))
                   (value (pprint-pop)))
-              (format stream "~S ~@_~:[~S~;<unbound>~*~]"
+              (format stream "~S ~@_~:[~W~;#<unbound>~*~]"
                       name (eq value magic) value))))))))
 
 ;;;----- That's all, folks --------------------------------------------------