encapsulate.lisp

;;;-*-Mode: LISP; Package: CCL -*-
;;;
;;;   Copyright (C) 1994-2001 Digitool, Inc
;;;   This file is part of OpenMCL.  
;;;
;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
;;;   License , known as the LLGPL and distributed with OpenMCL as the
;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
;;;   conflict, the preamble takes precedence.  
;;;
;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
;;;
;;;   The LLGPL is also available online at
;;;   http://opensource.franz.com/preamble.html


;;;  Modified by alanr Wed May 24, 2006 to be usable in abcl. None of
;;;  the generic function stuff works but I'll leave it there in case I want
;;;  to try to make it work
;;;  Advising setf methods not tried yet (probably won't work)

(defpackage "ENCAPSULATE" (:USE "CL" "SYSTEM")
	    (:export "TRACE" "UNTRACE" "ADVISE" "UNADVISE" "ARGLIST"))
(in-package encapsulate)
(shadowing-import '(trace untrace advise unadvise arglist) 'cl-user)

;; Lets try encapsulations
;; trace is here too
;; Make trace like 1.3, trace methods, trace (setf car)


(defvar *trace-alist* nil)
(defvar *trace-enable* t)
(defvar *trace-level* 0)
(defparameter *trace-max-indent* 40)
(defvar *trace-print-level* nil)
(defvar *trace-print-length* nil)
(defparameter *trace-bar-frequency* nil)

(defvar *advise-alist* nil)

(defparameter *encapsulation-table*
  (make-hash-table :test #'eq :rehash-size 2 :size 2))

(defstruct (encapsulation)
  symbol         ; the uninterned name containing original def
  type           ; trace or advise
  spec           ; the original function spec
  advice-name    ; optional
  advice-when    ; :before, :after, :around 
  owner          ; where encapsulation is installed
)

(defun setf-function-spec-name (spec)
  (if (and (consp spec) (eq (car spec) 'setf))
    (or (error "Not yet")
	(%setf-method (cadr spec)) ; this can be an anonymous function
        (setf-function-name (cadr spec)))
    spec))


(defun trace-tab (&aux (n (min *trace-level* *trace-max-indent*)))
  (fresh-line *trace-output*)
  (dotimes (i n)
    (declare (fixnum i))
    (write-char (if (and *trace-bar-frequency* 
			 (eq 0 (mod i *trace-bar-frequency*)))
		  #\| #\Space) *trace-output*)))

(defun trace-before  (&rest args)
  (declare (dynamic-extent args))
  (trace-tab)
  (let* ((*print-level* *trace-print-level*)
         (*print-length* *trace-print-length*)
         (*print-readably* nil))
    (format *trace-output* "Calling ~S ~%" args)
    (force-output *trace-output*)))

(defun trace-after (sym &rest args &aux (n (length args)))
  (declare (dynamic-extent args))
  (let* ((*print-level* *trace-print-level*)
         (*print-length* *trace-print-length*)
         (*print-readably* nil))
    (if (eq n 1)
      (progn
        (trace-tab)
        (format *trace-output* "~S returned ~S~%" sym (car args)))
      (progn
        (trace-tab)
        (format *trace-output* "~S returned ~S values :" sym n)
        (dolist (val args)
          (trace-tab)
          (format *trace-output* "     ~S" val))))
    (force-output *trace-output*)))

(defun forget-encapsulations (name)
  (when (%traced-p name)
    (format t "~%... Untracing ~a" name) 
    (%untrace-1 name))
  (when (%advised-p name nil nil t)
    (format t "~%... Unadvising ~a" name) 
    (unadvise-1 name))
  nil)

(defun function-encapsulated-p (fn-or-method)
  (typecase fn-or-method
    ((or method symbol cons)(function-encapsulation fn-or-method))
    (function
     (or (function-traced-p fn-or-method)
         (function-advised-p fn-or-method )))))

(defun function-traced-p (fn)
  (%function-in-alist fn *trace-alist*))

(defun function-advised-p (fn)
  (%function-in-alist fn *advise-alist*))                           

(defun %function-in-alist (def list)
  (dolist (cap list)
    (let ((symbol (encapsulation-owner cap)))
      (typecase symbol
        (symbol (when (eq (and (fboundp symbol) (symbol-function symbol)) def)
                  (return cap)))
        (method (when (eq (%method-function symbol) def)
                  (return cap)))
        (standard-generic-function
         (when (eq symbol def) (return cap)))))))

(defun function-encapsulation (spec)
  (typecase spec
    ((or symbol method)
     (gethash spec *encapsulation-table*))
    (function (function-encapsulated-p spec))
    (cons (gethash (setf-function-spec-name spec) *encapsulation-table*))))

; she works now - does the equivalent of the original gf - called from traced def
(defun %%call-encapsulated-gf (thing args)
  (error "NOT YET")
  ; (print 'one)(print thing)(print args)
  ; thing is gf . %%1st-arg-dcode
  ; args is ok
  (let* ((dcode (cdr thing))
         (proto (assq dcode dcode-proto-alist))  ; <<
         (dt (%gf-dispatch-table (car thing))))
    (if proto ; assume all of these special dudes want args individually 
      (if (listp args)
        (apply dcode dt args)
        (%apply-lexpr dcode dt args))
      (funcall dcode dt args))))
    


;; the dcode function of the original gf has been bashed with a combined method whose
;; dcode function is this. So the combined method is called with 2 args (dispatch-table
;; and args to the gf). The combined method in turn makes a lexpr of those 2 args.

(defun %%call-gf-encapsulation (thing args)
  (error "NOT YET")
  ; (print 'two)(print thing)(print (if (listp args) args (collect-lexpr-args args 0)))
  ; thing traced-blitz  gf-blitz . %%1st-arg-dcode  
  ; args = dispatch-table . original-args
  ;  dont need dispatch-table - its just there as a side effect
  (if (listp args)  ; this probably never happens
    (let ((orig-args (cadr args)))
      (if (listp orig-args)
        (apply (car thing) orig-args)
        (%apply-lexpr (car thing) orig-args)))
    (let* ((orig-args (%lexpr-ref args (%lexpr-count args) 1)))
      (if (listp orig-args)
        (apply (car thing) orig-args)
        ; knee deep in lexprs
        (%apply-lexpr (car thing) orig-args)))))
    

(defun standard-generic-function-p (f)
  (typep f 'standard-generic-function))

(defun %fhave (sym fun)
  (setf (symbol-function sym) fun)
  fun)

(defun encapsulate (fn-spec old-def type trace-spec newsym
                            &optional advice-name advice-when)
  (let ((capsule (function-encapsulation fn-spec))
        gf-dcode old-encapsulation)
    (%fhave newsym
            (if (standard-generic-function-p old-def)  
		(progn (error "NOT YET")
		       (let ((dcode (%gf-dcode old-def)))
			 (setq gf-dcode
			       (if (and (combined-method-p dcode)
					(eq '%%call-gf-encapsulation
					    (function-name (%combined-method-dcode dcode))))
				   (let ((stuff (%combined-method-methods dcode)))
				     (setq old-encapsulation (car stuff))
				     (cdr stuff))
				   (cons old-def dcode)))
			 (setf (uvref old-def 0)(uvref *gf-proto* 0)) ; <<  gotta remember to fix it
			 (or old-encapsulation
			     (%cons-combined-method old-def gf-dcode #'%%call-encapsulated-gf))))
              old-def))                 ; make new symbol call old definition
    ;; move the encapsulation from fn-spec to sym    
    (cond (capsule (put-encapsulation newsym capsule)))    
    (put-encapsulation fn-spec
                       (make-encapsulation
                        :symbol newsym
                        :type type
                        :spec trace-spec
                        :advice-name advice-name
                        :advice-when advice-when))
    (values newsym gf-dcode)))
 

;; call with cap nil to remove - for symbol anyway
;; maybe advising methods is silly - just define a before method

(defun put-encapsulation (spec cap)
  (when cap
    (setf (encapsulation-owner cap) spec)
    (record-encapsulation cap)
    )
  (let ((key (typecase spec
               ((or symbol method standard-generic-function) spec)
               (cons (setf-function-spec-name spec))
               (t (report-bad-arg spec '(or symbol method cons))))))
    (if cap
      (setf (gethash key *encapsulation-table*) cap)
      (remhash key *encapsulation-table*)))
  cap)

(defmacro without-interrupts (&body body)
  `(progn ,@body))

(defun remove-encapsulation (capsule &optional dont-replace)
  ; optional don't replace is for unadvising, tracing all on a method
  (let (spec nextsym newdef def)
    (setq spec (encapsulation-owner capsule))
    (setq def (typecase spec
                (symbol (and (fboundp spec) (symbol-function spec)))
                (method spec)))
    (setq nextsym (encapsulation-symbol capsule))
    (setq newdef (and (fboundp nextsym) (symbol-function nextsym)))
    (without-interrupts
     (if (standard-generic-function-p def)
	 (progn (error "NOT YET")
	 (if (and (combined-method-p newdef)
                (eq '%%call-encapsulated-gf (function-name (%combined-method-dcode newdef))))
         (let* ((orig-decode (require-type (cdr (%combined-method-methods newdef)) 'function))
                (proto (cdr (assq orig-decode dcode-proto-alist)))
                ) ; <<
           (setf (%gf-dcode def) orig-decode)
           (setf (uvref def 0)(uvref (or proto *gf-proto*) 0)))
         (setf (car (%combined-method-methods (%gf-dcode def))) newdef)))
       (typecase spec
         (symbol (%fhave spec newdef))
         (method (error "NOT YET")
		 (setf (%method-function spec) newdef)
                 (remove-obsoleted-combined-methods spec)
                 newdef)))
     (put-encapsulation spec
                        (if (null dont-replace)
                          (function-encapsulation nextsym)))
     (put-encapsulation nextsym nil)
     (unrecord-encapsulation capsule)
     )))



(defun record-encapsulation (capsule)
  (ecase (encapsulation-type capsule)
    (trace
     (when (not (ext:memq capsule *trace-alist*))
       (push capsule *trace-alist*)))
    (advice
     (when (not (ext:memq capsule *advise-alist*))
       (push capsule *advise-alist*)))))

(defun delq (thing list)
  (delete thing list :test 'eq))

(defun unrecord-encapsulation (capsule)
  (ecase (encapsulation-type capsule)
    (trace
      (setq *trace-alist* (delq capsule *trace-alist*)))
    (advice
     (setq *advise-alist* (delq capsule *advise-alist*)))))


(defun find-unencapsulated-definition (spec)
  ;; spec is a symbol, function, or method object
  ;; returns a raw function ?? 
  (let (foo)
    (loop while (setq foo (function-encapsulation spec))
	 do (setq spec (encapsulation-symbol foo)))
    (values
    (typecase spec
      (symbol (and (fboundp spec) (symbol-function spec)))
      (method (%method-function spec))
      (t spec))
    spec)))

(defun %trace-fboundp (spec)
  (typecase spec
    (symbol (and (fboundp spec) (symbol-function spec)))
    (method (%method-function spec))))


(defun %trace-function-spec-p (spec &optional define-if-not)
  ;; weed out macros and special-forms
  (typecase spec
    (symbol
     (when (or (null spec)(special-operator-p spec)(macro-function spec))
       (error "Cannot trace or advise ~S." spec))
;     (cl-user::print-db (and (fboundp spec) (symbol-function spec)))
     (let ((res (or (and (fboundp spec) (symbol-function spec))
		    (and define-if-not
                                       (progn (warn "~S was undefined" spec)
                                              (%fhave spec (%function 'trace-null-def)))))))
       (when (not res)(error "~S is undefined." spec))
       (values res spec)))
    (method
     (values (%method-function spec) spec))
    (cons
     (case (car spec)
       (:method 
        (let ((gf (cadr spec))
              (qualifiers (butlast (cddr spec)))
              (specializers (car (last (cddr spec))))
              method)
          (require-type specializers 'list)
          (prog ()
            AGN
            (cond ((setq method
                         (find-method-by-names gf qualifiers specializers))
                   (return (values (%method-function method) method)))
                  (define-if-not
                    (when (define-undefined-method spec gf qualifiers specializers)
                      (go AGN)))
                  (t (error "Method ~s qualifiers ~s specializers ~s not found."
                            gf qualifiers specializers))))))
       (setf
        (let ((name-or-fn (setf-function-spec-name spec)))
          (cond ((symbolp name-or-fn)(%trace-function-spec-p name-or-fn))
                ((functionp name-or-fn) ; its anonymous - give it a name
                 (let ((newname (gensym)))
                   (newname %fhave name-or-fn)
                   (store-setf-method (cadr spec) newname)
                   (values name-or-fn newname))))))))))
    

(defun trace-null-def (&rest ignore)
  (declare (ignore ignore)))

(defun define-undefined-method (spec gf qualifiers specializers)
  (let (vars def)    
    (flet ((blob (e)
                 (let ((v (gensym)))
                   (push v vars)
                   (list v e))))
      (declare (dynamic-extent #'blob))
      (setq def
            (let ((lambda-list (mapcar #' blob specializers)))
              (eval
               `(defmethod ,gf ,@qualifiers (,@lambda-list &rest ignore)
                  (declare (ignore ignore ,@vars))))))
      (when def (warn "~S was undefined" spec))
      def)))

(defun %trace (sym &key before after step define-if-not)  
  (let (def newdef trace-thing)
    (multiple-value-setq (def trace-thing) 
      (%trace-function-spec-p sym define-if-not))
    (if def
      (let ()
        (when (%traced-p trace-thing)
          (%untrace-1 trace-thing)
          (setq def (%trace-fboundp trace-thing)))
        (when step   ; just check if has interpreted def
          (if (typep def 'standard-generic-function)
            (let ((methods (%gf-methods def)))
              ; should we complain if no methods? naah
              (dolist (m methods) ; stick :step-gf in advice-when slot
                (%trace m :step t)
                (let ((e (function-encapsulation m)))
                  (when e (setf (encapsulation-advice-when e) :step-gf))))
              ; we choose to believe that before and after are intended for the gf
              (if  (or before after)
                (setq step nil)                
                (return-from %trace)))
            #|(uncompile-for-stepping trace-thing nil t)|#))
        (let ((newsym (gensym "TRACE"))
              (method-p (typep trace-thing 'method)))
          (when (and (null before)(null after)(null step))
            (setq before #'trace-before)
            (setq after #'trace-after))
          (case before 
            (:print (setq before #'trace-before)))
          (case after
            (:print (setq after #'trace-after)))
          (setq newdef (trace-global-def 
                        sym newsym before after step method-p))
          (when method-p
            (copy-method-function-bits def newdef))
          (without-interrupts
           (multiple-value-bind (ignore gf-dcode) (encapsulate trace-thing def 'trace sym newsym)
             (declare (ignore ignore))
             (cond (gf-dcode 
                    (setf (%gf-dcode def)
                          (%cons-combined-method def (cons newdef gf-dcode) #'%%call-gf-encapsulation)))
                   ((symbolp trace-thing) (%fhave trace-thing newdef))
                   ((typep trace-thing 'method)
                    (setf (%method-function trace-thing) newdef)
                    (remove-obsoleted-combined-methods trace-thing)
                    newdef))))))
      (error "Trace does not understand ~S." sym))))

;; sym is either a symbol or a method

(defun %traced-p (sym)
  (let ((foo (function-encapsulation sym)))
    (and foo (eq (encapsulation-type foo) 'trace))))

(defmacro untrace (&rest syms)
  "Remove tracing from the specified functions. With no args, untrace all
   functions."
  (if syms
    `(%untrace-0 ',syms)
    `(%untrace-all)))

(defun %untrace-0 (syms)
  (let (val x)
    (dolist (symbol syms)
      (setq x (%untrace symbol))
      (when x (push x val)))
    val))


(defun %untrace (sym)
  (when (and (consp sym)(consp (car sym)))
    (setq sym (car sym)))
  (multiple-value-bind (def trace-thing) (%trace-function-spec-p sym)
    (let (val)
      (when (typep def 'standard-generic-function)
        (let ((methods (%gf-methods def)))
          (dolist (m methods)
            (let ((e (function-encapsulation m)))
              (when (and e (eq (encapsulation-advice-when e) :step-gf))
                (remove-encapsulation e)
                (push m  val))))))
      ; gf could have first been traced :step, and then just plain traced
      ; maybe the latter trace should undo the stepping??
      (when (%traced-p trace-thing)
        (%untrace-1 trace-thing)
        (push trace-thing val))
      (if (null (cdr val))(car val) val))))

(defun %untrace-all ()
  (let ((val nil))
    (dolist (cap *trace-alist*)
      (push (encapsulation-spec cap) val)
      (remove-encapsulation cap))
    val))

;; thing is a symbol or method - def is current definition
;; we already know its traced
(defun %untrace-1 (thing)
  (let (capsule)
    (setq capsule (function-encapsulation thing))
    ;; trace encapsulations must be first      
    (when (not (eq (encapsulation-type capsule) 'trace))
      (error "~S was not traced." thing))
    (remove-encapsulation capsule)
    (encapsulation-spec capsule)))


(defmacro trace (&rest syms)
  "TRACE {Option Global-Value}* {Name {Option Value}*}*

TRACE is a debugging tool that provides information when specified
functions are called."
  (if syms
    `(%trace-0 ',syms)
    `(%trace-list)))

(defun %trace-0 (syms)
  (dolist (symbol syms)
       (cond ((consp symbol)
              (cond ((null (cdr symbol))
                     (%trace (car symbol) :before :print :after :print))
                    ((ext:memq (car symbol) '(:method setf))
                     (%trace symbol :before :print :after :print))
                    (t (apply #'%trace symbol))))
             (t (%trace symbol :before :print :after :print)))))

(defun %trace-list ()
  (let (res)
    (dolist (x *trace-alist*)
      (push (encapsulation-spec x) res))
    res))


;; this week def is the name of an uninterned gensym whose fn-cell is original def

(defun trace-global-def (sym def before after step &optional method-p)
  (let ((saved-method-var (gensym)) do-it step-it)
    (when step
      (setq step-it            
            `(step-apply-simple ',def args)))
    (setq do-it
          (cond (step
                 (if (eq step t)
                   step-it
                   `(if (apply ',step ',sym args) ; gaak
                      ,step-it
                      ,(if (and before method-p)
                         `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
                         `(apply ',def args)))))
                (t (if (and before method-p)
                     `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
                     `(apply ',def args)))))
    (flet ((quoted-p (x)
             (and (consp x)
                  (case (car x)
                    ((function quote) t)))))
      (compile-named-function-warn
       `(lambda (,@(if (and before method-p)
                     `(&method ,saved-method-var))
                 &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
          (declare (dynamic-extent args))
          (let ((*trace-level* (1+ *trace-level*)))
            (declare (special *trace-enable* *trace-level*))
            ,(if before
               `(when *trace-enable*
                  (let* ((*trace-enable* nil))
                    ,(cond
                      ((eq before :break)
                       `(progn (apply #'trace-before ',sym args)
                               (break "~S" args)))
                      (t `(apply ,(if (quoted-p before) before `',before) ',sym args))))))           
            ,(if after
               `(let ((vals (multiple-value-list ,do-it)))
                  (when *trace-enable*
                    (let* ((*trace-enable* nil))
                      ,(cond ((eq after :break)
                              `(progn
                                 (apply #'trace-after ',sym vals)
                                 (break "~S" vals)))
                             (t `(apply ,(if (quoted-p after) after `',after) ',sym  vals)))))
                  (values-list vals))
               do-it)))
       `(traced ,sym)))))

; &method var tells compiler to bind var to contents of next-method-context
(defun advise-global-def (function-spec def when stuff &optional method-p)
  (declare (ignore function-spec))
  (let* ((saved-method-var (gensym)))
    (compile nil
    `(lambda (,@(if (and method-p (not (eq when :after)))
                  `(&method ,saved-method-var))
              &rest arglist)
       (declare (dynamic-extent arglist))
       (let ()
         ,(ecase
            when
            (:before
             `(block nil
                ,stuff                  
                (return ,(if method-p
                           `(apply-with-method-context ,saved-method-var (symbol-function ',def) arglist)
                           `(apply ',def arglist)))))
            (:after         
             `(block nil
                (let ((values (multiple-value-list (apply (function ,def) arglist))))
                  (declare (dynamic-extent values))
                  ,stuff
                  (return (values-list values)))))
            (:around
             ;; stuff is e.g. (+ 5 (:do-it))
             (if method-p 
               `(macrolet ((:do-it ()
                             `(apply-with-method-context ,',saved-method-var 
                                                         (symbol-function ',',def)
                                                         arglist)))
                  (block nil
                    (return  ,stuff)))
               `(macrolet ((:do-it ()
                             `(apply (function ,',def) arglist)))
                  (block nil
                    (return  ,stuff)))))))))))


(defun compile-named-function-warn (fn name)
  (multiple-value-bind (result warnings)(compile nil fn)    
    (SYSTEM::%SET-LAMBDA-NAME  result name)
    (when warnings 
      (let ((first t))
        (dolist (w warnings)
          (signal-compiler-warning w first nil nil nil)
          (setq first nil))))
    result))

;; want to look like
;; (setq values (multiple-value-list (progn ,@frob)))
     
       
(defun %advised-p (thing &optional when advice-name quick)
  ;; thing is a symbol, result is list of encapsulations
  ;; Quick when used as a simple predicate
  (let ((nx thing) cap val)
    (loop while (setq cap (function-encapsulation nx))
	 do (when (eq (encapsulation-type cap) 'advice)
        (if quick (return-from %advised-p cap))
        (when (or (and (null when)(null advice-name))
                  (and (eq when (encapsulation-advice-when cap))
                       (equal advice-name (encapsulation-advice-name cap))))
          (push cap val)))
	 (setq nx (encapsulation-symbol cap)))
    val))  


(defun advise-2 (newdef newsym method-p function-spec when advice-name define-if-not)      
  (let (advise-thing def orig-sym orig-def)
    (multiple-value-setq (def advise-thing) 
      (%trace-function-spec-p function-spec define-if-not))
    (when (not def)(error "Advise does not understand ~s." function-spec))
    (when (%traced-p advise-thing)
      (setq orig-sym
            (encapsulation-symbol (function-encapsulation advise-thing)))
      (setq orig-def (and (fboundp orig-sym) (symbol-function orig-sym))))
    (let ((capsules (%advised-p advise-thing when advice-name)))
      (when capsules 
        (unadvise-capsules capsules)
        ; get the right def you fool!
        (setq def (%trace-function-spec-p function-spec))))
;    (cl-user::print-db orig-def def)
    (without-interrupts 
     (multiple-value-bind (ignore gf-dcode)
                          (encapsulate (or orig-sym advise-thing) (or orig-def def) 
                                       'advice function-spec newsym
                                       advice-name when)
       (declare (ignore ignore))
       (SYSTEM::%SET-LAMBDA-NAME  newdef `(advised ',function-spec))
       (if method-p (copy-method-function-bits def newdef))
       (if gf-dcode (setq newdef (%cons-combined-method def (cons newdef gf-dcode)
                                                        #'%%call-gf-encapsulation)))                     
;       (cl-user::print-db 'here)
       (cond (orig-sym
              (%fhave orig-sym newdef))  ; make traced call advised
             (t  (cond (gf-dcode (setf (%gf-dcode def) newdef))
                       ((symbolp advise-thing)
                        (%fhave advise-thing newdef))
                       ((typep advise-thing 'method)
                        (progn 
                          (setf (%method-function advise-thing) newdef)
                          (remove-obsoleted-combined-methods advise-thing)
                          newdef)))))))))

;; workaround the fact that you can't compile a function named by a gensym in abcl
(defpackage ".advise")
(defvar *advise-counter* 0)

(defun advise-gensym (function)
  (loop for sym = (intern (format nil "~a-ADVICE-~a" function (incf *advise-counter*)) '|.advise|)
     until (not (fboundp sym)) 
     finally (return sym)))

(defmacro advise (function form &key (when :before) name define-if-not)
  (let* ((newsym (advise-gensym function))
         ; WAS typep advise-thing 'method
         (method-p (or (typep function 'method) ; can this happen?
                       (and (consp function)(eq (car function) :method))))
         (newdef (advise-global-def function newsym when form method-p)))
      `(advise-2 ,newdef ',newsym ,method-p ',function ',when ',name
                 ,define-if-not)))

(defmacro advisedp (function-spec &key when name)
  `(advisedp-1 ',function-spec ',when ',name))

(defun advisedp-1 (function-spec when name)
  (let (val)
    (flet ((xtract-capsule (c)
             (list (encapsulation-spec c)
                   (encapsulation-advice-when c)
                   (encapsulation-advice-name c))))
      (cond ((eq t function-spec)
             (dolist (c *advise-alist*)
               (when (and
                      (or (null when)(eq when (encapsulation-advice-when c)))
                      (or (null name)(equal name (encapsulation-advice-name c))))
                 (push (xtract-capsule c) val))))
            (t (let* ((advise-thing (nth-value 1  (%trace-function-spec-p function-spec)))
                      (capsules (%advised-p advise-thing when name)))
                 (dolist (capsule capsules)
                   (push (xtract-capsule capsule) val)))))
      val)))               


(defun unadvise-1 (function-spec &optional when advice-name ignore)
  (declare (ignore ignore))
  (let ((advise-thing (nth-value 1 (%trace-function-spec-p function-spec))))
    (let ((capsules (%advised-p advise-thing when advice-name)))
      (when capsules (unadvise-capsules capsules)))))

(defun unadvise-capsules (capsules)
  (let (val)
    (dolist (capsule capsules)
        (push (list (encapsulation-spec capsule)
                    (encapsulation-advice-when capsule)
                    (encapsulation-advice-name capsule))
              val)
        (remove-encapsulation capsule))
    val))

(defmacro unadvise (function &key when name)
  (cond ((not (eq function t))
         `(unadvise-1 ',function ',when ',name))
        (t '(%unadvise-all))))

(defun %unadvise-all ()
  (unadvise-capsules *advise-alist*))

(defun %set-unencapsulated-definition (spec newdef)
  (let (foo)
    (loop while (setq foo (function-encapsulation spec)) 
       do (setq spec (encapsulation-symbol foo)))
    (typecase spec
      (symbol
       (%fhave spec newdef)) ;; or fset ??  
      (method
       (setf (%method-function spec) newdef)
       (remove-obsoleted-combined-methods spec)
       newdef))))


;; return t if we defined it, nil otherwise

(defun %defun-encapsulated-maybe (name newdef)
  (let ((def (and (fboundp name) (symbol-function name))))
    (when (and def (function-encapsulated-p name))
      (cond ((or *loading-files* (typep def 'standard-generic-function))
             (forget-encapsulations name)
             nil)
            (t (%set-unencapsulated-definition name newdef)
               T)))))

(defun %move-method-encapsulations-maybe (oldmethod newmethod)
  ;; deal with method redefinition
  (let (cap newdef olddef old-inner-def)
    (when (and (setq cap (function-encapsulation oldmethod))
               (not (eq oldmethod newmethod)))      
      (cond (*loading-files*
             (when (%traced-p oldmethod)
               (warn "~%... Untracing ~s" (%untrace-1 oldmethod)))
             (when (%advised-p oldmethod nil nil t)
               (format t "~%... Unadvising ~s" (unadvise-1 oldmethod))))
            (t (setq newdef (%method-function newmethod))
               (setq olddef (%method-function oldmethod))
               (setq old-inner-def (find-unencapsulated-definition oldmethod))
               ;; make last encapsulation call new definition            
               (%set-unencapsulated-definition oldmethod newdef)
               (setf (%method-function newmethod) olddef)
               (remove-encapsulation cap t)
               (put-encapsulation newmethod cap)
               (setf (%method-function oldmethod) old-inner-def)
               (advise-set-method-bits newmethod newdef)
               )))))

(defun advise-set-method-bits (spec newdef)
  ;; spec is a symbol, function, or method object
  (let (foo)
    (loop while (setq foo (function-encapsulation spec)) 
       do      
       (let ((def (typecase spec
		    (symbol (and (fboundp spec) (symbol-function spec)))
		    (method (%method-function spec))
		    (t nil))))
	 (if def
	     (copy-method-function-bits newdef def)
	     (error "whats going on here anyway"))))
    (setq spec (encapsulation-symbol foo))))


#|
	Change History (most recent last):
	2	12/29/94	akh	merge with d13
|# ;(do not edit past this line!!)