home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume11 / test.el / part01 / tst-display.el next >
Encoding:
Text File  |  1987-09-08  |  12.2 KB  |  398 lines
  1. ;;; display.el - GnuTest Display Package
  2. ;;; Copyright (c) 1987 Wang Institute of Graduate Studies
  3. ;;; Andy Bliven <bliven@wanginst>
  4.  
  5. (provide 'tst-display)
  6. (require 'tst-annotate)
  7.  
  8. ;;; ----------------------------------------------------------------------
  9. ;;; Public Variables--
  10.   
  11. (defconst tst-display-window-width 10
  12.   "*  Width of each display window, in columns")
  13.   
  14. (defconst tst-display-attributes (list 'zero 'constant)
  15.   "*  List of attributes to be displayed in batch mode.")
  16.  
  17. ;;; ----------------------------------------------------------------------
  18. ;;; Private Variables--
  19.   
  20. (defvar tst-display-buffer-alist nil
  21.   "An alist of attribute names and buffer objects")
  22.   
  23. (defvar tst-display-lisp-buffer nil
  24.   "The buffer of emacs lisp code that has been annotated.")
  25.   
  26. (defvar tst-display-lisp-window nil
  27.   "The window containing emacs lisp code.")
  28.   
  29. (defvar tst-display-mode-map nil
  30.   "Keymap for GnuTest Display major mode.")
  31. (or tst-display-mode-map
  32.     (progn
  33.       (setq tst-display-mode-map (make-keymap))
  34.       (suppress-keymap tst-display-mode-map) ; requires full keymap, not sparse
  35.                     ; key definitions
  36.       (define-key tst-display-mode-map "\C-n"    'tst-display-next-line)
  37.       (define-key tst-display-mode-map "\C-p"    'tst-display-previous-line)
  38.       (define-key tst-display-mode-map "\C-v"    'tst-display-scroll-up)
  39.       (define-key tst-display-mode-map "\M-v"     'tst-display-scroll-down)
  40.       (define-key tst-display-mode-map "\C-c\C-h" 'tst-display-mode-help)
  41.       (define-key tst-display-mode-map "\C-cc"   'tst-display-constant)
  42.       (define-key tst-display-mode-map "\C-cl"   'tst-display-redraw)
  43.       (define-key tst-display-mode-map "\C-cn"   'tst-display-next)
  44.       (define-key tst-display-mode-map "\C-cp"   'tst-display-previous)
  45.       (define-key tst-display-mode-map "\C-cq"   'tst-display-mode-exit)
  46.       (define-key tst-display-mode-map "\C-cz"   'tst-display-zero)
  47.       )
  48.     )
  49.   
  50. (defvar tst-display-window-alist nil
  51.   "An alist of attribute names and window objects")
  52.  
  53. (defvar tst-batch-results "tst-batch-results"
  54.   "* a kluge")
  55.  
  56. (defvar tst-display-saved-variables nil
  57.   "The property list of this variable contains values of all variables
  58.    saved on entry to tst-display-mode.")
  59.   
  60.  
  61.  
  62. ;;; ----------------------------------------------------------------------
  63. ;;; Public Functions--
  64.   
  65. (defun tst-display-batch (&optional lisp-buffer)
  66.   "   Batch mode execution of the annotation display package.  Writes the
  67.    summary reports 'zero' and 'constant' generated by the tst-analyze
  68.    package into a 'compilation' style buffer named '*compilation*'.  If
  69.    called interactively this is available for viewing with the '^X`' key,
  70.    otherwise it is saved to the file named in tst-batch-results.  If
  71.    LISP-BUFFER is not specified, current-buffer is used instead as the
  72.    label on each line of the report."
  73.   (interactive)
  74.                     ; body
  75.   (let ((lisp-buffer (or lisp-buffer (current-buffer)))
  76.     (save-window (selected-window)))
  77.     (pop-to-buffer "*compilation*")
  78.     (erase-buffer)
  79.     (insert "# GnuTest analysis of " (buffer-name lisp-buffer) "\n"
  80.         "#   (lines which were never evaluated during tests or returned\n"
  81.         "#    the same value every time they were evaluated.)\n")
  82.     (mapcar '(lambda (line)
  83.            (insert (tst-display-batch-string lisp-buffer
  84.                          line
  85.                          'zero
  86.                          'constant)))
  87.         (tst-ann-get-lines))
  88.     (if (interactive-p)
  89.     (progn
  90.       (goto-char (point-min))    ; top of results buffer
  91.       (switch-to-buffer "*compilation*")
  92.       (select-window save-window)    ; go back to original window
  93.       )
  94.       ;; else
  95.       (write-file tst-batch-results) ; write buffer to disk
  96.       )
  97.     )
  98.   )
  99.   
  100. (defun tst-display-mode ()
  101.   "*  Major mode for displaying GnuTest annotation with associated
  102.    emacs-lisp code buffer.  Precondition:  tst-instrument and tst-analyze
  103.    have already been evaluated for this buffer.
  104.    C-n     tst-display-next-line        
  105.    C-p     tst-display-previous-line    
  106.    C-v     tst-display-scroll-up        
  107.    M-v     tst-display-scroll-down      
  108.    C-c C-h tst-display-mode-help
  109.    C-c c   tst-display-constant
  110.    C-c l   tst-display-redraw           
  111.    C-c n   tst-display-next
  112.    C-c p   tst-display-previous
  113.    C-c q   tst-display-mode-exit
  114.    C-c z   tst-display-zero
  115.   "
  116.   (interactive)
  117.                     ; body
  118.   (if (equal major-mode 'tst-display-mode)
  119.       (tst-display-mode-exit)
  120.     (put 'tst-display-saved-variables 'mode-name mode-name)
  121.     (put 'tst-display-saved-variables 'major-mode major-mode)
  122.     (put 'tst-display-saved-variables 'local-map (current-local-map))
  123.     (put 'tst-display-saved-variables 'buffer-read-only buffer-read-only)
  124.     (put 'tst-display-saved-variables 'truncate-lines truncate-lines)
  125.     (setq mode-name "Test Display")
  126.     (setq major-mode 'tst-display-mode)
  127.     (use-local-map tst-display-mode-map) ; setup keymap
  128.     (set-buffer-modified-p (buffer-modified-p))    ; Idiom to reset modeline.
  129.     (setq truncate-lines t)
  130.     (setq buffer-read-only t)
  131.     (setq tst-display-lisp-buffer (current-buffer))
  132.     (setq tst-display-lisp-window (selected-window))
  133.     )
  134.   )
  135.  
  136. (defun tst-display-mode-help ()
  137.   "Help screen for Test Display Mode."
  138.   (interactive)
  139.   (with-output-to-temp-buffer "*Help*"
  140.     (princ (car (cdr (cdr (symbol-function 'tst-display-mode)))))
  141.     )
  142.   )
  143.   
  144. (defun tst-display-mode-exit ()
  145.   "exit Test Display Mode"
  146.   (interactive)
  147.                     ; close annotation windows
  148.   (let ((buflist (mapcar 'cdr tst-display-buffer-alist)))
  149.     (mapcar '(lambda (buf)
  150.            (and (get-buffer-window buf)
  151.             (delete-window (get-buffer-window buf))))
  152.         buflist)
  153.     )                    ; let
  154.                     ; clean up global variables
  155.   (setq tst-display-buffer-alist nil)
  156.                     ; restore old state
  157.   (setq mode-name (get 'tst-display-saved-variables 'mode-name))
  158.   (setq major-mode (get 'tst-display-saved-variables 'major-mode))
  159.   (use-local-map (get 'tst-display-saved-variables 'local-map))
  160.   (set-buffer-modified-p (buffer-modified-p))    ; Idiom to reset modeline.
  161.   (setq truncate-lines (get 'tst-display-saved-variables 'truncate-lines))
  162.   (setq buffer-read-only (get 'tst-display-saved-variables 'buffer-read-only))
  163.   )
  164.   
  165. (defun tst-display-constant ()
  166.   "Display values which never changed during test runs."
  167.   (interactive)
  168.                     ;body
  169.   (tst-display-open-buffer 'constant)
  170.   (tst-display-open-window 'constant)
  171.   )
  172.   
  173. (defun tst-display-zero ()
  174.   "Display values which were never evaluated during test runs."
  175.   (interactive)
  176.                     ;body
  177.   (tst-display-open-buffer 'zero)
  178.   (tst-display-open-window 'zero)
  179.   )
  180.   
  181. (defun tst-display-next-line (&optional lines)
  182.   "Move point down one line in lisp buffer and any annotation buffers."
  183.   (interactive "p")
  184.   (let ((nlines (or lines 1))
  185.     (savewindow (selected-window))
  186.     (buflist (mapcar 'cdr tst-display-buffer-alist)))
  187.     (mapcar '(lambda (buf)
  188.            (let ((win (get-buffer-window buf)))
  189.          (if win
  190.              (progn (select-window win)
  191.                 (next-line nlines)))))
  192.         (cons tst-display-lisp-buffer buflist)
  193.         )
  194.     (select-window savewindow)
  195.     )
  196.   )
  197.  
  198. (defun tst-display-previous-line (&optional lines)
  199.   "Move point up LINES lines (1 if nil) in lisp buffer and any annotation
  200.    buffers."
  201.   (interactive "p")
  202.   (let ((nlines (- (or lines 1))))
  203.     (tst-display-next-line nlines)
  204.     )
  205.   )
  206.   
  207. (defun tst-display-scroll-down (&optional lines)
  208.   "Scroll down LINES lines in lisp buffer and any annotation buffers."
  209.   (interactive "P")
  210.   (let ((nlines (and lines (prefix-numeric-value lines)))
  211.     (savewindow (selected-window))
  212.     (buflist (mapcar 'cdr tst-display-buffer-alist)))
  213.     (mapcar '(lambda (buf)
  214.            (let ((win (get-buffer-window buf)))
  215.          (if win
  216.              (progn (select-window win)
  217.                 (scroll-down nlines)))))
  218.         (cons tst-display-lisp-buffer buflist)
  219.         )
  220.     (select-window savewindow)
  221.     )
  222.   )
  223.  
  224. (defun tst-display-scroll-up (&optional lines)
  225.   "Scroll up LINES lines in lisp buffer and any annotation buffers."
  226.   (interactive "P")
  227.   (let ((nlines (and lines (- (prefix-numeric-value lines))))
  228.     (savewindow (selected-window))
  229.     (buflist (mapcar 'cdr tst-display-buffer-alist)))
  230.     (mapcar '(lambda (buf)
  231.            (let ((win (get-buffer-window buf)))
  232.          (if win
  233.              (progn (select-window win)
  234.                 (scroll-up nlines)))))
  235.         (cons tst-display-lisp-buffer buflist)
  236.         )
  237.     (select-window savewindow)
  238.     )
  239.   )
  240.   
  241. (defun tst-display-open-buffer (attribute)
  242.   "Create a buffer named *display-ATTRIBUTE*.  Fill it with values from
  243.    the annotation database."
  244.   (interactive "Sattribute name: ")
  245.   (let ((newbuffer nil)
  246.     (bufname (concat "*tst-"
  247.              (prin1-to-string attribute)
  248.              "*")))
  249.     (save-excursion
  250.                     ; get buffer
  251.       (setq newbuffer (get-buffer-create bufname))
  252.       (setq tst-display-buffer-alist
  253.         (tst-alist-put tst-display-buffer-alist
  254.                attribute
  255.                newbuffer))
  256.                     ; fill buffer
  257.       (set-buffer newbuffer)
  258.       (let ((buffer-read-only nil))
  259.     (setq mode-line-format (prin1-to-string attribute))
  260.     (erase-buffer)
  261.     (newline (tst-display-maxline))
  262.     (mapcar '(lambda (line)
  263.            (goto-line line)
  264.            (insert (tst-display-get-string line attribute)))
  265.         (tst-ann-get-lines))
  266.                     ; setup keymap
  267.     (use-local-map tst-display-mode-map)
  268.     (setq truncate-lines t)
  269.     )
  270.       (setq buffer-read-only t)))
  271.   )
  272.   
  273. (defun tst-display-save-buffer (attribute)
  274.   "Save a buffer given ATTRIBUTE name."
  275.   (set-buffer (tst-alist-get tst-display-buffer-alist attribute))
  276.   (set-visited-file-name (buffer-name))
  277.   (save-buffer)
  278.   )
  279.   
  280. (defun tst-display-open-window (attribute)
  281.   "Open a window onto an attribute."
  282.   (interactive "Sattribute name: ")
  283.                     ; body
  284.   (let ((saved-line (tst-display-current-line)))
  285.     (split-window-horizontally tst-display-window-width)
  286.     (setq tst-display-window-alist
  287.       (tst-alist-put tst-display-window-alist
  288.              attribute
  289.              (selected-window)))
  290.     (switch-to-buffer (tst-alist-get tst-display-buffer-alist attribute))
  291.     (other-window 1)
  292.     (tst-display-redraw)
  293. ;    (goto-line saved-line)
  294. ;    (recenter)
  295. ;    (recenter)
  296.     )
  297.   )
  298.   
  299. (defun tst-display-close-window (attribute)
  300.   "Close a window onto an attribute."
  301.   (interactive "Sattribute name: ")
  302.   
  303.   (let ((win (tst-alist-get tst-display-window-alist attribute)))
  304.     (and win
  305.     (progn (delete-window win)
  306.            (tst-alist-rem tst-display-window-alist attribute)))
  307.     )
  308.   )
  309.   
  310. (defun tst-display-redraw (&optional line)
  311.   "Redraw all windows after moving to same line in display-windows
  312.    as in current window."
  313.   (interactive)
  314.   (let ((curline (or line (tst-display-current-line)))
  315.     (savewindow (selected-window))
  316.     (buflist (mapcar 'cdr tst-display-buffer-alist)))
  317.     (mapcar '(lambda (buf)
  318.            (let ((win (get-buffer-window buf)))
  319.          (select-window win)
  320.          (goto-line curline)
  321.          (recenter)))
  322.         buflist)
  323.     (select-window savewindow)
  324.     (goto-line curline)
  325.     (recenter)
  326.     )
  327.   )
  328.   
  329.  
  330. ;;; ----------------------------------------------------------------------
  331. ;;; Private Functions--
  332.  
  333. (defun tst-display-batch-string (buffer line &rest attrlist)
  334.   "Returns a string 'buffer-name:line-number:values\n'."
  335.   (let (value string)
  336.     (setq string (apply 'concat
  337.             (mapcar '(lambda (attr)
  338.                    (tst-display-get-string line attr))
  339.                 attrlist))
  340.       )
  341.     (if (equal "" string)
  342.     ""
  343.       (concat (buffer-name buffer)
  344.           ":"
  345.           (prin1-to-string line)
  346.           "==  "
  347.           string
  348.           "\n"))
  349.     )
  350.   )
  351.  
  352. (defun tst-display-get-string (line attribute)
  353.   "   return a string representation of the value <LINE ATTRIBUTE> from
  354.    the annotation database."
  355.                     ; body
  356.   (let ((value (tst-ann-get line attribute)))
  357.     (cond
  358.      ((null value) "")
  359.      ((and (listp value)
  360.        (= 1 (length value))) (prin1-to-string (car value)))
  361.      (t (prin1-to-string value))
  362.      )
  363.     )
  364.   )
  365.   
  366. (defun tst-display-maxline ()
  367.   "Returns number of lines in lisp-buffer"
  368.   (save-excursion
  369.    (set-buffer tst-display-lisp-buffer)
  370.    (count-lines (point-min) (point-max))
  371.    )
  372.   )
  373.   
  374. (defun tst-display-current-line ()
  375.   "Returns current line number"
  376.   (1+ (count-lines (point-min) (point)))
  377.   )
  378.   
  379. (defun tst-display-test-init ()
  380.   "Test driver for package functions."
  381.   (interactive)
  382.   
  383.   (let ((attr-list tst-display-attributes)
  384.     (line-list nil)
  385.     (line 1)
  386.     )
  387.                     ; Create a database (cheap)
  388.     (tst-ann-set-db nil)
  389.     (goto-char (point-min))
  390.     (while (not (eobp))
  391.       (tst-ann-put line 'constant (list line line line))
  392.       (tst-ann-put line 'zero 'NEVER->>)
  393.       (next-line 1)
  394.       (setq line (1+ line))
  395.       )
  396.     )
  397.   )
  398.