Path: utzoo!utgpu!news-server.csri.toronto.edu!cs.utexas.edu!uunet!tut.cis.ohio-state.edu!ZAPHOD.LANL.GOV!egdorf
From: egdorf@ZAPHOD.LANL.GOV (Skip Egdorf)
Newsgroups: comp.lang.clos
Subject: (long) RE: accessing clos objects
Message-ID: <9102132350.AA04207@zaphod.lanl.gov.lanl.gov>
Date: 13 Feb 91 23:50:37 GMT
Sender: welch@tut.cis.ohio-state.edu
Distribution: inet
Organization: CommonLoops
Lines: 325


Sorry for the rather long post, but I had some requests, both for
the code, and also about both my implementation of "all-instances-of-a-class"
and the notion of "instances-have-names" and why the two ideas seem
somehow related.

The short answer is "I don't know, but they seem to be either both
there or not both there in the systems with which I play."
You can stop reading if you don't want the long answer.

I mentioned in an earlier posting that I had implemented this beast
and am using it in some projects. I have had a couple of requests
to show the code, primarily due to the fact that many of the ideas
being discussed on this thread now were tossed around here internally
when I was initially building this. I don't want to imply that this
is the "right" result, (in fact I will welcome any comments on the
warts in the code I am about to present... being code that is in-use,
there are certainly a few...) rather that this is one implementation
of named objects that has been (at least) used for several months
in "real" projects and that provides the ability to access the instances of
a class.

The problem with the "metaclass vs. mixin" argument is that there are
actually three disjoint issues involved, one addressed by a mixin/subclass,
and two addressed by a metaclass.

1. An object has a name as an attribute. My name is "Skip Egdorf" and
   that is an attribute of me. Any such named object should have an
   accessor of some sort that allows access to this attribute.
   Note that it is NOT an attribute of me that I know all my co-workers,
   or the other members of whatever class I may be in at the moment.

This argues for a mixin or subclass of some sort that recognizes the
fact that my name is an attribute of me. The note is there to point out
that an :Allocation :Class  slot giving all instances is probably NOT the
best way to go.

2. One point of naming an object is so that something can say "Where is
   Skip Egdorf?" when the actual object is desired. The Los Alamos
   telephone directory is an example.
   The real question is "How does one find the directory?"
   I contend that I may be in several directories (e.g. the Los Alamos
   Telephone directory, and the ACM membership directory) and that the
   directory that I am in at the moment is an attribute of my class rather
   than just of me.

This implies some global name space of instances relative to some classes.
The :Allocation :Class slot that contains the table of all names should
thus be in the metaclass object, not the class object. (I actually waffle
in the code below, and use a single global name table...)

3. The reverse of the global name table of (2.) is a request to some group
   to find a name given an object.

This argues that the set of all instances of a class is an attribute of the
class, and is thus a metaclass issue. I believe that this was the arena of
the original question in this thread.

I have actually heard (and made) some good arguments that this should be
implemented as an inverted lookup on the metaclass table in (2.) However,
the pragmatic implementation of this has been found (for this project, anyway)
to be that a class maintains a list of its instances, and a graph-search of
the class-direct-subclass graph is used to find all such related instances.

was the set of all instances of a class (item 3.) The named-instances issue was
then seen to be (while needed for various reasons for this project) both
independent of the list-of-all-instances, and almost free once the list-of-all
instances was in place. (This is why I tied them together in my earlier posting.)
The main tie-together comes in the class-direct-instance-map slot that contains
name-instance pairs rather than just instances. The only reason for this is
that it is easier to search the list of instances in the class of an object
than it is to search a hash table of all instances in order to implement
(instance-name object)

Usually, I find that I make all classes use named instances. I have found
that once some instances are named, the users will soon come up with some reason
for talking about some other class's instances by name. My general rule now
is that if I design a system without named instances (and therefore some other
mechanism for keeping track of the instances) then no one misses the names.
If, however, I introduce the idea of calling instances by name, then this
is the common mechanism expected.

The one thing that I don't understand is that it seems only to be in those
systems where I have introduced named instances that I seem to need to
examine the instances of a class and vice versa. I don't understand what quirk
of my design personality leads to this. The two notions should be relatively
independent.

