Re: MOP in MCL 2.0

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

>On Aug 17,  4:30pm, Bill St. Clair wrote:
>> I already have a cheap implementation that slows down all SLOT-VALUE
>> calls and isn't called by DEFCLASS generated accessor functions. Ask and
>> I'll send it (or post it if demand is great).
>
>Please post it, or send me a copy.

It's short, so I've included it here. It's also available for anonymous
FTP from cambridge.apple.com in the file:

/pub/mcl2/contrib/slot-value-using-class.lisp

I figured out how to make it work for DEFCLASS generated accessors as
well. The only price you pay is in speed.

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

; slot-value-using-class.lisp
;
; Slow and simple implementation of SLOT-VALUE-USING-CLASS and friends
; for MCL 2.0.
; This slows down all calls to SLOT-VALUE & friends and disables all
; optimization for DEFCLASS generated accessors.

(in-package :ccl)

(export '(slot-value-using-class slot-boundp-using-class 
          slot-exists-p-using-class slot-makunbound-using-class))

(eval-when (:compile-toplevel :execute)
  (require "LISPEQU")                   ; for population-data
  )

(defvar *slot-value-using-class-inited* nil)

(unless *slot-value-using-class-inited*
  (setf (symbol-function 'std-slot-value) #'slot-value
        (symbol-function 'std-set-slot-value) #'set-slot-value
        (symbol-function 'std-slot-boundp) #'slot-boundp
        (symbol-function 'std-slot-exists-p) #'slot-exists-p
        (symbol-function 'std-slot-makunbound) #'slot-makunbound)
  ; This turns off optimization for DEFCLASS generated accessors
  (setq *standard-reader-method-class* nil
        *standard-writer-method-class* nil)
  (dolist (gf (population-data %all-gfs%))
    ; unoptimize existing accessors
    (compute-dcode gf))
  (setq *slot-value-using-class-inited* t))

(defmethod slot-value-using-class ((class t) instance slot-name)
  (std-slot-value instance slot-name))

(defmethod (setf slot-value-using-class) (value (class t) instance slot-name)
  (std-set-slot-value instance slot-name value))

(defmethod slot-boundp-using-class ((class t) instance slot-name)
  (std-slot-boundp instance slot-name))

(defmethod slot-exists-p-using-class ((class t) instance slot-name)
  (std-slot-exists-p instance slot-name))

(defmethod slot-makunbound-using-class ((class t) instance slot-name)
  (std-slot-makunbound instance slot-name))

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defun slot-value (instance slot-name)
  (slot-value-using-class (class-of instance) instance slot-name))

(defun set-slot-value (instance slot-name value)
  (setf (slot-value-using-class (class-of instance) instance slot-name)
        value))

(defun slot-boundp (instance slot-name)
  (slot-boundp-using-class (class-of instance) instance slot-name))

(defun slot-exists-p (instance slot-name)
  (slot-exists-p-using-class (class-of instance) instance slot-name))

(defun slot-makunbound (instance slot-name)
  (slot-makunbound-using-class (class-of instance) instance slot-name))
)