rs@uunet.UU.NET (Rich Salz) (09/10/87)
Submitted-by: "Mark A. Ardis" <maa@sei.cmu.edu>
Posting-number: Volume 11, Issue 36
Archive-name: test.el/Part01
I am sending you (in 3 parts) a package for GNU Emacs called
"test". It is designed to help authors of GNU Emacs Lisp packages
test their products. Some of the features of "test" provide
assistance in constructing tests and testscripts. Other features
assist in the analysis of the effectiveness of testing.
Unfortunately, this package has not been adequately tested itself. It
is the product of a semester-long project at Wang Institute. Since
the MSE program is being discontinued, we are forced to distribute
this package prematurely, lest it be lost. As the instructor of the
course I will be glad to collect comments, suggestions, bug reports,
etc. at my new address:
Mark A. Ardis
Software Engineering Institute
4500 Fifth Avenue
Pittsburgh, PA 15213
(412) 268-7636
maa@sei.cmu.edu (ARPANET)
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create:
# tst-display.el
# tst-equal.el
# tst-inequal.el
# tst-instrument.el
# This archive created: Thu Aug 6 17:02:17 1987
export PATH; PATH=/bin:/usr/bin:$PATH
echo shar: "extracting 'tst-display.el'" '(12443 characters)'
if test -f 'tst-display.el'
then
echo shar: "will not over-write existing file 'tst-display.el'"
else
sed 's/^X//' << \SHAR_EOF > 'tst-display.el'
X;;; display.el - GnuTest Display Package
X;;; Copyright (c) 1987 Wang Institute of Graduate Studies
X;;; Andy Bliven <bliven@wanginst>
X
X(provide 'tst-display)
X(require 'tst-annotate)
X
X;;; ----------------------------------------------------------------------
X;;; Public Variables--
X
X(defconst tst-display-window-width 10
X "* Width of each display window, in columns")
X
X(defconst tst-display-attributes (list 'zero 'constant)
X "* List of attributes to be displayed in batch mode.")
X
X;;; ----------------------------------------------------------------------
X;;; Private Variables--
X
X(defvar tst-display-buffer-alist nil
X "An alist of attribute names and buffer objects")
X
X(defvar tst-display-lisp-buffer nil
X "The buffer of emacs lisp code that has been annotated.")
X
X(defvar tst-display-lisp-window nil
X "The window containing emacs lisp code.")
X
X(defvar tst-display-mode-map nil
X "Keymap for GnuTest Display major mode.")
X(or tst-display-mode-map
X (progn
X (setq tst-display-mode-map (make-keymap))
X (suppress-keymap tst-display-mode-map) ; requires full keymap, not sparse
X ; key definitions
X (define-key tst-display-mode-map "\C-n" 'tst-display-next-line)
X (define-key tst-display-mode-map "\C-p" 'tst-display-previous-line)
X (define-key tst-display-mode-map "\C-v" 'tst-display-scroll-up)
X (define-key tst-display-mode-map "\M-v" 'tst-display-scroll-down)
X (define-key tst-display-mode-map "\C-c\C-h" 'tst-display-mode-help)
X (define-key tst-display-mode-map "\C-cc" 'tst-display-constant)
X (define-key tst-display-mode-map "\C-cl" 'tst-display-redraw)
X (define-key tst-display-mode-map "\C-cn" 'tst-display-next)
X (define-key tst-display-mode-map "\C-cp" 'tst-display-previous)
X (define-key tst-display-mode-map "\C-cq" 'tst-display-mode-exit)
X (define-key tst-display-mode-map "\C-cz" 'tst-display-zero)
X )
X )
X
X(defvar tst-display-window-alist nil
X "An alist of attribute names and window objects")
X
X(defvar tst-batch-results "tst-batch-results"
X "* a kluge")
X
X(defvar tst-display-saved-variables nil
X "The property list of this variable contains values of all variables
X saved on entry to tst-display-mode.")
X
X
X
X;;; ----------------------------------------------------------------------
X;;; Public Functions--
X
X(defun tst-display-batch (&optional lisp-buffer)
X " Batch mode execution of the annotation display package. Writes the
X summary reports 'zero' and 'constant' generated by the tst-analyze
X package into a 'compilation' style buffer named '*compilation*'. If
X called interactively this is available for viewing with the '^X`' key,
X otherwise it is saved to the file named in tst-batch-results. If
X LISP-BUFFER is not specified, current-buffer is used instead as the
X label on each line of the report."
X (interactive)
X ; body
X (let ((lisp-buffer (or lisp-buffer (current-buffer)))
X (save-window (selected-window)))
X (pop-to-buffer "*compilation*")
X (erase-buffer)
X (insert "# GnuTest analysis of " (buffer-name lisp-buffer) "\n"
X "# (lines which were never evaluated during tests or returned\n"
X "# the same value every time they were evaluated.)\n")
X (mapcar '(lambda (line)
X (insert (tst-display-batch-string lisp-buffer
X line
X 'zero
X 'constant)))
X (tst-ann-get-lines))
X (if (interactive-p)
X (progn
X (goto-char (point-min)) ; top of results buffer
X (switch-to-buffer "*compilation*")
X (select-window save-window) ; go back to original window
X )
X ;; else
X (write-file tst-batch-results) ; write buffer to disk
X )
X )
X )
X
X(defun tst-display-mode ()
X "* Major mode for displaying GnuTest annotation with associated
X emacs-lisp code buffer. Precondition: tst-instrument and tst-analyze
X have already been evaluated for this buffer.
X C-n tst-display-next-line
X C-p tst-display-previous-line
X C-v tst-display-scroll-up
X M-v tst-display-scroll-down
X C-c C-h tst-display-mode-help
X C-c c tst-display-constant
X C-c l tst-display-redraw
X C-c n tst-display-next
X C-c p tst-display-previous
X C-c q tst-display-mode-exit
X C-c z tst-display-zero
X "
X (interactive)
X ; body
X (if (equal major-mode 'tst-display-mode)
X (tst-display-mode-exit)
X (put 'tst-display-saved-variables 'mode-name mode-name)
X (put 'tst-display-saved-variables 'major-mode major-mode)
X (put 'tst-display-saved-variables 'local-map (current-local-map))
X (put 'tst-display-saved-variables 'buffer-read-only buffer-read-only)
X (put 'tst-display-saved-variables 'truncate-lines truncate-lines)
X (setq mode-name "Test Display")
X (setq major-mode 'tst-display-mode)
X (use-local-map tst-display-mode-map) ; setup keymap
X (set-buffer-modified-p (buffer-modified-p)) ; Idiom to reset modeline.
X (setq truncate-lines t)
X (setq buffer-read-only t)
X (setq tst-display-lisp-buffer (current-buffer))
X (setq tst-display-lisp-window (selected-window))
X )
X )
X
X(defun tst-display-mode-help ()
X "Help screen for Test Display Mode."
X (interactive)
X (with-output-to-temp-buffer "*Help*"
X (princ (car (cdr (cdr (symbol-function 'tst-display-mode)))))
X )
X )
X
X(defun tst-display-mode-exit ()
X "exit Test Display Mode"
X (interactive)
X ; close annotation windows
X (let ((buflist (mapcar 'cdr tst-display-buffer-alist)))
X (mapcar '(lambda (buf)
X (and (get-buffer-window buf)
X (delete-window (get-buffer-window buf))))
X buflist)
X ) ; let
X ; clean up global variables
X (setq tst-display-buffer-alist nil)
X ; restore old state
X (setq mode-name (get 'tst-display-saved-variables 'mode-name))
X (setq major-mode (get 'tst-display-saved-variables 'major-mode))
X (use-local-map (get 'tst-display-saved-variables 'local-map))
X (set-buffer-modified-p (buffer-modified-p)) ; Idiom to reset modeline.
X (setq truncate-lines (get 'tst-display-saved-variables 'truncate-lines))
X (setq buffer-read-only (get 'tst-display-saved-variables 'buffer-read-only))
X )
X
X(defun tst-display-constant ()
X "Display values which never changed during test runs."
X (interactive)
X ;body
X (tst-display-open-buffer 'constant)
X (tst-display-open-window 'constant)
X )
X
X(defun tst-display-zero ()
X "Display values which were never evaluated during test runs."
X (interactive)
X ;body
X (tst-display-open-buffer 'zero)
X (tst-display-open-window 'zero)
X )
X
X(defun tst-display-next-line (&optional lines)
X "Move point down one line in lisp buffer and any annotation buffers."
X (interactive "p")
X (let ((nlines (or lines 1))
X (savewindow (selected-window))
X (buflist (mapcar 'cdr tst-display-buffer-alist)))
X (mapcar '(lambda (buf)
X (let ((win (get-buffer-window buf)))
X (if win
X (progn (select-window win)
X (next-line nlines)))))
X (cons tst-display-lisp-buffer buflist)
X )
X (select-window savewindow)
X )
X )
X
X(defun tst-display-previous-line (&optional lines)
X "Move point up LINES lines (1 if nil) in lisp buffer and any annotation
X buffers."
X (interactive "p")
X (let ((nlines (- (or lines 1))))
X (tst-display-next-line nlines)
X )
X )
X
X(defun tst-display-scroll-down (&optional lines)
X "Scroll down LINES lines in lisp buffer and any annotation buffers."
X (interactive "P")
X (let ((nlines (and lines (prefix-numeric-value lines)))
X (savewindow (selected-window))
X (buflist (mapcar 'cdr tst-display-buffer-alist)))
X (mapcar '(lambda (buf)
X (let ((win (get-buffer-window buf)))
X (if win
X (progn (select-window win)
X (scroll-down nlines)))))
X (cons tst-display-lisp-buffer buflist)
X )
X (select-window savewindow)
X )
X )
X
X(defun tst-display-scroll-up (&optional lines)
X "Scroll up LINES lines in lisp buffer and any annotation buffers."
X (interactive "P")
X (let ((nlines (and lines (- (prefix-numeric-value lines))))
X (savewindow (selected-window))
X (buflist (mapcar 'cdr tst-display-buffer-alist)))
X (mapcar '(lambda (buf)
X (let ((win (get-buffer-window buf)))
X (if win
X (progn (select-window win)
X (scroll-up nlines)))))
X (cons tst-display-lisp-buffer buflist)
X )
X (select-window savewindow)
X )
X )
X
X(defun tst-display-open-buffer (attribute)
X "Create a buffer named *display-ATTRIBUTE*. Fill it with values from
X the annotation database."
X (interactive "Sattribute name: ")
X (let ((newbuffer nil)
X (bufname (concat "*tst-"
X (prin1-to-string attribute)
X "*")))
X (save-excursion
X ; get buffer
X (setq newbuffer (get-buffer-create bufname))
X (setq tst-display-buffer-alist
X (tst-alist-put tst-display-buffer-alist
X attribute
X newbuffer))
X ; fill buffer
X (set-buffer newbuffer)
X (let ((buffer-read-only nil))
X (setq mode-line-format (prin1-to-string attribute))
X (erase-buffer)
X (newline (tst-display-maxline))
X (mapcar '(lambda (line)
X (goto-line line)
X (insert (tst-display-get-string line attribute)))
X (tst-ann-get-lines))
X ; setup keymap
X (use-local-map tst-display-mode-map)
X (setq truncate-lines t)
X )
X (setq buffer-read-only t)))
X )
X
X(defun tst-display-save-buffer (attribute)
X "Save a buffer given ATTRIBUTE name."
X (set-buffer (tst-alist-get tst-display-buffer-alist attribute))
X (set-visited-file-name (buffer-name))
X (save-buffer)
X )
X
X(defun tst-display-open-window (attribute)
X "Open a window onto an attribute."
X (interactive "Sattribute name: ")
X ; body
X (let ((saved-line (tst-display-current-line)))
X (split-window-horizontally tst-display-window-width)
X (setq tst-display-window-alist
X (tst-alist-put tst-display-window-alist
X attribute
X (selected-window)))
X (switch-to-buffer (tst-alist-get tst-display-buffer-alist attribute))
X (other-window 1)
X (tst-display-redraw)
X; (goto-line saved-line)
X; (recenter)
X; (recenter)
X )
X )
X
X(defun tst-display-close-window (attribute)
X "Close a window onto an attribute."
X (interactive "Sattribute name: ")
X
X (let ((win (tst-alist-get tst-display-window-alist attribute)))
X (and win
X (progn (delete-window win)
X (tst-alist-rem tst-display-window-alist attribute)))
X )
X )
X
X(defun tst-display-redraw (&optional line)
X "Redraw all windows after moving to same line in display-windows
X as in current window."
X (interactive)
X (let ((curline (or line (tst-display-current-line)))
X (savewindow (selected-window))
X (buflist (mapcar 'cdr tst-display-buffer-alist)))
X (mapcar '(lambda (buf)
X (let ((win (get-buffer-window buf)))
X (select-window win)
X (goto-line curline)
X (recenter)))
X buflist)
X (select-window savewindow)
X (goto-line curline)
X (recenter)
X )
X )
X
X
X;;; ----------------------------------------------------------------------
X;;; Private Functions--
X
X(defun tst-display-batch-string (buffer line &rest attrlist)
X "Returns a string 'buffer-name:line-number:values\n'."
X (let (value string)
X (setq string (apply 'concat
X (mapcar '(lambda (attr)
X (tst-display-get-string line attr))
X attrlist))
X )
X (if (equal "" string)
X ""
X (concat (buffer-name buffer)
X ":"
X (prin1-to-string line)
X "== "
X string
X "\n"))
X )
X )
X
X(defun tst-display-get-string (line attribute)
X " return a string representation of the value <LINE ATTRIBUTE> from
X the annotation database."
X ; body
X (let ((value (tst-ann-get line attribute)))
X (cond
X ((null value) "")
X ((and (listp value)
X (= 1 (length value))) (prin1-to-string (car value)))
X (t (prin1-to-string value))
X )
X )
X )
X
X(defun tst-display-maxline ()
X "Returns number of lines in lisp-buffer"
X (save-excursion
X (set-buffer tst-display-lisp-buffer)
X (count-lines (point-min) (point-max))
X )
X )
X
X(defun tst-display-current-line ()
X "Returns current line number"
X (1+ (count-lines (point-min) (point)))
X )
X
X(defun tst-display-test-init ()
X "Test driver for package functions."
X (interactive)
X
X (let ((attr-list tst-display-attributes)
X (line-list nil)
X (line 1)
X )
X ; Create a database (cheap)
X (tst-ann-set-db nil)
X (goto-char (point-min))
X (while (not (eobp))
X (tst-ann-put line 'constant (list line line line))
X (tst-ann-put line 'zero 'NEVER->>)
X (next-line 1)
X (setq line (1+ line))
X )
X )
X )
SHAR_EOF
if test 12443 -ne "`wc -c < 'tst-display.el'`"
then
echo shar: "error transmitting 'tst-display.el'" '(should have been 12443 characters)'
fi
fi
echo shar: "extracting 'tst-equal.el'" '(32129 characters)'
if test -f 'tst-equal.el'
then
echo shar: "will not over-write existing file 'tst-equal.el'"
else
sed 's/^X//' << \SHAR_EOF > 'tst-equal.el'
X;;; tst-equal.el -- A number of definitions of equality
X;;; Lorri Menard, Wang Institute of Graduate Studies
X;;; Don Zaremba, Wang Institute of Graduate Studies
X;;; Copyright 1987 Wang Institute of Graduate Studies
X;;;
X
X(provide 'tst-equal)
X
X(defvar tst-equ-log-all-compares "t"
X "* If not nil then all comparisons are logged into the buffer
X *equal-log*."
X)
X
X(defvar tst-equ-max-line-diffs "15"
X "* Maximum number of different lines to log when comparing
X buffer contents line-by-line. "
X)
X
X(defvar tst-equ-state-functions '(tst-equ-session
X tst-equ-buffers
X tst-equ-processes
X tst-equ-windows)
X "* A list of functions to be executed when comparing objects
X of type state."
X)
X
X(defvar tst-equ-buff-state-functions '(tst-equ-point
X tst-equ-mark
X tst-equ-contents
X tst-equ-modified
X tst-equ-file
X tst-equ-local-vars)
X "* A list of functions to be executed when comparing objects
X of type buffer-state."
X)
X
X(defconst tst-equ-indent 3)
X
X(defmacro tst-equ-level1 ()
X (insert "*") (indent-to tst-equ-indent))
X
X(defmacro tst-equ-level2 ()
X (insert "**") (indent-to (* tst-equ-indent 2)))
X
X(defmacro tst-equ-level3 ()
X (insert "***") (indent-to (* tst-equ-indent 3)))
X
X(defmacro tst-equ-level4 ()
X (insert "****") (indent-to (* tst-equ-indent 4)))
X
X(defmacro tst-equ-level5 ()
X (insert "*****") (indent-to (* tst-equ-indent 5)))
X
X(defmacro tst-equ-level6 ()
X (insert "******") (indent-to (* tst-equ-indent 6)))
X
X(defmacro tst-equ-level7 ()
X (insert "*******") (indent-to (* tst-equ-indent 7)))
X
X(defmacro tst-equ-level8 ()
X (insert "********") (indent-to (* tst-equ-indent 8)))
X
X(defmacro tst-equ-level9 ()
X (insert "*********") (indent-to (* tst-equ-indent 9)))
X
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X; A number of equality testing functions follow. Each is of the
X; form tst-equ-state-component (state1 state2). Each compares a particular
X; component from the two states and returns t if equal, else nil.
X; As a side effect the buffer *equal-log* is updated with the results
X; of the comparison
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-equ-state (tst-equ-state1 tst-equ-state2 name)
X "Compares for equality the complete state of a pair of sessions.
X The two parameters STATE1 and STATE2 must be complete states
X as returned by tst-reg-capture-state. The results of the comparison
X are written into buffer *equal-log*. NAME is used to identify the test.
X Four major components are compared: session, buffers, windows, and
X processes. "
X
X (interactive "XState variable 1:
XXState variable 2:
XsName of this test:")
X
X
X (let (ss-fun-vector function-name tst-equ-result tst-equ-startpoint temppoint)
X
X (message "Comparing states...")
X (setq ss-fun-vector tst-equ-state-functions)
X (setq tst-equ-result t); let's be optomistic
X
X ; set up the log buffer
X (get-buffer-create "*equal-log*")
X (set-buffer "*equal-log*")
X (outline-mode)
X (tst-equ-level1)
X (setq tst-equ-startpoint (point)) ;save "here"
X (insert "State comparison: " name)
X (newline)
X (newline)
X
X (while ss-fun-vector
X (progn
X (setq function-name (car ss-fun-vector))
X (setq ss-fun-vector (cdr ss-fun-vector))
X (newline)
X;;; (insert " " (prin1-to-string function-name))
X (newline)
X (if (not (funcall function-name tst-equ-state1 tst-equ-state2))
X (setq tst-equ-result nil); set return value if failed
X ); fi
X ); ngrop
X ); elihw
X
X ; if we failed and a hook exist then run iot
X (if (and (not tst-equ-result) 'tst-equ-state-hook)
X (run-hooks 'tst-equ-state-hook))
X
X (if (not tst-equ-result)
X (progn
X (setq temppoint (point))
X (goto-char tst-equ-startpoint)
X (insert "?")
X (goto-char (1+ temppoint))
X ); ngorp
X );fi
X (message "Comparing states... done")
X tst-equ-result
X ); tel
X); nufed tst-equ-state
X
X(defun tst-equ-session (state1 state2)
X "Compares the session components from two states. The
X two parameters STATE1 and STATE2 must be complete states
X as returned by tst-reg-capture-state. The session components
X include: global-bound-syms. "
X
X (interactive "P")
X
X (let (sess1 sess2 syms1 syms2 ss-startpoint ss-gs-startpoint temppoint el1 el2)
X (message "Comparing state of sessions...")
X
X (goto-char (point-max)) ; .. of output buffer
X (tst-equ-level2)
X (setq ss-startpoint (point))
X (insert "Sessions state")
X (newline)
X
X (setq sess1 (cadr (assoc 'session state1)))
X (setq sess2 (cadr (assoc 'session state2)))
X
X (tst-equ-level3)
X (setq ss-gs-startpoint (point))
X (insert "Global symbols")
X (newline)
X
X (setq syms1 (cadr (assoc 'global-bound-syms sess1)))
X (setq syms2 (cadr (assoc 'global-bound-syms sess2)))
X (if (not (setq tst-equ-result (equal syms1 syms2)))
X (progn
X (while (and syms1 syms2)
X (setq el1 (car syms1))
X (setq syms1 (cdr syms1))
X (setq el2 (assoc (car el1) syms2))
X ;; (debug "nil" el1 el2)
X (if el2
X (setq syms2 (delq el2 syms2))
X;; (list 'setq syms2 (list 'delq (list 'assoc (car el1) syms2)
X;; syms2))
X (progn ;else ..
X (indent-to (* tst-equ-indent 4))
X (insert "?")
X (insert (prin1-to-string (car el1)) " not found in second state")
X (newline)
X ); ngorp
X ); fi
X (tst-equ-diff-element el1 el2)
X ); wlihw
X (if syms1
X (progn
X (while syms1
X (setq el1 (car syms1))
X (setq syms1 (cdr syms1))
X (indent-to (* tst-equ-indent 4))
X (insert "?")
X (insert (prin1-to-string (car el1)) " not found in second state")
X (newline)
X ); elihw
X ); ngorp
X ); fi
X (if syms2
X (progn
X (while syms2
X (setq el2 (car syms2))
X (setq syms2 (cdr syms2))
X (indent-to (* tst-equ-indent 4))
X (insert "?")
X (insert (prin1-to-string (car el2)) " not found in first state")
X (newline)
X ); elihw
X
X );ngorp
X ); fi
X ); ngorp
X ; else .. nevermind.
X ); fi
X (if (not tst-equ-result)
X (progn
X (setq temppoint (point))
X (goto-char ss-startpoint)
X (insert "?")
X; if ever there are more things in a session, these two lines need to
X; be separate.
X (goto-char ss-gs-startpoint)
X (insert "?")
X;
X (goto-char (1+ temppoint))
X );
X ); fi
X
X tst-equ-result
X ); tel
X)
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-equ-buffers (tst-equ-buffers1 tst-equ-buffers2)
X "Compares the buffers components from two states. The
X two parameters STATE1 and STATE2 must be complete states
X as returned by tst-reg-capture-state. Compares each buffer for
X equality with its corresponding buffer (by name) in the other
X state. tst-equ-buffer-state is called for each pair of buffers. "
X
X (interactive "P")
X ; Local Variables
X (let (buffers1 buffers2 buff1 buff-name buff2 tst-equ-result buf1names
X bs-startpoint temppoint)
X
X (message "Comparing state of buffers...")
X (setq tst-equ-result t)
X (setq buffers1 (cadr (assoc 'buffers tst-equ-buffers1))); get the first value
X (setq buffers2 (cadr (assoc 'buffers tst-equ-buffers2))); get the second value
X
X ; set up the log buffer
X (goto-char (point-max))
X (tst-equ-level2)
X (setq bs-startpoint (point))
X (insert "Buffers state")
X (newline)
X
X (while buffers1
X (progn
X (setq buff1 (car buffers1))
X (setq buffers1 (cdr buffers1))
X ; get the name of the 1st buffer and use it to find the second
X (setq buff-name (cadr (assoc 'buf-state-name buff1)))
X (setq buf1names (cons buff-name buf1names))
X
X ; create a log entry for this buffer
X
X ; now locate the second buffer
X (setq buff2 (tst-equ-find-buffer-with-name tst-equ-buffers2 buff-name))
X (if (not buff2)
X (progn
X (newline)
X (indent-to (* tst-equ-indent 2))
X (insert "?")
X (insert buff-name " not found in second state")
X (newline)
X (setq tst-equ-result nil)
X ); ngorp
X ; else
X (progn
X ; now compare them and set tst-equ-result
X (if (not (tst-equ-buffer-state buff1 buff2))
X (setq tst-equ-result nil)
X ) ; fi
X ) ; ngorp
X ); fi
X
X ); ngrop
X ); elihw
X;;; now that we have checked for everything from the first state,
X;;; want to see if there are any buffers in the second state that are
X;;; not in the first one. Remember the list "buf1names" that was built
X;;; during the first while loop? Well, we'll member this list instead
X;;; of "tst-equ-find-buffer-with-name"ing it, because this seems more efficient.
X
X (while buffers2
X (progn
X (setq buff2 (car buffers2))
X (setq buffers2 (cdr buffers2))
X
X (setq buff-name (cadr (assoc 'buf-state-name buff2)))
X (if (not (member buff-name buf1names))
X (progn
X (newline)
X (indent-to (* tst-equ-indent 4))
X (insert "?")
X (insert buff-name " not found in first state")
X (newline)
X (setq tst-equ-result nil)
X ); ngorp
X ); fi
X ); ngorp
X ); elihw
X
X ; if we failed and a hook exist then run it
X (if (and (not tst-equ-result) 'tst-equ-buffers-hook)
X (run-hooks 'tst-equ-buffers-hook))
X
X (if (not tst-equ-result)
X (progn
X (setq temppoint (point))
X (goto-char bs-startpoint)
X (insert "?")
X (goto-char (1+ temppoint))
X ); nprog
X ); fi
X
X tst-equ-result
X ) ; let
X) ; defun tst-equ-buffers
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-equ-windows (tst-equ-windows1 tst-equ-windows2)
X "Compares the window components from two states. The
X two parameters STATE1 and STATE2 must be complete states
X as returned by tst-reg-capture-state."
X
X (interactive "P")
X ; Local Variables
X (let (window1 window2 tst-equ-result start-point saved-point)
X
X (message "Comparing state of windows ...")
X
X (setq window1 (cadr (assoc 'windows tst-equ-windows1)))
X (setq window2 (cadr (assoc 'windows tst-equ-windows2)))
X (setq tst-equ-result t)
X
X (tst-equ-level2)
X (setq start-point (point))
X (insert "Window state")
X (newline)
X
X (setq tst-equ-result (tst-equ-wstates window1 window2 ))
X
X ; if we failed and a hook exist then run iot
X (if (and (not tst-equ-result) 'tst-equ-windows-hook)
X (run-hooks 'tst-equ-windows-hook))
X
X ; if we still fail the out a ?
X (if (not tst-equ-result)
X (progn
X (setq saved-point (point))
X (goto-char start-point)
X (insert "?")
X (goto-char (1+ saved-point))
X ); ngorp
X ); if
X
X tst-equ-result
X ) ; let
X); defun
X
X(defun tst-equ-wstates (wstate1 wstate2)
X "Check the equality of two windows"
X
X (let (sibling leftc-edges start-point tst-equ-result tresult obj1 obj2 assoc-list
X label-list component label childs1 childs2 cl1 cl2 cr1 cr2)
X
X (setq tst-equ-result t)
X
X ; check for spilt windows
X (if (assoc 'split wstate1)
X (progn
X (setq childs1 (cadr (assoc 'children wstate1)))
X (setq childs2 (cadr (assoc 'children wstate2)))
X ; Save the children
X (setq cl1 (car childs1))
X (setq cl2 (car childs2))
X (setq cr1 (car (cdr childs1)))
X (setq cr2 (car (cdr childs2)))
X
X ; Now do the comparisons
X (setq tresult (tst-equ-wstates cl1 cl2))
X (setq tst-equ-result (and tresult (tst-equ-wstates cr1 cr2)))
X ); progn
X ); if split
X
X ; else not spilt so compare windows
X (progn
X ; first set up the assoc and label list
X (setq assoc-list '(window-edges window-buffer window-start window-point
X current-window))
X (setq label-list '(edges buffer start point current))
X
X ; setup *equal-log* buffer
X (newline)
X (tst-equ-level3)
X (setq start-point (point))
X (insert "window")
X (newline)
X
X ; loop thru the full assoc list
X (while assoc-list
X (progn
X (setq component (car assoc-list))
X (setq assoc-list (cdr assoc-list))
X (setq label (car label-list))
X (setq label-list (cdr label-list))
X
X ; now get the two objects and compare them
X (tst-equ-level4)
X (setq obj1 (cadr (assoc component wstate1)))
X (setq obj2 (cadr (assoc component wstate2)))
X (setq tresult (equal obj1 obj2))
X (if (not tresult)
X (progn
X (insert "?")
X (setq tst-equ-result nil)
X ); ngorp
X ; else
X (insert " ")
X ); if
X (insert (prin1-to-string component) ": ")
X (tst-equ-log-diff tresult obj1 obj2)
X ); progn after the while
X ); while assoc-list
X
X tst-equ-result
X ); progn
X ); let
X); defun
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-equ-processes (state1 state2)
X "Compares the process components from two states. The
X two parameters STATE1 and STATE2 must be complete states
X as returned by tst-reg-capture-state. The session components
X include: command exit-status filter name sentinel status. "
X
X (interactive "P")
X ; Local Variables
X (let (proc1 proc2 p1 p2 c1 c2 tst-equ-result proc-list component start-point
X saved-point)
X
X (message "Comparing state of processes...")
X (setq proc-list '(command exit-status filter name sentinel status))
X
X (setq proc1 (cadr (assoc 'processes state1)))
X (setq proc2 (cadr (assoc 'processes state2)))
X (setq tst-equ-result t)
X
X (tst-equ-level2)
X (setq start-point (point))
X (insert "Processes state")
X (newline)
X
X (while proc1
X (progn
X (setq p1 (car proc1))
X (setq proc1 (cdr proc1))
X (setq p2 (car proc2))
X (setq proc2 (cdr proc2))
X
X (setq proc-list '(command exit-status filter name
X sentinel status process-mark))
X (newline)
X (while proc-list
X (progn
X (setq component (car proc-list))
X (setq proc-list (cdr proc-list))
X (setq c1 (cadr (assoc component p1)))
X (setq c2 (cadr (assoc component p2)))
X (setq cresult (equal c1 c2))
X
X (tst-equ-level3)
X (if (not cresult)
X (progn
X (insert "?")
X (setq tst-equ-result nil)
X ); ngorp
X ; else
X (insert " ")
X ); fi
X (insert (prin1-to-string component) ": ")
X (tst-equ-log-diff cresult c1 c2)
X ); ngorp
X ); elihw
X
X
X ); ngorp
X ); while proc1
X
X ; if we failed and a hook exist then run iot
X (if (and (not tst-equ-result) 'tst-equ-processes-hook)
X (run-hooks 'tst-equ-processes-hook))
X
X (if (not tst-equ-result)
X (progn
X (setq saved-point (point))
X (goto-char start-point)
X (insert "?")
X (goto-char (1+ saved-point))
X ); ngorp
X ); fi
X tst-equ-result
X ); tel
X); nufed
X
X
X(defun tst-equ-buffer-state (buff-state1 buff-state2)
X "Compares two buffers for equality. The two parameters
X BUFFER1 and BUFFER2 must be buffer states as returned
X by tst-equ-find-buffer. The following components are
X compared by default: point mark contents file local-variables.
X This can be modified by changing the elemetns in the variable
X tst-equ-buff-state-functions. "
X
X (interactive "P")
X
X; Variables
X
X (let (bs-fun-vector function-name tst-equ-result saved-beg msg
X fname
X saved-end tst-equ-buffer-state-startpoint)
X (get-buffer-create "*equal-log*")
X (set-buffer "*equal-log*")
X (outline-mode)
X (goto-char (point-max))
X
X (newline)
X (tst-equ-level2)
X (setq tst-equ-buffer-state-startpoint (point))
X (insert "Comparison of buffers named: " )
X (insert (cadr (assoc 'buf-state-name buff-state1)))
X (newline)
X
X (setq msg (concat "Comparing state of buffer "
X (cadr (assoc 'buf-state-name buff-state1))))
X (message msg)
X
X (setq bs-fun-vector tst-equ-buff-state-functions)
X (setq tst-equ-result t) ; let's be optomistic
X
X (while bs-fun-vector
X (progn
X (setq function-name (car bs-fun-vector))
X (setq bs-fun-vector (cdr bs-fun-vector))
X
X (tst-equ-level3)
X (setq saved-beg (point))
X (setq fname (prin1-to-string function-name))
X (setq fname (substring fname (match-end
X (string-match "tst-equ-" fname)) nil))
X (insert fname ": ")
X; (newline)
X (if (not (funcall function-name buff-state1 buff-state2))
X (progn
X (setq tst-equ-result nil) ; set return value if failed
X (setq saved-end (point))
X (goto-char saved-beg)
X (insert "?")
X (goto-char (1+ saved-end))
X
X ); ngorp
X ); fi
X
X ); progn
X ); while
X (if (not tst-equ-result)
X (progn
X (setq temppoint (point))
X (goto-char tst-equ-buffer-state-startpoint)
X (insert "?")
X (goto-char (1+ temppoint))
X ); ngorp
X ); fi
X tst-equ-result
X ) ; let
X
X) ; defun tst-equ-buffer-state
X
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-equ-contents (buff-state1 buff-state2)
X "Compares the contents component from two buffer states. "
X
X (interactive "P")
X ; Local Variables
X (let (tst-equ-contents1 tst-equ-contents2 tst-equ-result)
X
X (setq tst-equ-contents1 (cadr (assoc 'buf-state-contents buff-state1)))
X (setq tst-equ-contents2 (cadr (assoc 'buf-state-contents buff-state2)))
X (setq tst-equ-result (string-equal tst-equ-contents1 tst-equ-contents2))
X
X ; if a hook exist and we failed the compare then run the hook ..
X (if (and (not tst-equ-result) 'tst-equ-contents-hook)
X (run-hooks 'tst-equ-contents-hook))
X
X (if (not tst-equ-result)
X (progn
X (indent-to (* tst-equ-indent 4))
X (insert "contents not equal")
X ); ngorp
X (progn
X (indent-to (* tst-equ-indent 4))
X (insert "contents equal")
X ); ngorp
X ); fi
X (newline)
X tst-equ-result
X ) ; let
X) ; defun tst-equ-contents
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-equ-contents-region (buff-state1 buff-state2)
X "Compares the contents component from two buffer states between
X point and mark. "
X
X (interactive "P")
X ; Local Variables
X (let (tst-equ-contents-region1 tst-equ-contents-region2
X buf-point buf-mark tst-equ-result)
X
X (setq tst-equ-contents-region1 (cadr (assoc 'buf-state-contents buff-state1)))
X (setq buf-point (cadr (assoc 'buf-state-point buff-state1)))
X (setq buf-mark (cadr (assoc 'buf-state-mark buff-state1)))
X (setq tst-equ-contents-region1
X (substring tst-equ-contents-region1 buf-point buf-mark))
X
X (setq tst-equ-contents-region2 (cadr (assoc 'buf-state-contents buff-state2)))
X (setq buf-point (cadr (assoc 'buf-state-point buff-state2)))
X (setq buf-mark (cadr (assoc 'buf-state-mark buff-state2)))
X (setq tst-equ-contents-region2
X (substring tst-equ-contents-region2 buf-point buf-mark))
X
X (setq tst-equ-result (string-equal
X tst-equ-contents-region1 tst-equ-contents-region2))
X
X ; if a hook exist and we failed the compare then run the hook ..
X (if (and (not tst-equ-result) 'tst-equ-contents-region-hook)
X (run-hooks 'tst-equ-contents-region-hook))
X
X (if (not tst-equ-result)
X (progn
X (indent-to (* tst-equ-indent 4))
X (insert "contents not equal")
X ); ngorp
X (progn
X (indent-to (* tst-equ-indent 4))
X (insert "contents equal")
X ); ngorp
X ); fi
X (newline)
X tst-equ-result
X ) ; let
X) ; defun tst-equ-contents-region
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-equ-contents-line (buff-state1 buff-state2)
X "Compares the contents component from two buffer states. Comparison
X is performed line by line. Will run a hook named 'tst-equ-line-hook
X that can access the strings tst-equ-line1 and tst-equ-line2. Hook is
X called only if the comparison fails but can set tst-equ-result to t if
X it wants."
X
X (interactive "P")
X ; Local Variables
X (let (c1 c2 tst-equ-line1 tst-equ-line2 tst-equ-result more1 more2
X start1 end1 start2 end2 final-result found-so-far)
X
X (setq c1 (cadr (assoc 'buf-state-contents buff-state1))); get the first value
X (setq c2 (cadr (assoc 'buf-state-contents buff-state2))); get the second value
X (setq final-result t more1 t more2 t)
X (setq start1 0 start2 0 found-so-far 0); starting index in strings
X
X
X (while (and more1 more2)
X (progn
X (setq end1 (string-match "\n" c1 start1))
X (if (not end1)
X (setq more1 nil); we hit end-of-contents
X ; else
X (progn
X (setq tst-equ-line1 (substring c1 start1 end1 ))
X (setq start1 (match-end 0))
X ); ngorp
X ); fi
X (setq end2 (string-match "\n" c2 start2))
X (if (not end2)
X (setq more2 nil); we hit end-of-contents
X ; else
X (progn
X (setq tst-equ-line2 (substring c2 start2 end2 ))
X (setq start2 (match-end 0))
X ); ngorp
X ); fi
X
X ; now do the comparison if we have two lines
X (if (and more1 more2)
X (progn
X (setq tst-equ-result (string-equal tst-equ-line1 tst-equ-line2))
X
X ; if a hook exist and we failed the compare then run the hook ..
X (if (and (not tst-equ-result) 'tst-equ-line-hook)
X (run-hooks 'tst-equ-line-hook))
X
X ; but test again in case hook modified result
X (if (not tst-equ-result)
X (progn
X (setq final-result nil)
X (tst-equ-log-diff-line tst-equ-line1 tst-equ-line2)
X (setq found-so-far (+ 1 found-so-far))
X (if (>= found-so-far tst-equ-max-line-diffs)
X (progn
X ; i want to just get out of here.
X (setq more1 nil)
X (setq more2 nil) ;fake 'em into leaving
X ); ngorp
X ); fi
X ); ngorp
X ); fi
X ); ngorp
X ); fi
X ); ngorp
X ); elihw
X final-result
X ) ; let
X) ; defun tst-equ-contents-line
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-equ-point (buff-state1 buff-state2)
X "Compares the point component from two buffer states. "
X
X (interactive "P")
X ; Local Variables
X (let (tst-equ-point1 tst-equ-point2 tst-equ-result)
X
X (setq tst-equ-point1 (cadr (assoc 'buf-state-point buff-state1)))
X (setq tst-equ-point2 (cadr (assoc 'buf-state-point buff-state2)))
X (setq tst-equ-result (equal tst-equ-point1 tst-equ-point2))
X
X ; if a hook exist and we failed the compare then run the hook ..
X (if (and (not tst-equ-result) 'tst-equ-point-hook)
X (run-hooks 'tst-equ-point-hook))
X
X (tst-equ-log-diff tst-equ-result (int-to-string tst-equ-point1)
X (int-to-string tst-equ-point2))
X tst-equ-result
X ) ; let
X) ; defun tst-equ-point
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-equ-mark (buff-state1 buff-state2)
X "Compares the mark component from two buffer states. "
X
X (interactive "P")
X ; Local Variables
X (let (tst-equ-mark1 tst-equ-mark2 tst-equ-result)
X
X (setq tst-equ-mark1 (cadr (assoc 'buf-state-mark buff-state1)))
X (setq tst-equ-mark2 (cadr (assoc 'buf-state-mark buff-state2)))
X (setq tst-equ-result (equal tst-equ-mark1 tst-equ-mark2))
X
X ; if a hook exist and we failed the compare then run the hook ..
X (if (and (not tst-equ-result) 'tst-equ-mark-hook)
X (run-hooks 'tst-equ-mark-hook))
X
X (tst-equ-log-diff tst-equ-result tst-equ-mark1 tst-equ-mark2)
X tst-equ-result
X
X ) ; let
X) ; defun tst-equ-mark
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-equ-modified (buff-state1 buff-state2)
X "Compares the modified component from two buffer states. "
X
X (interactive "P")
X ; Local Variables
X (let (tst-equ-modified1 tst-equ-modified2 tst-equ-result)
X
X (setq tst-equ-modified1 (cadr (assoc 'buf-state-modified buff-state1)))
X (setq tst-equ-modified2 (cadr (assoc 'buf-state-modified buff-state2)))
X (setq tst-equ-result (equal tst-equ-modified1 tst-equ-modified2))
X
X ; if a hook exist and we failed the compare then run the hook ..
X (if (and (not tst-equ-result) 'tst-equ-modified-hook)
X (run-hooks 'tst-equ-modified-hook))
X
X (tst-equ-log-diff tst-equ-result tst-equ-modified1 tst-equ-modified2)
X tst-equ-result
X
X ) ; let
X) ; defun tst-equ-modified
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-equ-file (buff-state1 buff-state2)
X "Compares the file component from two buffer states. "
X
X (interactive "P")
X ; Local Variables
X (let (tst-equ-file1 tst-equ-file2 tst-equ-result)
X
X (setq tst-equ-file1 (cadr (assoc 'buf-state-file buff-state1))); get the first value
X (setq tst-equ-file2 (cadr (assoc 'buf-state-file buff-state2))); get the second value
X (setq tst-equ-result (equal tst-equ-file1 tst-equ-file2))
X
X ; if a hook exist and we failed the compare then run the hook ..
X (if (and (not tst-equ-result) 'tst-equ-file-hook)
X (run-hooks 'tst-equ-file-hook))
X
X (tst-equ-log-diff tst-equ-result tst-equ-file1 tst-equ-file2)
X tst-equ-result
X
X ) ; let
X) ; defun tst-equ-file
X
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X(defun tst-equ-diff-element (el1 el2)
X " Logs differences between the two elements based on the type of
Xelement that it is. (keymap, vector, string, list)"
X
X (let ()
X
X (cond ((keymapp (cdr el1)) (tst-equ-log-keymap el1 el2))
X ((syntax-table-p (cdr el1)) (tst-equ-log-syntable el1 el2))
X ((stringp (cdr el1)) (tst-equ-log-string el1 el2))
X ((atom (cdr el1)) (tst-equ-log-atom el1 el2))
X ((arrayp (cdr el1)) (tst-equ-log-array el1 el2))
X (t (tst-equ-log-fubar el1 el2))
X ); dnoc
X); tel
X); defun tst-equ-diff-element
X
X(defun tst-equ-log-fubar (el1 el2)
X" Generic equal-comparer for elements of a symbol"
X
X (let ()
X (if (not (equal el1 el2))
X (progn
X; (debug nil "in fubar" el1 el2)
X (indent-to (* tst-equ-indent 4))
X (insert (prin1-to-string (car el1)))
X (if (cdr el1)
X (insert ": "(prin1-to-string (cdr el1)) " "
X (prin1-to-string (cdr el2)))
X ); fi
X (newline)
X ); ngorp
X ); fi
X); tel
X); defun tst-equ-log-fubar
X
X(defun tst-equ-log-string (el1 el2)
X
X (let ()
X
X (if (not (equal el1 el2))
X (progn
X; (debug nil "In string" (car el1))
X (indent-to (* tst-equ-indent 4))
X (insert (prin1-to-string (car el1)))
X (newline)
X ); ngorp
X ); fi
X ); tel
X); defun tst-equ-log-string
X
X(defun tst-equ-log-atom (el1 el2)
X
X (let ()
X
X (if (not (equal el1 el2))
X (progn
X; (debug nil "in atom" el1 el2)
X (indent-to (* tst-equ-indent 4))
X (insert (prin1-to-string (car el1))
X " " (prin1-to-string (cdr el1))
X " " (prin1-to-string (cdr el2)))
X (newline)
X ); ngorp
X ); fi
X ); tel
X); defun tst-equ-log-atom
X
X(defun tst-equ-log-syntable (a1 a2)
X " Outputs the differences between two syntax tables in the form:
X element_number : value1 value2"
X
X (let (e1 e2 index)
X; (debug nil "In syntable" (car el1))
X (if (not (equal a1 a2))
X (while (not (= index 256))
X (setq e1 (aref a1 index))
X (setq e2 (aref a2 index))
X (if (not (equal e1 e2))
X (progn
X (indent-to (* tst-equ-indent 4))
X (insert (prin1-to-string index) ": "
X (prin1-to-string e1) " " (prin1-to-string e2))
X (newline)
X );ngorp
X ); fi
X (+1 index)
X ); elihw
X ); fi
X ); tel
X); defun tst-equ-log-syntable
X
X
X
X(defun tst-equ-log-keymap (a1 a2)
X " Outputs only the fact that two keymaps do not match. Has the potential
X for future enhancements (like, describing which keys don't match"
X
X; (debug nil "in keymap" (car el1))
X (if (not (equal a1 a2))
X (progn
X (indent-to (* tst-equ-indent 4))
X (insert (prin1-to-string (car a1)))
X ); ngorp
X );fi
X); defun tst-equ-log-keymap
X; (let (e1 e2 index)
X; (while (not (= index 256))
X; (setq e1 (aref a1 index))
X; (setq e2 (aref a2 index))
X; (if (not (equal e1 e2))
X; (progn
X; (indent-to (* tst-equ-indent 4))
X; (insert (prin1-to-string index) ": "
X; (prin1-to-string e1) " " (prin1-to-string e2))
X; (newline)
X; );ngorp
X; ); fi
X; (+1 index)
X; ); elihw
X;
X; ); tel
X;); defun tst-equ-log-syntable
X
X
X
X(defun tst-equ-log-diff (equal-flag v1 v2)
X "Logs differences in *equal-log* buffer. "
X
X
X (let ()
X (if (or tst-equ-log-all-compares (not equal-flag))
X (progn
X (indent-to (* tst-equ-indent 4))
X (insert (prin1-to-string v1) " " (prin1-to-string v2))
X (newline)
X ); ngorp
X );fi
X
X ) ; let
X) ; defun tst-equ-log-diff
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-equ-log-diff-line (line1 line2)
X "Logs differences in *equal-log* buffer. "
X
X
X (let ()
X
X (goto-char (point-max))
X (newline)
X (indent-to (* tst-equ-indent 4))
X (insert "1: " line1)
X (newline)
X (indent-to (* tst-equ-indent 4))
X (insert "2: " line2)
X (newline)
X
X ) ; let
X) ; defun tst-equ-log-diff-line
X
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-equ-find-buffer-with-name (state name )
X "Return a buff-state of the buffer from STATE with name NAME."
X
X; Variables
X
X (let (buffers buff-state buff-name found)
X
X (setq found nil)
X (setq buffers (cadr (assoc 'buffers state)))
X
X
X (while (not found)
X (progn
X (setq buff-state (car buffers))
X (setq buffers (cdr buffers))
X (setq buff-name (cadr (assoc 'buf-state-name buff-state)))
X (if (equal buff-name name)
X (setq found t)
X ; else
X (progn
X (if (not buffers)
X (progn
X (setq found t)
X (setq buff-state nil)
X ); progn
X ); fi
X ); ngrop
X ); if
X ); progn
X ); while
X buff-state
X ) ; let
X) ; defun tst-equ-find-buffer-with-name
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun tst-equ-named-buff-states (state1 name1 state2 name2)
X " Compares, from STATE1, the state of the buffer who's name is
X NAME1 with, from STATE2, the state of the buffer who's name
X is NAME2. If STATE2 is nil, then a buffer of NAME2 is expected
X in STATE1. "
X
X (interactive "P")
X
X; Variables
X
X (let (buff-state-1 buff-state-2)
X
X ; first locate the buffers
X (setq buff-state-1 (tst-equ-find-buffer-with-name state1 name1))
X (if state2
X (setq buff-state-2 (tst-equ-find-buffer-with-name state2 name2))
X ; else
X (setq buff-state-2 (tst-equ-find-buffer-with-name state1 name2))
X ) ; if
X (tst-equ-buffer-state buff-state-1 buff-state-2)
X
X ) ; let
X) ; defun tst-equ-named-buff-states
X
X(defun tst-equ-local-vars (b1 b2)
X " Compares the values of the local variables in two buffers and
X logs the ones that are different."
X
X
X (interactive "P")
X
X (let (vars1 vars2 var1 var2 tst-equ-result firsttime)
X
X (setq tst-equ-result t) ;default to "all equal "
X (setq firsttime nil) ;still just my first time ...
X
X
X (setq vars1 (cadr (assoc 'buf-state-local-vars b1)))
X
X (setq vars2 (cadr (assoc 'buf-state-local-vars b2)))
X
X (while vars1 ;go through the b1 vars first.
X (setq var1 (car vars1)) ;get the next variable
X (setq vars1 (cdr vars1)) ;.. and set the list to the tail
X (setq var2 (assoc (car var1) vars2)) ; find this variable in b2
X (if var2
X (progn
X (if (not (equal var1 var2))
X (progn
X (if (not firsttime)
X (progn
X (indent-to (* tst-equ-indent 3))
X (insert "local variables not equal ")
X (newline)
X (setq firsttime t)
X ); ngorp
X ); fi
X (setq tst-equ-result nil)
X (indent-to (* tst-equ-indent 4))
X (insert (prin1-to-string (car var1))
X " " (prin1-to-string (cdr var1))
X " " (prin1-to-string (cdr var2)))
X (newline)
X ); ngorp
X );fi
X ); ngorp
X ; else
X (progn
X (setq tst-equ-result nil)
X (if (not firsttime)
X (progn
X (insert "?")
X (indent-to (* tst-equ-level 3))
X (insert "local variables not equal ")
X (newline)
X (setq firsttime t)
X ); ngorp
X ); fi
X (indent-to (* tst-equ-level 4))
X (insert (prin1-to-string (car var1)) "not found in second buffer ")
X (newline)
X ); ngorp (of else)
X ); fi [if vars2]
X ); elihw
X
X (setq vars1 (cadr (assoc 'buf-state-local-vars b1)))
X (while vars2
X
X (setq var2 (car vars2)) ;get the next variable
X (setq vars2 (cdr vars2)) ;.. and set the list to the tail
X (setq var1 (assoc (car var2) vars1))
X (if (not var1)
X (progn
X (setq tst-equ-result nil)
X (if (not firsttime)
X (progn
X (indent-to (* tst-equ-indent 4))
X (insert "local variables not equal:")
X (newline)
X (setq firsttime t)
X ); ngorp
X ); fi
X (indent-to (* tst-equ-indent 4))
X (insert (prin1-to-string (car var2)) " not found in first buffer " )
X (newline)
X ); ngorp (of else)
X ); fi
X ); elihw
X (if tst-equ-result
X (progn
X (indent-to (* tst-equ-indent 4))
X (insert "local variables are equal ")
X (newline)
X ); ngorp
X ); fi
X tst-equ-result ;return the tst-equ-result
X ); tel
X ); defun tst-equ-local-vars
X
X
X
SHAR_EOF
if test 32129 -ne "`wc -c < 'tst-equal.el'`"
then
echo shar: "error transmitting 'tst-equal.el'" '(should have been 32129 characters)'
fi
fi
echo shar: "extracting 'tst-inequal.el'" '(3828 characters)'
if test -f 'tst-inequal.el'
then
echo shar: "will not over-write existing file 'tst-inequal.el'"
else
sed 's/^X//' << \SHAR_EOF > 'tst-inequal.el'
X;;; inequal.el -- A number of inequality functions.
X;;; See also equal.el
X;;; Lorri Menard, Wang Institute of Graduate Studies
X;;; Don Zaremba, Wang Institute of Graduate Studies
X;;; Copyright 1987 Wang Institute of Graduate Studies
X;;;
X
X(provide 'tst-inequal)
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun string-equal-less-white (str1 str2)
X " Returns t if the two strings are equal after ignoring whitespace."
X
X (let ()
X (string-equal-less-regexp "\\s " str1 str2)
X ) ; let
X) ; line-of-buffer
X
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun string-equal-less-regexp (regexp str1 str2)
X " Returns t if the two strings are equal after ignoring all substrings
X that match regexp ."
X
X (let (start1 end1 start2 end2 token1 token2 success more1 more2)
X (setq success t more1 t more2 t)
X (setq start1 (first-not-regexp regexp str1 0)); move to 1st non-white
X (setq start2 (first-not-regexp regexp str2 0)); move to 1st non-white
X
X (while (and more1 more2)
X (progn
X (setq end1 (string-match regexp str1 start1))
X (setq end2 (string-match regexp str2 start2))
X (if end1
X (progn ; end1 not nil
X (setq token1 (substring str1 start1 end1))
X (setq start1 (first-not-regexp regexp str1 end1))
X (if (not start1) ; check for trailing delimiter only
X (setq more1 nil))
X ); progn
X ;else
X (progn
X (setq token1 (substring str1 start1 nil));
X (setq more1 nil)
X ); progn
X ); if
X (if end2
X (progn ; end2 not nil
X (setq token2 (substring str2 start2 end2))
X (setq start2 (first-not-regexp regexp str2 end2))
X (if (not start2) ; check for trailing delimiter only
X (setq more2 nil))
X ); progn
X ;else
X (progn
X (setq token2 (substring str2 start2 nil));
X (setq more2 nil)
X ); progn
X ); if
X; (send-string-to-terminal "[")
X; (send-string-to-terminal token1)
X; (send-string-to-terminal "][")
X; (send-string-to-terminal token2)
X; (send-string-to-terminal "]")
X (setq success (string-equal token1 token2))
X (if (not success)
X (setq more1 nil)) ; if failed then stop the loop
X ); progn
X ) ; while
X (and (not more1) (not more2) success)
X ) ; let
X) ; string-equal-less-white
X
X
X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
X
X(defun first-not-regexp (regexp str sindex)
X " Returns the index of the first char in string that does not match
X regular expression. Returns nil if nothing doesn't match."
X
X (let (fm more string-is-nil)
X (setq more t slen)
X (setq slen (length str))
X (if (equal 0 slen) ; test for a zero length string
X nil
X ; else
X (progn
X (setq string-is-nil nil)
X (setq fm (string-match regexp str sindex)) ; start of match
X (if (or (not fm) (< sindex fm)) (setq more nil)) ; found non-regexp
X; (debug nil "Before while" fm sindex)
X (while more
X (progn
X (setq sindex (match-end 0))
X (if (>= sindex slen)
X (progn
X (setq string-is-nil t)
X (setq more nil)
X )
X ;else
X (progn
X (setq fm (string-match regexp str sindex))
X (if (or (not fm) (< sindex fm)) (setq more nil))
X; (debug nil "In while " fm sindex)
X ); progn
X ); if
X ); progn
X ); while
X (if string-is-nil nil sindex)
X ); progn
X ); if
X ) ; let
X) ; first-not-regexp
X
X
X
X
X; example hook usage
X;
X; (setq tst-equ-line-hook 'first-5)
X; (setq tst-equ-mark-hook 'great-mark)
X;
X; example line hook - only compares first 5 chars on a line
X;(defun first-5 ()
X; (string-equal (substring tst-equ-line1 0 5) (substring tst-equ-line2 0 5))
X;)
X
X;example mark hook - only concerned with relative order of marks
X;(defun great-mark ()
X; (> tst-equ-mark1 tst-equ-mark2)
X; )
X
X
X
SHAR_EOF
if test 3828 -ne "`wc -c < 'tst-inequal.el'`"
then
echo shar: "error transmitting 'tst-inequal.el'" '(should have been 3828 characters)'
fi
fi
echo shar: "extracting 'tst-instrument.el'" '(5937 characters)'
if test -f 'tst-instrument.el'
then
echo shar: "will not over-write existing file 'tst-instrument.el'"
else
sed 's/^X//' << \SHAR_EOF > 'tst-instrument.el'
X;;; tst-instrument
X;;; Copyright 1987 Richard Rosenthal
X;;; All rights reserved.
X
X(provide 'tst-instrument)
X(require 'tst-annotate)
X
X(defvar *tst-last-instrumented-line* 0
X "Defined in instrument.el. Used in the following functions:
X tst-instrument-defun
X tst-instrument-primitive")
X
X(defun tst-instrument ()
X "The tst-instrument function creates a buffer containing a copy of
Xthe buffer in which the function was invoked. All code in the copied
Xbuffer is then instrumented and compiled. We are talking about
Xcompiling LISP code."
X (interactive)
X (let* ((old-buffer (buffer-name))
X (instrumented-buffer
X (get-buffer-create (concat old-buffer "-instrumented"))))
X (save-excursion
X (set-buffer instrumented-buffer)
X (emacs-lisp-mode)
X (erase-buffer)
X (insert-buffer old-buffer)
X (tst-ann-set-db nil)
X (tst-instrument-region (point-min) (point-max))
X (eval-current-buffer)
X (message "Done"))))
X
X
X(defun tst-instrument-region (start end)
X (interactive "r")
X (save-restriction
X (narrow-to-region start end)
X (goto-char (point-min))
X (or (looking-at "\\s( *defun\\b") (beginning-of-next-defun))
X (while (< (point) (point-max))
X (tst-instrument-defun)
X (beginning-of-next-defun))))
X
X
X(defun tst-instrument-defun ()
X (save-excursion
X (save-restriction
X (push-mark (point) 'nomsg)
X (setq *tst-last-instrumented-line* (line-number))
X (if (error-occurred (forward-sexp 1))
X (progn
X (goto-char (point-max))
X nil)
X (narrow-to-region (mark) (point))
X (goto-char (point-min))
X (down-list 1)
X (next-sexp) ;looking at defun
X (beginning-of-next-sexp) ;looking at function name
X (let ((start (point))
X end)
X (forward-sexp 1)
X (setq end (point))
X (backward-sexp 1)
X (message "Instrumenting (defun %s..." (buffer-substring start end))
X )
X (beginning-of-next-sexp) ;looking at parameter list
X (beginning-of-next-sexp) ;looking at comment?
X (if (looking-at "\\s\"")
X (beginning-of-next-sexp)) ;looking at parameter list
X
X ;; now looking at first statement in defun
X (while (< (point) (point-max))
X (cond
X ((looking-at "\\s(")
X (tst-instrument-function))
X
X ;;inside a comment
X ((nth 4 (parse-partial-sexp (point-min) (point) nil nil nil))
X (end-of-line)
X (next-sexp))
X
X (t
X (beginning-of-next-sexp))))
X t))))
X
X
X(defun tst-instrument-function ()
X;;;at this point, I was definitly looking at a left "(".
X (cond
X ((tst-looking-at-prohibited-form-p)
X (beginning-of-next-sexp)) ;do nothing, skip it
X
X ((tst-looking-at-special-form-p)
X (tst-instrument-primitive) ;instrument around it
X (tst-instrument-special-form)) ;try to go in it
X
X (t
X (tst-instrument-primitive) ;instrument around it
X (down-list 1)))) ;go in it
X
X(defun tst-looking-at-prohibited-form-p ()
X (cond
X ((looking-at "\\s( *interactive\\b") t)
X ((looking-at "\\s( *quote\\b") t)
X ((looking-at "\\s'\\s(") t)
X (t nil)))
X
X(defun tst-looking-at-special-form-p ()
X "List potential trouble makers in this function"
X (cond
X ((looking-at "\\s( *cond\\b") t)
X ((looking-at "\\s( *function\\b") t)
X ((looking-at "\\s( *let\\b") t)
X ((looking-at "\\s( *progn\\b") t)
X (t nil)))
X
X(defun tst-instrument-special-form ()
X "Explain how to deal with known trouble makers in this function"
X (cond
X ((looking-at "\\s( *let\\b") ;minor problem
X (tst-instrument-let))
X ((looking-at "\\s( *progn\\b") ;no problem
X (down-list 1))
X (t ;skip forms I don't know about
X (beginning-of-next-sexp))))
X
X(defun tst-instrument-primitive ()
X (let ((start (line-number)))
X (if (> start *tst-last-instrumented-line*)
X (progn
X (setq *tst-last-instrumented-line* start)
X (insert "(tst-cover " (int-to-string start) " ")
X (forward-sexp 1)
X (insert ")")
X (backward-char 1)
X (backward-sexp 1)
X (tst-ann-append start 'count '(0))))))
X
X
X(defun tst-instrument-let ()
X (down-list 1)
X (next-sexp) ;looking at let
X (beginning-of-next-sexp) ;looking at parameter list
X (forward-sexp 1) ;skip parameters for now
X (next-sexp))
X
X
X;;;----------------------------------------------------------------------------
X(defun tst-cover (id arg)
X "Version 2: for testing, display arg in mini-buffer while
Xmoving cursor around buffer"
X (save-excursion
X (goto-line id)
X (re-search-forward "\\s(")
X (message "function returns %s" (prin1-to-string arg))
X (sit-for 2)
X )
X arg)
X
X(defun tst-cover (id arg)
X "Version 1: for testing, display id and arg in mini-buffer"
X (message "tst-cover %d %s" id (prin1-to-string arg))
X (sit-for 0)
X arg)
X
X(defun tst-cover (id arg)
X "Version 0: for testing, does nothing"
X arg)
X
X(defun tst-cover (id arg)
X "The Real Thing: uses annotation capabilities"
X (tst-ann-inc id 'count)
X (tst-ann-append id 'values (list arg))
X arg)
X
X
X;;;============================================================================
X(defun beginning-of-next-defun ()
X "This function finds LISP defun"
X (if (= (point) (point-max))
X nil
X (forward-char 1)
X (and (re-search-forward "\\s( *defun\\b" nil 'move 1)
X (re-search-backward "\\s("))))
X
X(defmacro error-occurred (&rest body)
X "As defined in mlsupport.el"
X (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
X
X(defun line-number ()
X "Return line number of current line. Gives consistent results."
X (count-lines-correctly 1 (point)))
X
X(defun count-lines-correctly (start end)
X "Return number of newlines between START and END. Gives
Xconsistent results."
X (save-excursion
X (save-restriction
X (goto-char end)
X (end-of-line)
X (narrow-to-region start (point))
X (goto-char (point-min))
X (- (buffer-size) (forward-line (buffer-size))))))
X
X(defun next-sexp ()
X (while (error-occurred (forward-sexp))
X (forward-char 1))
X (or (= (point) (point-max)) (backward-sexp)))
X
X(defun beginning-of-next-sexp ()
X (forward-sexp 1)
X (next-sexp))
SHAR_EOF
if test 5937 -ne "`wc -c < 'tst-instrument.el'`"
then
echo shar: "error transmitting 'tst-instrument.el'" '(should have been 5937 characters)'
fi
fi
exit 0
# End of shell archive
--
Rich $alz
Cronus Project, BBN Labs rsalz@bbn.com
Moderator, comp.sources.unix sources@uunet.uu.net