(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.
fluids are a similar idea, except that a "fluid" is a CLOS object, not a symbol.
Apache 2