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, 05 Oct 2014 23:40:17 +0200 Organization: AvatarAcademy.nl Message-ID: <87fvf2gpq6.fsf_-_@drakenvlieg.flower> References: <87wq8uffw9.fsf@drakenvlieg.flower> <87sij2j1x4.fsf@drakenvlieg.flower> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1412545250 10131 80.91.229.3 (5 Oct 2014 21:40:50 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Sun, 5 Oct 2014 21:40:50 +0000 (UTC) To: guile-devel Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sun Oct 05 23:40:45 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 1XatXl-0007C6-9I for guile-devel@m.gmane.org; Sun, 05 Oct 2014 23:40:41 +0200 Original-Received: from localhost ([::1]:48758 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XatXk-0004do-Q0 for guile-devel@m.gmane.org; Sun, 05 Oct 2014 17:40:40 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:36903) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XatXX-0004dV-26 for guile-devel@gnu.org; Sun, 05 Oct 2014 17:40:31 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1XatXS-00058M-6x for guile-devel@gnu.org; Sun, 05 Oct 2014 17:40:26 -0400 Original-Received: from smtp-vbr13.xs4all.nl ([194.109.24.33]:3226) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XatXR-00058A-Q7 for guile-devel@gnu.org; Sun, 05 Oct 2014 17:40:22 -0400 Original-Received: from drakenvlieg.flower.peder.onsbrabantnet.nl (static.kpn.net [92.70.116.82] (may be forged)) (authenticated bits=0) by smtp-vbr13.xs4all.nl (8.13.8/8.13.8) with ESMTP id s95LeHkh039032 (version=TLSv1/SSLv3 cipher=DHE-RSA-AES128-SHA bits=128 verify=NO); Sun, 5 Oct 2014 23:40:19 +0200 (CEST) (envelope-from janneke@gnu.org) X-Url: http://AvatarAcademy.nl In-Reply-To: <87sij2j1x4.fsf@drakenvlieg.flower> (Jan Nieuwenhuizen's message of "Sun, 05 Oct 2014 11:33:59 +0200") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.3 (gnu/linux) X-Virus-Scanned: by XS4ALL Virus Scanner X-detected-operating-system: by eggs.gnu.org: Genre and OS details not recognized. X-Received-From: 194.109.24.33 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:17553 Archived-At: --=-=-= Content-Type: text/plain Jan Nieuwenhuizen writes: Changes in v3: * fix source-line/user-source-line confusion in srfi-64 * better conforming commit message --=-=-= 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 2776b305b1b81ccebbb94ae4ef83ae83996a5253 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/srfi-64.test (guile-test-runner): Update callers. --- test-suite/test-suite/lib.scm | 45 +++++++++++++++++++++++----------------= ---- test-suite/tests/srfi-64.test | 14 +++++++++----- 2 files changed, 33 insertions(+), 26 deletions(-) diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm index 9ecaf89..7bd3260 100644 --- a/test-suite/test-suite/lib.scm +++ b/test-suite/test-suite/lib.scm @@ -77,16 +77,16 @@ ;;;; CORE FUNCTIONS ;;;; -;;;; The function (run-test name expected-result thunk) is the heart of the +;;;; 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 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 +;;;; TEST NAMES). The third 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)))) +;;;; (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 @@ -104,9 +104,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: ;;;; @@ -159,9 +159,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: ;;;; @@ -317,7 +317,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))) @@ -331,20 +331,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. @@ -353,9 +354,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 () @@ -363,7 +364,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) @@ -377,12 +378,12 @@ ((_ 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 @@ -408,13 +409,13 @@ (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 (lamb= da () 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 (lamb= da () body rest ...))))) =20 ;;;; TEST NAMES @@ -620,11 +621,13 @@ '(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:" (assoc-ref location 'filename) (1+ (as= soc-ref location 'line)))) (display label port) (display ": " port) (display (format-test-name name) port) 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 --=-=-=--