changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/obj/meta/stealth.lisp

changeset 258: 11ef863e0ac0
parent: 8ddd89b5e264
author: Richard Westhaver <ellis@rwest.io>
date: Mon, 01 Apr 2024 23:58:17 -0400
permissions: -rw-r--r--
description: keyutils init 
     1 ;;; obj/meta/stealth.lisp --- Stealth Mixin
     2 
     3 ;; see https://github.com/robert-strandh/Stealth-mixin
     4 
     5 ;;; Code:
     6 (in-package :obj/meta/stealth)
     7 
     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
    10 ;;;; aware of it.
    11 
    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.
    15 
    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.
    19 
    20 (defvar *stealth-mixins* (make-hash-table))
    21 
    22 (defmacro class-stealth-mixins (class)
    23   `(gethash ,class *stealth-mixins*))
    24 
    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)))
    32 							:test #'class-equalp)
    33 			   :metaclass (class-of (find-class victim-class)))
    34 
    35   ;; Register it as a new mixin for the victim class
    36   (pushnew mixin-name (class-stealth-mixins victim-class))
    37 
    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))
    42        &rest arguments
    43        &key (direct-superclasses nil direct-superclasses-p)
    44        &allow-other-keys)
    45     (cond (direct-superclasses-p
    46            ;; Silently modify the super classes to include our new
    47            ;; mixin.
    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
    53                   arguments))
    54           (t
    55            (call-next-method))))
    56   mixin-name)
    57 
    58 (defmacro define-stealth-mixin (name super-classes victim-class
    59                                 &rest for-defclass)
    60   "Like DEFCLASS but adds the newly defined class to the super classes
    61 of 'victim-class'."
    62   `(progn
    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)))