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

