allocation of :class, ...

[Dan Larner <LARNER@SCORE.STANFORD.EDU>]

I'm encountering a difficulty (illustrated below) with the inheritance of slots
having :allocation of :class (using AAAI88 PCL).  Is this a problem, or am I
misinterpreting the CLOS spec?  Also, the use of subtype to determine 
relationships between classes appears to be unavailable. (I've been unable
to find anything on these in either the xxx-notes files or the recent items
on the mailing list. Is there a public list of known problems and as yet 
unimplemented features (beyond reading the xxx-notes files) so that one can 
easily check for an existing notice of a seemingly new observation?)  Finally,
the last item is a HACK to defclass so that it returns the newly defined class,
and so far this HACK has not caused me any problems.

;;; define a class 'a', with one class slot called shared
> (defclass a () ((shared :allocation :class :accessor shared :initform nil)))
NIL
;;; define a simple subclass 'b' of 'a'
> (defclass b (a) ())
NIL
;;; make instances of both 'a' and 'b'
> (setf ai (*make-instance 'a) bi (*make-instance 'b))
#<B 34202223>
;;; put a value into the shared slot of ai
> (setf (shared ai) '(hello))
(HELLO)
;;; show ai and bi, and find that bi's class slot is different from ai's,
;;; even though the b class did not redefine the slot
> (describe ai)
#<A 34166413> is an instance of class #<Standard-Class A 34036673>:
 The following slots have :CLASS allocation:
 SHARED    (HELLO)
> (describe bi)
#<B 34202223> is an instance of class #<Standard-Class B 34146653>:
 The following slots have :CLASS allocation:
 SHARED    NIL
;;; Also, am unable to determine type relationships
> (subtypep 'b 'a)
NIL
NIL
>
;;; but now, try it again using a surgical operation, - it seems like the
;;; class slots start out pointing to the same place, but then get corrupted
;;; when the entire value is replaced
> (defclass x () ((shared :allocation :class :initform '(1 2 3) :accessor shared)))
NIL
> (defclass y (x) ())
NIL
> (setf xi (*make-instance 'x) yi (*make-instance 'y))
#<Y 34407163>
> (rplacd (shared xi) '(hello))
(1 HELLO)
> (describe xi)
#<X 34405553> is an instance of class #<Standard-Class X 34330533>:
 The following slots have :CLASS allocation:
 SHARED    (1 HELLO)
> (describe yi)
#<Y 34407163> is an instance of class #<Standard-Class Y 34363053>:
 The following slots have :CLASS allocation:
 SHARED    (1 HELLO)
> (setf (shared yi) 45)
45
> (describe yi)
#<Y 34407163> is an instance of class #<Standard-Class Y 34363053>:
 The following slots have :CLASS allocation:
 SHARED    45
> (describe xi)
#<X 34405553> is an instance of class #<Standard-Class X 34330533>:
 The following slots have :CLASS allocation:
 SHARED    (1 HELLO)
> 
;;; Hacked defclass - so that it returns the new class object
(defmacro DEFCLASS (name includes slots &rest options)
  (declare (indentation 2 4 3 1))
  (let ((metaclass 'standard-class))
    ;; Now go see if there is a :metaclass option.  We need that before we
    ;; can do anything else.  If there is a :metaclass option, we remove it
    ;; from the options -- it isn't needed anymore since the class-protype
    ;; communicates the same information.
    (dolist (option options)
      (if (not (listp option))
          (error "~S is not a legal defclass option." option)
          (when (eq (car option) ':metaclass)
            (unless (legal-class-name-p (cadr option))
              (error "The value of the :metaclass option (~S) is not a~%~ 
                      legal class name."
                     (cadr option)))
            (unless (find-class (cadr option) nil)
              (error "The value of the :metaclass option (~S) does not name~%~
                      a currently defined class.  The metaclass must be~%~
                      defined at the time the defclass form is compiled or~%~
                      evaluated."
                     (cadr option)))
            (setq metaclass (cadr option)
                  options (remove option options)))))
    ;; A HACK - append a find-class form to the returned form so that the
    ;; class will be returned instead of NIL
    (append (let ((prototype-class (class-prototype (find-class metaclass))))
      (make-top-level-form `(defclass ,name)
			   '(compile load eval)
	(expand-defclass prototype-class name includes slots options)))
	    `((find-class ,(list 'quote name))))))
-------