home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume11 / test.el / part01 / tst-instrument.el < prev   
Lisp/Scheme  |  1987-09-08  |  6KB  |  212 lines
  1. ;;; tst-instrument
  2. ;;; Copyright 1987 Richard Rosenthal
  3. ;;; All rights reserved.
  4.  
  5. (provide 'tst-instrument)
  6. (require 'tst-annotate)
  7.  
  8. (defvar *tst-last-instrumented-line* 0
  9.   "Defined in instrument.el.  Used in the following functions:
  10.      tst-instrument-defun
  11.      tst-instrument-primitive")
  12.  
  13. (defun tst-instrument ()
  14.   "The tst-instrument function creates a buffer containing a copy of
  15. the buffer in which the function was invoked.  All code in the copied
  16. buffer is then instrumented and compiled.  We are talking about
  17. compiling LISP code."
  18.   (interactive)
  19.   (let* ((old-buffer (buffer-name))
  20.      (instrumented-buffer
  21.       (get-buffer-create (concat old-buffer "-instrumented"))))
  22.     (save-excursion
  23.       (set-buffer instrumented-buffer)
  24.       (emacs-lisp-mode)
  25.       (erase-buffer)
  26.       (insert-buffer old-buffer)
  27.       (tst-ann-set-db nil)
  28.       (tst-instrument-region (point-min) (point-max))
  29.       (eval-current-buffer)
  30.       (message "Done"))))
  31.  
  32.  
  33. (defun tst-instrument-region (start end)
  34.   (interactive "r")
  35.   (save-restriction
  36.     (narrow-to-region start end)
  37.     (goto-char (point-min))
  38.     (or (looking-at "\\s( *defun\\b") (beginning-of-next-defun))
  39.     (while (< (point) (point-max))
  40.       (tst-instrument-defun)
  41.       (beginning-of-next-defun))))
  42.  
  43.  
  44. (defun tst-instrument-defun ()
  45.   (save-excursion
  46.     (save-restriction
  47.       (push-mark (point) 'nomsg)
  48.       (setq *tst-last-instrumented-line* (line-number))
  49.       (if (error-occurred (forward-sexp 1))
  50.       (progn
  51.         (goto-char (point-max))
  52.         nil)
  53.     (narrow-to-region (mark) (point))
  54.     (goto-char (point-min))
  55.     (down-list 1)
  56.     (next-sexp)            ;looking at defun
  57.     (beginning-of-next-sexp)    ;looking at function name
  58.     (let ((start (point))
  59.           end)
  60.       (forward-sexp 1)
  61.       (setq end (point))
  62.       (backward-sexp 1)
  63.       (message "Instrumenting (defun %s..." (buffer-substring start end))
  64.       )
  65.     (beginning-of-next-sexp)    ;looking at parameter list
  66.     (beginning-of-next-sexp)    ;looking at comment?
  67.     (if (looking-at "\\s\"")
  68.         (beginning-of-next-sexp))    ;looking at parameter list
  69.  
  70.     ;; now looking at first statement in defun
  71.     (while (< (point) (point-max))
  72.       (cond
  73.        ((looking-at "\\s(")
  74.         (tst-instrument-function))
  75.  
  76.        ;;inside a comment
  77.        ((nth 4 (parse-partial-sexp (point-min) (point) nil nil nil))
  78.         (end-of-line)
  79.         (next-sexp))
  80.  
  81.        (t
  82.         (beginning-of-next-sexp))))
  83.     t))))
  84.  
  85.  
  86. (defun tst-instrument-function ()
  87. ;;;at this point, I was definitly looking at a left "(".
  88.   (cond
  89.    ((tst-looking-at-prohibited-form-p)
  90.     (beginning-of-next-sexp))        ;do nothing, skip it
  91.  
  92.    ((tst-looking-at-special-form-p)
  93.     (tst-instrument-primitive)        ;instrument around it
  94.     (tst-instrument-special-form))    ;try to go in it
  95.  
  96.    (t
  97.     (tst-instrument-primitive)        ;instrument around it
  98.       (down-list 1))))            ;go in it
  99.  
  100. (defun tst-looking-at-prohibited-form-p ()
  101.   (cond
  102.    ((looking-at "\\s( *interactive\\b") t)
  103.    ((looking-at "\\s( *quote\\b") t)
  104.    ((looking-at "\\s'\\s(") t)
  105.    (t nil)))
  106.  
  107. (defun tst-looking-at-special-form-p ()
  108.   "List potential trouble makers in this function"
  109.   (cond
  110.    ((looking-at "\\s( *cond\\b") t)
  111.    ((looking-at "\\s( *function\\b") t)
  112.    ((looking-at "\\s( *let\\b") t)
  113.    ((looking-at "\\s( *progn\\b") t)
  114.    (t nil)))
  115.  
  116. (defun tst-instrument-special-form ()
  117.   "Explain how to deal with known trouble makers in this function"
  118.   (cond
  119.    ((looking-at "\\s( *let\\b")        ;minor problem
  120.     (tst-instrument-let))
  121.    ((looking-at "\\s( *progn\\b")    ;no problem
  122.     (down-list 1))
  123.    (t                    ;skip forms I don't know about
  124.     (beginning-of-next-sexp))))
  125.  
  126. (defun tst-instrument-primitive ()
  127.   (let ((start (line-number)))
  128.     (if (> start *tst-last-instrumented-line*)
  129.     (progn
  130.       (setq *tst-last-instrumented-line* start)
  131.       (insert "(tst-cover " (int-to-string start) " ")
  132.       (forward-sexp 1)
  133.       (insert ")")
  134.       (backward-char 1)
  135.       (backward-sexp 1)
  136.       (tst-ann-append start 'count '(0))))))
  137.  
  138.  
  139. (defun tst-instrument-let ()
  140.   (down-list 1)
  141.   (next-sexp)                ;looking at let
  142.   (beginning-of-next-sexp)        ;looking at parameter list
  143.   (forward-sexp 1)            ;skip parameters for now
  144.   (next-sexp))
  145.  
  146.  
  147. ;;;----------------------------------------------------------------------------
  148. (defun tst-cover (id arg)
  149.   "Version 2:  for testing, display arg in mini-buffer while
  150. moving cursor around buffer"
  151.   (save-excursion
  152.     (goto-line id)
  153.     (re-search-forward "\\s(")
  154.     (message "function returns %s" (prin1-to-string arg))
  155.     (sit-for 2)
  156.     )
  157.   arg)
  158.  
  159. (defun tst-cover (id arg)
  160.   "Version 1:  for testing, display id and arg in mini-buffer"
  161.   (message "tst-cover %d %s" id (prin1-to-string arg))
  162.   (sit-for 0)
  163.   arg)
  164.  
  165. (defun tst-cover (id arg)
  166.   "Version 0:  for testing, does nothing"
  167.   arg)
  168.  
  169. (defun tst-cover (id arg)
  170.   "The Real Thing:  uses annotation capabilities"
  171.   (tst-ann-inc id 'count)
  172.   (tst-ann-append id 'values (list arg))
  173.   arg)
  174.  
  175.  
  176. ;;;============================================================================
  177. (defun beginning-of-next-defun ()
  178.   "This function finds LISP defun"
  179.   (if (= (point) (point-max))
  180.       nil
  181.     (forward-char 1)
  182.     (and (re-search-forward "\\s( *defun\\b" nil 'move 1)
  183.      (re-search-backward "\\s("))))
  184.  
  185. (defmacro error-occurred (&rest body)
  186.   "As defined in mlsupport.el"
  187.   (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
  188.  
  189. (defun line-number ()
  190.   "Return line number of current line.  Gives consistent results."
  191.   (count-lines-correctly 1 (point)))
  192.  
  193. (defun count-lines-correctly (start end)
  194.   "Return number of newlines between START and END.  Gives
  195. consistent results."
  196.   (save-excursion
  197.     (save-restriction
  198.       (goto-char end)
  199.       (end-of-line)
  200.       (narrow-to-region start (point))
  201.       (goto-char (point-min))
  202.       (- (buffer-size) (forward-line (buffer-size))))))
  203.  
  204. (defun next-sexp ()
  205.   (while (error-occurred (forward-sexp))
  206.     (forward-char 1))
  207.   (or (= (point) (point-max)) (backward-sexp)))
  208.  
  209. (defun beginning-of-next-sexp ()
  210.   (forward-sexp 1)
  211.   (next-sexp))
  212.