Re: Getting slot accessors for defclass reconstruction

[bill@cambridge.apple.com (Bill St. Clair)]

>Howdy. I need to build a class reconstruction form from a defined
>class in mcl2.0. I found CCL:CLASS-DIRECT-INSTANCE-SLOTS and
>CCL:CLASS-DIRECT-INSTANCE-SLOTS, whose values I've mostly managed to
>decode via experimentation. From them I know each slot's name,
>initform, initargs, and type. (The initform seems to be a compiled
>anonymous function for some forms and a list for strings, numbers, and
>quoted values. So I guess can't get the original form that was passed
>to defclass to make the compiled function, right?)
>
>My problem is in determining the names of the :accessor, :reader, and
>:writer values and which slots they apply to!  By inspecting
>STANDARD-CLASS instances I found the CCL::ALIST slot which holds
>STANDARD-READER-METHODs and STANDARD-WRITER-METHODs, but doesn't tell
>me which slot they apply to. Could someone please tell me if and how I
>can get the original information back or a better approach to solving
>my problem? I'm considering using a defclass-like macro that saves
>slot information in my own class information structure, but I'd rather
>use what mcl stores, if it's adequate. I'll be grateful for any help I
>get on this!

This should get you started. I can't guarantee that this code will
continue to work in future versions of MCL, but if I change MCL's
slot definition objects in a future release, I'll almost certainly
include working definitions of these functions.

SLOT-DEFINITION-INITFORM does the best it can. If you call it
repeatedly and use the result to redefine a class, you'll get
an extra level of function wrapper each time.

Since SLOT-DEFINITION-READERS & SLOT-DEFINITION-WRITERS were impossible
to do (MCL's slot definition objects do not know their class), I
wrote SLOT-READERS & SLOT-WRITERS instead. Each of these takes two
arguments: a class and a slot name.

I have not tested these in MCL 2.0b1, but they work in MCL 2.0 final.

-Bill

-----------------------------------------------------------------------

; slot-definition-readers.lisp
;
; More of the AMOP slot definition accessors for MCL 2.0

(in-package :ccl)

(export '(slot-definition-initargs slot-definition-initform
          slot-definition-initfunction slot-definition-type
          slot-readers slot-writers
          accessor-method-slot-definition))

(defun maybe-slot-definition-p (thing)
  (let ((sd thing))
    (and (consp sd)
         (consp (setq sd (cdr (the cons sd))))
         (consp (cdr (the cons sd))))))

(defun ensure-slotd (thing)
  (if (maybe-slot-definition-p thing)
    thing
    (require-type thing '(satisfies maybe-slot-definition-p))))

(defmethod slot-definition-initargs ((slotd list))
  (%slotd-initargs (ensure-slotd slotd)))

(defmethod slot-definition-initform ((slotd list))
  (let ((fun-or-form-list (%slotd-initform (ensure-slotd slotd))))
    (if (listp fun-or-form-list)
      (car fun-or-form-list)
      `(funcall ,fun-or-form-list))))

(defmethod slot-definition-initfunction ((slotd list))
  (let ((fun-or-form-list (%slotd-initform (ensure-slotd slotd))))
    (cond ((null fun-or-form-list) nil)
          ((listp fun-or-form-list) 
           (let ((value (car fun-or-form-list)))
             #'(lambda () value)))
          (t fun-or-form-list))))

(defmethod slot-definition-type ((slotd list))
  (or (%slotd-type (ensure-slotd slotd)) t))

; The AMOP defines functions called SLOT-DEFINITION-READERS
; and SLOT-DEFINITION-WRITERS, which take a slot definition
; object as their single argument. MCL does not store the
; class in a slot definition object, so it can't work that way.
(defun slot-readers (class slot-name)
  (let ((res nil))
    (dolist (accessor (%class-get class 'accessor-methods))
      (if (and (eq slot-name (method-slot-name accessor))
               (typep accessor 'standard-reader-method))
        (push (method-name accessor) res)))
    res))

(defun slot-writers (class slot-name)
  (let ((res nil))
    (dolist (accessor (%class-get class 'accessor-methods))
      (if (and (eq slot-name (method-slot-name accessor))
               (typep accessor 'standard-writer-method))
        (push (method-name accessor) res)))
    res))        

(defmethod accessor-method-slot-definition ((method standard-accessor-method))
  (let* ((name (method-slot-name method))
         (class (car (method-specializers method))))
    (or (assq name (class-direct-instance-slots class))
        (assq name (class-direct-class-slots class))
        (error "Can't find slot definition for slot named ~s of ~s"
               name class))))