Mercurial > hg > xemacs-beta

comparison lisp/test-harness.el @ 5541:ebd367b82ccd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Improve treatment of expected bugs. * * * Simplify Known-Bug-Expect-Error to produce cleaner output.
author Stephen J. Turnbull <stephen@xemacs.org>
date Mon, 08 Aug 2011 13:57:19 +0900
parents ac37a5f7e5be
children 3bc58dc9d688
comparison
equal deleted inserted replaced
5540:eed303fac325 5541:ebd367b82ccd
67 67
68 ;; Declared for dynamic scope; _do not_ initialize here. 68 ;; Declared for dynamic scope; _do not_ initialize here.
69 (defvar unexpected-test-file-failures) 69 (defvar unexpected-test-file-failures)
70 70
71 (defvar test-harness-bug-expected nil 71 (defvar test-harness-bug-expected nil
72 "Non-nil means a bug is expected; backtracing/debugging should not happen.") 72 "Non-nil means a bug is expected; backtracing/debugging should not happen.
73 However, the individual test summary should be printed.")
73 74
74 (defvar test-harness-test-compiled nil 75 (defvar test-harness-test-compiled nil
75 "Non-nil means the test code was compiled before execution. 76 "Non-nil means the test code was compiled before execution.
76 77
77 You probably should not make tests depend on compilation. 78 You probably should not make tests depend on compilation.
323 "Wrap a BODY that consists of tests that are known to fail. 324 "Wrap a BODY that consists of tests that are known to fail.
324 This causes messages to be printed on failure indicating that this is expected, 325 This causes messages to be printed on failure indicating that this is expected,
325 and on success indicating that this is unexpected." 326 and on success indicating that this is unexpected."
326 `(let ((test-harness-bug-expected t) 327 `(let ((test-harness-bug-expected t)
327 (test-harness-failure-tag "KNOWN BUG") 328 (test-harness-failure-tag "KNOWN BUG")
328 (test-harness-success-tag "PASS (FAILURE EXPECTED)")) 329 (test-harness-success-tag "PASS (FAIL EXPECTED: was bug fixed?)"))
329 ,@body)) 330 ,@body))
330 331
331 (defmacro Known-Bug-Expect-Error (expected-error &rest body) 332 (defmacro Known-Bug-Expect-Error (expected-error &rest body)
332 "Wrap a BODY that consists of tests that are known to trigger an error. 333 "Wrap a BODY containing a test known to trigger an error it shouldn't.
333 This causes messages to be printed on failure indicating that this is expected, 334 This causes messages to be printed on failure indicating that this is expected
334 and on success indicating that this is unexpected." 335 of the bug, and on success indicating that this is unexpected."
335 (let ((quoted-body (if (eql 1 (length body)) 336 `(let ((test-harness-bug-expected t)
336 `(quote ,(car body)) `(quote (progn ,@body))))) 337 (test-harness-failure-tag "KNOWN BUG")
337 `(let ((test-harness-bug-expected t) 338 (test-harness-success-tag
338 (test-harness-failure-tag "KNOWN BUG") 339 (format "PASS (EXPECTED ERROR %S due to bug: fixed?)"
339 (test-harness-success-tag "PASS (FAILURE EXPECTED)")) 340 (quote ,expected-error))))
340 (condition-case error-info 341 (condition-case err
341 (progn 342 (progn ,@body)
342 (setq trick-optimizer (progn ,@body)) 343 (,expected-error)
343 (Print-Pass 344 (error
344 "%S executed successfully, but expected error %S" 345 (let ((m (format " Expected %S due to bug, got %S: mutated?\n"
345 ,quoted-body 346 (quote ,expected-error) err)))
346 ',expected-error) 347 (if (noninteractive) (message m))
347 (incf passes)) 348 (princ m))))))
348 (,expected-error
349 (Print-Failure "%S ==> error %S, as expected"
350 ,quoted-body ',expected-error)
351 (incf no-error-failures))
352 (error
353 (Print-Failure "%S ==> expected error %S, got error %S instead"
354 ,quoted-body ',expected-error error-info)
355 (incf wrong-error-failures))))))
356 349
357 (defmacro Implementation-Incomplete-Expect-Failure (&rest body) 350 (defmacro Implementation-Incomplete-Expect-Failure (&rest body)
358 "Wrap a BODY containing tests that are known to fail due to incomplete code. 351 "Wrap a BODY containing tests that are known to fail due to incomplete code.
359 This causes messages to be printed on failure indicating that the 352 This causes messages to be printed on failure indicating that the
360 implementation is incomplete (and hence the failure is expected); and on 353 implementation is incomplete (and hence the failure is expected); and on
361 success indicating that this is unexpected." 354 success indicating that this is unexpected."
362 `(let ((test-harness-bug-expected t) 355 `(let ((test-harness-bug-expected t)
363 (test-harness-failure-tag "IMPLEMENTATION INCOMPLETE") 356 (test-harness-failure-tag "IMPLEMENTATION INCOMPLETE")
364 (test-harness-success-tag "PASS (FAILURE EXPECTED)")) 357 (test-harness-success-tag
358 "PASS (FAILURE EXPECTED: feature implemented?)"))
365 ,@body)) 359 ,@body))
366 360
367 (defun Print-Failure (fmt &rest args) 361 (defun Print-Failure (fmt &rest args)
368 (setq fmt (format "%s: %s" test-harness-failure-tag fmt)) 362 (setq fmt (format "%s: %s" test-harness-failure-tag fmt))
369 (if (noninteractive) (apply #'message fmt args)) 363 (if (noninteractive) (apply #'message fmt args))
370 (princ (concat (apply #'format fmt args) "\n"))) 364 (princ (concat (apply #'format fmt args) "\n")))
371 365
372 (defun Print-Pass (fmt &rest args) 366 (defun Print-Pass (fmt &rest args)
373 (setq fmt (format "%s: %s" test-harness-success-tag fmt)) 367 (setq fmt (format "%s: %s" test-harness-success-tag fmt))
374 (and test-harness-verbose 368 (and (or test-harness-verbose test-harness-bug-expected)
369 (if (and noninteractive test-harness-bug-expected)
370 (apply #'message fmt args))
375 (princ (concat (apply #'format fmt args) "\n")))) 371 (princ (concat (apply #'format fmt args) "\n"))))
376 372
377 (defun Print-Skip (test reason &optional fmt &rest args) 373 (defun Print-Skip (test reason &optional fmt &rest args)
378 (setq fmt (concat "SKIP: %S BECAUSE %S" fmt)) 374 (setq fmt (concat "SKIP: %S BECAUSE %S" fmt))
379 (princ (concat (apply #'format fmt test reason args) "\n"))) 375 (princ (concat (apply #'format fmt test reason args) "\n")))
430 (if ,failing-case 426 (if ,failing-case
431 "Assertion failed: %S; failing case = %S" 427 "Assertion failed: %S; failing case = %S"
432 "Assertion failed: %S") 428 "Assertion failed: %S")
433 ,description ,failing-case) 429 ,description ,failing-case)
434 (incf assertion-failures) 430 (incf assertion-failures)
435 (test-harness-assertion-failure-do-debug error-info)) 431 (test-harness-assertion-failure-do-debug error-info)
432 nil)
436 (Print-Failure 433 (Print-Failure
437 (if ,failing-case 434 (if ,failing-case
438 "%S ==> error: %S; failing case = %S" 435 "%S ==> error: %S; failing case = %S"
439 "%S ==> error: %S") 436 "%S ==> error: %S")
440 ,description error-info ,failing-case) 437 ,description error-info ,failing-case)
441 (incf other-failures) 438 (incf other-failures)
442 (test-harness-unexpected-error-do-debug error-info))) 439 (test-harness-unexpected-error-do-debug error-info)
440 nil))
443 #'(lambda () 441 #'(lambda ()
444 (assert ,assertion) 442 (assert ,assertion)
445 (Print-Pass "%S" ,description) 443 (Print-Pass "%S" ,description)
446 (incf passes))) 444 (incf passes)
445 t))
447 (cl-assertion-failed nil)))) 446 (cl-assertion-failed nil))))
448 447
449 (defmacro Check-Error (expected-error &rest body) 448 (defmacro Check-Error (expected-error &rest body)
450 (let ((quoted-body (if (eql 1 (length body)) 449 (let ((quoted-body (if (eql 1 (length body))
451 `(quote ,(car body)) `(quote (progn ,@body))))) 450 `(quote ,(car body)) `(quote (progn ,@body)))))