The code below implements one global name space for instances. This is needed
only to allow (find-instance 'foo) where foo might be an instance of any group.
In general, I don't think that this is really reasonable. e.g. My workstation
is named "zaphod" and the President of the Universe in "The Hitchikers Guide to
the Galaxy" is named "zaphod". Both instances might exist in the same system.
The use of a single name space for any and all instances it is an artifact
of the current project, and a mild desire to have a set of routines analogous
to the class naming facilities of CLOS (where classes form a single name-space
(relative to packages, naturally)).

The main routines and the related class name routines are

(class-direct-subclasses class)		(class-direct-instances class)
(class-name class)			(instance-name instance)
(setf (class-name class) name)		(setf (instance-name instance) name)
(find-class name)			(find-instance name)

Below is the code, followed by a transcript of example usage.
Feel free to pass it on as desired.
Also, feel free to return comments and criticisms to me.
---------------------------------------
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright, 1991. The Regents of the University of California.
;;; This software was produced under a U. S. Government contract
;;; (W-7405-ENG-36) by Los Alamos National Laboratory, which is
;;; operated by the University of California for the U. S. Department
;;; of Energy.  The U. S. Government is licensed to use, reproduce,
;;; and distribute this software. Permission is granted to the
;;; public to copy and use this software without charge, provided
;;; that this Notice and any statement of authorship are reproduced
;;; on all copies.  Neither the Government nor the University makes
;;; any warranty, express or implied, or assumes any liability or
;;; responsibility for the use of this software.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package 'user)

;;;
;;; This metaclass is a subclass of standard-class rather than a mixin.
;;;

(defclass named-object-metaclass (standard-class)
  ((class-direct-instance-map
    :documentation "The table of (name instance) pairs."
    :accessor class-direct-instance-map
    :initform ())
   )
  (:documentation "The metaclass that provides named instances.")
  )

;;;
;;; The thing that will usually be desired by a client is just the list of
;;; instances rather than the name-instance table.
;;; The name is an analog to (class-direct-subclasses ...)
;;;

(defgeneric class-direct-instances (self)
  (:documentation "Give a list of all instances of just this class."))

(defmethod class-direct-instances ((self named-object-metaclass))
  "Return a list of all named instances of this class"
  (mapcar #'cdr (class-direct-instance-map self)))

;;;
;;; At the same time, it is nice to have a single name space for instances.
;;;

(defvar *instance-name-table*)

(setf *instance-name-table* (make-hash-table))

;;;
;;; (instance-name object) is an analog to (class-name class)
;;; The stuff needed for defsetf could be done in a more up-to-date way, except
;;; that this must run in a couple of older, more constrained Lisps for a while.
;;; Note that this silently replaces an existing mapping with new information.
;;; In an industrial strength version, this should be an error. This "feature"
;;; is used by the existing clients.
;;;

(defun instance-name (self)
  "Get the name of an instance"
  (car (rassoc self (class-direct-instance-map (class-of self)))))

(defun instance-name-setf-method (self name)
  "A setf method for the instance-name of any named object."
  (let* ((parent (class-of self))
	 (name-instance-pair (rassoc self (class-direct-instance-map parent))))
    (if (null name-instance-pair)
	(push (cons name self) (class-direct-instance-map parent))
	(if (not (eql name (car name-instance-pair)))
	    (setf (car name-instance-pair) name)))
    (setf (gethash name *instance-name-table*) self))
  name)

(defsetf instance-name instance-name-setf-method)

;;;
;;; (find-instance 'foo) is an anolog of (find-class 'foo)
;;;

(defun find-instance (self)
  "Turn an instance name into an instance referance."
  (gethash self *instance-name-table*))

;;;
;;; Now there must exist a class, analogous to standard-object, that serves as
;;; the root class of all classes with named instances. This class serves
;;; the primary purpose of allowing specialization of initialize-instance
;;; for any instance that should have a name.
;;; Properly, this class should be automatically used as a root by the
;;; named-object-metaclass just as standard-object is used by standard-class.
;;; For now, I just make sure that any subclasses of this class use
;;; :metaclass named-object-metaclass.
;;; It is arguable that a slot (perhaps "name") should be provided with
;;; an accessor and an initarg. I believe that this is best left to subclasses.
;;;

(defclass named-objects (standard-object)
  ()
  (:metaclass named-object-metaclass))

;;;
;;; This initialize instance wrapper provides a default name if none is
;;; provided. It is expected that aomething like an ":initarg name" will
;;; be provided for and invoked by a more specific wrapper if desired.
;;; The default name is of the form foo-1234 for instances of class foo.
;;;

(defmethod initialize-instance :after ((self named-objects) &rest initargs)
  "A simple CLOS compatable instance name creator."
  (setf (instance-name self)
	(gentemp (format nil "~a-" (class-name (class-of self))))))

;;;
;;; Finally, we must face the problem of disposing of old classes. The
;;; redefinition protocols are not fully implemented here. This is meant to
;;; give the flavor of what is to be used rather than a complete implementation.
;;; This is exactly the place where it would be nice to have a hook into the
;;; garbage collector...
;;; For now, Please call destroy-object when you want it to go away, and be careful
;;; not to keep any residual referances to the instance...
;;;

(defgeneric cleanup-class-of-destroyed-instance (self instance)
  (:documentation "Allow a class to clean up as an instance goes away."))

(defmethod cleanup-class-of-destroyed-instance ((self named-object-metaclass) instance)
  "Remove an instance name from a classes' name table."
  (let ((name-pair (rassoc instance (class-direct-instance-map self))))
    (if (not (null name-pair))
	(setf (class-direct-instance-map self)
	      (delete name-pair (class-direct-instance-map self))))))

(defgeneric destroy-instance (self)
  (:documentation "Clean up an instance."))

(defmethod destroy-instance ((self named-objects))
  "Clean up an instance."
  (remhash (instance-name self) *instance-name-table*)
  (cleanup-class-of-destroyed-instance (class-of self) self))
-----------------------------------------
;;; Sun Common Lisp, Development Environment 4.0.1, 6 July 1990
;;; Sun-4 Version for SunOS 4.0.x and sunOS 4.1
;;;
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990
;;;            by Sun Microsystems, Inc.,  All Rights Reserved
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990
;;;            by Lucid, Inc., All Rights Reserved
;;; This software product contains confidential and trade secret
;;; information belonging to Sun Microsystems, Inc.  It may not be copied
;;; for any reason other than for archival and backup purposes.
;;;
;;; Sun, Sun-4, and Sun Common Lisp are trademarks of Sun Microsystems Inc.

;;; Loading source file "lisp-init.lisp"
> (load "777-support/named-object-metaclass.lisp")
;;; Loading source file "777-support/named-object-metaclass.lisp"
#P"/home/zaphod/egdorf/777-support/named-object-metaclass.lisp"
> (defclass vehicles (named-objects)
    ()
    (:metaclass named-object-metaclass))
#<Named-Object-Metaclass VEHICLES>
> (defclass trucks (vehicles)
    ()
    (:metaclass named-object-metaclass))
#<Named-Object-Metaclass TRUCKS>
> (defclass cars (vehicles)
    ()
    (:metaclass named-object-metaclass))
#<Named-Object-Metaclass CARS>
> (setf t1 (make-instance 'trucks))
#<Trucks #X16AE396>
> (setf t2 (make-instance 'trucks))
#<Trucks #X16BA236>
> (setf c1 (make-instance 'cars))
#<Cars #X16BA436>
> (setf c2 (make-instance 'cars))
#<Cars #X16BA676>
> (class-direct-instances (find-class 'cars))
(#<Cars #X16BA676> #<Cars #X16BA436>)
> (class-direct-instances (find-class 'trucks))
(#<Trucks #X16BA236> #<Trucks #X16AE396>)
> (instance-name t1)
TRUCKS-1
> (instance-name t2)
TRUCKS-2
> (instance-name c1)
CARS-3
> (instance-name c2)
CARS-4
> (setf (instance-name t1) 'george)
GEORGE
> (setf (instance-name c2) 'fred)
FRED
> (mapcar #'instance-name (class-direct-instances (find-class 'trucks)))
(TRUCKS-2 GEORGE)
> (mapcar #'instance-name (class-direct-instances (find-class 'cars)))
(FRED CARS-3)
> (find-instance 'george)
#<Trucks #X16AE396>
T
> (find-instance 'trucks-2)
#<Trucks #X16BA236>
T
> (find-instance 'cars-3)
#<Cars #X16BA436>
T
> (find-instance 'fred)
#<Cars #X16BA676>
T
>

						Skip Egdorf
						hwe@lanl.gov