X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/e5152ebe572654951e849ba89d2c8ba4d4223e80..813da880d2d77f04ea623f426d543d298528f967:/mdw-mop.lisp diff --git a/mdw-mop.lisp b/mdw-mop.lisp index 85e7885..01c829c 100644 --- a/mdw-mop.lisp +++ b/mdw-mop.lisp @@ -1,7 +1,5 @@ ;;; -*-lisp-*- ;;; -;;; $Id$ -;;; ;;; Useful bits of MOP hacking ;;; ;;; (c) 2006 Straylight/Edgeware @@ -13,12 +11,12 @@ ;;; 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. @@ -27,25 +25,17 @@ ;;; Packages. (defpackage #:mdw.mop - (: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 - #:singleton-class-mixin - #:mdw-class #:abstract-class #:singleton-class - #:print-object-with-slots)) + (:use #:common-lisp #:mdw.base + #+(or cmu clisp) #:mop + #+sbcl #:sb-mop + #+ecl #:clos)) (in-package #:mdw.mop) ;;;-------------------------------------------------------------------------- ;;; Copying instances. +(export 'copy-instance-using-class) (defgeneric copy-instance-using-class (class object &rest initargs) (:documentation "Does the donkey-work behind copy-instance.")) @@ -59,6 +49,7 @@ (apply #'shared-initialize new nil initargs) new)) +(export 'copy-instance) (defun copy-instance (object &rest initargs) "Make a copy of OBJECT, modifying it by setting slots as requested by INITARGS." @@ -67,6 +58,7 @@ ;;;-------------------------------------------------------------------------- ;;; Handy macros. +(export 'with-slot-variables) (defmacro with-slot-variables (slots instance &body body) "A copy-out-and-write-back variant of with-slots. @@ -106,10 +98,7 @@ (listify slots) (mapcar #'slot-definition-name (class-slots class)))))) - (multiple-value-bind - (docs decls body) - (parse-body body :allow-docstring-p nil) - (declare (ignore docs)) + (with-parsed-body (body decls) body (with-gensyms (instvar) `(let ((,instvar ,instance)) ,@(and class `((declare (type ,(class-name class) ,instvar)))) @@ -139,6 +128,7 @@ ;;;-------------------------------------------------------------------------- ;;; Basic stuff. +(export 'compatible-class) (defclass compatible-class (standard-class) () (:documentation @@ -161,6 +151,7 @@ ;;;-------------------------------------------------------------------------- ;;; Utilities for messing with slot options. +(export 'initargs-for-effective-slot) (defgeneric initargs-for-effective-slot (class direct-slots) (:documentation "Missing functionality from the MOP: given a class and its direct slots @@ -185,8 +176,9 @@ direct-slots))) :allocation (slot-definition-allocation (car direct-slots))))) +(export 'make-effective-slot) (defun make-effective-slot (class initargs) - "Construct an effectie slot definition for a slot on the class, given the + "Construct an effective slot definition for a slot on the class, given the required arguments." (apply #'make-instance (apply #'effective-slot-definition-class class initargs) @@ -212,6 +204,7 @@ ;;;-------------------------------------------------------------------------- ;;; Filterered slots. +(export 'filtered-slot-class-mixin) (defclass filtered-slot-class-mixin (compatible-class) () (:documentation @@ -221,13 +214,15 @@ (Yes, I know that using functions would be nicer, but the MOP makes that surprisingly difficult.)")) +(defgeneric slot-definition-filter (slot) + (:method ((slot slot-definition)) nil)) + +(export 'filtered-direct-slot-definition) (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)) - +(export 'filtered-effective-slot-definition) (defclass filtered-effective-slot-definition (standard-effective-slot-definition) ((filter :initarg :filter :accessor slot-definition-filter))) @@ -276,6 +271,7 @@ ;;;-------------------------------------------------------------------------- ;;; Predicates. +(export 'predicate-class-mixin) (defclass predicate-class-mixin (compatible-class) ((predicates :type list :initarg :predicate :initform nil :documentation "Predicate generic function to create.")) @@ -310,12 +306,14 @@ ;;;-------------------------------------------------------------------------- ;;; Abstract classes. +(export 'abstract-class-mixin) (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.")) +(export '(instantiate-abstract-class instantiate-abstract-class-class)) (define-condition instantiate-abstract-class (error) ((class :reader instantiate-abstract-class-class :initarg :class :documentation "The class someone attempted to instantiate.")) @@ -333,6 +331,7 @@ ;;;-------------------------------------------------------------------------- ;;; Singleton classes. +(export 'singleton-class-mixin) (defclass singleton-class-mixin (compatible-class) ((instance :initform nil :type (or null standard-object))) (:documentation @@ -349,6 +348,7 @@ ;;;-------------------------------------------------------------------------- ;;; Useful classes. +(export 'mdw-class) (defclass mdw-class (filtered-slot-class-mixin predicate-class-mixin compatible-class) @@ -359,36 +359,40 @@ metaclass for all your classes if you don't use any of its fancy features.")) +(export 'abstract-class) (defclass abstract-class (mdw-class abstract-class-mixin) ()) + +(export 'singleton-class) (defclass singleton-class (mdw-class singleton-class-mixin) ()) ;;;-------------------------------------------------------------------------- ;;; Printing things. +(export 'print-object-with-slots) (defun print-object-with-slots (obj stream) "Prints objects in a pleasant way. Not too clever about circularity." (let ((class (class-of obj)) - (magic (cons 'magic nil))) + (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))) - (class-slots class))) - (format stream "~S" (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 ~@_~:[~W~;#~*~]" - name (eq value magic) value)))))))) + (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))) + (class-slots class))) + (format stream "~S" (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 ~@_~:[~W~;#~*~]" + name (eq value magic) value)))))))) ;;;----- That's all, folks --------------------------------------------------