From unknown Sun Jun 22 22:41:32 2025 Content-Disposition: inline Content-Transfer-Encoding: quoted-printable MIME-Version: 1.0 X-Mailer: MIME-tools 5.509 (Entity 5.509) Content-Type: text/plain; charset=utf-8 From: bug#73605 <73605@debbugs.gnu.org> To: bug#73605 <73605@debbugs.gnu.org> Subject: Status: [PATCH] Replace SRFI-64 with a new implementation. Reply-To: bug#73605 <73605@debbugs.gnu.org> Date: Mon, 23 Jun 2025 05:41:32 +0000 retitle 73605 [PATCH] Replace SRFI-64 with a new implementation. reassign 73605 guile submitter 73605 Tomas Volf <~@wolfsden.cz> severity 73605 normal tag 73605 patch thanks From debbugs-submit-bounces@debbugs.gnu.org Wed Oct 02 15:41:48 2024 Received: (at submit) by debbugs.gnu.org; 2 Oct 2024 19:41:48 +0000 Received: from localhost ([127.0.0.1]:59290 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1sw5EG-0004Od-8M for submit@debbugs.gnu.org; Wed, 02 Oct 2024 15:41:48 -0400 Received: from lists.gnu.org ([209.51.188.17]:35546) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from <~@wolfsden.cz>) id 1sw5EB-0004OL-KE for submit@debbugs.gnu.org; Wed, 02 Oct 2024 15:41:43 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from <~@wolfsden.cz>) id 1sw5E3-0005Bl-UQ for bug-guile@gnu.org; Wed, 02 Oct 2024 15:41:32 -0400 Received: from wolfsden.cz ([37.205.8.62]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from <~@wolfsden.cz>) id 1sw5Dt-0002mS-Km for bug-guile@gnu.org; Wed, 02 Oct 2024 15:41:31 -0400 Received: by wolfsden.cz (Postfix, from userid 104) id 57897311D7B; Wed, 2 Oct 2024 19:41:14 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=wolfsden.cz; s=mail; t=1727898074; bh=EC1hmuif1yxuvfrfBPM91abDyT7/rZPiSdvwfxpfKcU=; h=From:To:Cc:Subject:Date; b=AosE83wl3dv8qKQjr4Txt4fKDZrEQO51S9o6y8dv9KAX8iNBjiG/wKAT3K/o3Aanx jKXtKYegBWBc8FH1YwIjRXuA7SH6os2y3XnZSmGqQ9DzKqx1jIUR+Kh6FftlKD2hZz dpUOWLIDZ5IfoehgFAChZTY9pRgdvYZuLL7Y61W6zbvaMQ2mCzfdgoLXXfOvrt0AbR 28vMbcWxcMq5nAwZuSXPCv5AUtj8bQlknQp8CuEX5psE1cvCJFkHiMchmh6dDxH4rX RoZ8N8GM+s5qAxHIWlMA29GQvur79mcpPqT3f2udwbtASLfnUx/N9xrG9mFCa2UBLj nVj/zefwbmz7Wm5+tMltWMokmw0GFG77ecdwT0yn/yPQFI2h+19dkBoulSLWwKxUD/ ley5JWZ8kt0Kkhm3ixL4uHCLJWl+I4v9V23ZVelF+6c2YdTHUqK7gkCRHPpDGDevVs h0T/uhYseK2sH7cS7SRp6/Q53J4Oj+wmta105qF/psAJcZXMdhMfKycZyklSOq1Ktd 6YhWZZbe3MW5oS8aI20lnlZfm3EsQJelWCHWb+JD/ydwSqcKEj2JUYg1ZDJ16RYZ9Z +K4NeqZE5s+P+d3YbQ6rAj+ExHv0shH3Nz9ImVYMGmFo9j/eXH7yudOiQANgCqTdtH 0qsj+9dmS5NTT+0/2ImKrBFE= X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on wolfsden X-Spam-Level: X-Spam-Status: No, score=-3.1 required=5.0 tests=ALL_TRUSTED,BAYES_00, DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.6 Received: from localhost (unknown [81.17.16.87]) by wolfsden.cz (Postfix) with ESMTPSA id 84F64312D3B; Wed, 2 Oct 2024 19:41:11 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=wolfsden.cz; s=mail; t=1727898071; bh=EC1hmuif1yxuvfrfBPM91abDyT7/rZPiSdvwfxpfKcU=; h=From:To:Cc:Subject:Date; b=ry4D7hFKbmPiQItORlUO69s8pEBe1p9mSBgLtuWIxIK2cmx9IGH2wGe1eVa8aTqkI d08B6ZcdhlDWL50qXQ+Lqec6yjiuH1Z2JlmeRLh8G0BQfR1r4acdOZTLKVUQmBOyOc IvA7Oq+JIwRtSFoFLEOHAIz3UpFEUorYsU/PH7q5LQvU/4AaIrbX+YDDOBiTEWiyoE SX0zlM+5gaFAsKis6bY6sGfBanOQPnU39npaTh5TFXZOLX2XrsRQZ490cjY6C0uqgx PKsNdY6gn3OgfGSu3wV+OOPvZak21/S1EkpYp73DfagcokbCUMEe/KZ5hKalE/ghpk 2yomlfi1xj9kUtouQmoXeywshcrRDP6A5TmWX/Ivu5Ro0Yr/sQRWe18Z2B4KyAhK91 D37PR2cvVP/mKh9McpNRTtoyVE6tx4cAT+XWKr/BYHdziuEEanTw83+lA0BDCXr4YW qg4w+PnUl/vVmH1Ep6kvg/exEHYk6estcFcJJQwIFrUZdIzrHEnDjyFDOD6czZOHjC ZyLqpZWrq7lLP2Is8cRAO8nyEHH6ZUO8HjgeS9uDhlaW7h8CcfenXfjDbjjGCizQI4 gPoSNExPM6lGtwWJ3tm2Iu12IveCTteZc/RPI4NI7cJJh6Oi4hhchx9NUVsJVngbvR uaBOT5q9F5gd7qWuY+yIoyEI= From: Tomas Volf <~@wolfsden.cz> To: bug-guile@gnu.org Subject: [PATCH] Replace SRFI-64 with a new implementation. Date: Wed, 2 Oct 2024 21:27:59 +0200 Message-ID: <20241002194105.24409-1-~@wolfsden.cz> X-Mailer: git-send-email 2.46.0 MIME-Version: 1.0 X-Debbugs-Cc: guile-devel@gnu.org Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Received-SPF: pass client-ip=37.205.8.62; envelope-from=~@wolfsden.cz; helo=wolfsden.cz X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, RCVD_IN_VALIDITY_CERTIFIED_BLOCKED=0.001, RCVD_IN_VALIDITY_RPBL_BLOCKED=0.001, SPF_HELO_PASS=-0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-Spam-Score: -1.3 (-) X-Debbugs-Envelope-To: submit Cc: Tomas Volf <~@wolfsden.cz> X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -2.3 (--) The bundled (reference) implementation was of somewhat mixed quality and it failed to follow standard in multiple places. This commit replaces it with a new one, written from scratch to follow the standard as close as possible. * module/srfi/srfi-64/testing.scm: Delete file. * module/srfi/srfi-64.scm: Replace with new implementation. * am/bootstrap.am (srfi/srfi-64.go): Remove extra dependencies. (NOCOMP_SOURCES): Remove srfi/srfi-64/testing.scm. * test-suite/tests/srfi-64-test.scm ("8.6.1. Simple (form 1) test-apply") ("8.6.2. Simple (form 2) test-apply"): Adjust tests to follow the specification. --- The current implementation of SRFI-64 is buggy and does not even follow the specification in many places. This blog post[0] lists some of the bugs found. This commit it by a new one written from scratch, that tries to solve both of those problems. The code library was tested with GNU Guix (probably biggest user of SRFI-64?) and it works. There are only 4 tests that used to pass and do not with a new implementation. In all of those cases, the bug in the test itself was masked by non-compliance of the previous SRFI-64 implementation. More details here [1]. Tests in Guile (srfi-64-test.scm) did require two changes, the test code does not (in my opinion) follow the specification. Since spec says > Any skip specifiers introduced by a test-skip are removed by a following > non-nested test-end. The test-ends on lines 729 and 747 are nested, they are not top-level, so the skip specifier should not be cleared. But I am opened to debate on this one. During writing the implementation, I produced many (over 300) test files which are available here[2]. I am not sure whether to have them in this commit as well. Opinions? Last remaining point to note is that there is some additional functionality not covered by the specification included (define-test, ...). I can remove it, by I consider it useful. Documentation is currently lacking, but that is intentional, since #71300 is not accepted yet, and logically it would belong in there. 0: https://wolfsden.cz/blog/post/state-of-srfi-64.html 1: https://emacs.ch/@graywolf/112944743928293340 2: https://git.wolfsden.cz/guile-wolfsden/tree/tests/srfi-64 am/bootstrap.am | 2 - module/srfi/srfi-64.scm | 1011 +++++++++++++++++++++++++++- module/srfi/srfi-64/testing.scm | 1044 ----------------------------- test-suite/tests/srfi-64-test.scm | 4 +- 4 files changed, 978 insertions(+), 1083 deletions(-) delete mode 100644 module/srfi/srfi-64/testing.scm diff --git a/am/bootstrap.am b/am/bootstrap.am index 9e5fca0db..d4a415e35 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -54,7 +54,6 @@ COMPILE = $(AM_V_GUILEC) \ ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm ice-9/read.scm ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm -srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm # Keep this rule in sync with that in `am/guilec'. ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm @@ -438,7 +437,6 @@ NOCOMP_SOURCES = \ ice-9/r7rs-libraries.scm \ ice-9/quasisyntax.scm \ srfi/srfi-42/ec.scm \ - srfi/srfi-64/testing.scm \ srfi/srfi-67/compare.scm \ system/base/lalr.upstream.scm \ system/repl/describe.scm \ diff --git a/module/srfi/srfi-64.scm b/module/srfi/srfi-64.scm index 925726f5c..1f60a72e5 100644 --- a/module/srfi/srfi-64.scm +++ b/module/srfi/srfi-64.scm @@ -1,6 +1,5 @@ -;;; srfi-64.scm -- SRFI 64 - A Scheme API for test suites. +;;; Copyright (C) 2024 Tomas Volf <~@wolfsden.cz> -;; Copyright (C) 2014 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -16,41 +15,983 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;; Commentary: + +;;; Implementation of the SRFI-64. In contrast to the reference +;;; implementation of @samp{(srfi srfi-64)} it aims to implement the +;;; standard fully and correctly. + +;;; Code: + (define-module (srfi srfi-64) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) #:export - (test-begin - test-end test-assert test-eqv test-eq test-equal - test-approximate test-assert test-error test-apply test-with-runner - test-match-nth test-match-all test-match-any test-match-name - test-skip test-expect-fail test-read-eval-string - test-runner-group-path test-group test-group-with-cleanup - test-result-ref test-result-set! test-result-clear test-result-remove - test-result-kind test-passed? - test-log-to-file - test-runner? test-runner-reset test-runner-null - test-runner-simple test-runner-current test-runner-factory test-runner-get - test-runner-create test-runner-test-name - test-runner-pass-count test-runner-pass-count! - test-runner-fail-count test-runner-fail-count! - test-runner-xpass-count test-runner-xpass-count! - test-runner-xfail-count test-runner-xfail-count! - test-runner-skip-count test-runner-skip-count! - test-runner-group-stack test-runner-group-stack! - test-runner-on-test-begin test-runner-on-test-begin! - test-runner-on-test-end test-runner-on-test-end! - test-runner-on-group-begin test-runner-on-group-begin! - test-runner-on-group-end test-runner-on-group-end! - test-runner-on-final test-runner-on-final! - test-runner-on-bad-count test-runner-on-bad-count! - test-runner-on-bad-end-name test-runner-on-bad-end-name! - test-result-alist test-result-alist! - test-runner-aux-value test-runner-aux-value! - test-on-group-begin-simple test-on-group-end-simple - test-on-bad-count-simple test-on-bad-end-name-simple - test-on-final-simple test-on-test-end-simple - test-on-final-simple) - #:declarative? #f) ; #f needed for test-log-to-file + ( + ;; Going by individual sections of the specification, top to bottom: + ;; Simple test-cases + test-approximate + test-assert + test-eq + test-equal + test-eqv + ;; Tests for catching errors + test-error + ;; Testing syntax + test-read-eval-string + ;; Test groups and paths + test-begin + test-end + test-group + ;; Handling set-up and cleanup + test-group-with-cleanup + ;; Test specifiers + test-match-all + test-match-any + test-match-name + test-match-nth + ;; Skipping selected tests + test-expect-fail + test-skip + ;; Test-runner + test-runner-create + test-runner-current + test-runner-factory + test-runner-get + test-runner-null + test-runner-simple + test-runner? + ;; Running specific tests with a specified runner + test-apply + test-with-runner + ;; Result kind + test-passed? + test-result-kind + ;; Test result properties + test-result-alist + test-result-clear + test-result-ref + test-result-remove + test-result-set! + ;; Call-back hooks + test-runner-on-bad-count + test-runner-on-bad-count! + test-runner-on-bad-end-name + test-runner-on-bad-end-name! + test-runner-on-final + test-runner-on-final! + test-runner-on-group-begin + test-runner-on-group-begin! + test-runner-on-group-end + test-runner-on-group-end! + test-runner-on-test-begin + test-runner-on-test-begin! + test-runner-on-test-end + test-runner-on-test-end! + ;; Simple runner call-back functions + test-on-bad-count-simple + test-on-bad-end-name-simple + test-on-group-begin-simple + test-on-group-end-simple + test-on-test-begin-simple + test-on-test-end-simple + ;; Test-runner components + test-runner-aux-value + test-runner-aux-value! + test-runner-fail-count + test-runner-group-path + test-runner-group-stack + test-runner-pass-count + test-runner-reset + test-runner-skip-count + test-runner-test-name + test-runner-xfail-count + test-runner-xpass-count + + ;; Additional functionality not in SRFI-64: + define-test + test-procedure? + test-thunk + + &bad-end-name + bad-end-name? + bad-end-name-begin-name + bad-end-name-end-name)) + +(define (set-documentation! symbol docstring) + "Set the docstring for @var{symbol} in current module to @var{docstring}. + +Do not use this procedure for forms that already support setting the +docstring. Should directly follow the definition of @var{symbol}. + +Example: + +@lisp +(define answer 42) +(set-documentation! 'answer + \"The answer to life, the universe, and everything.\") +@end lisp" + (set-object-property! (module-ref (current-module) symbol) + 'documentation + docstring)) (cond-expand-provide (current-module) '(srfi-64)) -(include-from-path "srfi/srfi-64/testing.scm") +(define-record-type + (%make-test-runner) + test-runner? + ;; Test result properties + (result-alist test-runner-result-alist test-runner-result-alist!) + ;; Call-back hooks + (on-bad-count test-runner-on-bad-count test-runner-on-bad-count!) + (on-bad-end-name test-runner-on-bad-end-name test-runner-on-bad-end-name!) + (on-final test-runner-on-final test-runner-on-final!) + (on-group-begin test-runner-on-group-begin test-runner-on-group-begin!) + (on-group-end test-runner-on-group-end test-runner-on-group-end!) + (on-test-begin test-runner-on-test-begin test-runner-on-test-begin!) + (on-test-end test-runner-on-test-end test-runner-on-test-end!) + ;; Test-runner components + (counts test-runner-counts test-runner-counts!) + + (test-name test-runner-test-name test-runner-test-name!) + + (group-stack test-runner-group-stack test-runner-group-stack!) + + (aux-value test-runner-aux-value test-runner-aux-value!) + + ;; Implementation details + (fail-list test-runner-fail-list test-runner-fail-list!) + (groups test-runner-groups test-runner-groups!) + (run-list test-runner-run-list test-runner-run-list!) + (skip-list test-runner-skip-list test-runner-skip-list!)) + +(define (test-runner-reset runner) + (test-runner-result-alist! runner '()) + + (test-runner-counts! runner '()) + + (test-runner-test-name! runner #f) + + (test-runner-group-stack! runner '()) + + (test-runner-fail-list! runner '()) + (test-runner-groups! runner '()) + ;; run-list is not documented as part of the test-runner, so it should *not* + ;; be cleared. + (test-runner-skip-list! runner '())) + +(define (test-runner-group-path runner) + "Return list of names of groups we're nested in, with the outermost group +first." + (reverse (test-runner-group-stack runner))) + +(define (test-runner-fail-count r) + "Return the number of tests that failed, but were expected to pass." + (or (assq-ref (test-runner-counts r) 'fail) 0)) + +(define (test-runner-pass-count r) + "Return the number of tests that passed, and were expected to pass." + (or (assq-ref (test-runner-counts r) 'pass) 0)) + +(define (test-runner-skip-count r) + "Return the number of tests or test groups that were skipped." + (or (assq-ref (test-runner-counts r) 'skip) 0)) + +(define (test-runner-xfail-count r) + "Return the number of tests that failed, and were expected to fail." + (or (assq-ref (test-runner-counts r) 'xfail) 0)) + +(define (test-runner-xpass-count r) + "Return the number of tests that passed, but were expected to fail." + (or (assq-ref (test-runner-counts r) 'xpass) 0)) + + +;;; +;;; Test specifiers +;;; +(define (test-match-name name) + "Return a specifier matching the current test name against @var{name}." + (λ (runner) + (equal? name (test-runner-test-name runner)))) + +(define* (test-match-nth n #:optional (count 1)) + "Return a stateful predicate. A counter keeps track of how many times it +has been called. The predicate matches the @var{n}'th time it is +called (where 1 is the first time), and the next @code{(- @var{count} 1)} +times, where @var{count} defaults to 1." + (let ((i 0) + (m (+ n count -1))) + (λ (runner) + (set! i (1+ i)) + (and (>= i n) (<= i m))))) + +(define (obj->specifier obj) + "Convert an object to a specifier accounting for the convenience +short-hands." + (match obj + ((? procedure? spec) + spec) + ((? string? name) + (test-match-name name)) + ((? integer? count) + (test-match-nth 1 count)))) + +(define (test-match-any . specifiers) + "Return specifier matching if any specifier in @var{specifiers} matches. +Each specifier is applied, in order, so side-effects from a later specifier +happen even if an earlier specifier is true." + (let ((specifiers (map obj->specifier specifiers))) + (λ (runner) + (fold (λ (specifier seed) + (or (specifier runner) seed)) + #f + specifiers)))) + +(define (test-match-all . specifiers) + "Return specifier matching if all @var{specifiers} match. Each specifier is +applied, in order, so side-effects from a later specifier happen even if an +earlier specifier is true." + (let ((specifiers (map obj->specifier specifiers))) + (λ (runner) + (fold (λ (specifier seed) + (and (specifier runner) seed)) + #t + specifiers)))) + + +;;; +;;; Skipping selected tests +;;; +(define (test-skip specifier) + "Evaluating test-skip adds the resulting specifier to the set of currently +active skip-specifiers. Before each test (or test-group) the set of active +skip-specifiers are applied to the active test-runner. If any specifier +matches, then the test is skipped. + +@var{specifier} can be a predicate of one argument (the test runner), a +string (used as if @code{(test-match-name @var{specifier})}) or an +integer (used as if @code{(test-match-nth 1 @var{specifier})})." + (let ((r (test-runner-current))) + (test-runner-skip-list! r (cons (obj->specifier specifier) + (test-runner-skip-list r))))) + +(define (any-specifier-matches? specifiers) + "Does any specifier in @var{specifiers} match current test? + +All specifiers are always evaluated." + (let ((r (test-runner-current))) + (fold (λ (specifier seed) + (or (specifier r) seed)) + #f + specifiers))) + +(define (should-skip?) + "Should current test be skipped?" + (any-specifier-matches? (test-runner-skip-list (test-runner-current)))) + + +;;; +;;; Expected failures +;;; +(define (test-expect-fail specifier) + "Matching tests (where matching is defined as in test-skip) are expected to +fail. This only affects test reporting, not test execution." + (let ((r (test-runner-current))) + (test-runner-fail-list! r (cons (obj->specifier specifier) + (test-runner-fail-list r))))) + +(define (should-fail?) + "Should the current test fail?" + (any-specifier-matches? (test-runner-fail-list (test-runner-current)))) + + +;;; +;;; Test result properties +;;; +(define* (test-result-ref runner pname #:optional default) + "Returns the property value associated with the @var{pname} property name. +If there is no value associated with @var{pname} return @var{default}, or +@code{#f} if @var{default} is not specified." + (or (assoc-ref (test-runner-result-alist runner) pname) + default)) + +(define (test-result-set! runner pname value) + "Sets the property value associated with the @var{pname} property name to +@var{value}." + (test-runner-result-alist! runner + (assoc-set! (test-runner-result-alist runner) + pname + value))) + +(define (test-result-remove runner pname) + "Remove the property with the name @var{pname}." + (test-runner-result-alist! runner + (assoc-remove! (test-runner-result-alist runner) + pname))) + +(define (test-result-clear runner) + "Remove all result properties." + ;; Standard says the following for test-result-alist: + ;; > However, a test-result-clear does not modify the returned alist. + ;; + ;; Therefore we assign a new empty list instead of removing all entries. + (test-runner-result-alist! runner '())) + +(define test-result-alist test-runner-result-alist) +(set-documentation! 'test-result-alist + "Returns an association list of the current result properties. It is +unspecified if the result shares state with the test-runner. The result +should not be modified; on the other hand, the result may be implicitly +modified by future @code{test-result-set!} or @code{test-result-remove} calls. +However, a @code{test-result-clear} does not modify the returned alist.") + + +;;; +;;; Result kind +;;; +(define* (test-result-kind #:optional (runner (test-runner-current))) + "Result code of most recent test. Returns @code{#f} if no tests have been run yet. +If we have started on a new test, but do not have a result yet, then the +result kind is @code{'xfail} if the test is expected to fail, @code{'skip} if +the test is supposed to be skipped, or @code{#f} otherwise." + (test-result-ref runner 'result-kind)) + +(define* (test-passed? #:optional (runner (test-runner-current))) + "Is the value of @code{(test-result-kind [runner])} one of @code{'pass} or +@code{'xpass}? + +This function is of little use, since @code{'xpass} is type of failure. You +should write your own wrapper checking @code{'pass} and @code{'xfail} +instead." + (let ((result (test-result-kind runner))) + (or (eq? result 'pass) + (eq? result 'xpass)))) + + +;;; +;;; Simple test runner +;;; +(define (test-on-bad-count-simple runner actual-count expected-count) + "Log the discrepancy between expected and actual test counts." + (format #t "*** Expected to run ~a tests, but ~a was executed. ***~%" + expected-count actual-count)) + +(define (test-on-bad-end-name-simple runner begin-name end-name) + "Log the discrepancy between the -begin and -end suite names." + (format #t "*** Suite name mismatch: test-begin (~a) != test-end (~a) ***~%" + begin-name end-name)) + +(define (test-on-final-simple runner) + "Display summary of the test suite." + (display "*** Test suite finished. ***\n") + (for-each (λ (x) + (let ((count ((cdr x) runner))) + (when (> count 0) + (format #t "*** # of ~a: ~a~%" (car x) count)))) + `(("expected passes " . ,test-runner-pass-count) + ("expected failures " . ,test-runner-xfail-count) + ("unexpected passes " . ,test-runner-xpass-count) + ("unexpected failures" . ,test-runner-fail-count) + ("skips " . ,test-runner-skip-count)))) + +(define (test-on-group-begin-simple runner suite-name count) + "Log that the group is beginning." + (format #t "*** Entering test group: ~a~@[ (# of tests: ~a) ~] ***~%" + suite-name count)) + +(define (test-on-group-end-simple runner) + "Log that the group is ending." + ;; There is no portable way to get the test group name. + (format #t "*** Leaving test group: ~a ***~%" + (car (test-runner-group-stack runner)))) + +(define (test-on-test-begin-simple runner) + "Do nothing." + #f) + +(define (test-on-test-end-simple runner) + "Log that test is done." + (define (maybe-print-prop prop pretty?) + (let* ((val (test-result-ref runner prop)) + (val (string-trim-both + (with-output-to-string + (λ () + (if pretty? + (pretty-print val #:per-line-prefix " ") + (display val))))))) + (when val + (format #t "~a: ~a~%" prop val)))) + + (let ((result-kind (test-result-kind runner))) + ;; Skip tests not executed due to run list. + (when result-kind + (format #t "* ~:@(~a~): ~a~%" + result-kind + (test-runner-test-name runner)) + (unless (member result-kind '(pass xfail)) + (maybe-print-prop 'source-file #f) + (maybe-print-prop 'source-line #f) + (maybe-print-prop 'source-form #t) + (maybe-print-prop 'expected-value #f) + (maybe-print-prop 'expected-error #t) + (maybe-print-prop 'actual-value #f) + (maybe-print-prop 'actual-error #t))))) + +(define (test-runner-simple) + "Creates a new simple test-runner, that prints errors and a summary on the +standard output port." + (let ((r (%make-test-runner))) + (test-runner-reset r) + + (test-runner-on-bad-count! r test-on-bad-count-simple) + (test-runner-on-bad-end-name! r test-on-bad-end-name-simple) + (test-runner-on-final! r test-on-final-simple) + (test-runner-on-group-begin! r test-on-group-begin-simple) + (test-runner-on-group-end! r test-on-group-end-simple) + (test-runner-on-test-begin! r test-on-test-begin-simple) + (test-runner-on-test-end! r test-on-test-end-simple) + + (test-runner-run-list! r (make-parameter #f)) + r)) + + +;;; +;;; Test runner +;;; + +(define test-runner-current (make-parameter #f)) +(set-documentation! 'test-runner-current + "Parameter representing currently installed test runner.") + +(define (test-runner-get) + "Get current test runner if any, raise an exception otherwise." + (or (test-runner-current) + (throw 'no-test-runner))) + +(define test-runner-factory (make-parameter test-runner-simple)) +(set-documentation! 'test-runner-factory + "Factory producing new test runner. Has to be a procedure of arity 0 +returning new test runner. Defaults to @code{test-runner-simple}.") + +(define (test-runner-create) + "Create a new test-runner. Equivalent to @code{((test-runner-factory))}." + ((test-runner-factory))) + +(define (test-runner-null) + (let ((r (%make-test-runner)) + (dummy-1 (λ (_) #f)) + (dummy-3 (λ (_ __ ___) #f))) + (test-runner-reset r) + + (test-runner-on-bad-count! r dummy-3) + (test-runner-on-bad-end-name! r dummy-3) + (test-runner-on-final! r dummy-1) + (test-runner-on-group-begin! r dummy-3) + (test-runner-on-group-end! r dummy-1) + (test-runner-on-test-begin! r dummy-1) + (test-runner-on-test-end! r dummy-1) + + (test-runner-run-list! r (make-parameter #f)) + r)) + + +;;; +;;; Test groups and paths +;;; +(define-record-type + (make-group name count executed-count installed-runner? previous-skip-list) + group? + (name group-name) + (count group-count) + (executed-count group-executed-count group-executed-count!) + (installed-runner? group-installed-runner?) + (previous-skip-list group-previous-skip-list)) + +(define (increment-executed-count r) + "Increment executed count of the first group." + (let ((groups (test-runner-groups r))) + (unless (null? groups) + (let ((group (car groups))) + (group-executed-count! group + (1+ (group-executed-count group))))))) + +(define* (test-begin suite-name #:optional count) + "Enter a new test group." + (let* ((r (test-runner-current)) + (r install? (if r + (values r #f) + (values (test-runner-create) #t))) + (group (make-group suite-name + count + 0 + install? + (test-runner-skip-list r)))) + (when install? + (test-runner-current r)) + + (test-runner-test-name! r suite-name) + (test-runner-groups! r (cons group (test-runner-groups r))) + ;; Per-strict reading of SRFI-64, -group-stack is required to be + ;; non-copying, hence non-computed. So duplicate the information already + ;; present in -groups here. + (test-runner-group-stack! r (cons suite-name (test-runner-group-stack r))) + + ((test-runner-on-group-begin r) r suite-name count))) + +(define* (test-end #:optional suite-name) + "Leave the current test group." + (let* ((r (test-runner-current)) + (group (car (test-runner-groups r)))) + + (let ((begin-name (car (test-runner-group-stack r))) + (end-name suite-name)) + (when (and end-name (not (string=? begin-name end-name))) + ((test-runner-on-bad-end-name r) r begin-name end-name) + (raise-exception (make-bad-end-name begin-name end-name)))) + + (let ((expected-count (group-count group)) + (actual-count (group-executed-count group))) + (when (and expected-count (not (= expected-count actual-count))) + ((test-runner-on-bad-count r) r actual-count expected-count))) + + ((test-runner-on-group-end r) r) + + (test-runner-groups! r (cdr (test-runner-groups r))) + (test-runner-group-stack! r (cdr (test-runner-group-stack r))) + (test-runner-skip-list! r (group-previous-skip-list group)) + + (if (null? (test-runner-group-stack r)) + ((test-runner-on-final r) r) + (increment-executed-count r)) + + (when (group-installed-runner? group) + (test-runner-current #f)))) + +(define-syntax test-group + (syntax-rules () + "Execute @var{decl-or-expr ...} in a named test group. The whole group is +skipped if it matches an active test-skip." + ((_ suite-name decl-or-expr ...) + (let ((r (test-runner-current)) + (name suite-name)) + ;; Since test-runner stores skip state, if we do not have test-runner, + ;; the test cannot be on skip list (it does not exist). + (when (or (not r) + (begin + ;; Specifiers are using -test-name, so we need to do this + ;; here and not rely on test-begin. + (test-runner-test-name! r name) + (not (should-skip?)))) + (dynamic-wind + (λ () (test-begin name)) + (λ () decl-or-expr ...) + (λ () (test-end name)))))))) + + +;;; +;;; Handling set-up and cleanup +;;; +(define-syntax test-group-with-cleanup + (syntax-rules () + "Execute each of the @var{decl-or-expr} forms in order, and then execute +the @var{cleanup-form}. The latter shall be executed even if one of a +@var{decl-or-expr} forms raises an exception." + ((_ suite-name decl-or-expr ... cleanup-form) + (dynamic-wind + (λ () #t) + (λ () (test-group suite-name decl-or-expr ...)) + (λ () cleanup-form))))) + + +;;; +;;; Simple test-cases +;;; +(define (syntax->source-properties form) + "Extract properties of syntax @var{form} and return them as a alist with +keys compatible with Guile's SRFI-64 implementation." + (let* ((source (syntax-source form)) + (file (and=> source (cut assq-ref <> 'filename))) + (line (and=> source (cut assq-ref <> 'line))) + ;; I do not care about column. Tests are not nested enough. + (file-alist (if file + `((source-file . ,file)) + '())) + (line-alist (if line + `((source-line . ,(1+ line))) ; 1st line should be 1. + '()))) + (datum->syntax form + `((source-form . ,(syntax->datum form)) + ,@file-alist + ,@line-alist)))) + +(define (preliminary-result-kind! r fail? skip?) + "Set result-kind before the test was run based on @var{fail?} and +@var{skip?}." + (test-result-set! r 'result-kind (cond + ;; I think this order is stupid, but it is + ;; what SRFI demands. + (fail? 'xfail) + (skip? 'skip) + (else #f)))) + +(define (final-result-kind! r match? fail-expected?) + "Set the final result-kind based on @var{match?} and @var{fail-expected?}." + (test-result-set! r 'result-kind (cond ((and match? fail-expected?) + 'xpass) + (match? + 'pass) + (fail-expected? + 'xfail) + (else + 'fail)))) + +(define (fail-on-exception thunk) + "Run the thunk and return the result. If exception occurs, record it and +return @code{#f}." + (with-exception-handler + (λ (exc) + (test-result-set! (test-runner-current) 'actual-error exc) + #f) + (λ () (thunk)) + #:unwind? #t)) + +(define (increment-test-count r) + "Increment the test count for the current 'result-kind." + (let* ((kind (test-result-kind r)) + (counts (test-runner-counts r)) + (c (or (assq-ref counts kind) 0))) + (test-runner-counts! r (assq-set! counts kind (1+ c))))) + +(define (test-thunk test-name properties thunk) + "Run test @var{thunk} while taking into account currently active skip list +and such. The result alist is initially set to @var{properties}, however +@var{thunk} is expected to make additions (actual, expected values, ...). + +@var{thunk} must return @code{#f} to indicate test failure. Otherwise the +test is considered successful." + (let ((r (test-runner-current))) + ;; Since skip checks are using -test-name, set it first. + (test-runner-test-name! r (or test-name "")) + (test-runner-result-alist! r properties) + + (let ((fail? (should-fail?)) + (run? (should-run?)) + (skip? (should-skip?))) + (preliminary-result-kind! r fail? skip?) + ((test-runner-on-test-begin r) r) + (when run? + (if skip? + (test-result-set! r 'result-kind 'skip) + (begin + (final-result-kind! r (fail-on-exception thunk) fail?) + (increment-executed-count r)))) + ((test-runner-on-test-end r) r) + (increment-test-count r)))) + +(define-syntax %test-assert + (λ (x) + (syntax-case x () + ((_ syn test-name expression) + #`(test-thunk (let () test-name) + '#,(syntax->source-properties #'syn) + (λ () + (let ((r (test-runner-current)) + (a (let () expression))) + (test-result-set! r 'actual-value a) + a))))))) + +(define-syntax test-assert + (λ (x) + (syntax-case x () + ((_ test-name expression) + #`(%test-assert #,x test-name expression)) + ((_ expression) + #`(%test-assert #,x #f expression))))) +(set-documentation! 'test-assert + "@defspec test-assert test-name expression +@defspecx test-assert expression +Evaluate the @var{expression}, the test passes if the result is true. + +@var{test-name} and @var{expression} are evaluated just once. It is an error +to invoke @code{test-assert} if there is no current test runner. + +@end defspec") + +(define-syntax %%test-2 + (λ (x) + (syntax-case x () + ((_ syn test-proc test-name expected test-expr) + #`(test-thunk (let () test-name) + '#,(syntax->source-properties #'syn) + (λ () + (let ((r (test-runner-current)) + (e (let () expected)) + (a (let () test-expr))) + (test-result-set! r 'expected-value e) + (test-result-set! r 'actual-value a) + (test-proc e a)))))))) + +(define-syntax %test-2 + (syntax-rules () + ((_ name test-proc) + (define-syntax name + (λ (x) + (syntax-case x () + ((_ test-name expected test-expr) + #`(%%test-2 #,x test-proc test-name expected test-expr)) + ((_ expected test-expr) + #`(%%test-2 #,x test-proc #f expected test-expr)))))))) + +(%test-2 test-eq eq?) +(%test-2 test-eqv eqv?) +(%test-2 test-equal equal?) + +(set-documentation! 'test-eq + "@defspec test-eq test-name expected test-expr +@defspecx test-eq expected test-expr +Test whether result of @var{test-expr} matches @var{expected} using +@code{eq?}. + +@end defspec") +(set-documentation! 'test-eqv + "@defspec test-eqv test-name expected test-expr +@defspecx test-eqv expected test-expr +Test whether result of @var{test-expr} matches @var{expected} using +@code{eqv?}. + +@end defspec") +(set-documentation! 'test-equal + "@defspec test-equal test-name expected test-expr +@defspecx test-equal expected test-expr +Test whether result of @var{test-expr} matches @var{expected} using +@code{equal?}. + +@end defspec") + +(define (within-epsilon ε) + (λ (expected actual) + (and (>= actual (- expected ε)) + (<= actual (+ expected ε))))) + +(define-syntax %test-approximate + (λ (x) + (syntax-case x () + ((_ syn test-name expected test-expr error) + #`(test-thunk (let () test-name) + '#,(syntax->source-properties #'syn) + (λ () + (let ((r (test-runner-current)) + (e (let () expected)) + (a (let () test-expr)) + (ε (let () error))) + (test-result-set! r 'expected-value e) + (test-result-set! r 'actual-value a) + (test-result-set! r 'epsilon ε) + ((within-epsilon ε) e a)))))))) + +(define-syntax test-approximate + (λ (x) + (syntax-case x () + ((_ test-name expected test-expr error) + #`(%test-approximate #,x test-name expected test-expr error)) + ((_ expected test-expr error) + #`(%test-approximate #,x #f expected test-expr error))))) +(set-documentation! 'test-approximate + "@defspec test-approximate test-name expected test-expr error +@defspecx test-approximate expected test-expr error +Test whether result of @var{test-expr} is within @var{error} of +@var{expected}. + +@end defspec") + +(define-syntax %test-error + (λ (x) + (syntax-case x () + ((_ syn test-name error-type test-expr) + #`(test-thunk (let () test-name) + '#,(syntax->source-properties #'syn) + (λ () + (let ((r (test-runner-current)) + (e-type (let () error-type))) + (test-result-set! r 'expected-error e-type) + (with-exception-handler + (λ (exc) + (test-result-set! r 'actual-error exc) + (match e-type + (#t #t) + (#f #f) + ((? symbol? sym) + (eq? sym (exception-kind exc))) + ((? procedure? proc) + (proc exc)) + ((? exception-type? exc-type) + ((exception-predicate exc-type) exc)))) + (λ () + test-expr + (not e-type)) + #:unwind? #t)))))))) + +(define-syntax test-error + (λ (x) + (syntax-case x () + ((_ test-name error-type test-expr) + #`(%test-error #,x test-name error-type test-expr)) + ((_ error-type test-expr) + #`(%test-error #,x #f error-type test-expr)) + ((_ test-expr) + #`(%test-error #,x #f #t test-expr))))) +(set-documentation! 'test-error + "@defspec test-error test-name error-type test-expr +@defspecx test-error error-type test-expr +@defspecx test-error test-expr +Evaluating @var{test-expr} is expected to signal an error. The kind of error +is indicated by @var{error-type}. It is always evaluated (even when no +exception is raised) and can be one of the following. + +@table @code +@item #t +Per specification, this matches any exception. + +@item #f +Pass if no exception is raised. + +@item symbol? +Symbols can be used to match against exceptions created using +@code{throw} and @code{error}. + +@item procedure? +The exception object is passed to the predicate procedure. Example +would be @code{external-error?}. + +@item exception-type? +Exception type like for example @code{&external-error}. + +@end table + +@end defspec") + + +;;; +;;; Testing syntax +;;; +(define (test-read-eval-string string) + "Parse the @var{string} (using @code{read}), evaluate and return the +result. + +An error is signaled if there are unread characters after the @code{read} is +done." + (with-input-from-string string + (λ () + (let ((exp (read))) + (unless (eof-object? (read-char)) + (error "read did not consume whole string")) + (eval exp (current-module)))))) + + +;;; +;;; Running specific tests with a specified runner +;;; +(define-syntax test-with-runner + (syntax-rules () + "Execute each @var{decl-or-expr} in order in a context where the current +test-runner is @var{runner}." + ((_ runner decl-or-expr ...) + (parameterize ((test-runner-current runner)) + #t + decl-or-expr ...)))) + +(define (should-run?) + "Should current test be considered for execution according to currently +active run list?" + (let ((run-list ((test-runner-run-list (test-runner-current))))) + (if run-list + (any-specifier-matches? run-list) + #t))) + +(define test-apply + (match-lambda* + (((? test-runner? r) specifiers ... thunk) + (test-with-runner r + (parameterize (((test-runner-run-list r) + (if (null? specifiers) + #f + (map obj->specifier specifiers)))) + (thunk)))) + ((specifiers ... thunk) + (apply test-apply + (or (test-runner-current) + (test-runner-create)) + `(,@specifiers ,thunk))))) +(set-documentation! 'test-apply + "@defunx test-apply runner specifier ... procedure +@defunx test-apply specifier ... procedure + +Call @var{procedure} with no arguments using the specified @var{runner} as the +current test-runner. If runner is omitted, then @code{(test-runner-current)} +is used. If there is no current runner, one is created as in +@code{test-begin}. If one or more @var{specifiers} are listed then only tests +matching the @var{specifiers} are executed. A specifier has the same form as +one used for @code{test-skip}. A test is executed if it matches any of the +specifiers in the @code{test-apply} and does not match any active +@code{test-skip} specifiers.") + + +;;; +;;; Additional functionality not covered by the SRFI. +;;; + +(define %define-test-property 'srfi-64-extra/proc-for-test) + +(define-syntax define-test + (λ (x) + (syntax-case x () + ((_ name e ...) + (let* ((binding-syn + (datum->syntax x + (string->symbol + (string-append "test-procedure-" + (syntax->datum #'name)))))) + #`(begin + (define (#,binding-syn) + (test-begin name) + e ... + (test-end name)) + (set-procedure-property! #,binding-syn + %define-test-property #t))))))) +(set-documentation! 'define-test + "@defspec define-test name form ... +Introduce a top-level procedure (using @code{define}) with body equivalent to + +@lisp +(test-begin @var{name}) +@var{form ...} +(test-end @var{name}) +@end lisp + +Due to the procedure name being derived from @var{name}, the @var{name} should +be unique per-module. + +The procedure has @code{%define-test-property} procedure property set to +@code{#t}. This can be used by test driver to discover all test procedures in +the module. + +@end defspec") + +(define (test-procedure? obj) + "Return whether @var{obj} is a procedure defined by define-test." + (and (procedure? obj) + (procedure-property obj %define-test-property))) + +(define-exception-type &bad-end-name &programming-error + make-bad-end-name bad-end-name? + (begin-name bad-end-name-begin-name) + (end-name bad-end-name-end-name)) +(set-documentation! '&bad-end-name + "Exception type raised when @var{suite-name} in @code{test-end} differs from +matching @code{test-begin}.") diff --git a/module/srfi/srfi-64/testing.scm b/module/srfi/srfi-64/testing.scm deleted file mode 100644 index cdaab140f..000000000 --- a/module/srfi/srfi-64/testing.scm +++ /dev/null @@ -1,1044 +0,0 @@ -;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner -;; Added "full" support for Chicken, Gauche, Guile and SISC. -;; Alex Shinn, Copyright (c) 2005. -;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. -;; Support for Guile 2 by Mark H Weaver , Copyright (c) 2014. -;; -;; Permission is hereby granted, free of charge, to any person -;; obtaining a copy of this software and associated documentation -;; files (the "Software"), to deal in the Software without -;; restriction, including without limitation the rights to use, copy, -;; modify, merge, publish, distribute, sublicense, and/or sell copies -;; of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: -;; -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - -(cond-expand - (chicken - (require-extension syntax-case)) - (guile-2 - (use-modules (srfi srfi-9) - ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated - ;; with either Guile's native exceptions or R6RS exceptions. - ;;(srfi srfi-34) (srfi srfi-35) - (srfi srfi-39))) - (guile - (use-modules (ice-9 syncase) (srfi srfi-9) - ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7 - (srfi srfi-39))) - (sisc - (require-extension (srfi 9 34 35 39))) - (kawa - (module-compile-options warn-undefined-variable: #t - warn-invoke-unknown-method: #t) - (provide 'srfi-64) - (provide 'testing) - (require 'srfi-34) - (require 'srfi-35)) - (else () - )) - -(cond-expand - (kawa - (define-syntax %test-export - (syntax-rules () - ((%test-export test-begin . other-names) - (module-export %test-begin . other-names))))) - (else - (define-syntax %test-export - (syntax-rules () - ((%test-export . names) (if #f #f)))))) - -;; List of exported names -(%test-export - test-begin ;; must be listed first, since in Kawa (at least) it is "magic". - test-end test-assert test-eqv test-eq test-equal - test-approximate test-assert test-error test-apply test-with-runner - test-match-nth test-match-all test-match-any test-match-name - test-skip test-expect-fail test-read-eval-string - test-runner-group-path test-group test-group-with-cleanup - test-result-ref test-result-set! test-result-clear test-result-remove - test-result-kind test-passed? - test-log-to-file - ; Misc test-runner functions - test-runner? test-runner-reset test-runner-null - test-runner-simple test-runner-current test-runner-factory test-runner-get - test-runner-create test-runner-test-name - ;; test-runner field setter and getter functions - see %test-record-define: - test-runner-pass-count test-runner-pass-count! - test-runner-fail-count test-runner-fail-count! - test-runner-xpass-count test-runner-xpass-count! - test-runner-xfail-count test-runner-xfail-count! - test-runner-skip-count test-runner-skip-count! - test-runner-group-stack test-runner-group-stack! - test-runner-on-test-begin test-runner-on-test-begin! - test-runner-on-test-end test-runner-on-test-end! - test-runner-on-group-begin test-runner-on-group-begin! - test-runner-on-group-end test-runner-on-group-end! - test-runner-on-final test-runner-on-final! - test-runner-on-bad-count test-runner-on-bad-count! - test-runner-on-bad-end-name test-runner-on-bad-end-name! - test-result-alist test-result-alist! - test-runner-aux-value test-runner-aux-value! - ;; default/simple call-back functions, used in default test-runner, - ;; but can be called to construct more complex ones. - test-on-group-begin-simple test-on-group-end-simple - test-on-bad-count-simple test-on-bad-end-name-simple - test-on-final-simple test-on-test-end-simple - test-on-final-simple) - -(cond-expand - (srfi-9 - (define-syntax %test-record-define - (syntax-rules () - ((%test-record-define alloc runner? (name index setter getter) ...) - (define-record-type test-runner - (alloc) - runner? - (name setter getter) ...))))) - (else - (define %test-runner-cookie (list "test-runner")) - (define-syntax %test-record-define - (syntax-rules () - ((%test-record-define alloc runner? (name index getter setter) ...) - (begin - (define (runner? obj) - (and (vector? obj) - (> (vector-length obj) 1) - (eq (vector-ref obj 0) %test-runner-cookie))) - (define (alloc) - (let ((runner (make-vector 23))) - (vector-set! runner 0 %test-runner-cookie) - runner)) - (begin - (define (getter runner) - (vector-ref runner index)) ...) - (begin - (define (setter runner value) - (vector-set! runner index value)) ...))))))) - -(%test-record-define - %test-runner-alloc test-runner? - ;; Cumulate count of all tests that have passed and were expected to. - (pass-count 1 test-runner-pass-count test-runner-pass-count!) - (fail-count 2 test-runner-fail-count test-runner-fail-count!) - (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!) - (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!) - (skip-count 5 test-runner-skip-count test-runner-skip-count!) - (skip-list 6 %test-runner-skip-list %test-runner-skip-list!) - (fail-list 7 %test-runner-fail-list %test-runner-fail-list!) - ;; Normally #t, except when in a test-apply. - (run-list 8 %test-runner-run-list %test-runner-run-list!) - (skip-save 9 %test-runner-skip-save %test-runner-skip-save!) - (fail-save 10 %test-runner-fail-save %test-runner-fail-save!) - (group-stack 11 test-runner-group-stack test-runner-group-stack!) - (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!) - (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!) - ;; Call-back when entering a group. Takes (runner suite-name count). - (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!) - ;; Call-back when leaving a group. - (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!) - ;; Call-back when leaving the outermost group. - (on-final 16 test-runner-on-final test-runner-on-final!) - ;; Call-back when expected number of tests was wrong. - (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!) - ;; Call-back when name in test=end doesn't match test-begin. - (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!) - ;; Cumulate count of all tests that have been done. - (total-count 19 %test-runner-total-count %test-runner-total-count!) - ;; Stack (list) of (count-at-start . expected-count): - (count-list 20 %test-runner-count-list %test-runner-count-list!) - (result-alist 21 test-result-alist test-result-alist!) - ;; Field can be used by test-runner for any purpose. - ;; test-runner-simple uses it for a log file. - (aux-value 22 test-runner-aux-value test-runner-aux-value!) -) - -(define (test-runner-reset runner) - (test-result-alist! runner '()) - (test-runner-pass-count! runner 0) - (test-runner-fail-count! runner 0) - (test-runner-xpass-count! runner 0) - (test-runner-xfail-count! runner 0) - (test-runner-skip-count! runner 0) - (%test-runner-total-count! runner 0) - (%test-runner-count-list! runner '()) - (%test-runner-run-list! runner #t) - (%test-runner-skip-list! runner '()) - (%test-runner-fail-list! runner '()) - (%test-runner-skip-save! runner '()) - (%test-runner-fail-save! runner '()) - (test-runner-group-stack! runner '())) - -(define (test-runner-group-path runner) - (reverse (test-runner-group-stack runner))) - -(define (%test-null-callback runner) #f) - -(define (test-runner-null) - (let ((runner (%test-runner-alloc))) - (test-runner-reset runner) - (test-runner-on-group-begin! runner (lambda (runner name count) #f)) - (test-runner-on-group-end! runner %test-null-callback) - (test-runner-on-final! runner %test-null-callback) - (test-runner-on-test-begin! runner %test-null-callback) - (test-runner-on-test-end! runner %test-null-callback) - (test-runner-on-bad-count! runner (lambda (runner count expected) #f)) - (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f)) - runner)) - -;; Not part of the specification. FIXME -;; Controls whether a log file is generated. -(define test-log-to-file #t) - -(define (test-runner-simple) - (let ((runner (%test-runner-alloc))) - (test-runner-reset runner) - (test-runner-on-group-begin! runner test-on-group-begin-simple) - (test-runner-on-group-end! runner test-on-group-end-simple) - (test-runner-on-final! runner test-on-final-simple) - (test-runner-on-test-begin! runner test-on-test-begin-simple) - (test-runner-on-test-end! runner test-on-test-end-simple) - (test-runner-on-bad-count! runner test-on-bad-count-simple) - (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) - runner)) - -(cond-expand - (srfi-39 - (define test-runner-current (make-parameter #f)) - (define test-runner-factory (make-parameter test-runner-simple))) - (else - (define %test-runner-current #f) - (define-syntax test-runner-current - (syntax-rules () - ((test-runner-current) - %test-runner-current) - ((test-runner-current runner) - (set! %test-runner-current runner)))) - (define %test-runner-factory test-runner-simple) - (define-syntax test-runner-factory - (syntax-rules () - ((test-runner-factory) - %test-runner-factory) - ((test-runner-factory runner) - (set! %test-runner-factory runner)))))) - -;; A safer wrapper to test-runner-current. -(define (test-runner-get) - (let ((r (test-runner-current))) - (if (not r) - (cond-expand - (srfi-23 (error "test-runner not initialized - test-begin missing?")) - (else #t))) - r)) - -(define (%test-specifier-matches spec runner) - (spec runner)) - -(define (test-runner-create) - ((test-runner-factory))) - -(define (%test-any-specifier-matches list runner) - (let ((result #f)) - (let loop ((l list)) - (cond ((null? l) result) - (else - (if (%test-specifier-matches (car l) runner) - (set! result #t)) - (loop (cdr l))))))) - -;; Returns #f, #t, or 'xfail. -(define (%test-should-execute runner) - (let ((run (%test-runner-run-list runner))) - (cond ((or - (not (or (eqv? run #t) - (%test-any-specifier-matches run runner))) - (%test-any-specifier-matches - (%test-runner-skip-list runner) - runner)) - (test-result-set! runner 'result-kind 'skip) - #f) - ((%test-any-specifier-matches - (%test-runner-fail-list runner) - runner) - (test-result-set! runner 'result-kind 'xfail) - 'xfail) - (else #t)))) - -(define (%test-begin suite-name count) - (if (not (test-runner-current)) - (let ((r (test-runner-create))) - (test-runner-current r) - (test-runner-on-final! r - (let ((old-final (test-runner-on-final r))) - (lambda (r) (old-final r) (test-runner-current #f)))))) - (let ((runner (test-runner-current))) - ((test-runner-on-group-begin runner) runner suite-name count) - (%test-runner-skip-save! runner - (cons (%test-runner-skip-list runner) - (%test-runner-skip-save runner))) - (%test-runner-fail-save! runner - (cons (%test-runner-fail-list runner) - (%test-runner-fail-save runner))) - (%test-runner-count-list! runner - (cons (cons (%test-runner-total-count runner) - count) - (%test-runner-count-list runner))) - (test-runner-group-stack! runner (cons suite-name - (test-runner-group-stack runner))))) -(cond-expand - (kawa - ;; Kawa has test-begin built in, implemented as: - ;; (begin - ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64))) - ;; (%test-begin suite-name [count])) - ;; This puts test-begin but only test-begin in the default environment., - ;; which makes normal test suites loadable without non-portable commands. - ) - (else - (define-syntax test-begin - (syntax-rules () - ((test-begin suite-name) - (%test-begin suite-name #f)) - ((test-begin suite-name count) - (%test-begin suite-name count)))))) - -(define (test-on-group-begin-simple runner suite-name count) - (if (null? (test-runner-group-stack runner)) - (begin - (display "%%%% Starting test ") - (display suite-name) - (if test-log-to-file - (let* ((log-file-name - (if (string? test-log-to-file) test-log-to-file - (string-append suite-name ".log"))) - (log-file - (cond-expand (mzscheme - (open-output-file log-file-name 'truncate/replace)) - (else (open-output-file log-file-name))))) - (display "%%%% Starting test " log-file) - (display suite-name log-file) - (newline log-file) - (test-runner-aux-value! runner log-file) - (display " (Writing full log to \"") - (display log-file-name) - (display "\")"))) - (newline))) - (let ((log (test-runner-aux-value runner))) - (if (output-port? log) - (begin - (display "Group begin: " log) - (display suite-name log) - (newline log)))) - #f) - -(define (test-on-group-end-simple runner) - (let ((log (test-runner-aux-value runner))) - (if (output-port? log) - (begin - (display "Group end: " log) - (display (car (test-runner-group-stack runner)) log) - (newline log)))) - #f) - -(define (%test-on-bad-count-write runner count expected-count port) - (display "*** Total number of tests was " port) - (display count port) - (display " but should be " port) - (display expected-count port) - (display ". ***" port) - (newline port) - (display "*** Discrepancy indicates testsuite error or exceptions. ***" port) - (newline port)) - -(define (test-on-bad-count-simple runner count expected-count) - (%test-on-bad-count-write runner count expected-count (current-output-port)) - (let ((log (test-runner-aux-value runner))) - (if (output-port? log) - (%test-on-bad-count-write runner count expected-count log)))) - -(define (test-on-bad-end-name-simple runner begin-name end-name) - (let ((msg (string-append (%test-format-line runner) "test-end " begin-name - " does not match test-begin " end-name))) - (cond-expand - (srfi-23 (error msg)) - (else (display msg) (newline))))) - - -(define (%test-final-report1 value label port) - (if (> value 0) - (begin - (display label port) - (display value port) - (newline port)))) - -(define (%test-final-report-simple runner port) - (%test-final-report1 (test-runner-pass-count runner) - "# of expected passes " port) - (%test-final-report1 (test-runner-xfail-count runner) - "# of expected failures " port) - (%test-final-report1 (test-runner-xpass-count runner) - "# of unexpected successes " port) - (%test-final-report1 (test-runner-fail-count runner) - "# of unexpected failures " port) - (%test-final-report1 (test-runner-skip-count runner) - "# of skipped tests " port)) - -(define (test-on-final-simple runner) - (%test-final-report-simple runner (current-output-port)) - (let ((log (test-runner-aux-value runner))) - (if (output-port? log) - (%test-final-report-simple runner log)))) - -(define (%test-format-line runner) - (let* ((line-info (test-result-alist runner)) - (source-file (assq 'source-file line-info)) - (source-line (assq 'source-line line-info)) - (file (if source-file (cdr source-file) ""))) - (if source-line - (string-append file ":" - (number->string (cdr source-line)) ": ") - ""))) - -(define (%test-end suite-name line-info) - (let* ((r (test-runner-get)) - (groups (test-runner-group-stack r)) - (line (%test-format-line r))) - (test-result-alist! r line-info) - (if (null? groups) - (let ((msg (string-append line "test-end not in a group"))) - (cond-expand - (srfi-23 (error msg)) - (else (display msg) (newline))))) - (if (and suite-name (not (equal? suite-name (car groups)))) - ((test-runner-on-bad-end-name r) r suite-name (car groups))) - (let* ((count-list (%test-runner-count-list r)) - (expected-count (cdar count-list)) - (saved-count (caar count-list)) - (group-count (- (%test-runner-total-count r) saved-count))) - (if (and expected-count - (not (= expected-count group-count))) - ((test-runner-on-bad-count r) r group-count expected-count)) - ((test-runner-on-group-end r) r) - (test-runner-group-stack! r (cdr (test-runner-group-stack r))) - (%test-runner-skip-list! r (car (%test-runner-skip-save r))) - (%test-runner-skip-save! r (cdr (%test-runner-skip-save r))) - (%test-runner-fail-list! r (car (%test-runner-fail-save r))) - (%test-runner-fail-save! r (cdr (%test-runner-fail-save r))) - (%test-runner-count-list! r (cdr count-list)) - (if (null? (test-runner-group-stack r)) - ((test-runner-on-final r) r))))) - -(define-syntax test-group - (syntax-rules () - ((test-group suite-name . body) - (let ((r (test-runner-current))) - ;; Ideally should also set line-number, if available. - (test-result-alist! r (list (cons 'test-name suite-name))) - (if (%test-should-execute r) - (dynamic-wind - (lambda () (test-begin suite-name)) - (lambda () . body) - (lambda () (test-end suite-name)))))))) - -(define-syntax test-group-with-cleanup - (syntax-rules () - ((test-group-with-cleanup suite-name form cleanup-form) - (test-group suite-name - (dynamic-wind - (lambda () #f) - (lambda () form) - (lambda () cleanup-form)))) - ((test-group-with-cleanup suite-name cleanup-form) - (test-group-with-cleanup suite-name #f cleanup-form)) - ((test-group-with-cleanup suite-name form1 form2 form3 . rest) - (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest)))) - -(define (test-on-test-begin-simple runner) - (let ((log (test-runner-aux-value runner))) - (if (output-port? log) - (let* ((results (test-result-alist runner)) - (source-file (assq 'source-file results)) - (source-line (assq 'source-line results)) - (source-form (assq 'source-form results)) - (test-name (assq 'test-name results))) - (display "Test begin:" log) - (newline log) - (if test-name (%test-write-result1 test-name log)) - (if source-file (%test-write-result1 source-file log)) - (if source-line (%test-write-result1 source-line log)) - (if source-form (%test-write-result1 source-form log)))))) - -(define-syntax test-result-ref - (syntax-rules () - ((test-result-ref runner pname) - (test-result-ref runner pname #f)) - ((test-result-ref runner pname default) - (let ((p (assq pname (test-result-alist runner)))) - (if p (cdr p) default))))) - -(define (test-on-test-end-simple runner) - (let ((log (test-runner-aux-value runner)) - (kind (test-result-ref runner 'result-kind))) - (if (memq kind '(fail xpass)) - (let* ((results (test-result-alist runner)) - (source-file (assq 'source-file results)) - (source-line (assq 'source-line results)) - (test-name (assq 'test-name results))) - (if (or source-file source-line) - (begin - (if source-file (display (cdr source-file))) - (display ":") - (if source-line (display (cdr source-line))) - (display ": "))) - (display (if (eq? kind 'xpass) "XPASS" "FAIL")) - (if test-name - (begin - (display " ") - (display (cdr test-name)))) - (newline))) - (if (output-port? log) - (begin - (display "Test end:" log) - (newline log) - (let loop ((list (test-result-alist runner))) - (if (pair? list) - (let ((pair (car list))) - ;; Write out properties not written out by on-test-begin. - (if (not (memq (car pair) - '(test-name source-file source-line source-form))) - (%test-write-result1 pair log)) - (loop (cdr list))))))))) - -(define (%test-write-result1 pair port) - (display " " port) - (display (car pair) port) - (display ": " port) - (write (cdr pair) port) - (newline port)) - -(define (test-result-set! runner pname value) - (let* ((alist (test-result-alist runner)) - (p (assq pname alist))) - (if p - (set-cdr! p value) - (test-result-alist! runner (cons (cons pname value) alist))))) - -(define (test-result-clear runner) - (test-result-alist! runner '())) - -(define (test-result-remove runner pname) - (let* ((alist (test-result-alist runner)) - (p (assq pname alist))) - (if p - (test-result-alist! runner - (let loop ((r alist)) - (if (eq? r p) (cdr r) - (cons (car r) (loop (cdr r))))))))) - -(define (test-result-kind . rest) - (let ((runner (if (pair? rest) (car rest) (test-runner-current)))) - (test-result-ref runner 'result-kind))) - -(define (test-passed? . rest) - (let ((runner (if (pair? rest) (car rest) (test-runner-get)))) - (memq (test-result-ref runner 'result-kind) '(pass xpass)))) - -(define (%test-report-result) - (let* ((r (test-runner-get)) - (result-kind (test-result-kind r))) - (case result-kind - ((pass) - (test-runner-pass-count! r (+ 1 (test-runner-pass-count r)))) - ((fail) - (test-runner-fail-count! r (+ 1 (test-runner-fail-count r)))) - ((xpass) - (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r)))) - ((xfail) - (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r)))) - (else - (test-runner-skip-count! r (+ 1 (test-runner-skip-count r))))) - (%test-runner-total-count! r (+ 1 (%test-runner-total-count r))) - ((test-runner-on-test-end r) r))) - -(cond-expand - (guile - (define-syntax %test-evaluate-with-catch - (syntax-rules () - ((%test-evaluate-with-catch test-expression) - (catch #t - (lambda () test-expression) - (lambda (key . args) - (test-result-set! (test-runner-current) 'actual-error - (cons key args)) - #f)))))) - (kawa - (define-syntax %test-evaluate-with-catch - (syntax-rules () - ((%test-evaluate-with-catch test-expression) - (try-catch test-expression - (ex - (test-result-set! (test-runner-current) 'actual-error ex) - #f)))))) - (srfi-34 - (define-syntax %test-evaluate-with-catch - (syntax-rules () - ((%test-evaluate-with-catch test-expression) - (guard (err (else #f)) test-expression))))) - (chicken - (define-syntax %test-evaluate-with-catch - (syntax-rules () - ((%test-evaluate-with-catch test-expression) - (condition-case test-expression (ex () #f)))))) - (else - (define-syntax %test-evaluate-with-catch - (syntax-rules () - ((%test-evaluate-with-catch test-expression) - test-expression))))) - -(cond-expand - ((or kawa mzscheme) - (cond-expand - (mzscheme - (define-for-syntax (%test-syntax-file form) - (let ((source (syntax-source form))) - (cond ((string? source) file) - ((path? source) (path->string source)) - (else #f))))) - (kawa - (define (%test-syntax-file form) - (syntax-source form)))) - (define (%test-source-line2 form) - (let* ((line (syntax-line form)) - (file (%test-syntax-file form)) - (line-pair (if line (list (cons 'source-line line)) '()))) - (cons (cons 'source-form (syntax-object->datum form)) - (if file (cons (cons 'source-file file) line-pair) line-pair))))) - (guile-2 - (define (%test-source-line2 form) - (let* ((src-props (syntax-source form)) - (file (and src-props (assq-ref src-props 'filename))) - (line (and src-props (assq-ref src-props 'line))) - (file-alist (if file - `((source-file . ,file)) - '())) - (line-alist (if line - `((source-line . ,(+ line 1))) - '()))) - (datum->syntax (syntax here) - `((source-form . ,(syntax->datum form)) - ,@file-alist - ,@line-alist))))) - (else - (define (%test-source-line2 form) - '()))) - -(define (%test-on-test-begin r) - (%test-should-execute r) - ((test-runner-on-test-begin r) r) - (not (eq? 'skip (test-result-ref r 'result-kind)))) - -(define (%test-on-test-end r result) - (test-result-set! r 'result-kind - (if (eq? (test-result-ref r 'result-kind) 'xfail) - (if result 'xpass 'xfail) - (if result 'pass 'fail)))) - -(define (test-runner-test-name runner) - (test-result-ref runner 'test-name "")) - -(define-syntax %test-comp2body - (syntax-rules () - ((%test-comp2body r comp expected expr) - (let () - (if (%test-on-test-begin r) - (let ((exp expected)) - (test-result-set! r 'expected-value exp) - (let ((res (%test-evaluate-with-catch expr))) - (test-result-set! r 'actual-value res) - (%test-on-test-end r (comp exp res))))) - (%test-report-result))))) - -(define (%test-approximate= error) - (lambda (value expected) - (let ((rval (real-part value)) - (ival (imag-part value)) - (rexp (real-part expected)) - (iexp (imag-part expected))) - (and (>= rval (- rexp error)) - (>= ival (- iexp error)) - (<= rval (+ rexp error)) - (<= ival (+ iexp error)))))) - -(define-syntax %test-comp1body - (syntax-rules () - ((%test-comp1body r expr) - (let () - (if (%test-on-test-begin r) - (let () - (let ((res (%test-evaluate-with-catch expr))) - (test-result-set! r 'actual-value res) - (%test-on-test-end r res)))) - (%test-report-result))))) - -(cond-expand - ((or kawa mzscheme guile-2) - ;; Should be made to work for any Scheme with syntax-case - ;; However, I haven't gotten the quoting working. FIXME. - (define-syntax test-end - (lambda (x) - (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () - (((mac suite-name) line) - (syntax - (%test-end suite-name line))) - (((mac) line) - (syntax - (%test-end #f line)))))) - (define-syntax test-assert - (lambda (x) - (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () - (((mac tname expr) line) - (syntax - (let* ((r (test-runner-get)) - (name tname)) - (test-result-alist! r (cons (cons 'test-name tname) line)) - (%test-comp1body r expr)))) - (((mac expr) line) - (syntax - (let* ((r (test-runner-get))) - (test-result-alist! r line) - (%test-comp1body r expr))))))) - (define (%test-comp2 comp x) - (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) () - (((mac tname expected expr) line comp) - (syntax - (let* ((r (test-runner-get)) - (name tname)) - (test-result-alist! r (cons (cons 'test-name tname) line)) - (%test-comp2body r comp expected expr)))) - (((mac expected expr) line comp) - (syntax - (let* ((r (test-runner-get))) - (test-result-alist! r line) - (%test-comp2body r comp expected expr)))))) - (define-syntax test-eqv - (lambda (x) (%test-comp2 (syntax eqv?) x))) - (define-syntax test-eq - (lambda (x) (%test-comp2 (syntax eq?) x))) - (define-syntax test-equal - (lambda (x) (%test-comp2 (syntax equal?) x))) - (define-syntax test-approximate ;; FIXME - needed for non-Kawa - (lambda (x) - (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () - (((mac tname expected expr error) line) - (syntax - (let* ((r (test-runner-get)) - (name tname)) - (test-result-alist! r (cons (cons 'test-name tname) line)) - (%test-comp2body r (%test-approximate= error) expected expr)))) - (((mac expected expr error) line) - (syntax - (let* ((r (test-runner-get))) - (test-result-alist! r line) - (%test-comp2body r (%test-approximate= error) expected expr)))))))) - (else - (define-syntax test-end - (syntax-rules () - ((test-end) - (%test-end #f '())) - ((test-end suite-name) - (%test-end suite-name '())))) - (define-syntax test-assert - (syntax-rules () - ((test-assert tname test-expression) - (let* ((r (test-runner-get)) - (name tname)) - (test-result-alist! r '((test-name . tname))) - (%test-comp1body r test-expression))) - ((test-assert test-expression) - (let* ((r (test-runner-get))) - (test-result-alist! r '()) - (%test-comp1body r test-expression))))) - (define-syntax %test-comp2 - (syntax-rules () - ((%test-comp2 comp tname expected expr) - (let* ((r (test-runner-get)) - (name tname)) - (test-result-alist! r (list (cons 'test-name tname))) - (%test-comp2body r comp expected expr))) - ((%test-comp2 comp expected expr) - (let* ((r (test-runner-get))) - (test-result-alist! r '()) - (%test-comp2body r comp expected expr))))) - (define-syntax test-equal - (syntax-rules () - ((test-equal . rest) - (%test-comp2 equal? . rest)))) - (define-syntax test-eqv - (syntax-rules () - ((test-eqv . rest) - (%test-comp2 eqv? . rest)))) - (define-syntax test-eq - (syntax-rules () - ((test-eq . rest) - (%test-comp2 eq? . rest)))) - (define-syntax test-approximate - (syntax-rules () - ((test-approximate tname expected expr error) - (%test-comp2 (%test-approximate= error) tname expected expr)) - ((test-approximate expected expr error) - (%test-comp2 (%test-approximate= error) expected expr)))))) - -(cond-expand - (guile - (define-syntax %test-error - (syntax-rules () - ((%test-error r etype expr) - (cond ((%test-on-test-begin r) - (let ((et etype)) - (test-result-set! r 'expected-error et) - (%test-on-test-end r - (catch #t - (lambda () - (test-result-set! r 'actual-value expr) - #f) - (lambda (key . args) - ;; TODO: decide how to specify expected - ;; error types for Guile. - (test-result-set! r 'actual-error - (cons key args)) - #t))) - (%test-report-result)))))))) - (mzscheme - (define-syntax %test-error - (syntax-rules () - ((%test-error r etype expr) - (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t))) - (let () - (test-result-set! r 'actual-value expr) - #f))))))) - (chicken - (define-syntax %test-error - (syntax-rules () - ((%test-error r etype expr) - (%test-comp1body r (condition-case expr (ex () #t))))))) - (kawa - (define-syntax %test-error - (syntax-rules () - ((%test-error r #t expr) - (cond ((%test-on-test-begin r) - (test-result-set! r 'expected-error #t) - (%test-on-test-end r - (try-catch - (let () - (test-result-set! r 'actual-value expr) - #f) - (ex - (test-result-set! r 'actual-error ex) - #t))) - (%test-report-result)))) - ((%test-error r etype expr) - (if (%test-on-test-begin r) - (let ((et etype)) - (test-result-set! r 'expected-error et) - (%test-on-test-end r - (try-catch - (let () - (test-result-set! r 'actual-value expr) - #f) - (ex - (test-result-set! r 'actual-error ex) - (cond ((and (instance? et ) - (gnu.bytecode.ClassType:isSubclass et )) - (instance? ex et)) - (else #t))))) - (%test-report-result))))))) - ((and srfi-34 srfi-35) - (define-syntax %test-error - (syntax-rules () - ((%test-error r etype expr) - (%test-comp1body r (guard (ex ((condition-type? etype) - (and (condition? ex) (condition-has-type? ex etype))) - ((procedure? etype) - (etype ex)) - ((equal? etype #t) - #t) - (else #t)) - expr #f)))))) - (srfi-34 - (define-syntax %test-error - (syntax-rules () - ((%test-error r etype expr) - (%test-comp1body r (guard (ex (else #t)) expr #f)))))) - (else - (define-syntax %test-error - (syntax-rules () - ((%test-error r etype expr) - (begin - ((test-runner-on-test-begin r) r) - (test-result-set! r 'result-kind 'skip) - (%test-report-result))))))) - -(cond-expand - ((or kawa mzscheme guile-2) - - (define-syntax test-error - (lambda (x) - (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () - (((mac tname etype expr) line) - (syntax - (let* ((r (test-runner-get)) - (name tname)) - (test-result-alist! r (cons (cons 'test-name tname) line)) - (%test-error r etype expr)))) - (((mac etype expr) line) - (syntax - (let* ((r (test-runner-get))) - (test-result-alist! r line) - (%test-error r etype expr)))) - (((mac expr) line) - (syntax - (let* ((r (test-runner-get))) - (test-result-alist! r line) - (%test-error r #t expr)))))))) - (else - (define-syntax test-error - (syntax-rules () - ((test-error name etype expr) - (let ((r (test-runner-get))) - (test-result-alist! r `((test-name . ,name))) - (%test-error r etype expr))) - ((test-error etype expr) - (let ((r (test-runner-get))) - (test-result-alist! r '()) - (%test-error r etype expr))) - ((test-error expr) - (let ((r (test-runner-get))) - (test-result-alist! r '()) - (%test-error r #t expr))))))) - -(define (test-apply first . rest) - (if (test-runner? first) - (test-with-runner first (apply test-apply rest)) - (let ((r (test-runner-current))) - (if r - (let ((run-list (%test-runner-run-list r))) - (cond ((null? rest) - (%test-runner-run-list! r (reverse run-list)) - (first)) ;; actually apply procedure thunk - (else - (%test-runner-run-list! - r - (if (eq? run-list #t) (list first) (cons first run-list))) - (apply test-apply rest) - (%test-runner-run-list! r run-list)))) - (let ((r (test-runner-create))) - (test-with-runner r (apply test-apply first rest)) - ((test-runner-on-final r) r)))))) - -(define-syntax test-with-runner - (syntax-rules () - ((test-with-runner runner form ...) - (let ((saved-runner (test-runner-current))) - (dynamic-wind - (lambda () (test-runner-current runner)) - (lambda () form ...) - (lambda () (test-runner-current saved-runner))))))) - -;;; Predicates - -(define (%test-match-nth n count) - (let ((i 0)) - (lambda (runner) - (set! i (+ i 1)) - (and (>= i n) (< i (+ n count)))))) - -(define-syntax test-match-nth - (syntax-rules () - ((test-match-nth n) - (test-match-nth n 1)) - ((test-match-nth n count) - (%test-match-nth n count)))) - -(define (%test-match-all . pred-list) - (lambda (runner) - (let ((result #t)) - (let loop ((l pred-list)) - (if (null? l) - result - (begin - (if (not ((car l) runner)) - (set! result #f)) - (loop (cdr l)))))))) - -(define-syntax test-match-all - (syntax-rules () - ((test-match-all pred ...) - (%test-match-all (%test-as-specifier pred) ...)))) - -(define (%test-match-any . pred-list) - (lambda (runner) - (let ((result #f)) - (let loop ((l pred-list)) - (if (null? l) - result - (begin - (if ((car l) runner) - (set! result #t)) - (loop (cdr l)))))))) - -(define-syntax test-match-any - (syntax-rules () - ((test-match-any pred ...) - (%test-match-any (%test-as-specifier pred) ...)))) - -;; Coerce to a predicate function: -(define (%test-as-specifier specifier) - (cond ((procedure? specifier) specifier) - ((integer? specifier) (test-match-nth 1 specifier)) - ((string? specifier) (test-match-name specifier)) - (else - (error "not a valid test specifier")))) - -(define-syntax test-skip - (syntax-rules () - ((test-skip pred ...) - (let ((runner (test-runner-get))) - (%test-runner-skip-list! runner - (cons (test-match-all (%test-as-specifier pred) ...) - (%test-runner-skip-list runner))))))) - -(define-syntax test-expect-fail - (syntax-rules () - ((test-expect-fail pred ...) - (let ((runner (test-runner-get))) - (%test-runner-fail-list! runner - (cons (test-match-all (%test-as-specifier pred) ...) - (%test-runner-fail-list runner))))))) - -(define (test-match-name name) - (lambda (runner) - (equal? name (test-runner-test-name runner)))) - -(define (test-read-eval-string string) - (let* ((port (open-input-string string)) - (form (read port))) - (if (eof-object? (read-char port)) - (cond-expand - (guile (eval form (current-module))) - (else (eval form))) - (cond-expand - (srfi-23 (error "(not at eof)")) - (else "error"))))) - diff --git a/test-suite/tests/srfi-64-test.scm b/test-suite/tests/srfi-64-test.scm index ca0b58943..beb5129b7 100644 --- a/test-suite/tests/srfi-64-test.scm +++ b/test-suite/tests/srfi-64-test.scm @@ -716,7 +716,7 @@ (test-begin "8.6. test-apply") (test-equal "8.6.1. Simple (form 1) test-apply" - '(("w" "p" "v") () () () ("x") (3 0 0 0 1)) + '(("w" "p" "v") () () () () (3 0 0 0 0)) (triv-runner (lambda () (test-begin "a") @@ -733,7 +733,7 @@ (test-assert "v" #t)))) (test-equal "8.6.2. Simple (form 2) test-apply" - '(("w" "p" "v") () () () ("x") (3 0 0 0 1)) + '(("w" "p" "v") () () () () (3 0 0 0 0)) (triv-runner (lambda () (test-begin "a") -- 2.46.0 From debbugs-submit-bounces@debbugs.gnu.org Sun Oct 13 16:10:12 2024 Received: (at 73605) by debbugs.gnu.org; 13 Oct 2024 20:10:12 +0000 Received: from localhost ([127.0.0.1]:57015 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t04uq-0001U4-Gr for submit@debbugs.gnu.org; Sun, 13 Oct 2024 16:10:12 -0400 Received: from eggs.gnu.org ([209.51.188.92]:42322) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t04un-0001Tk-50 for 73605@debbugs.gnu.org; Sun, 13 Oct 2024 16:10:11 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1t04uQ-00055m-TC; Sun, 13 Oct 2024 16:09:46 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:Date:References:In-Reply-To:Subject:To: From; bh=OBVzCy+EpEgQOzuFazZV3O8vImKqQlbRZHKijDef+jQ=; b=O5cTYYSAanCvnEuPqX4e zD495jyp15TFVrNEwTdSn2SoWZ5UY9SwXSKAJQ7NAT2FknuSrJQwgNhl0nGLk4xdjyVN5zNXpVBpC vK7H87ZPAduKslu+T2+mebaXMvIyXhvRD8wfcgQ/JchTl2icZSzXWsR/jPPUACKiDBKtLMioailMF FRCsbs5l4Zl1cKjeMqftFSTGRhyv0JuW81ErjBo6dJ4sqfm9aQoB26GjsyVgyBqKvdg3dliW0fp+h GNz0MVU2oOGYFMmkc/b+CMgPPLYeGFUOWRLVI3fwXLTYMLE8vnwHBWxsPP9YZX5r/uUat+FF6yqE1 lEEHNRBFiSY0hA==; From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Tomas Volf <~@wolfsden.cz> Subject: Re: bug#73605: [PATCH] Replace SRFI-64 with a new implementation. In-Reply-To: <20241002194105.24409-1-~@wolfsden.cz> (Tomas Volf's message of "Wed, 2 Oct 2024 21:27:59 +0200") References: <20241002194105.24409-1-~@wolfsden.cz> Date: Sun, 13 Oct 2024 22:09:36 +0200 Message-ID: <87o73nrchr.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 73605 Cc: Andy Wingo , guile-devel@gnu.org, 73605@debbugs.gnu.org, Rob Browning X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hi Tomas, Tomas Volf <~@wolfsden.cz> skribis: > The bundled (reference) implementation was of somewhat mixed quality and > it failed to follow standard in multiple places. This commit replaces > it with a new one, written from scratch to follow the standard as close > as possible. > > * module/srfi/srfi-64/testing.scm: Delete file. > * module/srfi/srfi-64.scm: Replace with new implementation. > * am/bootstrap.am (srfi/srfi-64.go): Remove extra dependencies. > (NOCOMP_SOURCES): Remove srfi/srfi-64/testing.scm. > * test-suite/tests/srfi-64-test.scm > ("8.6.1. Simple (form 1) test-apply") > ("8.6.2. Simple (form 2) test-apply"): Adjust tests to follow the > specification. Nice work! Andy, Rob: I=E2=80=99m willing to apply this patch as I think it=E2=80=99s = an improvement over the reference implementation that we currently have, and whose weaknesses Tomas described at length in . The fact that this new implementation was successfully tested with the test suite of Guix (probably the largest SRFI-64 user) is also reassuring to me. Everyone, please speak up if you object. If there are no objections within a week or so, I=E2=80=99d like to apply it. Thanks, Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Sun Oct 20 15:24:57 2024 Received: (at 73605-done) by debbugs.gnu.org; 20 Oct 2024 19:24:57 +0000 Received: from localhost ([127.0.0.1]:48575 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t2bXs-0000Jl-Lh for submit@debbugs.gnu.org; Sun, 20 Oct 2024 15:24:56 -0400 Received: from eggs.gnu.org ([209.51.188.92]:43916) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t2bXp-0000JV-Md for 73605-done@debbugs.gnu.org; Sun, 20 Oct 2024 15:24:54 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1t2bXK-0008TL-UK; Sun, 20 Oct 2024 15:24:22 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:Date:References:In-Reply-To:Subject:To: From; bh=GIuKbga+2rH0z5fSKg8OFJYz5IMB5oAy3hPE6UCZdfo=; b=mnNoCSkZxge+vrhEvbsK lqji/qWPMEzamuyg/jzz/86V5zGTO/XWYI29aOzSMK6+mqwYQoDVJ1hl67i+dvSKOOcXxezdFTpQW 05p4mw8/BghhCRseMQO16iR8pFrtEoxt3YE6sOz3U4kMK2hYZZQ5PMLmkjPWsQTVFxjqeSoytZouY 7OsJyVRqCV1yparn99qLltUBjTCzAeAKnwMyFKoHPV21vVJwXipvulA26WmNF+zr6i7VTyByWLy3P Se0eTtFwBHR74SVz2MgJ0bdVP/ALGuwBgtOaUPqC9mj40uWJqhAFn/Ra1ks+p5vUsF3vWf5rupr6D LuOaYNxzcL8DwQ==; From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Tomas Volf <~@wolfsden.cz> Subject: Re: bug#73605: [PATCH] Replace SRFI-64 with a new implementation. In-Reply-To: <87o73nrchr.fsf@gnu.org> ("Ludovic =?utf-8?Q?Court=C3=A8s=22'?= =?utf-8?Q?s?= message of "Sun, 13 Oct 2024 22:09:36 +0200") References: <20241002194105.24409-1-~@wolfsden.cz> <87o73nrchr.fsf@gnu.org> Date: Sun, 20 Oct 2024 21:24:20 +0200 Message-ID: <87a5eylgrf.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 73605-done Cc: Andy Wingo , 73605-done@debbugs.gnu.org, guile-devel@gnu.org, Rob Browning X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hi, Ludovic Court=C3=A8s skribis: > Tomas Volf <~@wolfsden.cz> skribis: > >> The bundled (reference) implementation was of somewhat mixed quality and >> it failed to follow standard in multiple places. This commit replaces >> it with a new one, written from scratch to follow the standard as close >> as possible. >> >> * module/srfi/srfi-64/testing.scm: Delete file. >> * module/srfi/srfi-64.scm: Replace with new implementation. >> * am/bootstrap.am (srfi/srfi-64.go): Remove extra dependencies. >> (NOCOMP_SOURCES): Remove srfi/srfi-64/testing.scm. >> * test-suite/tests/srfi-64-test.scm >> ("8.6.1. Simple (form 1) test-apply") >> ("8.6.2. Simple (form 2) test-apply"): Adjust tests to follow the >> specification. [...] > Everyone, please speak up if you object. If there are no objections > within a week or so, I=E2=80=99d like to apply it. Pushed as ad90f45a8c4fd00add44c214863850a425f787a0, thanks Tomas! Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Sun Oct 20 15:25:54 2024 Received: (at 73605) by debbugs.gnu.org; 20 Oct 2024 19:25:54 +0000 Received: from localhost ([127.0.0.1]:48585 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t2bYo-0000Rs-4M for submit@debbugs.gnu.org; Sun, 20 Oct 2024 15:25:54 -0400 Received: from eggs.gnu.org ([209.51.188.92]:52496) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t2bYn-0000Rb-80 for 73605@debbugs.gnu.org; Sun, 20 Oct 2024 15:25:53 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1t2bYI-0000N2-0L; Sun, 20 Oct 2024 15:25:22 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:Date:References:In-Reply-To:Subject:To: From; bh=hHih5byMoEZ30oQW2y5wneIyhH5dDNRWFriBx+WB+Sg=; b=bkyk03fGzG6ZdDAocxW2 rAf3Ke0Q1uTcDtI/e4keFJP4fDd4jWb1iFIh5MYnRz56j1VZNYMZ/OOcbxahUzTpZZKOj6E0c0xXD 1wV//NHYSC8b6WdZusqnyzPH2hDb0xAmwlV/N9shWR3YuNk9aOo/2NjUPfqld2za49OI2NNBs8SvO aGQdaHTLjeAPOAVjz+nmu3hPnyG8WIBrS9lsvXKz9K7MwvDY3YOrkRyVL4tqyAbva9NZtsDygaF7S La3JAOpj4HtpZ/nT3s3YJTTHYCD+9rCPtetccK02epWsbqf78IskBxzerYzGH6hxIWR/aNvS/wFPv 03pDw/I6hzkewA==; From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Tomas Volf <~@wolfsden.cz> Subject: Re: bug#73605: [PATCH] Replace SRFI-64 with a new implementation. In-Reply-To: <87o73nrchr.fsf@gnu.org> ("Ludovic =?utf-8?Q?Court=C3=A8s=22'?= =?utf-8?Q?s?= message of "Sun, 13 Oct 2024 22:09:36 +0200") References: <20241002194105.24409-1-~@wolfsden.cz> <87o73nrchr.fsf@gnu.org> Date: Sun, 20 Oct 2024 21:25:19 +0200 Message-ID: <875xpmlgps.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 73605 Cc: Andy Wingo , 73605@debbugs.gnu.org, guile-devel@gnu.org, Rob Browning X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Tomas, I leave you the satisfaction of closing all the SRFI-64 bugs. :-) Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Mon Oct 21 13:36:03 2024 Received: (at 73605) by debbugs.gnu.org; 21 Oct 2024 17:36:03 +0000 Received: from localhost ([127.0.0.1]:53214 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t2wK2-0004wK-Ib for submit@debbugs.gnu.org; Mon, 21 Oct 2024 13:36:03 -0400 Received: from mta-06-4.privateemail.com ([198.54.122.146]:61676) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t2wK1-0004vr-2h for 73605@debbugs.gnu.org; Mon, 21 Oct 2024 13:36:01 -0400 Received: from mta-06.privateemail.com (localhost [127.0.0.1]) by mta-06.privateemail.com (Postfix) with ESMTP id 4572818000B8; Mon, 21 Oct 2024 13:35:28 -0400 (EDT) Received: from [192.168.1.16] (unknown [51.154.167.214]) by mta-06.privateemail.com (Postfix) with ESMTPA; Mon, 21 Oct 2024 13:35:25 -0400 (EDT) Content-Type: text/plain; charset=utf-8 Mime-Version: 1.0 (Mac OS X Mail 13.4 \(3608.120.23.2.7\)) Subject: Re: bug#73605: [PATCH] Replace SRFI-64 with a new implementation. From: lloda In-Reply-To: <875xpmlgps.fsf@gnu.org> Date: Mon, 21 Oct 2024 19:35:23 +0200 Content-Transfer-Encoding: quoted-printable Message-Id: <09A9A831-0334-4109-823D-71FF335EBA75@sarc.name> References: <20241002194105.24409-1-~@wolfsden.cz> <87o73nrchr.fsf@gnu.org> <875xpmlgps.fsf@gnu.org> To: 73605@debbugs.gnu.org X-Mailer: Apple Mail (2.3608.120.23.2.7) X-Virus-Scanned: ClamAV using ClamSMTP X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: 73605 Cc: Tomas Volf <~@wolfsden.cz>, =?utf-8?Q?Ludovic_Court=C3=A8s?= X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) I'm pleased to see all these fixes. However, I noticed a few breakages. = They come from relying on undocumented behavior, but only using the = public interface, so others might be affected. I don't propose to patch = them, but perhaps to make a note in NEWS or (for the last two) to add a = paragraph in the manual explaining how to achieve the same goal =E2=80=93 = the reference documentation doesn't have enough examples. * test-begin and test-end now require strings. The old version accepted = symbols. * test-approximate requires real arguments. The old version accepted = complex arguments. * The exported variable test-log-to-file is gone. From debbugs-submit-bounces@debbugs.gnu.org Mon Oct 21 16:16:03 2024 Received: (at 73605) by debbugs.gnu.org; 21 Oct 2024 20:16:03 +0000 Received: from localhost ([127.0.0.1]:53454 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t2yot-0003v6-2K for submit@debbugs.gnu.org; Mon, 21 Oct 2024 16:16:03 -0400 Received: from wolfsden.cz ([37.205.8.62]:48078) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from <~@wolfsden.cz>) id 1t2yop-0003ue-Ir for 73605@debbugs.gnu.org; Mon, 21 Oct 2024 16:16:01 -0400 Received: by wolfsden.cz (Postfix, from userid 104) id 02D5B33023D; Mon, 21 Oct 2024 20:15:31 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=wolfsden.cz; s=mail; t=1729541731; bh=WTbOlzwBgNrHumAsySlOtA50GdyDESoszX8B0YCW6D4=; h=From:To:Cc:Subject:In-Reply-To:References:Date; b=GSRDg/9EK0dc8HLmUpI72REgq4pVM+MGjNuzcpqHGkW6vtHqgnrK8mTGoCtIFxw6H 6TXlZ0UMGwHyqGP6KHrUa3TEfyJ0umFbZPAa0TkEJOJdDbzx8Ky8qV4unrq3gEo5J9 pqBL43l2J6cV1ebeLfVn1F5Io1bPbJIT62OGOjjGE1yhwokVy23hkyMB8LR5GFkRNP DmGru05QEjqNEYYF5in3kBezqCAe8ehjQUKCdrsMpu6RoYKWiea8msoci4tbvemItv TtoiJhljsWEB506Gkey3NSC4hFQR0WnL5fGqJcR4xaOIBoemrbW6Njqt/wLljyWEBE E0X+QrMsO5wYmr9pyYd+iHLtiR6RfJrKQtKblnk+4GWyufNna8pKFhOpUumhm3bujd o9zK3Nk2O6WL1sF9Mo0r9+pk3cGLzS7ttiWkHn8sxGUBeSfxq/DSZUJbgNWHo3ofHw nkjkbT8XDXuLO9Xg1Ot+V5JMeLGPgJsZlaSt8cXhM0Xy/rJwsrVJRj8/bchKfCji4U X37IPzeiVUoeymy5cQIcLzCYdqeKD8/pCCjey5UVi6L/U7VrQiO3l2W0ShhqQ9lqvo 7CqkrlmZ/RbYrTsx83mFm0Faj7iVPtbBfOs5m4Ldn1DEquJ/bDu2OBy/hTPCONdmfH MRosWwCLwfqN6aSUkn/lc3lg= X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on wolfsden X-Spam-Level: X-Spam-Status: No, score=-3.1 required=5.0 tests=ALL_TRUSTED,BAYES_00, DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from localhost (unknown [193.32.127.157]) by wolfsden.cz (Postfix) with ESMTPSA id 61094331023; Mon, 21 Oct 2024 20:15:28 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=wolfsden.cz; s=mail; t=1729541728; bh=WTbOlzwBgNrHumAsySlOtA50GdyDESoszX8B0YCW6D4=; h=From:To:Cc:Subject:In-Reply-To:References:Date; b=VbdFWNzkLSFaKtAeVffv3qeTseRCAAVGVtVNjQ2Ia30Y1gYYaLtGyz45ZiGQq6QCD fqQQhjxNwN/88Jdkqt5NcLeCMHNXQTtscRL+0wgKC5Q7UXNbX0wgPsZx4XQGsrH3t+ DRT1WH7KT6L9BE8UKeM/VBZPbUQsMsBjczTEYDF+D+LWscr+LPi6IUWKYfNR5CatzX gCs2IZd2C6OvRgs02Iuzg5X9OTn5WNVjTJgHzQS+t2RJ7v9mlVQWMHjuBFhvdl1F+d /c3cbCnOVjkxxZ3kynHc2HPU1VvNmCtzkaxw9vBIT2liElT271R+2kArWaNOxEKEUL 6JcWdrtuApxDoh90iWoZ0Ph8AtEfnVhijApra+vC+PihGecdVpZ2WM/Uu4XrV0Rv3c yfseuDjZF/eZB8BORjq+5EI8TkG36XtrtltrI0rBbCscd5guS7TsIcoobF7+loseZK 7/gdHa8uUiEbRw3OJgPux4yJw6E2Kp2ity/EUeb5kxJ3NzK+yT44K76GgaBdgZ7X0z 8bWt43EA6lUcUWQKbW2KG4hpMMgBYO5Ts0FsHoN2jCNKhxnoikmL4LRYNx8z/lLvuq VaM2UqqtktTW9LsCjEuEeEkAgaxlB3dU6J/0DFAeqPx2wY72/dlWlgHRakFFkVg9oO 47lylp/KxIXekQgtSBCP+VKY= From: Tomas Volf <~@wolfsden.cz> To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: bug#73605: [PATCH] Replace SRFI-64 with a new implementation. In-Reply-To: <875xpmlgps.fsf@gnu.org> ("Ludovic =?utf-8?Q?Court=C3=A8s=22'?= =?utf-8?Q?s?= message of "Sun, 20 Oct 2024 21:25:19 +0200") References: <20241002194105.24409-1-~@wolfsden.cz> <87o73nrchr.fsf@gnu.org> <875xpmlgps.fsf@gnu.org> Date: Mon, 21 Oct 2024 22:15:27 +0200 Message-ID: <87bjzd8b6o.fsf@wolfsden.cz> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: 73605 Cc: 73605@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Ludovic Court=C3=A8s writes: > Tomas, I leave you the satisfaction of closing all the SRFI-64 bugs. > :-) Thank you for merging the patch, I am off to close the bug reports :) Tomas =2D-=20 There are only two hard things in Computer Science: cache invalidation, naming things and off-by-one errors. --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQJCBAEBCgAsFiEEt4NJs4wUfTYpiGikL7/ufbZ/wakFAmcWtl8OHH5Ad29sZnNk ZW4uY3oACgkQL7/ufbZ/wam4Rg//Z6AVr2Ebi9dh/9LxxsKnjRypUq90OShStpJB mF/G6JHKEM+hpeSFcAtTub/RD63lZq9ojZhhvmHVep26opQBy0TvPiVUhjLDOZsf 7OKiTPDaVgtlWKOAjmngYRnBuOsQVSIcHAzLYB+CLTwA0c4FTegicQnhg2SPRKsa +wMacx2X0EufBtH80QnM9nKvWKMmzuYljhOGTMaoosj+nO1SaJQblNI1r6yOR2bG GQGWTJ/dwZxRN+7Ck+Bj9+L3jNEXh2gQ7yDwbuNsxnRQuXVXFmXv7JfDDXem3IX+ XUL/wZ6V8UyT9OH9VWzFBGPZFJLjY2fCsJJ9naTJ+6ygTTDssHp6grhoy2f+WZlI coj/vIYghcRlKWdJbqNkVZMnxg3oSk+BWq8quRp2H6QffXrEFGEt93od2bRdfieA ludPQZSq7BKuEI0Du29Kxq4X5pP/oArlWXzEcHdE9uyVQDN+/9p0DQDGCkiOv3E2 GmjUafqo8zisA12V6Fl7DLAxJTCO96OBs34eYptR2VMjnEWK9JqiRZ78O/Jx8xTl hQdlAM5otVaNG7hBISQeOHbLw0dnqs/hFrQvf9MA1hgxQBf50bMxjhx3YR8eCA2c kv8KGGotjFdTAFCSXz3t7BtygM58sLMGu8ypEiUJ8evTXvcOm3fN/2L/RstZORaT mmPmicU= =i/uE -----END PGP SIGNATURE----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Sat Oct 26 09:24:36 2024 Received: (at 73605) by debbugs.gnu.org; 26 Oct 2024 13:24:36 +0000 Received: from localhost ([127.0.0.1]:40894 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t4gmR-0005dl-UV for submit@debbugs.gnu.org; Sat, 26 Oct 2024 09:24:36 -0400 Received: from eggs.gnu.org ([209.51.188.92]:45084) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t4gmP-0005dV-7s for 73605@debbugs.gnu.org; Sat, 26 Oct 2024 09:24:33 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1t4gjf-00043z-7B; Sat, 26 Oct 2024 09:21:43 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:Date:References:In-Reply-To:Subject:To: From; bh=3ZniN36q3uURCv1zvS7gAHhodRWcucKNOy/QbIN+ZIo=; b=qn4Y+FvfwmKEe744UIGt PFDVWeql1kkZQo9IiG2jgd8iES6bmdOfPQLsid+y91uVExdb/K6HYFEUfWYI48N+YiMh4u+98His/ ImQHIaTeYua+RuQ95NcDlTiN8+wInJzpLU76Y9IZmQW64fqzoc4MQPkjznOeGeYcrV1ovUlfaYmYM mCtsNX+kTcxJdOBhHoMbKz7GbSpD4zapCXsF/hn8blS+HycNm+l6M1Z2Qc+6hmD24SzDlO5Od+XW7 4lPafIAi+Cf23dLTXDWWjqE564SvurYcMZAlJuAN9fA8d+nDkbyVQAlkN9DGFQXOezYKoZDloSAFi oNMmfTywhOEYaw==; From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: lloda Subject: Re: bug#73605: [PATCH] Replace SRFI-64 with a new implementation. In-Reply-To: <09A9A831-0334-4109-823D-71FF335EBA75@sarc.name> (lloda@sarc.name's message of "Mon, 21 Oct 2024 19:35:23 +0200") References: <20241002194105.24409-1-~@wolfsden.cz> <87o73nrchr.fsf@gnu.org> <875xpmlgps.fsf@gnu.org> <09A9A831-0334-4109-823D-71FF335EBA75@sarc.name> X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: Quintidi 5 Brumaire an 233 de la =?utf-8?Q?R=C3=A9vo?= =?utf-8?Q?lution=2C?= jour de l'Oie X-PGP-Key-ID: 0x090B11993D9AEBB5 X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5 X-OS: x86_64-pc-linux-gnu Date: Sat, 26 Oct 2024 15:21:40 +0200 Message-ID: <875xpf0zkr.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 73605 Cc: Tomas Volf <~@wolfsden.cz>, 73605@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hi, lloda skribis: > I'm pleased to see all these fixes. However, I noticed a few breakages. T= hey come from relying on undocumented behavior, but only using the public i= nterface, so others might be affected. I don't propose to patch them, but p= erhaps to make a note in NEWS or (for the last two) to add a paragraph in t= he manual explaining how to achieve the same goal =E2=80=93 the reference d= ocumentation doesn't have enough examples. > > * test-begin and test-end now require strings. The old version accepted s= ymbols. > * test-approximate requires real arguments. The old version accepted comp= lex arguments. > * The exported variable test-log-to-file is gone. As discussed on IRC, I think we should consider restoring support for these idioms, whether or not they conform to the reference, in an effort to minimize breakage (especially since this is slated for a point release). WDYT, Tomas? Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Sat Oct 26 10:10:29 2024 Received: (at 73605) by debbugs.gnu.org; 26 Oct 2024 14:10:29 +0000 Received: from localhost ([127.0.0.1]:42189 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t4hUq-00086n-Io for submit@debbugs.gnu.org; Sat, 26 Oct 2024 10:10:28 -0400 Received: from wolfsden.cz ([37.205.8.62]:43672) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from <~@wolfsden.cz>) id 1t4hUm-00086a-R6 for 73605@debbugs.gnu.org; Sat, 26 Oct 2024 10:10:26 -0400 Received: by wolfsden.cz (Postfix, from userid 104) id 9A51333260E; Sat, 26 Oct 2024 14:09:49 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=wolfsden.cz; s=mail; t=1729951789; bh=QknA6+qM7KdnI7RQST2egkL4zz+POQLCstTztMJWBgk=; h=From:To:Cc:Subject:In-Reply-To:References:Date; b=ipA8JKQ4mOQmeuKfjqpTNS1AbRW4ztgxy6niRWHImuMpstK9bGIq2eKglbV36lb/n dwqnSt566TNj9WJ8+eScG0uf6NK6SRHXtIiI5F7V0EgKJEckiShU5dPvZ9xsLHz6cn 03fOkwApm6r+jqQ4Fg2+ZVThl/HYY2jFkie19I/RWNgCdA4vkr1xVo/YefmLSO50CS BZO+fXl8gd6UvLdtiZRGeXrDnNAxEIy/WhYC10zsoNLB7EOs8CZe516V5hxR4c1JmP JeDyyx17gf0fPTKQ4a0uK3N7epmJ2V4VK5rFvSfRjbCqG0M+y9f+HhjRiFwlW+/rfK s04iF8OLjDRcN0Mj07qvXQGRWuNyOlX9Vie8FS9Ml1UbTeKd3kAlkxIxHZyQ9D/YPZ dKPIe1jt08D83Bp49VAN0rUXECtR6MBXjauBqs1TgbOFuYZtX8yf16biSDwQFExQtn 5i+eFkjQdZRI2O1Y2+s3bOdgV3XQyqTxFCjhqSudj/17Ij8n/44EMLEwix7HU8B8dS 7LWEsdNgcpszIrXDhn4e9IBeQ5BvtCd4x895QX81qF45v9Lx4JFv8Clj6xiwpuyD+K 16FoKxeKDclHm92dxPZXUYc79wonUCgxCR3tMXAOt+pN+hcspiree81Hw/sfCrROIK H2sUXimDRW8CzCH3jfmPaBqc= X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on wolfsden X-Spam-Level: X-Spam-Status: No, score=-3.1 required=5.0 tests=ALL_TRUSTED,BAYES_00, DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from localhost (unknown [128.0.188.242]) by wolfsden.cz (Postfix) with ESMTPSA id 1139F32B146; Sat, 26 Oct 2024 14:09:49 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=wolfsden.cz; s=mail; t=1729951789; bh=QknA6+qM7KdnI7RQST2egkL4zz+POQLCstTztMJWBgk=; h=From:To:Cc:Subject:In-Reply-To:References:Date; b=ipA8JKQ4mOQmeuKfjqpTNS1AbRW4ztgxy6niRWHImuMpstK9bGIq2eKglbV36lb/n dwqnSt566TNj9WJ8+eScG0uf6NK6SRHXtIiI5F7V0EgKJEckiShU5dPvZ9xsLHz6cn 03fOkwApm6r+jqQ4Fg2+ZVThl/HYY2jFkie19I/RWNgCdA4vkr1xVo/YefmLSO50CS BZO+fXl8gd6UvLdtiZRGeXrDnNAxEIy/WhYC10zsoNLB7EOs8CZe516V5hxR4c1JmP JeDyyx17gf0fPTKQ4a0uK3N7epmJ2V4VK5rFvSfRjbCqG0M+y9f+HhjRiFwlW+/rfK s04iF8OLjDRcN0Mj07qvXQGRWuNyOlX9Vie8FS9Ml1UbTeKd3kAlkxIxHZyQ9D/YPZ dKPIe1jt08D83Bp49VAN0rUXECtR6MBXjauBqs1TgbOFuYZtX8yf16biSDwQFExQtn 5i+eFkjQdZRI2O1Y2+s3bOdgV3XQyqTxFCjhqSudj/17Ij8n/44EMLEwix7HU8B8dS 7LWEsdNgcpszIrXDhn4e9IBeQ5BvtCd4x895QX81qF45v9Lx4JFv8Clj6xiwpuyD+K 16FoKxeKDclHm92dxPZXUYc79wonUCgxCR3tMXAOt+pN+hcspiree81Hw/sfCrROIK H2sUXimDRW8CzCH3jfmPaBqc= From: Tomas Volf <~@wolfsden.cz> To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: bug#73605: [PATCH] Replace SRFI-64 with a new implementation. In-Reply-To: <875xpf0zkr.fsf@gnu.org> ("Ludovic =?utf-8?Q?Court=C3=A8s=22'?= =?utf-8?Q?s?= message of "Sat, 26 Oct 2024 15:21:40 +0200") References: <20241002194105.24409-1-~@wolfsden.cz> <87o73nrchr.fsf@gnu.org> <875xpmlgps.fsf@gnu.org> <09A9A831-0334-4109-823D-71FF335EBA75@sarc.name> <875xpf0zkr.fsf@gnu.org> Date: Sat, 26 Oct 2024 16:09:48 +0200 Message-ID: <874j4zklar.fsf@wolfsden.cz> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: 73605 Cc: lloda , 73605@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Hello, I was thinking about this and then forgot to reply. Sorry about that. Ludovic Court=C3=A8s writes: > Hi, > > lloda skribis: > >> I'm pleased to see all these fixes. However, I noticed a few breakages. = They >> come from relying on undocumented behavior, but only using the public >> interface, so others might be affected. I don't propose to patch them, b= ut >> perhaps to make a note in NEWS or (for the last two) to add a paragraph = in the >> manual explaining how to achieve the same goal =E2=80=93 the reference d= ocumentation >> doesn't have enough examples. >> >> * test-begin and test-end now require strings. The old version accepted = symbols. No problem with this one. Even the specification for test-begin does note: > Rationale: In some ways using symbols would be preferable. However, we > want human-readable names, and standard Scheme does not provide a way > to include spaces or mixed-case text in literal symbols. I am just thinking how to express it neatly, maybe something like the following would work well enough? =2D-8<---------------cut here---------------start------------->8--- =2D-- a/wolfsden/srfi/srfi-64.scm +++ b/wolfsden/srfi/srfi-64.scm @@ -513,6 +513,14 @@ returning new test runner. Defaults to @code{test-run= ner-simple}.") =20 ((test-runner-on-group-begin r) r suite-name count))) =20 +(define (%cmp-group-name a b) + (match (list a b) + (((? string?) (? string?)) + (string=3D? a b)) + (((? symbol?) (? symbol?)) + (eq? a b)) + (_ #f))) + (define* (test-end #:optional suite-name) "Leave the current test group." (let* ((r (test-runner-current)) @@ -520,7 +528,7 @@ returning new test runner. Defaults to @code{test-runn= er-simple}.") =20 (let ((begin-name (car (test-runner-group-stack r))) (end-name suite-name)) =2D (when (and end-name (not (string=3D? begin-name end-name))) + (when (and end-name (not (%cmp-group-name begin-name end-name))) ((test-runner-on-bad-end-name r) r begin-name end-name) (raise-exception (make-bad-end-name begin-name end-name)))) =2D-8<---------------cut here---------------end--------------->8--- Is there more elegant way to express this? >> * test-approximate requires real arguments. The old version accepted com= plex arguments. No objections, since it seems that (imag-part 0) works just fine, I can basically rewrite it to always consider the input complex, and it will work. >> * The exported variable test-log-to-file is gone. I oppose to restoring this one. When you loaded test file into REPL, it used to just litter your file system with random test log files created in whatever the current working directory is. I do not consider that to be a good behavior. > > As discussed on IRC, I think we should consider restoring support for > these idioms, whether or not they conform to the reference, in an effort > to minimize breakage (especially since this is slated for a point > release). > > WDYT, Tomas? Reacted above, I am fine with the first two, oppose to the third one. I will send a patch for the first two today. Tomas =2D-=20 There are only two hard things in Computer Science: cache invalidation, naming things and off-by-one errors. --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQJCBAEBCgAsFiEEt4NJs4wUfTYpiGikL7/ufbZ/wakFAmcc+CwOHH5Ad29sZnNk ZW4uY3oACgkQL7/ufbZ/wanlfg/+M7kRF2eIpWuVw2DbWHjAyb6OcgwLthHPsc2i rMxmHGGz+oGTIQ4cao0Krwc6D70sNNquWZCTm6/MROQi3jBx1yueoLaNRWEpKtIW o6FYIek27W0N9jShR/cP/hufbKiy5rdDsf41xetEcitrBb0gSNzdDKGSAfZzKd5J rRo9N4/Dhw1Ge+PVIUyA4SW5W2RKVr8W1OpuWzRd0brA/p+fCaBcW82Qh2msdBX5 gu3ZjHAfvAJrlWVWwoJw06Q8SPhGKaFPmltoQMNSD5k2sSSX4O9ckffCdGv/olt4 /yyrT3fVT8XEnycTvP0ePEnkRJKHt96UTZYp3GwY6WQavtxHzhGCZkPfyKaYWTh1 mlMpqPJxvKZ6zjl+yeyrXeAOLPbMXboAwkIbmFrYWOmGc+2njblRzm+CyMhg8c6Y jFSTuc9KWKezzCr+tM62mytxbx0q0hNiJkLuZ2ccHfInO9MvdmaTJiVAi2TWABqg +7iEGkA1itrwMfmd/XrL6Lk56XujbFOrRX1nh3o6gYZ//+Y56+hYFx5K3MdqzEft bE651i4AiKY0q2rTLtz5Sl8AcLhLCvbFdvRz2yDedaOsqfZOh1if4ThdQj8GoMdW 9Gw80UtM0+1/AvgFyJkVwK61Ar4nwzMs/izn8xz2C1F9vxjq6am642jp62HqdpF0 0avhgVQ= =JbUL -----END PGP SIGNATURE----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Sat Oct 26 14:10:33 2024 Received: (at 73605) by debbugs.gnu.org; 26 Oct 2024 18:10:33 +0000 Received: from localhost ([127.0.0.1]:42538 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t4lFB-0002PY-12 for submit@debbugs.gnu.org; Sat, 26 Oct 2024 14:10:33 -0400 Received: from mta-06-4.privateemail.com ([198.54.122.146]:40233) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t4lF9-0002PI-CO for 73605@debbugs.gnu.org; Sat, 26 Oct 2024 14:10:32 -0400 Received: from mta-06.privateemail.com (localhost [127.0.0.1]) by mta-06.privateemail.com (Postfix) with ESMTP id 06F2118000B5; Sat, 26 Oct 2024 14:09:52 -0400 (EDT) Received: from [192.168.1.16] (unknown [51.154.167.214]) by mta-06.privateemail.com (Postfix) with ESMTPA; Sat, 26 Oct 2024 14:09:48 -0400 (EDT) Content-Type: text/plain; charset=us-ascii Mime-Version: 1.0 (Mac OS X Mail 13.4 \(3608.120.23.2.7\)) Subject: Re: bug#73605: [PATCH] Replace SRFI-64 with a new implementation. From: lloda In-Reply-To: <874j4zklar.fsf@wolfsden.cz> Date: Sat, 26 Oct 2024 20:09:46 +0200 Content-Transfer-Encoding: quoted-printable Message-Id: <618AA602-0EBB-48E4-8BF2-08787AE63F1A@sarc.name> References: <20241002194105.24409-1-~@wolfsden.cz> <87o73nrchr.fsf@gnu.org> <875xpmlgps.fsf@gnu.org> <09A9A831-0334-4109-823D-71FF335EBA75@sarc.name> <875xpf0zkr.fsf@gnu.org> <874j4zklar.fsf@wolfsden.cz> To: Tomas Volf <~@wolfsden.cz> X-Mailer: Apple Mail (2.3608.120.23.2.7) X-Virus-Scanned: ClamAV using ClamSMTP X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: 73605 Cc: =?utf-8?Q?Ludovic_Court=C3=A8s?= , 73605@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) > On 26 Oct 2024, at 16:09, Tomas Volf <~@wolfsden.cz> wrote: >>> * test-approximate requires real arguments. The old version accepted = complex arguments. >=20 > No objections, since it seems that (imag-part 0) works just fine, I = can > basically rewrite it to always consider the input complex, and it will > work. I think just changing within-epsilon to check (<=3D (magnitude (- = expected value)) epsilon) would work. While looking at this I noticed that 1) the default test runner doesn't = print either the computed error or the specified error and 2) = test-approximate doesn't store the computed error in the test result (it = does store the specified error). This makes it difficult for a custom test runner to print these things. = I think test-approximate should store the computed error and also that = these properties should be documented, so user-defined test routines (to = compare other types) can use them as well.=20 >>> * The exported variable test-log-to-file is gone. >=20 > I oppose to restoring this one. When you loaded test file into REPL, = it > used to just litter your file system with random test log files = created > in whatever the current working directory is. I do not consider that = to > be a good behavior. I don't think the variable should be restored. I also think that if the = option were to be offered in a different way, not writing files is the = better default. However, users who relied on the variable should not = lose functionality. Perhaps add an argument to the default runner? Regards lloda From unknown Sun Jun 22 22:41:32 2025 Received: (at fakecontrol) by fakecontrolmessage; To: internal_control@debbugs.gnu.org From: Debbugs Internal Request Subject: Internal Control Message-Id: bug archived. Date: Sun, 24 Nov 2024 12:24:06 +0000 User-Agent: Fakemail v42.6.9 # This is a fake control message. # # The action: # bug archived. thanks # This fakemail brought to you by your local debbugs # administrator