Special Slots
A kind of pseudo-slot where the value is stored in a hidden symbol-value outside of the instance. This means the special slot can be dynamically bound (using progv) as a special variable would be. (The lets macro below is implemented with progv.) There's a generic function (like slot-unbound) that will be called if the special slot is not bound. It would also be nice to have a concise way to specify the initial value for a special slot. Note that this code uses ORF, another macro example.

(defvar *special-slot-table* (make-hash-table) "Map an instance to a plist of special slots.") (defun ensure-special-slot (instance accessor-name) (let ((accessor-string (symbol-name accessor-name))) (orf (getf (gethash instance *special-slot-table*) accessor-name) (gensym (format nil "~A-~A" accessor-string (string 'variable)))))) (defgeneric special-slot-unbound (class instance accessor-name) (:documentation "Called when a special slot is not BOUNDP.") (:method ((class t) instance accessor-name) (error 'unbound-special-slot :instance instance :name accessor-name))) (define-condition unbound-special-slot (cell-error) ((instance :initarg :instance :reader unbound-special-slot-instance)) (:report (lambda (condition stream &aux (accessor-name (cell-error-name condition))) (let ((special-slot-instance (unbound-special-slot-instance condition))) (format stream "The special slot ~S (associated with ~S) is unbound." accessor-name special-slot-instance))))) (defmacro define-special-slot (class-name accessor-name &optional documentation) "Define a special slot on a class, optionally with documentation on the function." `(progn (defmethod ,accessor-name ((instance ,class-name)) ,.(when (stringp documentation) (list documentation)) (let ((special-variable-name (ensure-special-slot instance ',accessor-name))) (cond ((boundp special-variable-name) (symbol-value special-variable-name)) (t (special-slot-unbound (class-of instance) instance ',accessor-name))))) ;; Writer method is simpler because no worries about BOUNDP-ness. (defmethod (setf ,accessor-name) (new-value (instance ,class-name)) (setf (symbol-value (ensure-special-slot instance ',accessor-name)) new-value)))) (defun special-slot-makunbound (instance accessor-name) (makunbound (ensure-special-slot instance accessor-name))) (defmacro lets ((&rest bindings) &body body) (loop for ((accessor-name instance) value) in bindings for symbol = `(ensure-special-slot ,instance ',accessor-name) collect symbol into symbols collect value into values finally (return `(progv (list ,.symbols) (list ,.values) ,@body)))) (defmacro lets* ((&rest bindings) &body body) (cond ((endp bindings) (list* 'progn body)) ((destructuring-bind (first . rest) bindings `(lets (,first) (lets* (,@rest) ,@body))))))

ContextL has a more sophisticated (i.e. MOP-based) facility for special classes.


Apache 2