anchor.diff:  
   (defun clear-m1-m2-pairs ()
     (setf *metap-m1-m2-pairs* nil))
  +
  +(defclass node ()
  +  ((class :initform nil :initarg :class)
  +   (supers :initform nil :initarg :supers)
  +   (subs :initform nil :initarg :subs)
  +   (footprint :initform nil)
  +   (junction-count :initform 0)))
  +
  +(defun construct-lattice (superclasses)
  +  (let ((lattice (make-hash-table :test 'eq)))
  +    (labels ((add-node (node)
  +               (with-slots (class) node
  +                 (or (gethash class lattice) (setf (gethash class lattice) node))))
  +             (get-node (class) (gethash class lattice))
  +             (rec (target superclasses)
  +               (with-slots (class supers subs) target
  +                 (some->> superclasses
  +                   (mapcar (lambda (s)
  +                             (if (get-node s)
  +                                 (with-slots (subs junction-count) (get-node s)
  +                                   (setf subs (->> (nreverse subs)
  +                                               (adjoin target)
  +                                                nreverse))
  +                                   (setf junction-count (1- (length subs)))
  +                                   (get-node s))
  +                                 (add-node (make-instance 'node
  +                                                          :class s
  +                                                          :subs (cons target nil))))))
  +                   (setf supers)
  +                   (mapcar (lambda (s)
  +                             (with-slots (class) s
  +                               (rec s (c2mop:class-direct-superclasses class)))))))))
  +      (symbol-macrolet ((base (gethash 'base lattice)))
  +        (setf base (make-instance 'node :class 'base))
  +        (rec base superclasses)
  +        base))))
  +
  +(defun display-node-data (node)
  +  (with-slots (class supers subs junction-count) node
  +    (format t "~a  junc-count:~a supers:~a subs:~a~%"
  +            class
  +            junction-count
  +            (mapcar (lambda (n) (ignore-errors (class-name (slot-value n 'class))))
  +                    supers)
  +            (mapcar (lambda (n) (ignore-errors (class-name (slot-value n 'class))))
  +                    subs))))
  +
  +(defun display-lattice (node)
  +  (let (top)
  +    (labels ((rec-upward (node)
  +               (with-slots (supers) node
  +                 (display-node-data node)
  +                 (if (null supers) (setf top node) (mapc #'rec-upward supers)))
  +               top)
  +             (rec-downward (node)
  +               (with-slots (subs) node
  +                 (display-node-data node)
  +                 (if (null subs) node (mapc #'rec-downward subs)))))
  +      (-> node
  +        (-<> (progn (format t "Upwards:~%") <>)) rec-upward
  +        (-<> (progn (format t "~%Downwards:~%") <>)) rec-downward))))
  + 
  +(defun compute-precedense-list (direct-superclasses)
  +  (let ((root (construct-lattice direct-superclasses))
  +        (reverse-precedense-list nil))
  +    (labels ((rec (node)
  +               (with-slots (class supers footprint junction-count) node
  +                 (cond ((null supers) (push class reverse-precedense-list))
  +                       ((< 0 junction-count) (decf junction-count))
  +                       (footprint nil)
  +                       (t (setf footprint t)
  +                          (push class reverse-precedense-list)
  +                          (mapc #'rec supers))))))
  +      (rec root)
  +      (cdr (nreverse reverse-precedense-list)))))
   
   (defmethod c2mop:ensure-class-using-class :around (class name &rest args
                                                      &key
  
positive.code:                                    :metaclass m2class)
                   (error "can not specify ~a as metaclass because this class ~a is a subclass of ~a."
                          metaclass name m1class)))))
      (let ((superclasses (mapcan (compose #'c2mop:compute-class-precedence-list #'find-class)
                                  direct-superclasses)))
        (loop for (m1class . m2class) in *metap-m1-m2-pairs*
           when (member (find-class m1class) superclasses) return (apply-m2class m1class m2class)
           finally (return (call-next-method))))))
  
  
negative.code: 
  (in-package :cl-user)
  (defpackage metap
    (:use :cl :cl-thread-macro)
    (:import-from :alexandria :compose)
    (:export :*metap-m1-m2-pairs*
             :register-m1-m2-pair
  