From: Jonathan Yavner Date: Sat, 17 Jul 2004 17:06:26 +0000 (+0000) Subject: Added some additional functions to the `1-valued', `compose', and progn groups. X-Git-Tag: ttn-vms-21-2-B4~5455 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=3e39672fd35c40e1dedc8213858a3ac424a31824;p=emacs.git Added some additional functions to the `1-valued', `compose', and progn groups. Bugfix for marking up the definition for an empty function. New category "potentially-1valued" for functions that are not erroneous if either 1-valued or multi-valued. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 2b249918d7f..cf0600b7605 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,13 @@ +2004-07-17 Jonathan Yavner + + * emacs-lisp/testcover.el: New category "potentially-1valued" for + functions that are not erroneous if either 1-valued or + multi-valued. Detect functions in this class. + (testcover-1value-functions, testcover-compose-functions, + testcover-progn-functions) Added some additional functions to lists. + (testcover-mark): Bugfix when marking up the definition for an + empty function. + 2004-07-17 Richard M. Stallman * replace.el (occur-read-primary-args): Pass default to read-from-minibuffer. diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index 547e2cbd32d..23e9a54b1bb 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -38,9 +38,9 @@ ;; 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. +;; 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,12 +55,14 @@ ;; 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: +;; 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, `if' and `cond' are -;; treated as 1-valued if all clauses are, in case those values are -;; always nil. +;; 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,12 +88,14 @@ these. This list is quite incomplete!" (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) + 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,9 +112,9 @@ them as having returned nil just before calling them." :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) + '(+ - * / = 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,16 +123,16 @@ side-effect-free functions should be here." :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) + '(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! Note: `or' is here in case the last argument is a function that -always returns nil." +incomplete!" :group 'testcover :type 'hook) @@ -140,6 +144,11 @@ call to one of the `testcover-1value-functions'." :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,7 +170,11 @@ call to one of the `testcover-1value-functions'." (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.") +`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,25 +219,32 @@ non-nil, byte-compiles each function after instrumenting." 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." + "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) + id val) (cond - ((not fun) ;Atom - (or (not (symbolp form)) - (memq form testcover-constants) - (memq form testcover-module-constants))) - ((consp fun) ;Embedded list + ((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)) - ;;Always return same value + ;;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,11 +253,9 @@ always return the same value." (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) + ;;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,33 +270,44 @@ always return the same value." (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) - (setcar (cdr form) `(testcover-after ,id nil))) + (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 - (setcar form 'testcover-1value)) - (t - (setcar form 'testcover-after))) - (when (testcover-reinstrument (nth 2 form)) - (aset testcover-vector id '1value))) + (setq val t) + (aset testcover-vector id '1value) + (setcar form 'testcover-1value))) + val) ((eq fun 'defun) - (if (testcover-reinstrument-list (nthcdr 3 form)) - (push (cadr form) testcover-module-1value-functions))) - ((eq fun 'defconst) + (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 fun (testcover-reinstrument-list (cadr form))) + (setq val (testcover-reinstrument-list (cadr form))) (if (nth 2 (cadr form)) - fun + val ;;No third value, always returns nil t)) ((memq fun '(let let*)) @@ -286,23 +315,23 @@ always return the same value." (mapc 'testcover-reinstrument-list (cadr form)) (testcover-reinstrument-list (cddr form))) ((eq fun 'if) - ;;1-valued if both THEN and ELSE clauses are + ;;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))) - ((memq fun '(when unless and)) - ;;1-valued if last clause of BODY is - (testcover-reinstrument-list (cdr form))) + (and then else 'maybe))) ((eq fun 'cond) - ;;1-valued if all clauses are - (testcover-reinstrument-clauses (cdr form))) + ;;Potentially 1-valued if all clauses are + (when (testcover-reinstrument-compose (cdr form) + 'testcover-reinstrument-list) + 'maybe)) ((eq fun 'condition-case) - ;;1-valued if BODYFORM is and all HANDLERS are + ;;Potentially 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))) + (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,16 +346,55 @@ always return the same value." (let ((testcover-1value-functions (remq 'quote testcover-1value-functions))) (testcover-reinstrument (cadr form)))) - ((memq fun '(1value noreturn)) + ((eq fun '1value) ;;Hack - pretend the arg is 1-valued here - (if (symbolp (cadr form)) ;A pseudoconstant variable - t + (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))))) + (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,13 +409,22 @@ always be nil, so we return t for 1-valued." (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." +(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 result (and (testcover-reinstrument-list x) result))) - clauselist) + (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,7 +464,7 @@ same value during coverage testing." (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."))) + (error "Value of form marked with `1value' does vary: %s" val))) val) @@ -415,7 +492,7 @@ eliminated by adding more test cases." ov j item) (or (and def-mark points coverage) (error "Missing edebug data for function %s" def)) - (when len + (when (> len 0) (set-buffer (marker-buffer def-mark)) (mapc 'delete-overlay (overlays-in def-mark (+ def-mark (aref points (1- len)) 1)))