diff base/stealth-mixins.lisp @ 252:b518b9f904e3

add stealth-mixin code from Strandh et al. (2007).

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/base/stealth-mixins.lisp	Thu Feb 24 11:23:18 2011 +0000
@@ -0,0 +1,56 @@
+(in-package #:amuse)
+
+;;;=====================================================================
+;;; Taken from: Strandh, R., Hamer, J., and Baumann, G., (2007). Using
+;;; Stealth Mixins to Achieve Modularity. In Proceedings of the 2007
+;;; Australian Software Engineering Conference (ASWEC'07).
+;;; =====================================================================
+
+(defvar *stealth-mixins* (make-hash-table))
+
+(defmacro class-stealth-mixins (class)
+  `(gethash ,class *stealth-mixins*))
+
+(defmacro define-stealth-mixin (name super-classes victim-class
+				&rest for-defclass)
+  "Like DEFCLASS but adds the newly defined class to the super classes
+   of `victim−class'."
+  `(progn
+     ;; First define the class we talk about
+     (defclass ,name ,super-classes ,@for-defclass)
+     ;; Add the class to the mixins of the victim
+     (sb-mop:ensure-class
+      ',victim-class
+      :direct-superclasses (adjoin ',name
+				   (and (find-class ',victim-class nil)
+					(sb-mop:class-direct-superclasses
+					 (find-class ',victim-class)))
+                                      :test #'class-equalp))
+     ;; Register it as a new mixin for the victim class
+     (pushnew ',name (class-stealth-mixins ',victim-class))
+     ;; When one wants to [re] define the victim class the new mixin
+     ;; should be present too . We do this by `patching' ensure−class:
+     (defmethod sb-mop:ensure-class-using-class :around
+         (class (name (eql ',victim-class)) &rest arguments
+		&key (direct-superclasses nil direct-superclasses-p)
+		&allow-other-keys)
+       (cond (direct-superclasses-p
+	      ;; Silently modify the super classes to include our new
+              ;; mixin.
+	      (dolist (k (class-stealth-mixins name))
+		(pushnew k direct-superclasses
+			 :test #'class-equalp))
+	      (apply #'call-next-method class name
+		     :direct-superclasses direct-superclasses
+		     arguments))
+	     (t
+	      (call-next-method))))
+      ',name))
+
+;; The `direct−superclasses' argument to ensure−class is a list of
+;; either classes or their names. Since we want to avoid duplicates,
+;; we need an appropriate equivalence predicate:
+(defun class-equalp (c1 c2)
+   (when (symbolp c1) (setf c1 (find-class c1)))
+   (when (symbolp c2) (setf c2 (find-class c2)))
+   (eq c1 c2))