dynamic-slots example

[ST.CLAIR@AppleLink.Apple.COM (St. Clair, William)]

   From: Karsten Poeck <Karsten_Poeck@ira.uka.de>
   To: info macl <info-macl@cambridge.apple.com>
   Sub:    dynamic-slots file missing
 
   In MCL 2.0 Reference in chapter 'converting to clos' on page 494 is
   mentioned a file 'dynamic-slots.lisp' which should be located in the
   example folder and should provide sample code to emulate dynamic
   slots in clos. I can't find this file neither in our version 'MCL
   2.0b1' nor in patches 1 to 3. Where can I find this file or something
   equivalent to it ?
 
   Karsten Poeck
   e-mail: poeck@ira.uka.de
 
Guess that one didn't make it into the examples folder.  It's a very simple
little hack that I worked up while thinking about differences between
Object Lisp and CLOS.  When we get more of the MOP, you'll be able to
declare a slot as (... :ALLOCATION :DYNAMIC ...) in DEFCLASS and define the
accessors with SLOT-VALUE-USING-CLASS.  I doubt any of this will exist
before MCL 2.1, however.  For now, try the following:
 
---------------------------------------------------------------------------
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; dynamic-slots.lisp
;; copyright (C) 1991, Apple Computer, Inc.
;;
;; A simple mixin class that uses the SLOT-MISSING trap to access
;; dynamically allocated slots.
;; Just mix in the class DYNAMIC-SLOT-MIXIN and you'll be able to
;; use DYNAMIC-HAVE & DYNAMIC-UNHAVE to add and remove dynamic slots.
;;
 
(in-package :ccl)
 
(export '(dynamic-slot-mixin dynamic-have dynamic-unhave))
 
(defclass dynamic-slot-mixin ()
  ((dynamic-slot-alist :initform nil :accessor dynamic-slot-alist)))
 
(defvar *unbound-marker* (list nil))
 
(defmethod dynamic-have ((instance dynamic-slot-mixin) slot-name &optional
                         (value *unbound-marker* value-p))
  (let ((cell (assq slot-name (dynamic-slot-alist instance))))
    (if cell
      (if value-p
        (setf (cdr cell) value)
        (cdr cell))
      (progn
        (push (cons slot-name value) (dynamic-slot-alist instance))
        value))))
 
(defmethod dynamic-unhave ((instance dynamic-slot-mixin) slot-name)
  (setf (dynamic-slot-alist instance)
        (delete slot-name (dynamic-slot-alist instance) :key #'car))
  nil)
 
(defmethod dynamic-slot-value ((instance dynamic-slot-mixin) slot-name)
  (let ((cell (assq slot-name (dynamic-slot-alist instance))))
    (if cell
      (let ((value (cdr cell)))
        (if (eq value *unbound-marker*)
          (slot-unbound (class-of instance) instance slot-name)
          value))
      (slot-missing (class-of instance) instance slot-name 'slot-value))))
 
(defmethod (setf dynamic-slot-value) (value (instance dynamic-slot-mixin)
slot-name)
  (let ((cell (assq slot-name (dynamic-slot-alist instance))))
    (if cell
      (setf (cdr cell) value)
      (slot-missing (class-of instance) instance slot-name 'setf value))))
 
(defmethod dynamic-slot-boundp ((instance dynamic-slot-mixin) slot-name)
  (let ((cell (assq slot-name (dynamic-slot-alist instance))))
    (if cell
      (neq *unbound-marker* (cdr cell))
      (slot-missing (class-of instance) instance slot-name 'slot-boundp))))
 
(defmethod dynamic-slot-makunbound ((instance dynamic-slot-mixin) slot-name)
  (let ((cell (assq slot-name (dynamic-slot-alist instance))))
    (if cell
      (setf (cdr cell) *unbound-marker*)
      (slot-missing (class-of instance) instance slot-name 'slot-makunbound))))
 
(defmethod dynamic-slot-exists-p ((instance dynamic-slot-mixin) slot-name)
  (assq slot-name (dynamic-slot-alist instance)))
 
(defvar *in-dynamic-slot-missing* nil)
 
(defmethod slot-missing (class (instance dynamic-slot-mixin) slot-name
operation
                               &optional value)
  (declare (ignore class))
  (if *in-dynamic-slot-missing*
    (call-next-method)
    (let ((*in-dynamic-slot-missing* t))
      (case operation
        (slot-value (dynamic-slot-value instance slot-name))
        (setf (setf (dynamic-slot-value instance slot-name) value))
        (slot-boundp (dynamic-slot-boundp instance slot-name))
        (slot-makunbound (dynamic-slot-makunbound instance slot-name))))))
 
#|
; Example
(defclass dynamic-class (dynamic-slot-mixin)
  ((real-slot :initform 'real-slot :accessor real-slot :initarg :real-slot)))
 
(defmethod initialize-instance ((instance dynamic-slot-mixin) &key)
  (call-next-method)
  (dynamic-have instance 'foo 'foo-value)
  (dynamic-have instance 'bar 'bar-value))
 
(defparameter *d* (make-instance 'dynamic-class))
 
(slot-value *d* 'real-slot)
(slot-value *d* 'foo)
(slot-value *d* 'bar)
(slot-value *d* 'missing)
|#