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.

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 3b1a0f9f4f4fc455ff0363353f2d93dc632cbaa4..b91a743be4287a9f4534f3cd1de542d667373abb 100644 (file)
--- 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 d4dd47fef0ff28107a9ccba201c4b773a50f38fb..2c37cf4286a2bcc48d2ff77f829918d9ccafea28 100644 (file)
--- 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 (file)
index 0000000..663611a
--- /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 (file)
index 0000000..020266d
--- /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 (file)
index 0000000..6039c85
--- /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 681a815b741029e180b7686abebd8f5454b8b471..929bbdc41be0b5c2d57cbba7c87688aa4baf905b 100644 (file)
--- 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 ();
     }