mop: Rearrange a bit.

[lisp] / mdw-mop.lisp

diff --git a/mdw-mop.lisp b/mdw-mop.lisp
index dee8ca45b65f7c5f72099adf20fee756d640252d..160eff976613189c6701f24bd1fed68c41041971 100644 (file)
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -27,18 +27,42 @@
 ;;; Packages.
 
 (defpackage #:mdw.mop
 ;;; Packages.
 
 (defpackage #:mdw.mop

-  (:use #:common-lisp #+cmu #:pcl)
-  (:export #:compatible-class
+  (:use #:common-lisp #:mdw.base #+cmu #:mop)
+  (:export #:copy-instance #:copy-instance-using-class
+          #:compatible-class

           #:initargs-for-effective-slot #:make-effective-slot
           #:filtered-slot-class-mixin
             #:filtered-direct-slot-definition
             #:filtered-effective-slot-definition
           #: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
           #: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)
 
           #: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))
+

 ;;;--------------------------------------------------------------------------
 ;;; Basic stuff.
 
 ;;;--------------------------------------------------------------------------
 ;;; Basic stuff.
 


@@ -151,7 +175,7 @@ (defmethod effective-slot-definition-class
       (call-next-method)))
 
 (defmethod initialize-instance :after
       (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)
   (with-slots (filter) slot
     (when (and (consp filter)
               (or (eq (car filter) 'function)


@@ -175,6 +199,40 @@ (defmethod (setf slot-value-using-class)
   (call-next-method (funcall (slot-definition-filter slot) value)
                    class object slot))
 
   (call-next-method (funcall (slot-definition-filter slot) value)
                    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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Abstract classes.
 


@@ -198,14 +256,37 @@ (defmethod make-instance ((class abstract-class-mixin) &rest whatever)
   (declare (ignore whatever))
   (error 'instantiate-abstract-class :class class))
 
   (declare (ignore whatever))
   (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
 ;;;--------------------------------------------------------------------------
 ;;; Useful classes.
 
 (defclass mdw-class (filtered-slot-class-mixin

+                    predicate-class-mixin

                     compatible-class)
                     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 abstract-class (mdw-class abstract-class-mixin) ())

+(defclass singleton-class (mdw-class singleton-class-mixin) ())

 
 ;;;--------------------------------------------------------------------------
 ;;; Printing things.
 
 ;;;--------------------------------------------------------------------------
 ;;; Printing things.


@@ -233,7 +314,7 @@ (defun print-object-with-slots (obj stream)
                 (progn (format stream " ~@_~:I") (setf sep t)))
             (let ((name (pprint-pop))
                   (value (pprint-pop)))
                 (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 --------------------------------------------------
                       name (eq value magic) value))))))))
 
 ;;;----- That's all, folks --------------------------------------------------