;; Copyright (c) 2003-2005 Edward Marco Baringer ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; - Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names ;; of its contributors may be used to endorse or promote products ;; derived from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :org.unknownlamer.ucw-im) (defclass aux-slots-mixin () ((%aux-slots :initform (make-hash-table :test #'eq)) (%aux-slots-order :reader aux-slots :initform nil))) (defmethod slot-missing ((class t) (obj aux-slots-mixin) slot-name operation &optional new-value) (with-slots (%aux-slots %aux-slots-order) obj (ecase operation (slot-value (multiple-value-bind (value present-p) (gethash slot-name %aux-slots) (if present-p value (slot-unbound class obj slot-name)))) (setf (unless (nth-value 1 (gethash slot-name %aux-slots)) (setf %aux-slots-order (nconc %aux-slots-order (list slot-name)))) (setf (gethash slot-name %aux-slots) new-value)) (slot-boundp (nth-value 1 (gethash slot-name %aux-slots))) (slot-makunbound (setf %aux-slots-order (delete slot-name %aux-slots-order)) (remhash slot-name %aux-slots)))))