--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; $Id$
+;;;
+;;; Useful bits of MOP hacking
+;;;
+;;; (c) 2006 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+;;;--------------------------------------------------------------------------
+;;; Packages.
+
+(defpackage #:mdw.mop
+ (:use #:common-lisp #+cmu #:pcl)
+ (:export #:compatible-class
+ #:initargs-for-effective-slot #:make-effective-slot
+ #:filtered-slot-class-mixin
+ #:filtered-direct-slot-definition
+ #:filtered-effective-slot-definition
+ #:abstract-class-mixin #:instantiate-abstract-class
+ #:mdw-class #:abstract-class
+ #:print-object-with-slots))
+
+(in-package #:mdw.mop)
+
+;;;--------------------------------------------------------------------------
+;;; Basic stuff.
+
+(defclass compatible-class (standard-class)
+ ()
+ (:documentation
+ "A class which can be be freely used in class heirarchies with
+ standard-class and other subclasses of compatible-class. This saves a
+ bunch of annoying messing about with `validate-superclass'."))
+
+(defmethod validate-superclass
+ ((sub compatible-class) (super compatible-class))
+ t)
+
+(defmethod validate-superclass
+ ((sub compatible-class) (super standard-class))
+ (eq (class-of super) (find-class 'standard-class)))
+
+(defmethod validate-superclass
+ ((sub standard-class) (super compatible-class))
+ (eq (class-of sub) (find-class 'standard-class)))
+
+;;;--------------------------------------------------------------------------
+;;; Utilities for messing with slot options.
+
+(defgeneric initargs-for-effective-slot (class direct-slots)
+ (:documentation
+ "Missing functionality from the MOP: given a class and its direct slots
+ definitions, construct and return the proposed initializer list for
+ constructing the effective-slot."))
+
+(defmethod initargs-for-effective-slot
+ ((class standard-class) direct-slots)
+ "Extract the effective slot options as required."
+ ;;
+ ;; This is taken from the Closette implementation, but it seems to work!
+ (let ((init-slot (find-if-not #'null direct-slots
+ :key #'slot-definition-initfunction)))
+ (list :name (slot-definition-name (car direct-slots))
+ :initform (and init-slot
+ (slot-definition-initform init-slot))
+ :initfunction (and init-slot
+ (slot-definition-initfunction init-slot))
+ :initargs (remove-duplicates
+ (apply #'append
+ (mapcar #'slot-definition-initargs
+ direct-slots)))
+ :allocation (slot-definition-allocation (car direct-slots)))))
+
+(defun make-effective-slot (class initargs)
+ "Construct an effectie slot definition for a slot on the class, given the
+ required arguments."
+ (apply #'make-instance
+ (apply #'effective-slot-definition-class class initargs)
+ initargs))
+
+(let ((stdslot (find-class 'standard-direct-slot-definition)))
+ (defmethod compute-effective-slot-definition
+ ((class compatible-class) slot-name direct-slots)
+ "Construct an effective slot definition for the given slot."
+ ;;
+ ;; Ideally we don't want to mess with a slot if it's entirely handled by
+ ;; the implementation. This check seems to work OK.
+ (if (every (lambda (slot)
+ (member (class-of slot)
+ (class-precedence-list stdslot)))
+ direct-slots)
+ (call-next-method)
+ (make-effective-slot class
+ (initargs-for-effective-slot class
+ direct-slots)))))
+
+;;;--------------------------------------------------------------------------
+;;; Filterered slots.
+
+(defclass filtered-slot-class-mixin (compatible-class)
+ ()
+ (:documentation
+ "A filtered slot interposes a filter on any attempt to write to the slot.
+ The filter is given the proposed new value, and should return the actual
+ new value. Specify the filter with a `:filter SYMBOL' slot option.
+ (Yes, I know that using functions would be nicer, but the MOP makes
+ that surprisingly difficult.)"))
+
+(defclass filtered-direct-slot-definition
+ (standard-direct-slot-definition)
+ ((filter :initarg :filter :reader slot-definition-filter)))
+
+(defgeneric slot-definition-filter (slot)
+ (:method ((slot slot-definition)) nil))
+
+(defclass filtered-effective-slot-definition
+ (standard-effective-slot-definition)
+ ((filter :initarg :filter :accessor slot-definition-filter)))
+
+(defmethod direct-slot-definition-class
+ ((class filtered-slot-class-mixin)
+ &key (filter nil filterp) &allow-other-keys)
+ (declare (ignore filter))
+ (if filterp
+ (find-class 'filtered-direct-slot-definition)
+ (call-next-method)))
+
+(defmethod effective-slot-definition-class
+ ((class filtered-slot-class-mixin)
+ &key (filter nil filterp) &allow-other-keys)
+ (declare (ignore filter))
+ (if filterp
+ (find-class 'filtered-effective-slot-definition)
+ (call-next-method)))
+
+(defmethod initialize-instance :after
+ ((slot filtered-direct-slot-definition) &key &allow-other-keys)
+ (with-slots (filter) slot
+ (when (and (consp filter)
+ (or (eq (car filter) 'function)
+ (eq (car filter) 'quote))
+ (symbolp (cadr filter))
+ (null (cddr filter)))
+ (setf filter (cadr filter)))))
+
+(defmethod initargs-for-effective-slot
+ ((class filtered-slot-class-mixin) direct-slots)
+ (let ((filter-slot (find-if #'slot-definition-filter direct-slots)))
+ (append (and filter-slot
+ (list :filter (slot-definition-filter filter-slot)))
+ (call-next-method))))
+
+(defmethod (setf slot-value-using-class)
+ (value
+ (class filtered-slot-class-mixin)
+ (object standard-object)
+ (slot filtered-effective-slot-definition))
+ (call-next-method (funcall (slot-definition-filter slot) object value)
+ class object slot))
+
+;;;--------------------------------------------------------------------------
+;;; Abstract classes.
+
+(defclass abstract-class-mixin (compatible-class)
+ ()
+ (:documentation
+ "Confusingly enough, a concrete metaclass for abstract classes. This
+ class has a `make-instance' implementation which signals an error."))
+
+(define-condition instantiate-abstract-class (error)
+ ((class :reader instantiate-abstract-class-class :initarg :class
+ :documentation "The class someone attempted to instantiate."))
+ (:report (lambda (cond stream)
+ (format stream "Cannot instantiate abstract class ~A."
+ (class-name (instantiate-abstract-class-class cond)))))
+ (:documentation
+ "Reports an attempt to instantiate an abstract class."))
+
+(defmethod make-instance ((class abstract-class-mixin) &rest whatever)
+ "Signals an error. The caller is a naughty boy."
+ (declare (ignore whatever))
+ (error 'instantiate-abstract-class :class class))
+
+;;;--------------------------------------------------------------------------
+;;; Useful classes.
+
+(defclass mdw-class (filtered-slot-class-mixin
+ compatible-class)
+ ())
+
+(defclass abstract-class (mdw-class abstract-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))
+ (magic (cons 'magic nil)))
+ (print-unreadable-object (obj stream)
+ (pprint-logical-block
+ (stream
+ (mapcan (lambda (slot)
+ (list (or (car (slot-definition-initargs slot))
+ (slot-definition-name slot))
+ (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))
+ (let ((sep nil))
+ (loop
+ (pprint-exit-if-list-exhausted)
+ (if sep
+ (format stream " ~_")
+ (progn (format stream " ~@_~:I") (setf sep t)))
+ (let ((name (pprint-pop))
+ (value (pprint-pop)))
+ (format stream "~S ~@_~:[~S~;<unbound>~*~]"
+ name (eq value magic) value))))))))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / commitdiff