Re: Getting slot accessors for defclass reconstruction

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

I forgot to require "LISPEQU" to get the definitions for %SLOTD-TYPE,
%SLOTD-INITFORM, and %SLOTD-INITARGS. The code should be:

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

; slot-definition-accessors.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))

(eval-when (:compile-toplevel :execute)
  (require "LISPEQU"))

(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))))