[Emacs-diffs] Changes to emacs/lisp/emacs-lisp/testcover.el [lexbind]

[Miles Bader]

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)))