comparison lisp/emacs-lisp/testcover.el @ 53196:b3327f1ed9e1

Ensure that forms marked with `1value' actually always return the same value.

53195:49d5fa0b5a1c

;;;=========================================================================
;;; Add instrumentation to your module
;;;=========================================================================

;;;###autoload
(defun testcover-start (filename &optional byte-compile)
  "Uses edebug to instrument all macros and functions in FILENAME, then
changes the instrumentation from edebug to testcover--much faster, no
problems with type-ahead or post-command-hook, etc.  If BYTE-COMPILE is
non-nil, byte-compiles each function after instrumenting."
  (interactive "f")
  (let ((buf             (find-file filename))
	(load-read-function 'testcover-read)
	(edebug-all-defs t))
    (setq edebug-form-data                       nil
	  testcover-module-constants             nil
	  testcover-module-1value-functions nil)

(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)))
    (cond
     ((not fun) ;Atom
      (or (not (symbolp form))
	  (memq form testcover-constants)
	  (memq form testcover-module-constants)))

      ;;1-valued if first argument is
      (testcover-reinstrument-list (cddr form))
      (testcover-reinstrument (cadr form)))
     ((memq fun testcover-compose-functions)
      ;;1-valued if all arguments are
      (setq fun t)
      (mapc #'(lambda (x) (setq fun (or (testcover-reinstrument x) fun)))
	    (cdr form))
      fun)
     ((eq fun 'edebug-enter)
      ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS))
      ;;  => (testcover-enter 'SYM #'(lambda nil FORMS))
      (setcar form 'testcover-enter)
      (setcdr (nthcdr 1 form) (nthcdr 3 form))

     ((eq fun 'edebug-after)
      ;;(edebug-after (edebug-before XXX) YYY FORM)
      ;; => (testcover-after YYY FORM), mark XXX as ok-coverage
      (unless (eq (cadr form) 0)
	(aset testcover-vector (cadr (cadr form)) 'ok-coverage))
      (setq fun (nth 2 form))
      (setcdr form (nthcdr 2 form))
      (if (not (memq (car-safe (nth 2 form)) testcover-noreturn-functions))
	  (setcar form 'testcover-after)
	;;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 ,fun nil)))
      (when (testcover-reinstrument (nth 2 form))
	(aset testcover-vector fun '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

	(testcover-reinstrument (cadr form))))
     ((memq fun '(1value noreturn))
      ;;Hack - pretend the arg is 1-valued here
      (if (symbolp (cadr form)) ;A pseudoconstant variable
	  t
	(let ((testcover-1value-functions
	       (cons (car (cadr form)) testcover-1value-functions)))
	  (testcover-reinstrument (cadr form)))))
     (t ;Some other function or weird thing
      (testcover-reinstrument-list (cdr form))
      nil))))

  "Turn off instrumentation of all macros and functions in FILENAME."
  (interactive "b")
  (let ((buf (find-file-noselect buffer)))
    (eval-buffer buf t)))

(defmacro 1value (form)
  "For coverage testing, indicate FORM should always have the same value."
  form)

(defmacro noreturn (form)
  "For coverage testing, indicate that FORM will never return."
  `(prog1 ,form
     (error "Form marked with `noreturn' did return")))


;;;=========================================================================
;;; Accumulate coverage data
;;;=========================================================================

   ((eq (aref testcover-vector idx) 'unknown)
    (aset testcover-vector idx val))
   ((not (equal (aref testcover-vector idx) val))
    (aset testcover-vector idx 'ok-coverage)))
  val)


;;;=========================================================================
;;; Display the coverage data as color splotches on your code.
;;;=========================================================================

	    (overlays-in def-mark (+ def-mark (aref points (1- len)) 1)))
      (while (> len 0)
	(setq len  (1- len)
	      data (aref coverage len))
	(when (and (not (eq data 'ok-coverage))
		   (setq j (+ def-mark (aref points len))))
	  (setq ov (make-overlay (1- j) j))
	  (overlay-put ov 'face
		       (if (memq data '(unknown 1value))
			   'testcover-nohits-face

53196:b3327f1ed9e1

;;;=========================================================================
;;; Add instrumentation to your module
;;;=========================================================================

(defun testcover-start (filename &optional byte-compile)
  "Uses edebug to instrument all macros and functions in FILENAME, then
changes the instrumentation from edebug to testcover--much faster, no
problems with type-ahead or post-command-hook, etc.  If BYTE-COMPILE is
non-nil, byte-compiles each function after instrumenting."
  (interactive "f")
  (let ((buf                (find-file filename))
	(load-read-function 'testcover-read)
	(edebug-all-defs t))
    (setq edebug-form-data                       nil
	  testcover-module-constants             nil
	  testcover-module-1value-functions nil)

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

      ;;1-valued if first argument is
      (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))
      (setcar form 'testcover-enter)
      (setcdr (nthcdr 1 form) (nthcdr 3 form))

     ((eq fun 'edebug-after)
      ;;(edebug-after (edebug-before XXX) YYY FORM)
      ;; => (testcover-after YYY FORM), mark XXX as ok-coverage
      (unless (eq (cadr form) 0)
	(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

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

  "Turn off instrumentation of all macros and functions in FILENAME."
  (interactive "b")
  (let ((buf (find-file-noselect buffer)))
    (eval-buffer buf t)))


;;;=========================================================================
;;; Accumulate coverage data
;;;=========================================================================

   ((eq (aref testcover-vector idx) 'unknown)
    (aset testcover-vector idx val))
   ((not (equal (aref testcover-vector idx) val))
    (aset testcover-vector idx 'ok-coverage)))
  val)

(defun testcover-1value (idx val)
  "Internal function for coverage testing.  Returns VAL after installing it in
`testcover-vector' at offset IDX.  Error if FORM does not always return the
same value during coverage testing."
  (cond
   ((eq (aref testcover-vector idx) '1value)
    (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)



;;;=========================================================================
;;; Display the coverage data as color splotches on your code.
;;;=========================================================================

	    (overlays-in def-mark (+ def-mark (aref points (1- len)) 1)))
      (while (> len 0)
	(setq len  (1- len)
	      data (aref coverage len))
	(when (and (not (eq data 'ok-coverage))
		   (not (eq (car-safe data) '1value))
		   (setq j (+ def-mark (aref points len))))
	  (setq ov (make-overlay (1- j) j))
	  (overlay-put ov 'face
		       (if (memq data '(unknown 1value))
			   'testcover-nohits-face