From e96e008d5962bdbf73e16350a3880983857e87a4 Mon Sep 17 00:00:00 2001 Message-Id: From: Mark Wooding Date: Thu, 27 Apr 2006 10:25:55 +0100 Subject: [PATCH] Add some MOP hacking. Organization: Straylight/Edgeware From: Mark Wooding * Abstract classes. * Filtered slots -- i.e., all slot writes can be passed through a canonifying filter. --- mdw-mop.lisp | 239 +++++++++++++++++++++++++++++++++++++++++++++++++++ mdw.asd | 1 + 2 files changed, 240 insertions(+) create mode 100644 mdw-mop.lisp diff --git a/mdw-mop.lisp b/mdw-mop.lisp new file mode 100644 index 0000000..e8946e8 --- /dev/null +++ b/mdw-mop.lisp @@ -0,0 +1,239 @@ +;;; -*-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~;~*~]" + name (eq value magic) value)))))))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/mdw.asd b/mdw.asd index 3ad147d..bd252ec 100644 --- a/mdw.asd +++ b/mdw.asd @@ -9,6 +9,7 @@ (:file "anaphora") (:file "sys-base") (:file "factorial") + (:file "mdw-mop") (:file "str") (:file "collect") (:file "unix") -- [mdw]