home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / interfaces / Emacs-cl-shell / advise.el next >
Encoding:
Text File  |  1990-04-18  |  7.8 KB  |  223 lines
  1. ;;; $Header: /tmp_mnt/am/p7/utility/gmacs/f2/RCS/advise.el,v 1.2 89/03/25 14:00:55 kahle Exp $
  2.  
  3. ;;;
  4. ;;;                NO WARRANTY
  5. ;;;
  6. ;;; This software is distributed free of charge and is in the public domain.
  7. ;;; Anyone may use, duplicate or modify this program.  Thinking Machines
  8. ;;; Corporation does not restrict in any way the use of this software by
  9. ;;; anyone.
  10. ;;; 
  11. ;;; Thinking Machines Corporation provides absolutely no warranty of any kind.
  12. ;;; The entire risk as to the quality and performance of this program is with
  13. ;;; you.  In no event will Thinking Machines Corporation be liable to you for
  14. ;;; damages, including any lost profits, lost monies, or other special,
  15. ;;; incidental or consequential damages arising out of the use of this program.
  16. ;;;
  17. ;;; 9/18/88
  18. ;;;
  19.  
  20. ;;This is an advise for gmacs lisp
  21. ;; roughly based on jim salem's common-lisp advise
  22. ;; in /cm/utilities/f5100/macros.lisp (if anyone wants the cl version,
  23. ;; write to brewster@think.com)
  24. ;;
  25. ;; -brewster
  26. ;;
  27. ;;; Using this advise is like using the lispm advise.
  28. ;;;  (advise foo :before (print 'this-is-before-foo-is-called))
  29. ;;;  (advise foo :after (print 'this-is-after-foo-is-called))
  30. ;;;  (advise foo :around (progn (print 'this-is-before-foo-is-called)
  31. ;;;                             :do-it
  32. ;;;                             (print 'this-is-after-foo-is-called))
  33. ;;;  
  34. ;;;  The arguments to the function being called can be accessed
  35. ;;;    by looking at the binding of arglist.
  36. ;;;  The return values can be modified by :around and :after code
  37. ;;;    by setq-ing VALUES with the list of the return values 
  38. ;;;    (it has to be a list even if it is just 1 value)
  39. ;;;
  40. ;;;
  41. ;;;  Unadvise (&optional function) works only on functions that have 
  42. ;;;    been advised 
  43. ;;;    with this advise.  It will replace the original function definition.
  44. ;;;    thus if a function is advised twice, the original will
  45. ;;;    be restored upon the call to unadvise.
  46. ;;;    If the function has been recompiled some other way, 
  47. ;;;    then the function will still be replaced with the function that 
  48. ;;;    was bound the first time advise was
  49. ;;;    called.  This seems like a bug and maybe should be fixed.
  50. ;;;    -brewster
  51. ;;; 
  52. ;;;  Test-Unadvise ()  is a simple test to see if advise and
  53. ;;;    unadvise work at all.
  54. ;;;    This is meant to be a verifier.  This should be run on other lisps.
  55. ;;;    This has been verified on a symbolics machine, lucid, and gmacs lisp.
  56.  
  57. (require 'cl)
  58. (provide 'advise)
  59.  
  60. (defvar *all-advise* nil "a list of lists of function-symbol class and forms")
  61.  
  62. (defun member-equal (item list)
  63.   "[cl] MEMBER ITEM LIST => Is ITEM in LIST?  Uses equal on the cars of LIST."
  64.   (let ((ptr list)
  65.         (done nil)
  66.         (result '()))
  67.     (while (not (or done (endp ptr)))
  68.       (cond ((equal item (car ptr))
  69.              (setq done t)
  70.              (setq result ptr)))
  71.       (setq ptr (cdr ptr)))
  72.     result))
  73.  
  74. (defmacro advise (function-symbol class &rest forms)
  75.   "Using this advise is like using the lispm advise.
  76.   (advise foo :before (print 'this-is-before-foo-is-called))
  77.   (advise foo :after (print 'this-is-after-foo-is-called))
  78.   (advise foo :around (progn (print 'this-is-before-foo-is-called)
  79.                              :do-it
  80.                              (print 'this-is-after-foo-is-called))"
  81.   (`
  82.    (let ((descriptor-list '((, function-symbol) (, class) (, forms))))
  83.      (unless (member-equal descriptor-list *all-advise*)
  84.        (add-advise-internal '(, function-symbol) '(, class) '(, forms))
  85.        (push descriptor-list *all-advise*)))))
  86.  
  87. (defun add-advise-internal (function class list-of-forms)
  88.   "returns the new function"
  89.   ;;this is for unadvise
  90.   (let* ((old-function-cell (symbol-function function))
  91.      (autoload-file (and (listp old-function-cell)
  92.                  (eq (car old-function-cell) 'autoload)
  93.                  (cadr old-function-cell)))
  94.      )
  95.     (if (not (get function ':original-function))
  96.     (setf (get function ':original-function) old-function-cell))
  97.     (setf (symbol-function function)
  98.       (cond (autoload-file
  99.          (` (lambda (&rest arglist)
  100.               (, (if (commandp function)
  101.                  '(interactive)
  102.                  nil))
  103.               (load (, autoload-file))
  104.               (add-advise-internal
  105.                '(, function) '(, class) '(, list-of-forms))
  106.               (if (interactive-p)
  107.               (call-interactively '(, function))
  108.               (apply '(, function) arglist)
  109.               ))))
  110.         (t;; not autoload
  111.          (ecase class
  112.            (:after
  113.             (` (lambda (&rest arglist)
  114.              (, (if (commandp function)
  115.                 '(interactive)
  116.                 nil))
  117.              (let ((values
  118.                 (multiple-value-list 
  119.                     (if (interactive-p)
  120.                     (call-interactively
  121.                      '(, old-function-cell))
  122.                     (apply '(, old-function-cell) arglist))))
  123.                    (progn 0);;this is here so that when
  124.             ;;;the bug in ` is fixed, this will still work.
  125.                    )
  126.                (,@ list-of-forms)
  127.                progn;;this is here because of a bug in `
  128.                (values-list values)
  129.                ))))
  130.            (:before
  131.             (` (lambda (&rest arglist)
  132.              (, (if (commandp function)
  133.                 '(interactive)
  134.                 nil))
  135.              (,@ list-of-forms)
  136.              (if (interactive-p)
  137.                  (call-interactively
  138.                   '(, old-function-cell))
  139.                  (apply '(, old-function-cell) arglist)))))
  140.            (:around
  141.             (` (lambda (&rest arglist)
  142.              (, (if (commandp function)
  143.                 '(interactive)
  144.                 nil))
  145.              (let (values 
  146.                    (progn 0);;this is here so that
  147.                    ;;when the bug in ` is fixed, this will still work.
  148.                    )
  149.                (,@ (change-do-it-to-funcall 
  150.                 list-of-forms
  151.                 old-function-cell
  152.                 (interactive-p)))
  153.                progn;;this is here because of a bug in `
  154.                (values-list values)))))))))))
  155.  
  156. (defun change-do-it-to-funcall (list-of-forms old-function-cell
  157.                           interactive-p)
  158.   (cond ((eq list-of-forms ':do-it)
  159.      (` (setq values (multiple-value-list
  160.                  (if (interactive-p)
  161.                  (call-interactively
  162.                    '(, old-function-cell))
  163.                  (apply '(, old-function-cell) arglist))))))
  164.     ((atom list-of-forms) list-of-forms)
  165.     (t (cons (change-do-it-to-funcall
  166.            (car list-of-forms) old-function-cell interactive-p)
  167.          (change-do-it-to-funcall
  168.            (cdr list-of-forms) old-function-cell interactive-p)))))
  169.  
  170.  
  171. ;;;***************************************************************************
  172. ;;; Unadvise
  173. ;;;***************************************************************************
  174. ;;;
  175. ;;; this does not find out if you recompiled the function since advising.
  176. ;;; This will restore the state of the function to before it was advised.
  177. ;;;  (this might want to be fixed)
  178.  
  179. (defun unadvise (function)
  180.   "this removes all advise from the specified function."
  181.   (unadvise-function function))
  182.  
  183. (defun unadvise-function (function)
  184.   (cond ((and (not (assoc function *all-advise*))  ;;not on *all-advise*
  185.           (not (get function ':original-function)))
  186.      t ;;nothing to do
  187.      )
  188.     ((and (assoc function *all-advise*)  ;;on *all-advise*
  189.           (not (get function ':original-function)))
  190.      (delete-advise function)
  191.      (error "Function %s seemed to have been advised, but the original function was not saved.
  192. Can not unadvise" function))
  193.     ((get function ':original-function)
  194.      (setf (symbol-function function) (get function ':original-function))
  195.      (setf (get function ':original-function) nil)
  196.      (delete-advise function))))
  197.  
  198. (defun delete-advise (function)
  199.   (let ((new-list nil))
  200.     (dolist (i *all-advise*)
  201.       (if (not (eq function (car i)))
  202.       (push i new-list)))
  203.     (setq *all-advise* (reverse new-list))))
  204.  
  205.  
  206. (defun test-unadvise ()
  207.   (unadvise 'test-unadvise-dummy)
  208.   (defun test-unadvise-dummy (x) x)
  209.   (if (not (eql 5 (test-unadvise-dummy 5)))
  210.       (error "test-unadvise-dummy: %s didnt compile right" (test-unadvise-dummy 5)))
  211.   (advise test-unadvise-dummy :after (setq values '(7)))
  212.   (if (not (eql 7 (test-unadvise-dummy 5)))
  213.       (error "test-unadvise-dummy: %s didnt advise right, should be 7" (test-unadvise-dummy 5)))
  214.   (unadvise 'test-unadvise-dummy)
  215.   (if (not (eql 5 (test-unadvise-dummy 5)))
  216.       (error "test-unadvise-dummy: %s didnt unadvise right" (test-unadvise-dummy 5))))
  217.  
  218.  
  219.  
  220.  
  221.  
  222.  
  223.