🚀 go-pugleaf

In article <1af37aINN232@early-bird.think.com> barmar@think.com (Barry Margolin) writes:
>In article <1992Oct1.071605.8674@cs.ucla.edu> lange@lanai.cs.ucla.edu (Trent Lange) writes:
>>it would be *very* useful if there was an slot :allocation option that
>>allocated :class-like slots per subclass -- maybe an option called
>>:class-class or something.  
>
>I'd call it something like :PER-CLASS.

Good name.

>I don't think it really adds that much functionality.  It's relatively
>straightforward to implement using existing CLOS facilities, not even MOP.

You're right, of course, that it doesn't add functionality that one
can't get through other means with CLOS and/or the MOP (as your example
shows).  However, having it built-in to the language is the only way to
portably have that functionality efficiently.

Slot access on :CLASS :ALLOCATED slots is generally extremely efficient.
In July 92 PCL, for example, a slot-value of a standard, class-allocated
slot on a specialized parameter within a defmethod is simply a matter
of taking the CDR of a class slot cons cell.  If :PER-CLASS was a
standard option, it could get the same efficiency at almost no additional
cost to the CLOS-implementor or system (given support for :CLASS slots).
In July 92 PCL, for example, adding standard :PER-CLASS support would
literally require about 10 additional lines of code.

Implementing :PER-CLASS slots portably now, however, requires using
extra coding like you suggest or using the MOP to specialize on
SLOT-VALUE-USING-CLASS, etc, both of which will generally lead to
significantly slower run-time slot access performance.

Anyway, since several people were interested, I've included portable MOP
code below supporting a metaclass that allows :PER-CLASS allocated slots.
Supporting it portably requires specializing S-V-U-C, etc., so it's
not as fast as it could be theoretically, but it should work.

I've also just placed an updated version of July-92 PCL
(July-92-PCL-1c-tar.Z) on parcftp.xerox.com that includes a version of this
metaclass having the necessary internal PCL internal hooks to run as
fast as :CLASS allocated slots.  It is in the file extensions.lisp.
(July-92 1c also includes a couple of obscure bug fixes from 1b).

- Trent Lange



