well, I think this pretty much works. It's not complete, but appears
not to fail to badly, and handles much (but not all) conceivably
circularities. as an exercise for the student, which ones are not
handled?
this was debugged under Franz Allegro CL on a Sparc 2. not fully
tested.
-- clint
;;; -*- mode: common-lisp; package: cl-user; base:10. -*-
;;;****************************************************************
;;;****************************************************************
;;;how to copy a nested CLOS structure. could be prettier.
;;;****************************************************************
;;;****************************************************************
;;;Scott McKay's original version, with some slight tuneup.
;(defun copy-instance (instance)
; (let* ((class (class-of instance))
; (copy (clos::allocate-instance class))
; name
; allocation)
; (dolist (slot (clos:class-slots class))
; (setq name (clos:slot-definition-name slot)
; allocation (clos:slot-definition-allocation slot))
; (when (and (eql allocation :instance)
; (slot-boundp instance name))
; (setf (slot-value copy name) (slot-value instance name))))
; copy))
;;;****************************************************************
;;;****************************************************************
;;;HACK ALERT !! this is a bit of grossness which I came up with to eliminate 'circular' structure-references.
;;;I hate doing things like this. it's not really finished correctly.
;;;one can imagine other cases of nesting in which this fails...I could keep pointers to everything, I guess.
;;;****************************************************************
;;;****************************************************************
;;;this is an A-list of the conses (original-obj new-obj). the original obj doesn't change, of course.
;;;the new obj is born empty. the slots are filled in later. this means that any special init behavior
;;;which creates circularity won't necessarily work. by making an alist, I record all objs which have
;;;been copied so far and tie them to their clones. then, when another pointer to the old obj occurs,
;;;I can easily get the pointer to the clone. this feels like a garbage-collector behavior.
(defvar *copied-instances*)
;;;****************************************************************
;;;****************************************************************
(defmacro with-copy-reset (&body body)
`(progn (setq *copied-instances* ()) ;be dead certain that we aren't retaining any old junk.
,@body
(setq *copied-instances* ()))) ;clear it again to avoid confusion.
;;;****************************************************************
;;;****************************************************************
(defmethod copy-instance ((instance t))
;;first, make sure we have an actual class
(typecase (class-of instance)
(clos::standard-class) ;all is OK, just fall through.
(clos::structure-class ;handle DEFSTRUCT instances specially.
;doesn't handle circularity right yet.
(let ((obj (clos::allocate-instance (class-of instance))))
(dolist (slot (slot-value (class-of instance) 'clos::direct-slots))
(setf (slot-value obj (slot-value slot 'clos::name))
(copy-instance (slot-value instance (slot-value slot 'clos::name))))
)
obj))
(otherwise ;if we don't, just return our self.
(return-from copy-instance instance)))
;;now, be sure we haven't already started on this object.
(if (setq temp (assoc instance *copied-instances*))
;;return the copy. this will be OK even if it's unfinished as yet. I think.
(return-from copy-instance (cdr temp)))
;;now work on copying the thing.
(let* ((class (class-of instance))
(copy (clos::allocate-instance class))
name
allocation)
;;now record that we are working on this class instance.
(setq *copied-instances* (acons instance copy))
(dolist (slot (clos:class-slots class))
(setq name (clos:slot-definition-name slot)
allocation (clos:slot-definition-allocation slot))
(when (and (eql allocation :instance)
(slot-boundp instance name))
(setf (slot-value copy name)
(copy-instance (slot-value instance name))) ;recurse on nested structures.
))
copy) ;return the newly created thing.
)
;;;****************************************************************
;;;on the off chance it's (a . b)
(defmethod copy-instance ((myself cons))
(cons (copy-instance (car myself))
(copy-instance (cdr myself))))
;;;****************************************************************
;;;just do a simple list. this fails for something circular, or for a dotted pair.
(defmethod copy-instance ((myself list))
(mapcar #'copy-instance myself))
;;;****************************************************************
;;;****************************************************************
;;;some basic things, to be sure that all are covered properly. this too is incomplete.
;;;****************************************************************
(defmethod copy-instance ((myself number))
myself
)
;;;****************************************************************
(defmethod copy-instance ((myself symbol))
myself
)
;;;****************************************************************
(defmethod copy-instance ((myself string))
(copy-seq myself)
)
;;;****************************************************************
;;;****************************************************************
;;;****************************************************************
;;;
;;; end of file
;;;
;;;****************************************************************
;;;****************************************************************
;;;****************************************************************
--
Clint Hyde "Give me a LispM or give me death!" -- anonymous
Advanced Decision Systems Internet: ·····@chesapeake.ads.com
2111 Wilson Blvd #800
Arlington, VA 22201 (703) 875-0327
golly. there's a bug in there having to do with ACONS. your compiler
or interpreter will tell you about it right away. just put
*copied-instances* in as the third arg.
-- clint
--
Clint Hyde "Give me a LispM or give me death!" -- anonymous
Advanced Decision Systems Internet: ·····@chesapeake.ads.com
2111 Wilson Blvd #800
Arlington, VA 22201 (703) 875-0327