;;; 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 #:mdw.base #+cmu #: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
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))))))
+ (with-parsed-body (body decls) body
+ (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.
(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.
(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
(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)
~mdw / lisp / blobdiff