From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Tomas Volf <~@wolfsden.cz> Newsgroups: gmane.lisp.guile.bugs Subject: bug#74841: [PATCH] srfi-19: Fix ~V converter in date->string. Date: Thu, 12 Dec 2024 22:03:21 +0100 Message-ID: <20241212210322.32016-2-~@wolfsden.cz> Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="29197"; mail-complaints-to="usenet@ciao.gmane.io" Cc: Tomas Volf <~@wolfsden.cz> To: 74841@debbugs.gnu.org Original-X-From: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Thu Dec 12 22:05:41 2024 Return-path: Envelope-to: guile-bugs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1tLqNQ-0007Rc-0m for guile-bugs@m.gmane-mx.org; Thu, 12 Dec 2024 22:05:40 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1tLqN1-0004P4-QI; Thu, 12 Dec 2024 16:05:19 -0500 Original-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 ) id 1tLqMp-0004Jw-OM for bug-guile@gnu.org; Thu, 12 Dec 2024 16:05:04 -0500 Original-Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1tLqMp-0006bE-Dg for bug-guile@gnu.org; Thu, 12 Dec 2024 16:05:03 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:Date:From:To:Subject; bh=dz/A5TaqWlP0kod1if8oJ68Yhrg24SHpdsYX3Jkzw84=; b=Rl6ccWd5viZTuWNDsvztwN2M9de1MA50EBjLjzlZmWUYdC6B1H+e0nOy91oPQtE65Kbn7D6KMsJ1YCFyaEZ9cm4afpO7c0KVwevjwe0kV6IqyQ6tYAOEtvXjrcapNTSJNBQlXJoYHaejwlxGDqJmK9V2opqR4KUeyvMzwHpAbFsY1UxQeX986cSgh4wBeRx6vcbYMHUuRU2uD+bDA2Y/LoEcvlAEBo9X/R0KvDlOBYn7lgpGbDZA/L84j9plDRGzQZL0mXBs5OtPH9+XeMKPfFzdQ1QVrBJV+uUBnX6aeT63AXPMlGWH9uhIAW2QC+XV86xF7CGaWpbUicegBunGWg==; Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1tLqMo-0000j0-NM for bug-guile@gnu.org; Thu, 12 Dec 2024 16:05:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Tomas Volf <~@wolfsden.cz> Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Thu, 12 Dec 2024 21:05:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 74841 X-GNU-PR-Package: guile X-GNU-PR-Keywords: patch X-Debbugs-Original-To: bug-guile@gnu.org Original-Received: via spool by submit@debbugs.gnu.org id=B.17340374462682 (code B ref -1); Thu, 12 Dec 2024 21:05:02 +0000 Original-Received: (at submit) by debbugs.gnu.org; 12 Dec 2024 21:04:06 +0000 Original-Received: from localhost ([127.0.0.1]:40585 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tLqLn-0000gn-TU for submit@debbugs.gnu.org; Thu, 12 Dec 2024 16:04:05 -0500 Original-Received: from lists.gnu.org ([209.51.188.17]:35496) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from <~@wolfsden.cz>) id 1tLqLj-0000ga-Fo for submit@debbugs.gnu.org; Thu, 12 Dec 2024 16:03:58 -0500 Original-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 1tLqLi-00048o-2e for bug-guile@gnu.org; Thu, 12 Dec 2024 16:03:54 -0500 Original-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 1tLqLf-0005R6-OA for bug-guile@gnu.org; Thu, 12 Dec 2024 16:03:53 -0500 Original-Received: by wolfsden.cz (Postfix, from userid 104) id C658235B32C; Thu, 12 Dec 2024 21:03:48 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=wolfsden.cz; s=mail; t=1734037428; bh=uuodW7FBdAEGpBSqznpZU8i1BVZtibZR0LZPPlZv57M=; h=From:To:Cc:Subject:Date; b=jMTkzrZI/Q1IJ1l+CD0vK/jWPAX9Zi6kHADR98f+a/bHuq86W4MFPhV3oOPD3wTKU 2MouY2Y0N2AAAUQeVpzl3a25rqRX/ZXioC1sEZqZYnTxIv5waBDDrjN8RD5IrdHXo7 NI/PCNxt+0wiVhZEQetiH1IJ67D8eUe9v5Fqt3TKpxatQRJ77OhZS7B8dE8d063iIx Mod5R/tFkY3oQpxDtFRqB7y0dRhFHwLSWkT4AdnHDRdocHyLLqvuWUPf4SNb+aX4E1 5EAfAhbYr5dTagsZZhWKb+Lz1CNsf4FpffrABAh16dUMAcgTHnG76KG4dNOPa8MyPF hx/W7QK3n/IdRP4FFTzWMryO91W52aB8z8B5Jgyqee2WJfme056BpoRMa7Dstk99gN NysDoSETCjfWcDh88ucE2l+qy1xwqj61mcN0XcPpL2fSJm0MWgdjeDH0xP87oYN34P 3TgyucOJaRX56i/Ai3v6KkiboiyHr6i1kLR9yAvf2N2e9OXgsKQcVUEDnj/dMevDj2 Xjjb80+7Uy+W1yjoIYvJvDa0p0/kkbYiSJF3tXurWSGj8XWGDLLPB0sFt762pMYkQK 4pcckTucCLhhY/bzF13LMf7Pg9vNSbZ4YwlMBdmc8sGtSY1bH1NpXq0WR+9Dipfpvv C1lQSRMT3juallmzIj4Ybp1Y= Original-Received: from localhost (unknown [128.0.188.242]) by wolfsden.cz (Postfix) with ESMTPSA id 3E08B35C29B; Thu, 12 Dec 2024 21:03:48 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=wolfsden.cz; s=mail; t=1734037428; bh=uuodW7FBdAEGpBSqznpZU8i1BVZtibZR0LZPPlZv57M=; h=From:To:Cc:Subject:Date; b=jMTkzrZI/Q1IJ1l+CD0vK/jWPAX9Zi6kHADR98f+a/bHuq86W4MFPhV3oOPD3wTKU 2MouY2Y0N2AAAUQeVpzl3a25rqRX/ZXioC1sEZqZYnTxIv5waBDDrjN8RD5IrdHXo7 NI/PCNxt+0wiVhZEQetiH1IJ67D8eUe9v5Fqt3TKpxatQRJ77OhZS7B8dE8d063iIx Mod5R/tFkY3oQpxDtFRqB7y0dRhFHwLSWkT4AdnHDRdocHyLLqvuWUPf4SNb+aX4E1 5EAfAhbYr5dTagsZZhWKb+Lz1CNsf4FpffrABAh16dUMAcgTHnG76KG4dNOPa8MyPF hx/W7QK3n/IdRP4FFTzWMryO91W52aB8z8B5Jgyqee2WJfme056BpoRMa7Dstk99gN NysDoSETCjfWcDh88ucE2l+qy1xwqj61mcN0XcPpL2fSJm0MWgdjeDH0xP87oYN34P 3TgyucOJaRX56i/Ai3v6KkiboiyHr6i1kLR9yAvf2N2e9OXgsKQcVUEDnj/dMevDj2 Xjjb80+7Uy+W1yjoIYvJvDa0p0/kkbYiSJF3tXurWSGj8XWGDLLPB0sFt762pMYkQK 4pcckTucCLhhY/bzF13LMf7Pg9vNSbZ4YwlMBdmc8sGtSY1bH1NpXq0WR+9Dipfpvv C1lQSRMT3juallmzIj4Ybp1Y= X-Mailer: git-send-email 2.46.0 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_RPBL_BLOCKED=0.001, RCVD_IN_VALIDITY_SAFE_BLOCKED=0.001, SPF_HELO_PASS=-0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Original-Sender: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.lisp.guile.bugs:11119 Archived-At: The ~V is supposed to print ISO week number, not a week number. This commit fixes that. * module/srfi/srfi-19.scm (date-week-number-iso): New procedure taken from the reference implementation. (directives)<#\V>: Use it. * test-suite/tests/srfi-19.test ("date->string ~V"): Add tests taken from the reference test suite. --- module/srfi/srfi-19.scm | 21 ++++++++++++- test-suite/tests/srfi-19.test | 57 ++++++++++++++++++++++++++++++++++- 2 files changed, 76 insertions(+), 2 deletions(-) diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index d809ac1ec..77be57a0e 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -753,6 +753,25 @@ (days-before-first-week date day-of-week-starting-week)) 7)) +(define (date-week-number-iso date) + ;; The week with the year's first Thursday is week 01. + (let* ((first-day-of-the-week (week-day 1 1 (date-year date))) + (offset (if (> first-day-of-the-week 4) 0 1)) + ;; -2: decrement one day to compensate 1-origin of date-year-day, + ;; and decrement one more day for Sunday belongs to the previous week. + (w (+ (floor-quotient (+ (date-year-day date) first-day-of-the-week -2) + 7) + offset))) + (cond ((zero? w) + ;; date belongs to the last week of the previous year + (date-week-number-iso (make-date 0 0 0 0 31 12 + (- (date-year date) 1) 0))) + ((and (= w 53) + (<= (week-day 1 1 (+ (date-year date) 1)) 4)) + ;; date belongs to the first week of the next year + 1) + (else w)))) + (define (current-date . tz-offset) (let ((time (current-time time-utc))) (time-utc->date @@ -1043,7 +1062,7 @@ (display (padding (date-week-number date 0) #\0 2) port)))) (cons #\V (lambda (date pad-with port) - (display (padding (date-week-number date 1) + (display (padding (date-week-number-iso date) #\0 2) port))) (cons #\w (lambda (date pad-with port) (display (date-week-day date) port))) diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index 55eb82320..5e3e1f445 100644 --- a/test-suite/tests/srfi-19.test +++ b/test-suite/tests/srfi-19.test @@ -412,7 +412,62 @@ incomplete numerical tower implementation.)" (with-test-prefix "date-week-number" (pass-if (= 0 (date-week-number (make-date 0 0 0 0 1 1 1984 0) 0))) (pass-if (= 0 (date-week-number (make-date 0 0 0 0 7 1 1984 0) 0))) - (pass-if (= 1 (date-week-number (make-date 0 0 0 0 8 1 1984 0) 0))))) + (pass-if (= 1 (date-week-number (make-date 0 0 0 0 8 1 1984 0) 0)))) + + (let ((convert (λ (lst) + (date->string + (make-date 0 0 0 0 + (caddr lst) (cadr lst) (car lst) + 0) + "~V")))) + (with-test-prefix "date->string ~V" + (pass-if-equal "Thursday, week 53" "53" + (convert '(2020 12 31))) + (pass-if-equal "Friday, week 53 (previous year)" "53" + (convert '(2021 1 1))) + (pass-if-equal "Sunday, week 53 (previous year)" "53" + (convert '(2021 1 3))) + (pass-if-equal "Monday, week 1" "01" + (convert '(2021 1 4))) + + (pass-if-equal "Sunday, week 52" "52" + (convert '(2019 12 29))) + (pass-if-equal "Monday, week 1 (next year)" "01" + (convert '(2019 12 30))) + (pass-if-equal "Tuesday, week 1 (next year)" "01" + (convert '(2019 12 31))) + (pass-if-equal "Wednesday, week 1" "01" + (convert '(2020 1 1))) + + (pass-if-equal "Saturday, week 52" "52" + (convert '(2016 12 31))) + (pass-if-equal "Sunday, week 52 (previous year)" "52" + (convert '(2017 1 1))) + (pass-if-equal "Monday, week 1" "01" + (convert '(2017 1 2))) + (pass-if-equal "Sunday, week 1" "01" + (convert '(2017 1 8))) + (pass-if-equal "Monday, week 2" "02" + (convert '(2017 1 9))) + + (pass-if-equal "Sunday, week 52" "52" + (convert '(2014 12 28))) + (pass-if-equal "Monday, week 1 (next year)" "01" + (convert '(2014 12 29))) + (pass-if-equal "Tuesday, week 1 (next year)" "01" + (convert '(2014 12 30))) + (pass-if-equal "Wednesday, week 1 (next year)" "01" + (convert '(2014 12 31))) + (pass-if-equal "Thursday, week 1" "01" + (convert '(2015 1 1))) + (pass-if-equal "Friday, week 1" "01" + (convert '(2015 1 2))) + (pass-if-equal "Saturday, week 1" "01" + (convert '(2015 1 3))) + (pass-if-equal "Sunday, week 1" "01" + (convert '(2015 1 4))) + (pass-if-equal "Monday, week 2" "02" + (convert '(2015 1 5)))))) ;; Local Variables: -- 2.46.0