;;; PER-CLASS-SLOT-ALLOCATION-MIXIN is a mixin for metaclasses that
;;;   allows its classes' instances to store slots with :allocation
;;;   :per-class.  :per-class allocated slots work like :class allocated
;;;   slots, but are specific to each individual subclass.  I.e. any
;;;   class that inherits a class with :per-class allocated slots
;;;   also inherits the slot (as with :class allocated slots), but
;;;   unlike :class allocated slots, the value stored in the slot
;;;   can be different for each subclass.
;;; PER-CLASS-EFFECTIVE-SLOT-DEFINITION is the
;;;   effective-slot-definition-class for slots that have :allocation
;;;   :per-class.
;;; PER-CLASSABLE-SLOTS-CLASS is a metaclass that includes
;;;   PER-CLASS-SLOT-ALLOCATION-MIXIN and STANDARD-CLASS.
;;;
;;; Note that there are two different "implementations" to allow
;;;   access of :per-class slots:  One is specific to July 92 PCL
;;;   and its progeny (#+july-92-pcl), that operates by tagging along
;;;   with July 92's internal implementation of :class allocated slots.
;;;   It is extremely efficient because it fools July 92's slot access
;;;   operations and optimizations into thinking :per-class slots are
;;;   like :class allocation slots.  The other implementation is the
;;;   portable implementation (#-july-92-pcl), that works by defining
;;;   the proper slot-value-using-class methods, etc.
;;;
;;;  Example usage:
;;;
;;;
;;; (defclass a-class ()
;;;   ((class-slot1     :initform nil :allocation :class)
;;;    (per-class-slot1 :initform nil :allocation :per-class))
;;;   (:metaclass per-classable-slots-class))
;;;
;;; (defclass b-class (a-class)
;;;   ()
;;;   (:metaclass per-classable-slots-class))

(eval-when (compile load eval)

(defclass per-class-slot-allocation-mixin
  ()
  ((per-class-slot-cells
     :initform      NIL
     :reader        class-per-class-slot-cells
     :documentation
      "Cells storing the slots with allocation :per-class."))
   (:documentation
     "Mixin for a metaclass to allow its classes' instances to store
      slots with :ALLOCATION :PER-CLASS.  :PER-CLASS allocated slots work
      like :CLASS allocated slots, but are specific to each individual
      subclass."))

(defclass per-class-effective-slot-definition
  (standard-effective-slot-definition)
  ((per-class-cell
     :initform NIL
     :type     (or cons null)
     :accessor slot-definition-per-class-cell
     :documentation
      "Cons cell storing the slot value when allocation = :per-class"))
  (:documentation
    "Effective-slot-definition-class for per-class-slot-allocation-mixin
     classes when :allocation = :PER-CLASS."))

(defclass per-classable-slots-class
  (per-class-slot-allocation-mixin
   standard-class)
  ()
  (:documentation
    "Example metaclass that's exactly like standard-class, but allows
     its slots to have :allocation :per-class."))

(defmethod validate-superclass ((class per-class-slot-allocation-mixin)
                                (new-super T))
  (or (typep new-super 'per-class-slot-allocation-mixin)
      (eq new-super (find-class 'standard-object))))

) ; eval-when


(defmethod effective-slot-definition-class
  ((class per-class-slot-allocation-mixin) initargs)
  "If the slot has :allocation :per-class, then class is
   per-class-effective-slot-definition, otherwise what it normally
   would be."
  (if (eq (cadr (memq :allocation initargs)) :per-class)
      (find-class 'per-class-effective-slot-definition)
      (call-next-method)))

(defconstant *per-class-slot-unbound* '..per-class-slot-unbound)

(defmethod compute-effective-slot-definition :around
  ((class per-class-slot-allocation-mixin)
   name
   direct-slot-definitions)
  (declare (ignore direct-slot-definitions))
  (let ((effective-slot-definition (call-next-method)))
    (when (eq (slot-definition-allocation effective-slot-definition)
              :per-class)
      (let ((per-class-cell (cons name *per-class-slot-unbound*)))
        (setf (slot-value effective-slot-definition 'per-class-cell)
              per-class-cell)))
    effective-slot-definition))

(defmethod compute-slots :around ((class per-class-slot-allocation-mixin))
  "Update class-per-class-slot-cells of class."
  (let ((effective-slot-definitions (call-next-method))
        (per-class-cells NIL))
    (dolist (eslotd effective-slot-definitions)
      (when (eq (slot-definition-allocation eslotd) :per-class)
        (push (slot-definition-per-class-cell eslotd) per-class-cells)))
    (setf (slot-value class 'per-class-slot-cells) per-class-cells)
    effective-slot-definitions))

(defmethod slot-value-using-class
  ((class  per-class-slot-allocation-mixin)
   (object standard-object)
   (slotd  per-class-effective-slot-definition))
  (let ((per-class-cell (slot-value slotd 'per-class-cell)))
    (if (consp per-class-cell)
        (cdr per-class-cell)
        (call-next-method))))

(defmethod (setf slot-value-using-class)
  (new-value (class  per-class-slot-allocation-mixin)
             (object standard-object)
             (slotd  per-class-effective-slot-definition))
  (let ((per-class-cell (slot-value slotd 'per-class-cell)))
    (if (consp per-class-cell)
        (setf (cdr per-class-cell) new-value)
        (call-next-method))))

(defmethod slot-boundp-using-class
  ((class  per-class-slot-allocation-mixin)
   (object standard-object)
   (slotd  per-class-effective-slot-definition))
  (let ((per-class-cell (slot-value slotd 'per-class-cell)))
    (if (consp per-class-cell)
        (not (eq (cdr per-class-cell) *per-class-slot-unbound*))
        (call-next-method))))