From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Jan Nieuwenhuizen Newsgroups: gmane.lisp.guile.devel Subject: Re: [PATCH] Add GNU-style error location for failing tests in test-suite. v3 Date: Sun, 07 Dec 2014 09:41:00 +0100 Organization: AvatarAcademy.nl Message-ID: <87k323n97n.fsf@drakenvlieg.flower> References: <87wq8uffw9.fsf@drakenvlieg.flower> <87sij2j1x4.fsf@drakenvlieg.flower> <87fvf2gpq6.fsf_-_@drakenvlieg.flower> <87vbn2o8qj.fsf@yeeloong.lan> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1417941686 29599 80.91.229.3 (7 Dec 2014 08:41:26 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Sun, 7 Dec 2014 08:41:26 +0000 (UTC) Cc: guile-devel To: Mark H Weaver Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sun Dec 07 09:41:21 2014 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1XxXP6-0003h7-BH for guile-devel@m.gmane.org; Sun, 07 Dec 2014 09:41:20 +0100 Original-Received: from localhost ([::1]:57350 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XxXP5-0001WL-Vh for guile-devel@m.gmane.org; Sun, 07 Dec 2014 03:41:19 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:39077) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XxXOw-0001WD-Uj for guile-devel@gnu.org; Sun, 07 Dec 2014 03:41:15 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1XxXOs-0001qj-3V for guile-devel@gnu.org; Sun, 07 Dec 2014 03:41:10 -0500 Original-Received: from lb1-smtp-cloud6.xs4all.net ([194.109.24.24]:55674) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XxXOr-0001po-PV for guile-devel@gnu.org; Sun, 07 Dec 2014 03:41:06 -0500 Original-Received: from drakenvlieg.flower.peder.onsbrabantnet.nl ([81.205.131.109]) by smtp-cloud6.xs4all.net with ESMTP id QYh01p0012MmGC101Yh11w; Sun, 07 Dec 2014 09:41:04 +0100 X-Url: http://AvatarAcademy.nl In-Reply-To: <87vbn2o8qj.fsf@yeeloong.lan> (Mark H. Weaver's message of "Wed, 29 Oct 2014 17:40:20 -0400") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.3 (gnu/linux) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x X-Received-From: 194.109.24.24 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:17618 Archived-At: --=-=-= Content-Type: text/plain Mark H Weaver writes: Hi Mark, > Did you try running "make check" with this patch applied? > I found that there were well over a hundred other uses of 'run-test' > in the test-suite directory that you didn't update. Ouch. > Also, can you try to keep lines to 80 columns max? Are those rethorical questions? Find updated version attached. Greetings, Jan. --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: inline; filename=0001-Add-GNU-style-error-location-for-failing-tests-in-te.patch Content-Transfer-Encoding: quoted-printable >From 322ebdc43806a95270fb98a1505d3fff49a3fce9 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 23 Sep 2014 18:37:44 +0200 Subject: [PATCH] Add GNU-style error location for failing tests in test-sui= te. * test-suite/test-suite/lib.scm (run-test): Add location parameter; display GNU style error location for failing test. * test-suite/test-suite/lib.scm (pass-if, pass-if-equal) (run-test-exception, pass-if-exception, expect-fail-exception): Update callers. * test-suite/tests/getopt-long.test (pass-if-fatal-exception) test-suite/tests/goops.test (with-test-prefix) test-suite/tests/numbers.test (run-division-tests) test-suite/tests/r5rs_pitfall.test (should-be, should-be-but-isnt) test-suite/tests/srfi-64.test (guile-test-runner): Update callers. --- test-suite/test-suite/lib.scm | 65 ++++++++++++++++++++++------------= ---- test-suite/tests/getopt-long.test | 4 ++- test-suite/tests/goops.test | 1 + test-suite/tests/numbers.test | 4 +-- test-suite/tests/r5rs_pitfall.test | 14 ++++---- test-suite/tests/srfi-64.test | 14 +++++--- 6 files changed, 60 insertions(+), 42 deletions(-) diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm index 27620a7..76a5820 100644 --- a/test-suite/test-suite/lib.scm +++ b/test-suite/test-suite/lib.scm @@ -80,16 +80,17 @@ ;;;; CORE FUNCTIONS ;;;; -;;;; The function (run-test name expected-result thunk) is the heart of the -;;;; testing environment. The first parameter NAME is a unique name for t= he -;;;; test to be executed (for an explanation of this parameter see below u= nder -;;;; TEST NAMES). The second parameter EXPECTED-RESULT is a boolean value -;;;; that indicates whether the corresponding test is expected to pass. If -;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESUL= T is -;;;; #f the test is expected to fail. Finally, THUNK is the function that -;;;; actually performs the test. For example: -;;;; -;;;; (run-test "integer addition" #t (lambda () (=3D 2 (+ 1 1)))) +;;;; The function (run-test name location expected-result thunk) is the he= art +;;;; of the testing environment. The first parameter NAME is a unique name +;;;; for the test to be executed (for an explanation of this parameter see +;;;; below under TEST NAMES). The third parameter EXPECTED-RESULT is a +;;;; boolean value that indicates whether the corresponding test is expect= ed +;;;; to pass. If EXPECTED-RESULT is #t the test is expected to pass, if +;;;; EXPECTED-RESULT is #f the test is expected to fail. Finally, THUNK is +;;;; the function that actually performs the test. For example: +;;;; +;;;; (run-test "integer addition" (current-source-location) #t (lambda = () +;;;; (=3D 2 (+ 1 1)))) ;;;; ;;;; To report success, THUNK should either return #t or throw 'pass. To ;;;; report failure, THUNK should either return #f or throw 'fail. If THU= NK @@ -107,9 +108,9 @@ ;;;; Convenience macros for tests expected to pass or fail ;;;; ;;;; * (pass-if name body) is a short form for -;;;; (run-test name #t (lambda () body)) +;;;; (run-test name (current-source-location) #t (lambda () body)) ;;;; * (expect-fail name body) is a short form for -;;;; (run-test name #f (lambda () body)) +;;;; (run-test name (current-source-location) #f (lambda () body)) ;;;; ;;;; For example: ;;;; @@ -162,9 +163,9 @@ ;;;; a test name in such cases. ;;;; ;;;; * (pass-if expression) is a short form for -;;;; (run-test 'expression #t (lambda () expression)) +;;;; (run-test 'expression location #t (lambda () expression)) ;;;; * (expect-fail expression) is a short form for -;;;; (run-test 'expression #f (lambda () expression)) +;;;; (run-test 'expression location #f (lambda () expression)) ;;;; ;;;; For example: ;;;; @@ -320,7 +321,7 @@ ;;; The idea is taken from Greg, the GNUstep regression test environment. (define run-test (let ((test-running #f)) - (lambda (name expect-pass thunk) + (lambda (name location expect-pass thunk) (if test-running (error "Nested calls to run-test are not permitted.")) (let ((test-name (full-name name))) @@ -334,20 +335,21 @@ (lambda (key . args) (case key ((pass) - (report (if expect-pass 'pass 'upass) test-name)) + (report (if expect-pass 'pass 'upass) test-name locatio= n)) ((fail) ;; ARGS may contain extra info about the failure, ;; such as the expected and actual value. (apply report (if expect-pass 'fail 'xfail) test-name + location args)) ((unresolved untested unsupported) - (report key test-name)) + (report key test-name location)) ((quit) - (report 'unresolved test-name) + (report 'unresolved test-name location) (quit)) (else - (report 'error test-name (cons key args)))))) + (report 'error test-name location (cons key args)))))) (set! test-running #f))))) =20 ;;; A short form for tests that are expected to pass, taken from Greg. @@ -356,9 +358,9 @@ ((_ name) ;; presume this is a simple test, i.e. (pass-if (even? 2)) ;; where the body should also be the name. - (run-test 'name #t (lambda () name))) + (run-test 'name (current-source-location) #t (lambda () name))) ((_ name rest ...) - (run-test name #t (lambda () rest ...))))) + (run-test name (current-source-location) #t (lambda () rest ...))))) =20 (define-syntax pass-if-equal (syntax-rules () @@ -366,7 +368,7 @@ ((_ expected body) (pass-if-equal 'body expected body)) ((_ name expected body ...) - (run-test name #t + (run-test name (current-source-location) #t (lambda () (let ((result (begin body ...))) (or (equal? expected result) @@ -380,16 +382,17 @@ ((_ name) ;; presume this is a simple test, i.e. (expect-fail (even? 2)) ;; where the body should also be the name. - (run-test 'name #f (lambda () name))) + (run-test 'name (current-source-location) #f (lambda () name))) ((_ name rest ...) - (run-test name #f (lambda () rest ...))))) + (run-test name (current-source-location) #f (lambda () rest ...))))) =20 ;;; A helper function to implement the macros that test for exceptions. -(define (run-test-exception name exception expect-pass thunk) +(define (run-test-exception name location exception expect-pass thunk) (match exception ((expected-key . expected-pattern) (run-test name + location expect-pass (lambda () (catch expected-key @@ -411,13 +414,15 @@ (define-syntax pass-if-exception (syntax-rules () ((_ name exception body rest ...) - (run-test-exception name exception #t (lambda () body rest ...))))) + (run-test-exception name (current-source-location) exception #t + (lambda () body rest ...))))) =20 ;;; A short form for tests expected to fail to throw a certain exception. (define-syntax expect-fail-exception (syntax-rules () ((_ name exception body rest ...) - (run-test-exception name exception #f (lambda () body rest ...))))) + (run-test-exception name (current-source-location) exception #f + (lambda () body rest ...))))) =20 ;;;; TEST NAMES @@ -636,11 +641,15 @@ '(fail upass unresolved error)) =20 ;;; Display a single test result in formatted form to the given port -(define (print-result port result name . args) +(define (print-result port result name location . args) (let* ((tag (assq result result-tags)) (label (if tag (cadr tag) #f))) (if label (begin + (if (not (eq? result 'pass)) + (format port "~a:~a:"=20 + (assoc-ref location 'filename) + (1+ (assoc-ref location 'line)))) (display label port) (display ": " port) (display (format-test-name name) port) diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-lo= ng.test index 4ae6048..a89d4a4 100644 --- a/test-suite/tests/getopt-long.test +++ b/test-suite/tests/getopt-long.test @@ -28,7 +28,9 @@ (with-error-to-port port (lambda () (run-test - name #t + name + (current-source-location) + #t (lambda () (catch (car exn) (lambda () exp #f) diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index d8a5ecf..94823b4 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -110,6 +110,7 @@ (with-output-to-string (lambda () (display class)))) + (current-source-location) #t (lambda () (catch #t diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 847f939..adf9fc1 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -5221,7 +5221,7 @@ =20 (define (run-division-tests quo+rem quo rem valid-answer?) (define (test n d) - (run-test (list n d) #t + (run-test (list n d) (current-source-location) #t (lambda () (let-values (((q r) (quo+rem n d))) (and (test-eqv? q (quo n d)) @@ -5240,7 +5240,7 @@ (pass-if-exception name exception (quo n d)) (pass-if-exception name exception (rem n d)))) =20 - (run-test "documented?" #t + (run-test "documented?" (current-source-location) #t (lambda () (and (documented? quo+rem) (documented? quo) diff --git a/test-suite/tests/r5rs_pitfall.test b/test-suite/tests/r5rs_pit= fall.test index 1d9fcf7..e44d1d3 100644 --- a/test-suite/tests/r5rs_pitfall.test +++ b/test-suite/tests/r5rs_pitfall.test @@ -25,16 +25,18 @@ (define-syntax should-be (syntax-rules () ((_ test-id value expression) - (run-test test-id #t (lambda () - (false-if-exception - (equal? expression value))))))) + (run-test test-id (current-source-location) #t + (lambda () + (false-if-exception + (equal? expression value))))))) =20 (define-syntax should-be-but-isnt (syntax-rules () ((_ test-id value expression) - (run-test test-id #f (lambda () - (false-if-exception - (equal? expression value))))))) + (run-test test-id (current-source-location) #f + (lambda () + (false-if-exception + (equal? expression value))))))) =20 (define call/cc call-with-current-continuation) =20 diff --git a/test-suite/tests/srfi-64.test b/test-suite/tests/srfi-64.test index 190d6b2..a374443 100644 --- a/test-suite/tests/srfi-64.test +++ b/test-suite/tests/srfi-64.test @@ -26,13 +26,17 @@ (lambda (runner) (let* ((result-alist (test-result-alist runner)) (result-kind (assq-ref result-alist 'result-kind)) - (test-name (list (assq-ref result-alist 'test-name)))) + (test-name (list (assq-ref result-alist 'test-name))) + (file-name (assq-ref result-alist 'source-file)) + (line (1- (assq-ref result-alist 'source-line))) + (location (list (cons 'filename file-name) + (cons 'line line)))) (case result-kind - ((pass) (report 'pass test-name)) - ((xpass) (report 'upass test-name)) - ((skip) (report 'untested test-name)) + ((pass) (report 'pass test-name location)) + ((xpass) (report 'upass test-name location)) + ((skip) (report 'untested test-name location)) ((fail xfail) - (apply report result-kind test-name result-alist)) + (apply report result-kind test-name location result-alist)) (else #t))))) runner)) =20 --=20 Jan Nieuwenhuizen | GNU LilyPond http://lilypond.org Freelance IT http://JoyofSource.com | Avatar=C2=AE http://AvatarAcademy.nl= =20=20 --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable --=20 Jan Nieuwenhuizen | GNU LilyPond http://lilypond.org Freelance IT http://JoyofSource.com | Avatar=C2=AE http://AvatarAcademy.nl= =20=20 --=-=-=--