Re: method discrimination on persistent objects

[Gregor.pa@Xerox.COM]

There was a braino in the previous mailing of this which came from
making one last edit before sending it out.  This code should work.  The
key difference is that any mention of the real-slots slot of db-classes
is now gone.

I have spent a little time thinking about the question you asked.  I
haven't answered sooner because I have been to busy to type in a long
reply.  I am still too busy so this will be a short reply.  Once I get
back from the Lisp conference I will be able to send more.

It seems to me that having make-instance return an object-id rather than
an object itself is causing problems.  I think a form of your third
solution is the way to go.  Here are some ideas about how to do it in
PCL.  Some of this is undocumented PCL, and will change in the next few
months.  But there is a corresponding part to all of this in the Chapter
3 we are working on.

We will define a new metaclass called db-class.  The feature of
this metaclass is that it will store the values of the slots for its
metainstances in the database.  The only thing stored in core will be
the object-id of the instance.  This implementation has an important 
problem which could be fixed later.  It allocates space for the database
slots in core even though this space is never used.  This could be fixed
later, remind me next week after the Lisp Conference.

(defclass db-class (standard-class)
     ())

As soon as the instances are allocated, we have to set their object-id.

(defmethod allocate-instance ((class db-class))
  (let ((instance (call-next-method)))
    (setf (slot-value instance 'object-id) (allocate-object-id))
    instance))

We need to add the special slot object-id slot to all db-classes.  This
just arranges to tack the slot onto all the other slots a given db-class
inherits.

(defmethod collect-slotds ((class db-class) local-slots cpl)
  (cons (make-slotd (find-class 'standard-slot-description)
		    :name 'object-id
		    :allocation :instance)
	(call-next-method)))

Now we need to teach slot-value for the class to use the value stored
in the database.  Of course the object-id slot is special as it is
stored in core.

(defmethod slot-value-using-class ((class db-class) object slot-name)
  (if (eq slot-name 'object-id)
      (call-next-method)
      (if (find slot-name (class-slots class) :key #'slotd-name)
	  (GET-VALUE-FROM-DB (slot-value object 'object-id)
			     slot-name)
	  (slot-missing object slot-name))))

(defmethod put-slot-using-class ((class db-class) object slot-name new-value)
  (if (eq slot-name 'object-id)
      (call-next-method)
      (if (find slot-name (class-slots class) :key #'slotd-name)
	  (PUT-VALUE-IN-DB (slot-value object 'object-id)
			   slot-name
			   new-value)
	  (slot-missing object slot-name))))

We also want to be able to use automatically generated accessor methods
to access the slots.  We need to make sure PCL uses the right code for
getting at these slots.

(defmethod make-reader-method-function ((class db-class) slotd)
  (let ((slot-name (slotd-name slotd)))
    #'(lambda (object)
	(slot-value object slot-name))))

(defmethod make-writer-method-function ((class db-class) slotd)
  (let ((slot-name (slotd-name slotd)))
    #'(lambda (object new-value)
	(setf (slot-value object slot-name) new-value))))

We need to make sure that we don't inherit any methods which have
optimized calls to slot-value in them.  This is because those methods
will be expecting the instance to have all its storage in core.  The
simple way to do this is to say that we can't be a subclass of a non
db-class class that has slots.

(defmethod check-super-metaclass-compatibility ((class db-class)
						(new-super t))
  (or (eq (class-of class) (class-of new-super))
      (null (class-slots new-super))))


It doesn't seem worth doing slot-value optimization because of the time
required to go to the database.  We have to disable the optimization
method we would otherwise inherit.

(defmethod optimize-slot-value ((class db-class) form) form)
(defmethod optimize-set-slot-value ((class standard-class) form) form)

Here are some stubs for the Database stuff.  This just arranges to store
the values in a different place so that we can show that the values
aren't being stored in the instance.  Note that the way I have this
setup, the database doesn't get any advance warning about the existence
of a new object id.  That would be easy to fix by having
allocate-object-id inform the database it just made a new id.


(defvar *db* ())
(defun get-value-from-db (object-id slot-name)
  (getf (cdr (get-db-internal object-id)) slot-name))
(defun put-value-in-db (object-id slot-name new-value)
  (setf (getf (cdr (get-db-internal object-id)) slot-name)
	new-value))

(defun get-db-internal (object-id)  
  (let ((instance (assq object-id *db*)))
    (unless instance
      (setq instance (list object-id))
      (push instance *db*))
    instance))


(defun allocate-object-id ()
  (gensym))


;;;
;;; Here is some code that tries it all out.
;;;
(defclass pos ()
     ((x :initform 0 :accessor pos-x)
      (y :initform 0 :accessor pos-y))
  (:metaclass db-class))

(defmethod describe-object ((p pos) stream)
  (format stream
	  "~&~S is a position, stored in the database.~@
           Its x coordinate is ~D, its y coordinate is ~D."
	  p (pos-x p) (pos-y p)))

(setq p1 (mki 'pos))
#<Position 27345>

(setf (pos-x p1) 10
      (pos-y p1) 10)
10

(describe-object p1 *standard-output*)
#<POS 104130217> is a position, stored in the database.
Its x coordinate is 10, its y coordinate is 10.
-------