From: Mark Wooding Date: Wed, 24 May 2006 08:12:14 +0000 (+0100) Subject: Merge branch 'master' of /home/mdw/public-git/lisp X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/commitdiff_plain/84f4b59f93535e938e21a083e05a49a1f20f9c26?hp=-c Merge branch 'master' of /home/mdw/public-git/lisp * 'master' of /home/mdw/public-git/lisp: optparse: Process docstring and declarations correctly in defopthandler. gitignore: Ignore CLisp FASL files. Various: Try porting the code to CLisp. Conflicts: mdw-mop.lisp: Trivial conflict in the defpackage stanza. --- 84f4b59f93535e938e21a083e05a49a1f20f9c26 diff --combined mdw-mop.lisp index e7ea27c,f274dcb..ff43c11 --- a/mdw-mop.lisp +++ b/mdw-mop.lisp @@@ -27,10 -27,9 +27,10 @@@ ;;; Packages. (defpackage #:mdw.mop - (:use #:common-lisp #:mdw.base #+cmu #:mop) + (:use #:common-lisp #:mdw.base #+(or cmu clisp) #:mop) - (:export #:compatible-class - #:copy-instance #:copy-instance-using-class + (: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 @@@ -44,99 -43,6 +44,99 @@@ (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)))))) + (multiple-value-bind + (docs decls body) + (parse-body body :allow-docstring-p nil) + (declare (ignore docs)) + (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) @@@ -159,6 -65,27 +159,6 @@@ (eq (class-of sub) (find-class 'standard-class))) ;;;-------------------------------------------------------------------------- -;;; 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)) - -;;;-------------------------------------------------------------------------- ;;; Utilities for messing with slot options. (defgeneric initargs-for-effective-slot (class direct-slots) @@@ -196,6 -123,7 +196,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. @@@ -366,7 -294,7 +367,7 @@@ (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 @@@ -377,8 -305,8 +378,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)