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.
* doc/ref/srfi-modules.texi (SRFI-19 Date to string): Mention ISO-8601
in description for ~V.
---
doc/ref/srfi-modules.texi | 4 +--
module/srfi/srfi-19.scm | 24 +++++++++++++-
test-suite/tests/srfi-19.test | 60 +++++++++++++++++++++++++++++++++--
3 files changed, 83 insertions(+), 5 deletions(-)
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index f072e6c3f..0b663902e 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -2864,8 +2864,8 @@ with locale decimal point, eg.@: @samp{5.2}
@item @nicode{~T} @tab time, 24 hour clock, @samp{~H:~M:~S}
@item @nicode{~U} @tab week of year, Sunday first day of week,
@samp{00} to @samp{52}
-@item @nicode{~V} @tab week of year, Monday first day of week,
-@samp{01} to @samp{53}
+@item @nicode{~V} @tab ISO 8601 week number of the year,
+Monday first day of week, @samp{01} to @samp{53}
@item @nicode{~w} @tab day of week, 0 for Sunday, @samp{0} to @samp{6}
@item @nicode{~W} @tab week of year, Monday first day of week,
@samp{00} to @samp{52}
diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index d809ac1ec..7ab0ad6dd 100644
--- a/module/srfi/srfi-19.scm
+++ b/module/srfi/srfi-19.scm
@@ -753,6 +753,28 @@
(days-before-first-week date day-of-week-starting-week))
7))
+;;; Taken from the reference implementation. Modified to fit Guile's
+;;; code style.
+(define (date-week-number-iso date)
+ "Return a ISO-8601 week number for the @var{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 +1065,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..3cacff669 100644
--- a/test-suite/tests/srfi-19.test
+++ b/test-suite/tests/srfi-19.test
@@ -26,7 +26,8 @@
#:use-module (test-suite lib)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
- #:use-module (ice-9 format))
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match))
;; Make sure we use the default locale.
(when (defined? 'setlocale)
@@ -412,7 +413,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 (match-lambda
+ ((y m d)
+ (date->string (make-date 0 0 0 0 d m y 0)
+ "~V")))))
+ ;; The test cases are taken from the test suite for the reference
+ ;; implementation.
+ (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.47.1
