[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to emacs/lisp/emacs-lisp/testcover.el [lexbind]
From: |
Miles Bader |
Subject: |
[Emacs-diffs] Changes to emacs/lisp/emacs-lisp/testcover.el [lexbind] |
Date: |
Fri, 23 Jul 2004 00:58:08 -0400 |
Index: emacs/lisp/emacs-lisp/testcover.el
diff -c emacs/lisp/emacs-lisp/testcover.el:1.2.2.3
emacs/lisp/emacs-lisp/testcover.el:1.2.2.4
*** emacs/lisp/emacs-lisp/testcover.el:1.2.2.3 Sun Dec 28 05:19:57 2003
--- emacs/lisp/emacs-lisp/testcover.el Fri Jul 23 04:42:20 2004
***************
*** 38,46 ****
;; instrumentation callbacks, then replace edebug's callbacks with ours.
;; * To show good coverage, we want to see two values for every form, except
;; functions that always return the same value and `defconst' variables
! ;; need show only value for good coverage. To avoid the brown splotch, the
! ;; definitions for constants and 1-valued functions must precede the
! ;; references.
;; * Use the macro `1value' in your Lisp code to mark spots where the local
;; code environment causes a function or variable to always have the same
;; value, but the function or variable is not intrinsically 1-valued.
--- 38,46 ----
;; instrumentation callbacks, then replace edebug's callbacks with ours.
;; * To show good coverage, we want to see two values for every form, except
;; functions that always return the same value and `defconst' variables
! ;; need show only one value for good coverage. To avoid the brown
! ;; splotch, the definitions for constants and 1-valued functions must
! ;; precede the references.
;; * Use the macro `1value' in your Lisp code to mark spots where the local
;; code environment causes a function or variable to always have the same
;; value, but the function or variable is not intrinsically 1-valued.
***************
*** 55,66 ****
;; call has the same value! Also, equal thinks two strings are the same
;; if they differ only in properties.
;; * Because we have only a "1value" class and no "always nil" class, we have
! ;; to treat as 1-valued any `and' whose last term is 1-valued, in case the
! ;; last term is always nil. Example:
;; (and (< (point) 1000) (forward-char 10))
! ;; This form always returns nil. Similarly, `if' and `cond' are
! ;; treated as 1-valued if all clauses are, in case those values are
! ;; always nil.
(require 'edebug)
(provide 'testcover)
--- 55,68 ----
;; call has the same value! Also, equal thinks two strings are the same
;; if they differ only in properties.
;; * Because we have only a "1value" class and no "always nil" class, we have
! ;; to treat as potentially 1-valued any `and' whose last term is 1-valued,
! ;; in case the last term is always nil. Example:
;; (and (< (point) 1000) (forward-char 10))
! ;; This form always returns nil. Similarly, `or', `if', and `cond' are
! ;; treated as potentially 1-valued if all clauses are, in case those
! ;; values are always nil. Unlike truly 1-valued functions, it is not an
! ;; error if these "potentially" 1-valued forms actually return differing
! ;; values.
(require 'edebug)
(provide 'testcover)
***************
*** 86,97 ****
(defcustom testcover-1value-functions
'(backward-char barf-if-buffer-read-only beginning-of-line
! buffer-disable-undo buffer-enable-undo current-global-map deactivate-mark
! delete-char delete-region ding error forward-char function* insert
! insert-and-inherit kill-all-local-variables lambda mapc narrow-to-region
! noreturn push-mark put-text-property run-hooks set-text-properties signal
! substitute-key-definition suppress-keymap throw undo use-local-map while
! widen yank)
"Functions that always return the same value. No brown splotch is shown
for these. This list is quite incomplete! Notes: Nobody ever changes the
current global map. The macro `lambda' is self-evaluating, hence always
--- 88,101 ----
(defcustom testcover-1value-functions
'(backward-char barf-if-buffer-read-only beginning-of-line
! buffer-disable-undo buffer-enable-undo current-global-map
! deactivate-mark delete-backward-char delete-char delete-region ding
! forward-char function* insert insert-and-inherit kill-all-local-variables
! kill-line kill-paragraph kill-region kill-sexp lambda
! minibuffer-complete-and-exit narrow-to-region next-line push-mark
! put-text-property run-hooks set-match-data signal
! substitute-key-definition suppress-keymap undo use-local-map while widen
! yank)
"Functions that always return the same value. No brown splotch is shown
for these. This list is quite incomplete! Notes: Nobody ever changes the
current global map. The macro `lambda' is self-evaluating, hence always
***************
*** 108,116 ****
:type 'hook)
(defcustom testcover-compose-functions
! '(+ - * / length list make-keymap make-sparse-keymap message propertize
! replace-regexp-in-string run-with-idle-timer
! set-buffer-modified-p)
"Functions that are 1-valued if all their args are either constants or
calls to one of the `testcover-1value-functions', so if that's true then no
brown splotch is shown for these. This list is quite incomplete! Most
--- 112,120 ----
:type 'hook)
(defcustom testcover-compose-functions
! '(+ - * / = append length list make-keymap make-sparse-keymap
! mapcar message propertize replace-regexp-in-string
! run-with-idle-timer set-buffer-modified-p)
"Functions that are 1-valued if all their args are either constants or
calls to one of the `testcover-1value-functions', so if that's true then no
brown splotch is shown for these. This list is quite incomplete! Most
***************
*** 119,134 ****
:type 'hook)
(defcustom testcover-progn-functions
! '(define-key fset function goto-char or overlay-put progn
save-current-buffer
! save-excursion save-match-data save-restriction save-selected-window
! save-window-excursion set set-default setq setq-default
! with-output-to-temp-buffer with-syntax-table with-temp-buffer
! with-temp-file with-temp-message with-timeout)
"Functions whose return value is the same as their last argument. No
brown splotch is shown for these if the last argument is a constant or a
call to one of the `testcover-1value-functions'. This list is probably
! incomplete! Note: `or' is here in case the last argument is a function that
! always returns nil."
:group 'testcover
:type 'hook)
--- 123,138 ----
:type 'hook)
(defcustom testcover-progn-functions
! '(define-key fset function goto-char mapc overlay-put progn
! save-current-buffer save-excursion save-match-data
! save-restriction save-selected-window save-window-excursion
! set set-default set-marker-insertion-type setq setq-default
! with-current-buffer with-output-to-temp-buffer with-syntax-table
! with-temp-buffer with-temp-file with-temp-message with-timeout)
"Functions whose return value is the same as their last argument. No
brown splotch is shown for these if the last argument is a constant or a
call to one of the `testcover-1value-functions'. This list is probably
! incomplete!"
:group 'testcover
:type 'hook)
***************
*** 140,145 ****
--- 144,154 ----
:group 'testcover
:type 'hook)
+ (defcustom testcover-potentially-1value-functions
+ '(add-hook and beep or remove-hook unless when)
+ "Functions that are potentially 1-valued. No brown splotch if actually
+ 1-valued, no error if actually multi-valued.")
+
(defface testcover-nohits-face
'((t (:background "DeepPink2")))
"Face for forms that had no hits during coverage test"
***************
*** 161,167 ****
(defvar testcover-module-1value-functions nil
"Symbols declared with defun in the last file processed by
! `testcover-start', whose functions always return the same value.")
(defvar testcover-vector nil
"Locally bound to coverage vector for function in progress.")
--- 170,180 ----
(defvar testcover-module-1value-functions nil
"Symbols declared with defun in the last file processed by
! `testcover-start', whose functions should always return the same value.")
!
! (defvar testcover-module-potentially-1value-functions nil
! "Symbols declared with defun in the last file processed by
! `testcover-start', whose functions might always return the same value.")
(defvar testcover-vector nil
"Locally bound to coverage vector for function in progress.")
***************
*** 206,230 ****
x))
(defun testcover-reinstrument (form)
! "Reinstruments FORM to use testcover instead of edebug. This function
! modifies the list that FORM points to. Result is non-nil if FORM will
! always return the same value."
(let ((fun (car-safe form))
! id)
(cond
! ((not fun) ;Atom
! (or (not (symbolp form))
! (memq form testcover-constants)
! (memq form testcover-module-constants)))
! ((consp fun) ;Embedded list
(testcover-reinstrument fun)
(testcover-reinstrument-list (cdr form))
nil)
((or (memq fun testcover-1value-functions)
(memq fun testcover-module-1value-functions))
! ;;Always return same value
(testcover-reinstrument-list (cdr form))
t)
((memq fun testcover-progn-functions)
;;1-valued if last argument is
(testcover-reinstrument-list (cdr form)))
--- 219,250 ----
x))
(defun testcover-reinstrument (form)
! "Reinstruments FORM to use testcover instead of edebug. This
! function modifies the list that FORM points to. Result is nil if
! FORM should return multiple vlues, t if should always return same
! value, 'maybe if either is acceptable."
(let ((fun (car-safe form))
! id val)
(cond
! ((not fun) ;Atom
! (when (or (not (symbolp form))
! (memq form testcover-constants)
! (memq form testcover-module-constants))
! t))
! ((consp fun) ;Embedded list
(testcover-reinstrument fun)
(testcover-reinstrument-list (cdr form))
nil)
((or (memq fun testcover-1value-functions)
(memq fun testcover-module-1value-functions))
! ;;Should always return same value
(testcover-reinstrument-list (cdr form))
t)
+ ((or (memq fun testcover-potentially-1value-functions)
+ (memq fun testcover-module-potentially-1value-functions))
+ ;;Might always return same value
+ (testcover-reinstrument-list (cdr form))
+ 'maybe)
((memq fun testcover-progn-functions)
;;1-valued if last argument is
(testcover-reinstrument-list (cdr form)))
***************
*** 233,243 ****
(testcover-reinstrument-list (cddr form))
(testcover-reinstrument (cadr form)))
((memq fun testcover-compose-functions)
! ;;1-valued if all arguments are
! (setq id t)
! (mapc #'(lambda (x) (setq id (or (testcover-reinstrument x) id)))
! (cdr form))
! id)
((eq fun 'edebug-enter)
;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS))
;; => (testcover-enter 'SYM #'(lambda nil FORMS))
--- 253,261 ----
(testcover-reinstrument-list (cddr form))
(testcover-reinstrument (cadr form)))
((memq fun testcover-compose-functions)
! ;;1-valued if all arguments are. Potentially 1-valued if all
! ;;arguments are either definitely or potentially.
! (testcover-reinstrument-compose (cdr form) 'testcover-reinstrument))
((eq fun 'edebug-enter)
;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS))
;; => (testcover-enter 'SYM #'(lambda nil FORMS))
***************
*** 252,284 ****
(aset testcover-vector (cadr (cadr form)) 'ok-coverage))
(setq id (nth 2 form))
(setcdr form (nthcdr 2 form))
(cond
((memq (car-safe (nth 2 form)) testcover-noreturn-functions)
;;This function won't return, so set the value in advance
;;(edebug-after (edebug-before XXX) YYY FORM)
;; => (progn (edebug-after YYY nil) FORM)
(setcar form 'progn)
! (setcar (cdr form) `(testcover-after ,id nil)))
((eq (car-safe (nth 2 form)) '1value)
;;This function is always supposed to return the same value
! (setcar form 'testcover-1value))
! (t
! (setcar form 'testcover-after)))
! (when (testcover-reinstrument (nth 2 form))
! (aset testcover-vector id '1value)))
((eq fun 'defun)
! (if (testcover-reinstrument-list (nthcdr 3 form))
! (push (cadr form) testcover-module-1value-functions)))
! ((eq fun 'defconst)
;;Define this symbol as 1-valued
(push (cadr form) testcover-module-constants)
(testcover-reinstrument-list (cddr form)))
((memq fun '(dotimes dolist))
;;Always returns third value from SPEC
(testcover-reinstrument-list (cddr form))
! (setq fun (testcover-reinstrument-list (cadr form)))
(if (nth 2 (cadr form))
! fun
;;No third value, always returns nil
t))
((memq fun '(let let*))
--- 270,313 ----
(aset testcover-vector (cadr (cadr form)) 'ok-coverage))
(setq id (nth 2 form))
(setcdr form (nthcdr 2 form))
+ (setq val (testcover-reinstrument (nth 2 form)))
+ (if (eq val t)
+ (setcar form 'testcover-1value)
+ (setcar form 'testcover-after))
+ (when val
+ ;;1-valued or potentially 1-valued
+ (aset testcover-vector id '1value))
(cond
((memq (car-safe (nth 2 form)) testcover-noreturn-functions)
;;This function won't return, so set the value in advance
;;(edebug-after (edebug-before XXX) YYY FORM)
;; => (progn (edebug-after YYY nil) FORM)
+ (setcar (cdr form) `(,(car form) ,id nil))
(setcar form 'progn)
! (aset testcover-vector id '1value)
! (setq val t))
((eq (car-safe (nth 2 form)) '1value)
;;This function is always supposed to return the same value
! (setq val t)
! (aset testcover-vector id '1value)
! (setcar form 'testcover-1value)))
! val)
((eq fun 'defun)
! (setq val (testcover-reinstrument-list (nthcdr 3 form)))
! (when (eq val t)
! (push (cadr form) testcover-module-1value-functions))
! (when (eq val 'maybe)
! (push (cadr form) testcover-module-potentially-1value-functions)))
! ((memq fun '(defconst defcustom))
;;Define this symbol as 1-valued
(push (cadr form) testcover-module-constants)
(testcover-reinstrument-list (cddr form)))
((memq fun '(dotimes dolist))
;;Always returns third value from SPEC
(testcover-reinstrument-list (cddr form))
! (setq val (testcover-reinstrument-list (cadr form)))
(if (nth 2 (cadr form))
! val
;;No third value, always returns nil
t))
((memq fun '(let let*))
***************
*** 286,308 ****
(mapc 'testcover-reinstrument-list (cadr form))
(testcover-reinstrument-list (cddr form)))
((eq fun 'if)
! ;;1-valued if both THEN and ELSE clauses are
(testcover-reinstrument (cadr form))
(let ((then (testcover-reinstrument (nth 2 form)))
(else (testcover-reinstrument-list (nthcdr 3 form))))
! (and then else)))
! ((memq fun '(when unless and))
! ;;1-valued if last clause of BODY is
! (testcover-reinstrument-list (cdr form)))
((eq fun 'cond)
! ;;1-valued if all clauses are
! (testcover-reinstrument-clauses (cdr form)))
((eq fun 'condition-case)
! ;;1-valued if BODYFORM is and all HANDLERS are
(let ((body (testcover-reinstrument (nth 2 form)))
! (errs (testcover-reinstrument-clauses (mapcar #'cdr
! (nthcdr 3 form)))))
! (and body errs)))
((eq fun 'quote)
;;Don't reinstrument what's inside!
;;This doesn't apply within a backquote
--- 315,337 ----
(mapc 'testcover-reinstrument-list (cadr form))
(testcover-reinstrument-list (cddr form)))
((eq fun 'if)
! ;;Potentially 1-valued if both THEN and ELSE clauses are
(testcover-reinstrument (cadr form))
(let ((then (testcover-reinstrument (nth 2 form)))
(else (testcover-reinstrument-list (nthcdr 3 form))))
! (and then else 'maybe)))
((eq fun 'cond)
! ;;Potentially 1-valued if all clauses are
! (when (testcover-reinstrument-compose (cdr form)
! 'testcover-reinstrument-list)
! 'maybe))
((eq fun 'condition-case)
! ;;Potentially 1-valued if BODYFORM is and all HANDLERS are
(let ((body (testcover-reinstrument (nth 2 form)))
! (errs (testcover-reinstrument-compose
! (mapcar #'cdr (nthcdr 3 form))
! 'testcover-reinstrument-list)))
! (and body errs 'maybe)))
((eq fun 'quote)
;;Don't reinstrument what's inside!
;;This doesn't apply within a backquote
***************
*** 317,332 ****
(let ((testcover-1value-functions
(remq 'quote testcover-1value-functions)))
(testcover-reinstrument (cadr form))))
! ((memq fun '(1value noreturn))
;;Hack - pretend the arg is 1-valued here
! (if (symbolp (cadr form)) ;A pseudoconstant variable
! t
(if (eq (car (cadr form)) 'edebug-after)
(setq id (car (nth 3 (cadr form))))
(setq id (car (cadr form))))
(let ((testcover-1value-functions
(cons id testcover-1value-functions)))
! (testcover-reinstrument (cadr form)))))
(t ;Some other function or weird thing
(testcover-reinstrument-list (cdr form))
nil))))
--- 346,400 ----
(let ((testcover-1value-functions
(remq 'quote testcover-1value-functions)))
(testcover-reinstrument (cadr form))))
! ((eq fun '1value)
;;Hack - pretend the arg is 1-valued here
! (cond
! ((symbolp (cadr form))
! ;;A pseudoconstant variable
! t)
! ((and (eq (car (cadr form)) 'edebug-after)
! (symbolp (nth 3 (cadr form))))
! ;;Reference to pseudoconstant
! (aset testcover-vector (nth 2 (cadr form)) '1value)
! (setcar (cdr form) `(testcover-1value ,(nth 2 (cadr form))
! ,(nth 3 (cadr form))))
! t)
! (t
(if (eq (car (cadr form)) 'edebug-after)
(setq id (car (nth 3 (cadr form))))
(setq id (car (cadr form))))
(let ((testcover-1value-functions
(cons id testcover-1value-functions)))
! (testcover-reinstrument (cadr form))))))
! ((eq fun 'noreturn)
! ;;Hack - pretend the arg has no return
! (cond
! ((symbolp (cadr form))
! ;;A pseudoconstant variable
! 'maybe)
! ((and (eq (car (cadr form)) 'edebug-after)
! (symbolp (nth 3 (cadr form))))
! ;;Reference to pseudoconstant
! (aset testcover-vector (nth 2 (cadr form)) '1value)
! (setcar (cdr form) `(progn (testcover-after ,(nth 2 (cadr form)) nil)
! ,(nth 3 (cadr form))))
! 'maybe)
! (t
! (if (eq (car (cadr form)) 'edebug-after)
! (setq id (car (nth 3 (cadr form))))
! (setq id (car (cadr form))))
! (let ((testcover-noreturn-functions
! (cons id testcover-noreturn-functions)))
! (testcover-reinstrument (cadr form))))))
! ((and (eq fun 'apply)
! (eq (car-safe (cadr form)) 'quote)
! (symbolp (cadr (cadr form))))
! ;;Apply of a constant symbol. Process as 1value or noreturn
! ;;depending on symbol.
! (setq fun (cons (cadr (cadr form)) (cddr form))
! val (testcover-reinstrument fun))
! (setcdr (cdr form) (cdr fun))
! val)
(t ;Some other function or weird thing
(testcover-reinstrument-list (cdr form))
nil))))
***************
*** 341,353 ****
(setq result (testcover-reinstrument (pop list))))
result))
! (defun testcover-reinstrument-clauses (clauselist)
! "Reinstrument each list in CLAUSELIST.
! Result is t if every clause is 1-valued."
(let ((result t))
(mapc #'(lambda (x)
! (setq result (and (testcover-reinstrument-list x) result)))
! clauselist)
result))
(defun testcover-end (buffer)
--- 409,430 ----
(setq result (testcover-reinstrument (pop list))))
result))
! (defun testcover-reinstrument-compose (list fun)
! "For a compositional function, the result is 1-valued if all
! arguments are, potentially 1-valued if all arguments are either
! definitely or potentially 1-valued, and multi-valued otherwise.
! FUN should be `testcover-reinstrument' for compositional functions,
! `testcover-reinstrument-list' for clauses in a `cond'."
(let ((result t))
(mapc #'(lambda (x)
! (setq x (funcall fun x))
! (cond
! ((eq result t)
! (setq result x))
! ((eq result 'maybe)
! (when (not x)
! (setq result nil)))))
! list)
result))
(defun testcover-end (buffer)
***************
*** 387,393 ****
(aset testcover-vector idx (cons '1value val)))
((not (and (eq (car-safe (aref testcover-vector idx)) '1value)
(equal (cdr (aref testcover-vector idx)) val)))
! (error "Value of form marked with `1value' does vary.")))
val)
--- 464,470 ----
(aset testcover-vector idx (cons '1value val)))
((not (and (eq (car-safe (aref testcover-vector idx)) '1value)
(equal (cdr (aref testcover-vector idx)) val)))
! (error "Value of form marked with `1value' does vary: %s" val)))
val)
***************
*** 415,421 ****
ov j item)
(or (and def-mark points coverage)
(error "Missing edebug data for function %s" def))
! (when len
(set-buffer (marker-buffer def-mark))
(mapc 'delete-overlay
(overlays-in def-mark (+ def-mark (aref points (1- len)) 1)))
--- 492,498 ----
ov j item)
(or (and def-mark points coverage)
(error "Missing edebug data for function %s" def))
! (when (> len 0)
(set-buffer (marker-buffer def-mark))
(mapc 'delete-overlay
(overlays-in def-mark (+ def-mark (aref points (1- len)) 1)))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] Changes to emacs/lisp/emacs-lisp/testcover.el [lexbind],
Miles Bader <=