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