;;;-*-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!!)