Fortran: update DATE_AND_TIME intrinsic for Fortran 2018 [PR96580]

Message ID trinity-6dbf6f4f-922c-4228-a34b-1b17489db6cd-1702923119190@3c-app-gmx-bs40
State Not Applicable
Headers
Series Fortran: update DATE_AND_TIME intrinsic for Fortran 2018 [PR96580] |

Checks

Context Check Description
snail/gcc-patch-check fail Git am fail log

Commit Message

Harald Anlauf Dec. 18, 2023, 6:11 p.m. UTC
  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
  

Comments

Steve Kargl Dec. 18, 2023, 7:25 p.m. UTC | #1
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.
  

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

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 3b1a0f9f4f4..b91a743be42 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -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;
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index d4dd47fef0f..2c37cf4286a 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -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}:
diff --git a/gcc/testsuite/gfortran.dg/date_and_time_2.f90 b/gcc/testsuite/gfortran.dg/date_and_time_2.f90
new file mode 100644
index 00000000000..663611a3ec3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/date_and_time_2.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/date_and_time_3.f90 b/gcc/testsuite/gfortran.dg/date_and_time_3.f90
new file mode 100644
index 00000000000..020266d87e9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/date_and_time_3.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/date_and_time_4.f90 b/gcc/testsuite/gfortran.dg/date_and_time_4.f90
new file mode 100644
index 00000000000..6039c85ecb2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/date_and_time_4.f90
@@ -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
diff --git a/libgfortran/intrinsics/date_and_time.c b/libgfortran/intrinsics/date_and_time.c
index 681a815b741..929bbdc41be 100644
--- a/libgfortran/intrinsics/date_and_time.c
+++ b/libgfortran/intrinsics/date_and_time.c
@@ -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