Dear all,
starting with Fortran 2018, DATE_AND_TIME allowed a non-default
integer VALUES argument.
While gfortran accepts this silently, this failed at runtime
because the library implementation beyond kind=4 and kind=8
was missing.
Futhermore, the standard effectively requires that the integer
kind is at least 2. The attached patch adds several checks,
plus adds checking for the array size to be sufficient, extends
the implementation to the remaining kinds, and corrects several
issues in the related documentation.
Regtested on x86_64-pc-linux-gnu. OK for mainline?
Thanks,
Harald
On Mon, Dec 18, 2023 at 07:11:59PM +0100, Harald Anlauf wrote:
> Dear all,
>
> starting with Fortran 2018, DATE_AND_TIME allowed a non-default
> integer VALUES argument.
>
> While gfortran accepts this silently, this failed at runtime
> because the library implementation beyond kind=4 and kind=8
> was missing.
>
> Futhermore, the standard effectively requires that the integer
> kind is at least 2. The attached patch adds several checks,
> plus adds checking for the array size to be sufficient, extends
> the implementation to the remaining kinds, and corrects several
> issues in the related documentation.
>
> Regtested on x86_64-pc-linux-gnu. OK for mainline?
>
Yes. Thanks for the patch.
From 1850bb6cbae7229e2c26e66a0a621817339f85e9 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Mon, 18 Dec 2023 18:59:02 +0100
Subject: [PATCH] Fortran: update DATE_AND_TIME intrinsic for Fortran 2018
[PR96580]
Fortran 2018 allows a non-default integer kind for its VALUES argument if
it has a decimal exponent range of at least four. Update checks, library
implementation and documentation.
gcc/fortran/ChangeLog:
PR fortran/96580
* check.cc (array_size_check): New helper function.
(gfc_check_date_and_time): Use it for checking minimum size of
VALUES argument. Update kind check to Fortran 2018.
* intrinsic.texi: Fix documentation of DATE_AND_TIME.
libgfortran/ChangeLog:
PR fortran/96580
* intrinsics/date_and_time.c (date_and_time): Handle VALUES argument
for kind=2 and kind=16 (if available).
gcc/testsuite/ChangeLog:
PR fortran/96580
* gfortran.dg/date_and_time_2.f90: New test.
* gfortran.dg/date_and_time_3.f90: New test.
* gfortran.dg/date_and_time_4.f90: New test.
---
gcc/fortran/check.cc | 48 +++++++++++++++++++
gcc/fortran/intrinsic.texi | 39 +++++++--------
gcc/testsuite/gfortran.dg/date_and_time_2.f90 | 21 ++++++++
gcc/testsuite/gfortran.dg/date_and_time_3.f90 | 29 +++++++++++
gcc/testsuite/gfortran.dg/date_and_time_4.f90 | 30 ++++++++++++
libgfortran/intrinsics/date_and_time.c | 32 +++++++++++--
6 files changed, 177 insertions(+), 22 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/date_and_time_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/date_and_time_3.f90
create mode 100644 gcc/testsuite/gfortran.dg/date_and_time_4.f90
@@ -1251,6 +1251,33 @@ gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
}
}
+/* Check size of an array argument against a required size.
+ Returns true if the requirement is satisfied or if the size cannot be
+ determined, otherwise return false and raise a gfc_error */
+
+static bool
+array_size_check (gfc_expr *a, int n, long size_min)
+{
+ bool ok = true;
+ mpz_t size;
+
+ if (gfc_array_size (a, &size))
+ {
+ HOST_WIDE_INT sz = gfc_mpz_get_hwi (size);
+ if (size_min >= 0 && sz < size_min)
+ {
+ gfc_error ("Size of %qs argument of %qs intrinsic at %L "
+ "too small (%wd/%ld)",
+ gfc_current_intrinsic_arg[n]->name,
+ gfc_current_intrinsic, &a->where, sz, size_min);
+ ok = false;
+ }
+ mpz_clear (size);
+ }
+
+ return ok;
+}
+
/***** Check functions *****/
@@ -6539,6 +6566,27 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
return false;
if (!variable_check (values, 3, false))
return false;
+ if (!array_size_check (values, 3, 8))
+ return false;
+
+ if (values->ts.kind != gfc_default_integer_kind
+ && !gfc_notify_std (GFC_STD_F2018, "VALUES argument of "
+ "DATE_AND_TIME at %L has non-default kind",
+ &values->where))
+ return false;
+
+ /* F2018:16.9.59 DATE_AND_TIME
+ "VALUES shall be a rank-one array of type integer
+ with a decimal exponent range of at least four."
+ This is a hard limit also required by the implementation in
+ libgfortran. */
+ if (values->ts.kind < 2)
+ {
+ gfc_error ("VALUES argument of DATE_AND_TIME at %L must have "
+ "a decimal exponent range of at least four",
+ &values->where);
+ return false;
+ }
}
return true;
@@ -4729,22 +4729,22 @@ end program test_ctime
@item @emph{Description}:
@code{DATE_AND_TIME(DATE, TIME, ZONE, VALUES)} gets the corresponding date and
time information from the real-time system clock. @var{DATE} is
-@code{INTENT(OUT)} and has form ccyymmdd. @var{TIME} is @code{INTENT(OUT)} and
-has form hhmmss.sss. @var{ZONE} is @code{INTENT(OUT)} and has form (+-)hhmm,
-representing the difference with respect to Coordinated Universal Time (UTC).
-Unavailable time and date parameters return blanks.
+@code{INTENT(OUT)} and of the form ccyymmdd. @var{TIME} is @code{INTENT(OUT)}
+and of the form hhmmss.sss. @var{ZONE} is @code{INTENT(OUT)} and of the form
+(+-)hhmm, representing the difference with respect to Coordinated Universal
+Time (UTC). Unavailable time and date parameters return blanks.
@var{VALUES} is @code{INTENT(OUT)} and provides the following:
@multitable @columnfractions .15 .70
-@item @code{VALUE(1)}: @tab The year
-@item @code{VALUE(2)}: @tab The month
-@item @code{VALUE(3)}: @tab The day of the month
-@item @code{VALUE(4)}: @tab Time difference with UTC in minutes
-@item @code{VALUE(5)}: @tab The hour of the day
-@item @code{VALUE(6)}: @tab The minutes of the hour
-@item @code{VALUE(7)}: @tab The seconds of the minute
-@item @code{VALUE(8)}: @tab The milliseconds of the second
+@item @code{VALUES(1)}: @tab The year, including the century
+@item @code{VALUES(2)}: @tab The month of the year
+@item @code{VALUES(3)}: @tab The day of the month
+@item @code{VALUES(4)}: @tab The time difference from UTC in minutes
+@item @code{VALUES(5)}: @tab The hour of the day
+@item @code{VALUES(6)}: @tab The minutes of the hour
+@item @code{VALUES(7)}: @tab The seconds of the minute
+@item @code{VALUES(8)}: @tab The milliseconds of the second
@end multitable
@item @emph{Standard}:
@@ -4758,13 +4758,14 @@ Subroutine
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{DATE} @tab (Optional) The type shall be @code{CHARACTER(LEN=8)}
-or larger, and of default kind.
-@item @var{TIME} @tab (Optional) The type shall be @code{CHARACTER(LEN=10)}
-or larger, and of default kind.
-@item @var{ZONE} @tab (Optional) The type shall be @code{CHARACTER(LEN=5)}
-or larger, and of default kind.
-@item @var{VALUES}@tab (Optional) The type shall be @code{INTEGER(8)}.
+@item @var{DATE} @tab (Optional) Scalar of type default @code{CHARACTER}.
+Recommended length is 8 or larger.
+@item @var{TIME} @tab (Optional) Scalar of type default @code{CHARACTER}.
+Recommended length is 10 or larger.
+@item @var{ZONE} @tab (Optional) Scalar of type default @code{CHARACTER}.
+Recommended length is 5 or larger.
+@item @var{VALUES}@tab (Optional) Rank-1 array of type @code{INTEGER} with
+a decimal exponent range of at least four and array size at least 8.
@end multitable
@item @emph{Return value}:
new file mode 100644
@@ -0,0 +1,21 @@
+! { dg-do compile }
+! { dg-additional-options "-std=f2018" }
+!
+! PR fortran/96580 - constraints on VALUES argument of DATE_AND_TIME intrinsic
+
+program test_time_and_date
+ implicit none
+ integer(1), dimension(8) :: values1
+ integer(2), dimension(8) :: values2
+ integer(4), dimension(8) :: values
+ integer(4), dimension(9) :: values4
+ integer(8), dimension(8) :: values8
+ integer , dimension(7) :: values7
+
+ call date_and_time(VALUES=values1) ! { dg-error "decimal exponent range" }
+ call date_and_time(VALUES=values2)
+ call date_and_time(VALUES=values)
+ call date_and_time(VALUES=values4)
+ call date_and_time(VALUES=values8)
+ call date_and_time(VALUES=values7) ! { dg-error "at .1. too small \\(7/8\\)" }
+end program test_time_and_date
new file mode 100644
@@ -0,0 +1,29 @@
+! { dg-do run }
+! { dg-additional-options "-std=f2018" }
+!
+! PR fortran/96580 - integer kind of VALUES argument of DATE_AND_TIME intrinsic
+
+program test_time_and_date
+ implicit none
+ integer(2), dimension(8) :: values2
+ integer(4), dimension(8) :: values4
+ integer(8), dimension(8) :: values8
+
+ call date_and_time(VALUES=values2)
+ call date_and_time(VALUES=values4)
+ call date_and_time(VALUES=values8)
+
+ ! Check consistency of year and of time difference from UTC
+ if (values2(1) /= -HUGE(0_2) .and. values4(1) /= -HUGE(0_4)) then
+ if (abs (values4(1) - values2(1)) > 1) stop 1
+ end if
+ if (values2(4) /= -HUGE(0_2) .and. values4(4) /= -HUGE(0_4)) then
+ if (values2(4) /= values4(4)) stop 2
+ end if
+ if (values4(1) /= -HUGE(0_4) .and. values8(1) /= -HUGE(0_8)) then
+ if (abs (values8(1) - values4(1)) > 1) stop 3
+ end if
+ if (values4(4) /= -HUGE(0_4) .and. values8(4) /= -HUGE(0_8)) then
+ if (values4(4) /= values8(4)) stop 4
+ end if
+end program test_time_and_date
new file mode 100644
@@ -0,0 +1,30 @@
+! { dg-do run }
+! { dg-additional-options "-std=f2018" }
+! { dg-require-effective-target fortran_integer_16 }
+!
+! PR fortran/96580 - integer kind of VALUES argument of DATE_AND_TIME intrinsic
+
+program test_time_and_date
+ implicit none
+ integer(4), dimension(8) :: values4
+ integer(8), dimension(8) :: values8
+ integer(16),dimension(8) :: values16
+
+ call date_and_time(VALUES=values4)
+ call date_and_time(VALUES=values8)
+ call date_and_time(VALUES=values16)
+
+ ! Check consistency of year and of time difference from UTC
+ if (values16(1) /= -HUGE(0_16) .and. values4(1) /= -HUGE(0_4)) then
+ if (abs (values4(1) - values16(1)) > 1) stop 1
+ end if
+ if (values16(4) /= -HUGE(0_16) .and. values4(4) /= -HUGE(0_4)) then
+ if (values16(4) /= values4(4)) stop 2
+ end if
+ if (values4(1) /= -HUGE(0_4) .and. values8(1) /= -HUGE(0_8)) then
+ if (abs (values8(1) - values4(1)) > 1) stop 3
+ end if
+ if (values4(4) /= -HUGE(0_4) .and. values8(4) /= -HUGE(0_8)) then
+ if (values4(4) /= values8(4)) stop 4
+ end if
+end program test_time_and_date
@@ -209,20 +209,20 @@ date_and_time (char *__date, char *__time, char *__zone,
delta = 1;
if (unlikely (len < VALUES_SIZE))
- runtime_error ("Incorrect extent in VALUE argument to"
+ runtime_error ("Incorrect extent in VALUES argument to"
" DATE_AND_TIME intrinsic: is %ld, should"
" be >=%ld", (long int) len, (long int) VALUES_SIZE);
/* Cope with different type kinds. */
if (elt_size == 4)
- {
+ {
GFC_INTEGER_4 *vptr4 = __values->base_addr;
for (i = 0; i < VALUES_SIZE; i++, vptr4 += delta)
*vptr4 = values[i];
}
else if (elt_size == 8)
- {
+ {
GFC_INTEGER_8 *vptr8 = (GFC_INTEGER_8 *)__values->base_addr;
for (i = 0; i < VALUES_SIZE; i++, vptr8 += delta)
@@ -233,6 +233,32 @@ date_and_time (char *__date, char *__time, char *__zone,
*vptr8 = values[i];
}
}
+ else if (elt_size == 2)
+ {
+ GFC_INTEGER_2 *vptr2 = (GFC_INTEGER_2 *)__values->base_addr;
+
+ for (i = 0; i < VALUES_SIZE; i++, vptr2 += delta)
+ {
+ if (values[i] == - GFC_INTEGER_4_HUGE)
+ *vptr2 = - GFC_INTEGER_2_HUGE;
+ else
+ *vptr2 = (GFC_INTEGER_2) values[i];
+ }
+ }
+#if defined (HAVE_GFC_INTEGER_16)
+ else if (elt_size == 16)
+ {
+ GFC_INTEGER_16 *vptr16 = (GFC_INTEGER_16 *)__values->base_addr;
+
+ for (i = 0; i < VALUES_SIZE; i++, vptr16 += delta)
+ {
+ if (values[i] == - GFC_INTEGER_4_HUGE)
+ *vptr16 = - GFC_INTEGER_16_HUGE;
+ else
+ *vptr16 = values[i];
+ }
+ }
+#endif
else
abort ();
}
--
2.35.3