Path: utzoo!utgpu!news-server.csri.toronto.edu!cs.utexas.edu!usc!wuarchive!uunet!tut.cis.ohio-state.edu!BBN.COM!kanderso
From: kanderso@BBN.COM
Newsgroups: comp.lang.clos
Subject: Re: accessing clos objects
Message-ID: <9102121807.AA16036@cheops.cis.ohio-state.edu>
Date: 12 Feb 91 17:52:53 GMT
References: <9102121706.AA06034@mingus.mitre.org>
Sender: welch@tut.cis.ohio-state.edu
Distribution: inet
Organization: CommonLoops
Lines: 120


  It's not clear how one would do this with :BEFORE and/or :AFTER
  methods.  An ordinary method specialized on the class in question
  would never get called, since MAKE-INSTANCE gets called on symbols and
  classes.  So, presumably the idea is to define a method on
  MAKE-INSTANCE that is EQL specialized to the class itself, or the name
  of the class.  But a :BEFORE or :AFTER method isn't going to be able
  to get access to the new instance, only to the class.  One would have
  to use, for instance, an :AROUND or a primary method and use
  CALL-NEXT-METHOD.  Thus:

    (DEFCLASS FLINTSTONE ()
        ((INSTANCES :ALLOCATION :CLASS
                    :INITFORM '()
                    :ACCESSOR FLINTSTONE-INSTANCES)
         (NAME :ACCESSOR FLINTSTONE-NAME)))

    (DEFMETHOD MAKE-INSTANCE ((F-CLASS (EQL (FIND-CLASS 'FLINTSTONE)))
                              &REST INITARGS)
      (LET ((NEW-FLINTSTONE (CALL-NEXT-METHOD)))
        (PUSH NEW-FLINTSTONE (FLINTSTONE-INSTANCES NEW-FLINTSTONE))
        NEW-FLINTSTONE))

  In general, I believe that EQL methods are fairly lousy with respect
  to performance.  Alternatively, on ecould define the recording
  behavior on SHARED-INITIALIZE, or something like that.  Defining a new
  metaclass is probably a better solution, certainly aesthetically
  speaking, although it makes it a little trickier to have the above
  behavior be inherited.

Here's an example of doing it each way.  It once ran in PCL.

;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-

(defclass named-mixin
	  ()
     ((name :initarg :name :initform NIL :reader name)))

(defmethod print-object ((thing named-mixin) stream)
  (printing-random-thing (thing stream)
   (format stream "~a ~a" (class-name (class-of thing)) (name thing))))


(defclass compatible-class-mixin
    ()
  ()
  (:documentation
   "A metaclass mixin that provides compatibility with standard-class."))

(defmethod check-super-metaclass-compatibility
	   ((class compatible-class-mixin) (super standard-class))
  t)

(defmethod describe ((thing compatible-class-mixin) &rest args)
  (apply 'describe-instance thing args))


(defclass instances-class-mixin
	  ()
     ((instances :initform () :accessor class-instances))
  (:documentation
    "Lets a class record its instances."))

(defmethod make-instance ((class instances-class-mixin) &rest initargs)
  (declare (ignore initargs))
  (let ((instance (call-next-method)))
    (add-instance class instance)
    instance))

(defmethod add-instance ((class instances-class-mixin) instance)
  (pushnew instance (class-instances class)))

(defmethod remove-instance ((class instances-class-mixin) instance)
  (setf (class-instances class)
	(delete instance (class-instances class) :test #'eq)))


;;; This version uses :class allocated slots, so each instance knows
;;; who its siblings are but the class doesn't know who its instances
;;; are.

(defclass i-mixin
	  ()
     ((instances :initform () :accessor instances :allocation :class)))

(defmethod *initialize-instance :before ((object i-mixin) &rest initargs)
	   (pushnew object (instances object)))

(defclass foo-x
	  (i-mixin)
     ((x)
      (y)))

(defclass foo-y
	  (i-mixin)
     ((z)
      (y)))

#||
;;; Example.
(defclass instance-recording-class
	  (instances-class-mixin
	    compatible-class-mixin
	    standard-class)
     ())

(defclass ifrob ()
     ((x :initarg x :accessor x)
      (y :initarg y :accessor y))
  (:metaclass instance-recording-class))

(defclass jfrob (ifrob)
     ((z :initarg x :accessor z))
  (:metaclass instance-recording-class))

(setq x (make-instance 'ifrob))
(setq y (make-instance 'jfrob))
(class-instances (find-class 'ifrob))

||#