Mercurial > core / lisp/lib/obj/meta/stealth.lisp
changeset 698: |
96958d3eb5b0 |
parent: |
11ef863e0ac0
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 04 Oct 2024 22:04:59 -0400 |
permissions: |
-rw-r--r-- |
description: |
fixes |
1 ;;; obj/meta/stealth.lisp --- Stealth Mixin 3 ;; see https://github.com/robert-strandh/Stealth-mixin 6 (in-package :obj/meta/stealth) 8 ;;;; The following hack is due to Gilbert Baumann. It allows us to 9 ;;;; dynamically mix in classes into a class without the latter being 12 ;;; Mixins are not intended to be directly instantiated, and instead 13 ;;; are used as superclasses to "normal" classes in order to capture 14 ;;; common things between several "normal" classes. 16 ;;; First of all we need to keep track of added mixins, we use a hash 17 ;;; table here. Better would be to stick this information to the 18 ;;; victim class itself. 20 (defvar *stealth-mixins* (make-hash-table)) 22 (defmacro class-stealth-mixins (class) 23 `(gethash ,class *stealth-mixins*)) 25 (defun add-mixin (mixin-name victim-class) 26 "Add the mixin to the superclasses of the victim" 27 (ensure-class victim-class 28 :direct-superclasses (adjoin mixin-name 29 (and (find-class victim-class nil) 30 (class-direct-superclasses 31 (find-class victim-class))) 33 :metaclass (class-of (find-class victim-class))) 35 ;; Register it as a new mixin for the victim class 36 (pushnew mixin-name (class-stealth-mixins victim-class)) 38 ;; When one wants to [re]define the victim class the new mixin 39 ;; should be present too. We do this by 'patching' ensure-class: 40 (defmethod ensure-class-using-class :around 41 (class (name (eql victim-class)) 43 &key (direct-superclasses nil direct-superclasses-p) 45 (cond (direct-superclasses-p 46 ;; Silently modify the super classes to include our new 48 (dolist (k (class-stealth-mixins name)) 49 (pushnew k direct-superclasses 50 :test #'class-equalp)) 51 (apply #'call-next-method class name 52 :direct-superclasses direct-superclasses 58 (defmacro define-stealth-mixin (name super-classes victim-class 60 "Like DEFCLASS but adds the newly defined class to the super classes 63 ;; First define the class we talk about 64 (defclass ,name ,super-classes ,@for-defclass) 65 ;; Add the class to the mixins of the victim 66 (add-mixin ',name ',victim-class)))