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