anchor.diff:  
   (in-package #:cl-user)
   
  -;; trivial portable 'advise' interface
  +(deftype function-name ()
  +  '(or symbol (cons symbol t)))
   
  -(defvar %advise% (make-hash-table :test 'eq))
  +;; trivial portable prototype of an 'advise' interface
  +
  +(defstruct (advise-record
  +             (:conc-name #:advised-)
  +             (:constructor
  +              make-advise-record (name original-function)))
  +  (original-function
  +   #'(lambda ()
  +       (error "Default advised-original-function"))
  +   :type function)
  +  ;; FIXME: add slot ENV
  +  (name #:unmamed
  +        :type function-name))
  +
  +(defconstant %advise-expand% 8)
  +
  +(defvar %advise-rec%
  +  (make-array %advise-expand%
  +              :element-type 'advise-record
  +              :adjustable t
  +              :fill-pointer 0))
  +
  +(defun get-advise (name &optional (errorp t))
  +  (declare (type function-name name)
  +           #+NIL (values (or null advise-record)
  +                         (or null array-dimension-designator)))
  +  ;; FIXME: lock %ADVISE-REC% (READ, NON-RECURSIVE) in this function
  +  (labels ((test (a b)
  +             (etypecase a
  +               (symbol (and (symbolp b)
  +                            (eq a b)))
  +               (cons (and (consp b)
  +                          (test (car a) (car b))
  +                          (test (cdr a) (cdr b)))))))
  +    ;; (test '(a a) '(a b)) ;; => NIL
  +    ;; (test '(a a) '(a a)) ;; => T
  +    ;; (test '(a a a) '(a a b)) ;; => NIL
  +    ;; (test '(a a b) '(a a b)) ;; => T
  +    (let ((n (position name %advise-rec%
  +                       :key #'advised-name
  +                       :test (etypecase name
  +                               (symbol #'eq)
  +                               (cons #'test)))))
  +      (cond
  +        (n (values (aref %advise-rec% n) n))
  +        (errorp (error "ADVISE-RECORD NOT FOUND: ~S" name))
  +        (t (values nil nil))))))
  +
  +(defun register-advise (name form)
  +  ;; FIXME: lock %ADVISE-REC% (WRITE) in this function
  +  (multiple-value-bind (adv n)
  +      (get-advise name nil)
  +    (declare (ignore n))
  +    (cond
  +      ((and adv (not (eq form (advised-original-function adv))))
  +       (error "ALREAY ADVISED: ~S => ~S" name adv))
  +      (t (let ((adv (make-advise-record name form)))
  +           (vector-push-extend adv %advise-rec% %advise-expand%)
  +           (values adv))))))
  +
  +(defun unregister-advise (name)
  +  ;; FIXME: lock %ADVISE-REC% (WRITE) in this function
  +  (multiple-value-bind (adv n)
  +      (get-advise name nil)
  +    (cond
  +      (adv
  +       (delete adv %advise-rec% :test #'eq)
  +       (values adv))
  +      (t (error "NOT ADVISED: ~S" name)))))
  +
  +
  +  
   
   (defmacro defadvise-macro (name lambda &key before after &environment env)
     ;; FIXME: This does not destructure LAMBDA for the BEFORE, AFTER functions,
  
positive.code:                    `((funcall ,after  ,@lambda))))))))
  
  
  (defmacro unadvise (name &environment env)
    (declare (ignore env))
    (let ((%name (gensym "%name-"))
          (%adv (gensym "%adv-"))
          (%undef (gensym "%undef-"))
          )
      `(let* ((,%name (quote ,name))
              (,%undef (gensym "%_%undef"))
              (,%adv (gethash ,%name %advise% ,%undef)))
         (cond
           ((eq ,%adv ,%undef)
            (warn "~S not advised" ,%name))
           (t
            (remhash ,%name %advise%)
            (let ((,%adv (eval ,%adv)))
              (setf (macro-function ,%name) ,%adv)
              (compile ,%name ,%adv)))
           ))))
  
  #|
  
  
negative.code: #+test (quux 12)
  ;; ^FIXME: *trace-output* shows order of eval: :BEFORE, :AFTER, :DURING
  
  (unadvise-macro quux)
  
  #+test (quux 28)
  
  
  
  |#
  
  ;; Prototypes
  
  
  
  #+NIL
  (defmacro compute-defkind (name &environment env)
  