extension metaclass

[Jacky Combs <combs@STC.LOCKHEED.COM>]

I am enclosing some code defining the metaclass EXTENSION-META.  I wanted to be
able to define classes with the slot CLASS-INSTANCES whose value was a list of
current instances of the class.  I would appreciate any comments or
suggestions.  Also any examples of defining metaclasses with other specific
behavior.  Thanks

Jacky



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


;;; This file contains an example of the additional code needed to implement a
;;; user defined META CLASS.  In order to inherit the functionality (slots and
;;; methods) of the system META class STANDARD-CLASS, a user defined META class
;;; must have STANDARD-CLASS in its list of SUPERS.

;;; Here we have defined the metaclass, EXTENSION-META, and added the new slot,
;;; EXTENSIONS, that will maintain a list of INSTANCE-OBJECTS.

(defclass extension-meta (standard-class)
     ((extensions
	:initform nil
	:accessor class-instances)))

;;; We need an additional definition (a more specific definition) of
;;; CHECK-SUPER-METACLASS-COMPATIBILITY to handle our EXTENSION-META metaclass.

(defmethod check-super-metaclass-compatibility ((x extension-meta)
						(y standard-class))
  't)

;;; We need to define additional methods for CLASS-FOR-REDEFINITION to handle
;;; cases when the new metaclass and old metaclass are not the same.  And
;;; because of the specific behavior of EXTENSION-META we need to mark the
;;; instances of the redefined class obsolete if it's previous class were
;;; STANDARD-CLASS and its current class EXTENSION-META.


(defmethod class-for-redefinition ((old-class extension-meta)
				   (proto-class standard-class)
				   name
				   local-supers
				   local-slot-slotds
				   extra)
  (declare (ignore name local-supers local-slot-slotds extra))
  (change-class old-class (class-of proto-class))
  old-class)

(defmethod class-for-redefinition ((old-class standard-class)
				   (proto-class extension-meta)
				   name
				   local-supers
				   local-slot-slotds
				   extra)
  (declare (ignore name local-supers local-slot-slotds extra))
  (change-class old-class (class-of proto-class))
  (make-instances-obsolete old-class)
  old-class)



;;; Here is the additional *MAKE-INSTANCE definition to handle EXTENSION-META
;;; classes so that as instances are created, they are added to the class' 
;;; EXTENSION slot.

(defmethod *make-instance ((class extension-meta) &rest args)
  (declare (ignore args))
  (let ((new-instance (call-next-method)))
    (setf (class-instances class) (push new-instance (class-instances class)))
    new-instance))



;;; Here are additions to the  UPDATE-INSTANCE-FOR-DIFFERENT-CLASS method along
;;; with defintions for a new method UPDATE-EXTENSIONS-DIFF-CLASS  that we need
;;; to handle EXTENSION-META class.

(defmethod update-instance-for-different-class
	   :after ((previous object)(current object) &rest args)
   (declare (ignore args))
   (let ((old-class (class-of previous))
	 (new-class (class-of current)))
      (update-extensions-diff-class old-class new-class current)))


(defmethod update-extensions-diff-class ((old standard-class)(new standard-class) cur)
  (declare (ignore cur))
  t)

(defmethod update-extensions-diff-class ((old standard-class)(new extension-meta) cur)
  (setf (class-instances new) (cons cur (class-instances new))))

(defmethod update-extensions-diff-class ((old extension-meta)(new extension-meta)  cur)  
  (setf (class-instances old) (remove cur (class-instances old) :test 'equal))
  (setf (class-instances new) (cons cur (class-instances new))))

(defmethod update-extensions-diff-class ((old extension-meta)(new standard-class)  cur)
  (setf (class-instances old) (remove cur (class-instances old) :test 'equal)))

;;; Here is the addition to the UPDATE-INSTANCE-FOR-REDEFINED-CLASS method
;;; along with definitions for a new method UPDATE-INSTNACE-FOR-REDEFINED-CLASS
;;; that we need to handle EXTENSION-META class.


(defmethod update-instance-for-redefined-class :after
  ((instance object) &rest args)
  (declare (ignore args))
      (let ((redef-class (class-of instance)))
	(update-extensions-redef-class redef-class instance)))
  
(defmethod update-extensions-redef-class ((redef-class standard-class) instance)
(declare (ignore instance))
t)

(defmethod update-extensions-redef-class 
    ((redef-class extension-meta)  instance) 
 (if (member instance (class-instances redef-class) :test 'equal) 
      nil
     (setf (class-instances redef-class) 
           (cons instance (class-instances redef-class)))))