Re: Compiling make-instance when using metaclasses and qualified methods on make-instance

[kanderso@BBN.COM]

  Date: Fri, 1 Nov 1991 13:21-0600
  From: "Donald H. Mitchell" <dmitchell@trc.amoco.com>
  Reply-To: dmitchell@trc.amoco.com
  Subject: Compiling make-instance when using metaclasses and qualified
  	 methods on make-instance
  To: slug@ai.sri.com
  Character-Type-Mappings: (1 0 (NIL 0) (NIL :ITALIC NIL) "CPTFONTI")
  Fonts: CPTFONT, CPTFONTI
  
  In CLOS on the Symbolics (8.1.1), this fails.  Symbolics admits the
  possibility of failure without holding out a possibility of repair.  I put a
  quick patch together to "fix" this error, but I am insecure regarding the
  possible effects of the patch.
  
  Below is the problem description, the patch, and Symbolic's response.
  
  If anyone has suggestions about the patch or the problem or the possibility
  that they may need a similar capability, I would appreciate knowing it.
  
  
  The problem seems to boil down to a problem with the compilation of
  (make-instance 'class-name) forms.   Normally, make-instance will resolve
  calls of this form by doing something similar to 
  (make-instance (find-class 'class-name)).
  
  In our system where we are using a subclass of standard-class as the default
  metaclass for new object classes AND we have wrapped make-instance for instances
  of that metaclass with an :around method to handle some initializations,
  the compiler apparently fails to account for "(find-class 'class-name)" above
  returning anything but an instance of standard-class.
  
  The example below illustrates the problem.
  Compile it and load it to note the internal error reported.
  
  (eval-when (compile load eval)
    (defclass new-class (standard-class)
        ((instances
           :allocation :instance
           :accessor instances-of
           :initform nil))))
  
  (defclass new-object ()
      ()
    (:metaclass new-class))
  
  (defmethod make-instance :around ((class new-class)
                                    &key &allow-other-keys)
    (let ((instance (call-next-method)))
      (pushnew instance (instances-of class))
      instance))
  
  (defclass test-object ()
      ()
    (:metaclass new-class))
  
  (setf a-test-object (make-instance 'test-object))
  
The compiler is trying to optimize this make-instance, but because you have an
around method, it currently isn't smart enough to.  You could also have
just said:

  (defmethod make-instance ((class new-class)
                                    &key &allow-other-keys)
    (let ((instance (call-next-method)))
      (pushnew instance (instances-of class))
      instance))
  
but, this wouldn't work either.
You can still make instances, you just can't get them optimized.  For example
the following should work:

(let ((name 'test-object)) (setq a-test-object (make-instance name)))

This works because the compiler does not try to optimize the make instance.
The drawback is that your make-instance is much slower.  Your patch seems
to do the same thing, though i'm not sure it is quite rigth.

FYI, here is two ways that i have done instance recording, the first is
like yours, the second is like what Naha suggested.  I have not tried this
on the Symbolics recently.

k

(in-package "USER")

#+lucid (import 'CLOS::SLOT-DEFINITION-NAME)
#+lucid (import 'clos::class-slots)

#||
COMPATIBILITY WITH STANDARD-CLASS

When a new metaclass is finalized, CLOS checks to see if it is compatible
with class STANDARD-CLASS.  By default, every metaclass is considered
incompatible.  The following class mixin guarrentees that the metaclass is
compatible.  Unfortunately, current implementations of CLOS differ on the
name of the generic-funtion that performs the compatiblity check.  We will
mix this mixin into every class mixin that is comatibly with STANDARD-CLASS
so that developers need not remember to.

||#

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

;;; Lucid version.
(defmethod clos-system::validate-superclass ((class compatible-class-mixin)
					     (super standard-object))
  T)

;;; PCL version.
(defmethod check-super-metaclass-compatibility
	   ((class compatible-class-mixin) (super standard-class))
  t)


#||

Lets consider two problems that come up commonly in programming:

1.  Keeping track of the instances created by an application.

2.  Allocating instances in a different way.

Ideally, the programmer should be able to create classes with such behavior
in the usual way and not worry about the details.  Sometimes this is not
possible without the MOP.

RECORDING INSTANCES

Here are two ways that an applications can keep track of the instance
created:

1.  INSTANCES-CLASS-MIXIN records the instances as a slot on the class.
The generic function (CLASS-INSTANCES class) returns a list of instances of
a class.

||#

(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)
  "Record a new instance of this class."
  (push instance (class-instances class)))

(defmethod remove-instance ((class instances-class-mixin) instance)
  "Remove an instance of this class."
  (setf (class-instances class)
	(delete instance (class-instances class) :test #'eq)))

;;; 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))
#<Ifrob #X2307D16>

> (setq y (make-instance 'jfrob))
#<Jfrob #X2336F76>

> (class-instances (find-class 'ifrob))
(#<Ifrob #X2307D16>)

> (class-instances (find-class 'jfrob))
(<Jfrob #X2336F76>)