/[emacs]/emacs/lisp/emacs-lisp/testcover.el
ViewVC logotype

Diff of /emacs/lisp/emacs-lisp/testcover.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6 by JYavner, Sun Nov 30 06:56:28 2003 UTC revision 1.7 by JYavner, Sat Jul 17 17:01:28 2004 UTC
# Line 38  Line 38 
38  ;;   instrumentation callbacks, then replace edebug's callbacks with ours.  ;;   instrumentation callbacks, then replace edebug's callbacks with ours.
39  ;; * To show good coverage, we want to see two values for every form, except  ;; * To show good coverage, we want to see two values for every form, except
40  ;;   functions that always return the same value and `defconst' variables  ;;   functions that always return the same value and `defconst' variables
41  ;;   need show only value for good coverage.  To avoid the brown splotch, the  ;;   need show only one value for good coverage.  To avoid the brown
42  ;;   definitions for constants and 1-valued functions must precede the  ;;   splotch, the definitions for constants and 1-valued functions must
43  ;;   references.  ;;   precede the references.
44  ;; * Use the macro `1value' in your Lisp code to mark spots where the local  ;; * Use the macro `1value' in your Lisp code to mark spots where the local
45  ;;   code environment causes a function or variable to always have the same  ;;   code environment causes a function or variable to always have the same
46  ;;   value, but the function or variable is not intrinsically 1-valued.  ;;   value, but the function or variable is not intrinsically 1-valued.
# Line 55  Line 55 
55  ;;   call has the same value!  Also, equal thinks two strings are the same  ;;   call has the same value!  Also, equal thinks two strings are the same
56  ;;   if they differ only in properties.  ;;   if they differ only in properties.
57  ;; * Because we have only a "1value" class and no "always nil" class, we have  ;; * Because we have only a "1value" class and no "always nil" class, we have
58  ;;   to treat as 1-valued any `and' whose last term is 1-valued, in case the  ;;   to treat as potentially 1-valued any `and' whose last term is 1-valued,
59  ;;   last term is always nil.  Example:  ;;   in case the last term is always nil.  Example:
60  ;;     (and (< (point) 1000) (forward-char 10))  ;;     (and (< (point) 1000) (forward-char 10))
61  ;;   This form always returns nil.  Similarly, `if' and `cond' are  ;;   This form always returns nil.  Similarly, `or', `if', and `cond' are
62  ;;   treated as 1-valued if all clauses are, in case those values are  ;;   treated as potentially 1-valued if all clauses are, in case those
63  ;;   always nil.  ;;   values are always nil.  Unlike truly 1-valued functions, it is not an
64    ;;   error if these "potentially" 1-valued forms actually return differing
65    ;;   values.
66    
67  (require 'edebug)  (require 'edebug)
68  (provide 'testcover)  (provide 'testcover)
# Line 86  these.  This list is quite incomplete!" Line 88  these.  This list is quite incomplete!"
88    
89  (defcustom testcover-1value-functions  (defcustom testcover-1value-functions
90    '(backward-char barf-if-buffer-read-only beginning-of-line    '(backward-char barf-if-buffer-read-only beginning-of-line
91      buffer-disable-undo buffer-enable-undo current-global-map deactivate-mark      buffer-disable-undo buffer-enable-undo current-global-map
92      delete-char delete-region ding error forward-char function* insert      deactivate-mark delete-backward-char delete-char delete-region ding
93      insert-and-inherit kill-all-local-variables lambda mapc narrow-to-region      forward-char function* insert insert-and-inherit kill-all-local-variables
94      noreturn push-mark put-text-property run-hooks set-text-properties signal      kill-line kill-paragraph kill-region kill-sexp lambda
95      substitute-key-definition suppress-keymap throw undo use-local-map while      minibuffer-complete-and-exit narrow-to-region next-line push-mark
96      widen yank)      put-text-property run-hooks set-match-data signal
97        substitute-key-definition suppress-keymap undo use-local-map while widen
98        yank)
99    "Functions that always return the same value.  No brown splotch is shown    "Functions that always return the same value.  No brown splotch is shown
100  for these.  This list is quite incomplete!  Notes: Nobody ever changes the  for these.  This list is quite incomplete!  Notes: Nobody ever changes the
101  current global map.  The macro `lambda' is self-evaluating, hence always  current global map.  The macro `lambda' is self-evaluating, hence always
# Line 108  them as having returned nil just before Line 112  them as having returned nil just before
112    :type 'hook)    :type 'hook)
113    
114  (defcustom testcover-compose-functions  (defcustom testcover-compose-functions
115    '(+ - * / length list make-keymap make-sparse-keymap message propertize    '(+ - * / = append length list make-keymap make-sparse-keymap
116      replace-regexp-in-string run-with-idle-timer      mapcar message propertize replace-regexp-in-string
117      set-buffer-modified-p)      run-with-idle-timer set-buffer-modified-p)
118    "Functions that are 1-valued if all their args are either constants or    "Functions that are 1-valued if all their args are either constants or
119  calls to one of the `testcover-1value-functions', so if that's true then no  calls to one of the `testcover-1value-functions', so if that's true then no
120  brown splotch is shown for these.  This list is quite incomplete!  Most  brown splotch is shown for these.  This list is quite incomplete!  Most
# Line 119  side-effect-free functions should be her Line 123  side-effect-free functions should be her
123    :type 'hook)    :type 'hook)
124    
125  (defcustom testcover-progn-functions  (defcustom testcover-progn-functions
126    '(define-key fset function goto-char or overlay-put progn save-current-buffer    '(define-key fset function goto-char mapc overlay-put progn
127      save-excursion save-match-data save-restriction save-selected-window      save-current-buffer save-excursion save-match-data
128      save-window-excursion set set-default setq setq-default      save-restriction save-selected-window save-window-excursion
129      with-output-to-temp-buffer with-syntax-table with-temp-buffer      set set-default set-marker-insertion-type setq setq-default
130      with-temp-file with-temp-message with-timeout)      with-current-buffer with-output-to-temp-buffer with-syntax-table
131        with-temp-buffer with-temp-file with-temp-message with-timeout)
132    "Functions whose return value is the same as their last argument.  No    "Functions whose return value is the same as their last argument.  No
133  brown splotch is shown for these if the last argument is a constant or a  brown splotch is shown for these if the last argument is a constant or a
134  call to one of the `testcover-1value-functions'.  This list is probably  call to one of the `testcover-1value-functions'.  This list is probably
135  incomplete!  Note: `or' is here in case the last argument is a function that  incomplete!"
 always returns nil."  
136    :group 'testcover    :group 'testcover
137    :type 'hook)    :type 'hook)
138    
# Line 140  call to one of the `testcover-1value-fun Line 144  call to one of the `testcover-1value-fun
144    :group 'testcover    :group 'testcover
145    :type 'hook)    :type 'hook)
146    
147    (defcustom testcover-potentially-1value-functions
148      '(add-hook and beep or remove-hook unless when)
149      "Functions that are potentially 1-valued.  No brown splotch if actually
150    1-valued, no error if actually multi-valued.")
151    
152  (defface testcover-nohits-face  (defface testcover-nohits-face
153    '((t (:background "DeepPink2")))    '((t (:background "DeepPink2")))
154    "Face for forms that had no hits during coverage test"    "Face for forms that had no hits during coverage test"
# Line 161  call to one of the `testcover-1value-fun Line 170  call to one of the `testcover-1value-fun
170    
171  (defvar testcover-module-1value-functions nil  (defvar testcover-module-1value-functions nil
172    "Symbols declared with defun in the last file processed by    "Symbols declared with defun in the last file processed by
173  `testcover-start', whose functions always return the same value.")  `testcover-start', whose functions should always return the same value.")
174    
175    (defvar testcover-module-potentially-1value-functions nil
176      "Symbols declared with defun in the last file processed by
177    `testcover-start', whose functions might always return the same value.")
178    
179  (defvar testcover-vector nil  (defvar testcover-vector nil
180    "Locally bound to coverage vector for function in progress.")    "Locally bound to coverage vector for function in progress.")
# Line 206  non-nil, byte-compiles each function aft Line 219  non-nil, byte-compiles each function aft
219      x))      x))
220    
221  (defun testcover-reinstrument (form)  (defun testcover-reinstrument (form)
222    "Reinstruments FORM to use testcover instead of edebug.  This function    "Reinstruments FORM to use testcover instead of edebug.  This
223  modifies the list that FORM points to.  Result is non-nil if FORM will  function modifies the list that FORM points to.  Result is nil if
224  always return the same value."  FORM should return multiple vlues, t if should always return same
225    value, 'maybe if either is acceptable."
226    (let ((fun (car-safe form))    (let ((fun (car-safe form))
227          id)          id val)
228      (cond      (cond
229       ((not fun) ;Atom       ((not fun)                         ;Atom
230        (or (not (symbolp form))        (when (or (not (symbolp form))
231            (memq form testcover-constants)                  (memq form testcover-constants)
232            (memq form testcover-module-constants)))                  (memq form testcover-module-constants))
233       ((consp fun) ;Embedded list          t))
234         ((consp fun)                       ;Embedded list
235        (testcover-reinstrument fun)        (testcover-reinstrument fun)
236        (testcover-reinstrument-list (cdr form))        (testcover-reinstrument-list (cdr form))
237        nil)        nil)
238       ((or (memq fun testcover-1value-functions)       ((or (memq fun testcover-1value-functions)
239            (memq fun testcover-module-1value-functions))            (memq fun testcover-module-1value-functions))
240        ;;Always return same value        ;;Should always return same value
241        (testcover-reinstrument-list (cdr form))        (testcover-reinstrument-list (cdr form))
242        t)        t)
243         ((or (memq fun testcover-potentially-1value-functions)
244              (memq fun testcover-module-potentially-1value-functions))
245          ;;Might always return same value
246          (testcover-reinstrument-list (cdr form))
247          'maybe)
248       ((memq fun testcover-progn-functions)       ((memq fun testcover-progn-functions)
249        ;;1-valued if last argument is        ;;1-valued if last argument is
250        (testcover-reinstrument-list (cdr form)))        (testcover-reinstrument-list (cdr form)))
# Line 233  always return the same value." Line 253  always return the same value."
253        (testcover-reinstrument-list (cddr form))        (testcover-reinstrument-list (cddr form))
254        (testcover-reinstrument (cadr form)))        (testcover-reinstrument (cadr form)))
255       ((memq fun testcover-compose-functions)       ((memq fun testcover-compose-functions)
256        ;;1-valued if all arguments are        ;;1-valued if all arguments are.  Potentially 1-valued if all
257        (setq id t)        ;;arguments are either definitely or potentially.
258        (mapc #'(lambda (x) (setq id (or (testcover-reinstrument x) id)))        (testcover-reinstrument-compose (cdr form) 'testcover-reinstrument))
             (cdr form))  
       id)  
259       ((eq fun 'edebug-enter)       ((eq fun 'edebug-enter)
260        ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS))        ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS))
261        ;;  => (testcover-enter 'SYM #'(lambda nil FORMS))        ;;  => (testcover-enter 'SYM #'(lambda nil FORMS))
# Line 252  always return the same value." Line 270  always return the same value."
270          (aset testcover-vector (cadr (cadr form)) 'ok-coverage))          (aset testcover-vector (cadr (cadr form)) 'ok-coverage))
271        (setq id (nth 2 form))        (setq id (nth 2 form))
272        (setcdr form (nthcdr 2 form))        (setcdr form (nthcdr 2 form))
273          (setq val (testcover-reinstrument (nth 2 form)))
274          (if (eq val t)
275              (setcar form 'testcover-1value)
276            (setcar form 'testcover-after))
277          (when val
278            ;;1-valued or potentially 1-valued
279            (aset testcover-vector id '1value))
280        (cond        (cond
281         ((memq (car-safe (nth 2 form)) testcover-noreturn-functions)         ((memq (car-safe (nth 2 form)) testcover-noreturn-functions)
282          ;;This function won't return, so set the value in advance          ;;This function won't return, so set the value in advance
283          ;;(edebug-after (edebug-before XXX) YYY FORM)          ;;(edebug-after (edebug-before XXX) YYY FORM)
284          ;;  => (progn (edebug-after YYY nil) FORM)          ;;  => (progn (edebug-after YYY nil) FORM)
285            (setcar (cdr form) `(,(car form) ,id nil))
286          (setcar form 'progn)          (setcar form 'progn)
287          (setcar (cdr form) `(testcover-after ,id nil)))          (aset testcover-vector id '1value)
288            (setq val t))
289         ((eq (car-safe (nth 2 form)) '1value)         ((eq (car-safe (nth 2 form)) '1value)
290          ;;This function is always supposed to return the same value          ;;This function is always supposed to return the same value
291          (setcar form 'testcover-1value))          (setq val t)
292         (t          (aset testcover-vector id '1value)
293          (setcar form 'testcover-after)))          (setcar form 'testcover-1value)))
294        (when (testcover-reinstrument (nth 2 form))        val)
         (aset testcover-vector id '1value)))  
295       ((eq fun 'defun)       ((eq fun 'defun)
296        (if (testcover-reinstrument-list (nthcdr 3 form))        (setq val (testcover-reinstrument-list (nthcdr 3 form)))
297            (push (cadr form) testcover-module-1value-functions)))        (when (eq val t)
298       ((eq fun 'defconst)          (push (cadr form) testcover-module-1value-functions))
299          (when (eq val 'maybe)
300            (push (cadr form) testcover-module-potentially-1value-functions)))
301         ((memq fun '(defconst defcustom))
302        ;;Define this symbol as 1-valued        ;;Define this symbol as 1-valued
303        (push (cadr form) testcover-module-constants)        (push (cadr form) testcover-module-constants)
304        (testcover-reinstrument-list (cddr form)))        (testcover-reinstrument-list (cddr form)))
305       ((memq fun '(dotimes dolist))       ((memq fun '(dotimes dolist))
306        ;;Always returns third value from SPEC        ;;Always returns third value from SPEC
307        (testcover-reinstrument-list (cddr form))        (testcover-reinstrument-list (cddr form))
308        (setq fun (testcover-reinstrument-list (cadr form)))        (setq val (testcover-reinstrument-list (cadr form)))
309        (if (nth 2 (cadr form))        (if (nth 2 (cadr form))
310            fun            val
311          ;;No third value, always returns nil          ;;No third value, always returns nil
312          t))          t))
313       ((memq fun '(let let*))       ((memq fun '(let let*))
# Line 286  always return the same value." Line 315  always return the same value."
315        (mapc 'testcover-reinstrument-list (cadr form))        (mapc 'testcover-reinstrument-list (cadr form))
316        (testcover-reinstrument-list (cddr form)))        (testcover-reinstrument-list (cddr form)))
317       ((eq fun 'if)       ((eq fun 'if)
318        ;;1-valued if both THEN and ELSE clauses are        ;;Potentially 1-valued if both THEN and ELSE clauses are
319        (testcover-reinstrument (cadr form))        (testcover-reinstrument (cadr form))
320        (let ((then (testcover-reinstrument (nth 2 form)))        (let ((then (testcover-reinstrument (nth 2 form)))
321              (else (testcover-reinstrument-list (nthcdr 3 form))))              (else (testcover-reinstrument-list (nthcdr 3 form))))
322          (and then else)))          (and then else 'maybe)))
      ((memq fun '(when unless and))  
       ;;1-valued if last clause of BODY is  
       (testcover-reinstrument-list (cdr form)))  
323       ((eq fun 'cond)       ((eq fun 'cond)
324        ;;1-valued if all clauses are        ;;Potentially 1-valued if all clauses are
325        (testcover-reinstrument-clauses (cdr form)))        (when (testcover-reinstrument-compose (cdr form)
326                                                'testcover-reinstrument-list)
327            'maybe))
328       ((eq fun 'condition-case)       ((eq fun 'condition-case)
329        ;;1-valued if BODYFORM is and all HANDLERS are        ;;Potentially 1-valued if BODYFORM is and all HANDLERS are
330        (let ((body (testcover-reinstrument (nth 2 form)))        (let ((body (testcover-reinstrument (nth 2 form)))
331              (errs (testcover-reinstrument-clauses (mapcar #'cdr              (errs (testcover-reinstrument-compose
332                                                            (nthcdr 3 form)))))                     (mapcar #'cdr (nthcdr 3 form))
333          (and body errs)))                     'testcover-reinstrument-list)))
334            (and body errs 'maybe)))
335       ((eq fun 'quote)       ((eq fun 'quote)
336        ;;Don't reinstrument what's inside!        ;;Don't reinstrument what's inside!
337        ;;This doesn't apply within a backquote        ;;This doesn't apply within a backquote
# Line 317  always return the same value." Line 346  always return the same value."
346        (let ((testcover-1value-functions        (let ((testcover-1value-functions
347               (remq 'quote testcover-1value-functions)))               (remq 'quote testcover-1value-functions)))
348          (testcover-reinstrument (cadr form))))          (testcover-reinstrument (cadr form))))
349       ((memq fun '(1value noreturn))       ((eq fun '1value)
350        ;;Hack - pretend the arg is 1-valued here        ;;Hack - pretend the arg is 1-valued here
351        (if (symbolp (cadr form)) ;A pseudoconstant variable        (cond
352            t         ((symbolp (cadr form))
353            ;;A pseudoconstant variable
354            t)
355           ((and (eq (car (cadr form)) 'edebug-after)
356                 (symbolp (nth 3 (cadr form))))
357            ;;Reference to pseudoconstant
358            (aset testcover-vector (nth 2 (cadr form)) '1value)
359            (setcar (cdr form) `(testcover-1value ,(nth 2 (cadr form))
360                                                  ,(nth 3 (cadr form))))
361            t)
362           (t
363          (if (eq (car (cadr form)) 'edebug-after)          (if (eq (car (cadr form)) 'edebug-after)
364              (setq id (car (nth 3 (cadr form))))              (setq id (car (nth 3 (cadr form))))
365            (setq id (car (cadr form))))            (setq id (car (cadr form))))
366          (let ((testcover-1value-functions          (let ((testcover-1value-functions
367                 (cons id testcover-1value-functions)))                 (cons id testcover-1value-functions)))
368            (testcover-reinstrument (cadr form)))))            (testcover-reinstrument (cadr form))))))
369         ((eq fun 'noreturn)
370          ;;Hack - pretend the arg has no return
371          (cond
372           ((symbolp (cadr form))
373            ;;A pseudoconstant variable
374            'maybe)
375           ((and (eq (car (cadr form)) 'edebug-after)
376                 (symbolp (nth 3 (cadr form))))
377            ;;Reference to pseudoconstant
378            (aset testcover-vector (nth 2 (cadr form)) '1value)
379            (setcar (cdr form) `(progn (testcover-after ,(nth 2 (cadr form)) nil)
380                                       ,(nth 3 (cadr form))))
381            'maybe)
382           (t
383            (if (eq (car (cadr form)) 'edebug-after)
384                (setq id (car (nth 3 (cadr form))))
385              (setq id (car (cadr form))))
386            (let ((testcover-noreturn-functions
387                   (cons id testcover-noreturn-functions)))
388              (testcover-reinstrument (cadr form))))))
389         ((and (eq fun 'apply)
390               (eq (car-safe (cadr form)) 'quote)
391               (symbolp (cadr (cadr form))))
392          ;;Apply of a constant symbol.  Process as 1value or noreturn
393          ;;depending on symbol.
394          (setq fun (cons (cadr (cadr form)) (cddr form))
395                val (testcover-reinstrument fun))
396          (setcdr (cdr form) (cdr fun))
397          val)
398       (t ;Some other function or weird thing       (t ;Some other function or weird thing
399        (testcover-reinstrument-list (cdr form))        (testcover-reinstrument-list (cdr form))
400        nil))))        nil))))
# Line 341  always be nil, so we return t for 1-valu Line 409  always be nil, so we return t for 1-valu
409        (setq result (testcover-reinstrument (pop list))))        (setq result (testcover-reinstrument (pop list))))
410      result))      result))
411    
412  (defun testcover-reinstrument-clauses (clauselist)  (defun testcover-reinstrument-compose (list fun)
413    "Reinstrument each list in CLAUSELIST.    "For a compositional function, the result is 1-valued if all
414  Result is t if every clause is 1-valued."  arguments are, potentially 1-valued if all arguments are either
415    definitely or potentially 1-valued, and multi-valued otherwise.
416    FUN should be `testcover-reinstrument' for compositional functions,
417      `testcover-reinstrument-list' for clauses in a `cond'."
418    (let ((result t))    (let ((result t))
419      (mapc #'(lambda (x)      (mapc #'(lambda (x)
420                (setq result (and (testcover-reinstrument-list x) result)))                (setq x (funcall fun x))
421            clauselist)                (cond
422                   ((eq result t)
423                    (setq result x))
424                   ((eq result 'maybe)
425                    (when (not x)
426                      (setq result nil)))))
427              list)
428      result))      result))
429    
430  (defun testcover-end (buffer)  (defun testcover-end (buffer)
# Line 387  same value during coverage testing." Line 464  same value during coverage testing."
464      (aset testcover-vector idx (cons '1value val)))      (aset testcover-vector idx (cons '1value val)))
465     ((not (and (eq (car-safe (aref testcover-vector idx)) '1value)     ((not (and (eq (car-safe (aref testcover-vector idx)) '1value)
466                (equal (cdr (aref testcover-vector idx)) val)))                (equal (cdr (aref testcover-vector idx)) val)))
467      (error "Value of form marked with `1value' does vary.")))      (error "Value of form marked with `1value' does vary: %s" val)))
468    val)    val)
469    
470    
# Line 415  eliminated by adding more test cases." Line 492  eliminated by adding more test cases."
492           ov j item)           ov j item)
493      (or (and def-mark points coverage)      (or (and def-mark points coverage)
494          (error "Missing edebug data for function %s" def))          (error "Missing edebug data for function %s" def))
495      (when len      (when (> len 0)
496        (set-buffer (marker-buffer def-mark))        (set-buffer (marker-buffer def-mark))
497        (mapc 'delete-overlay        (mapc 'delete-overlay
498              (overlays-in def-mark (+ def-mark (aref points (1- len)) 1)))              (overlays-in def-mark (+ def-mark (aref points (1- len)) 1)))

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26