diff options
| author | Harald Anlauf <anlauf@gmx.de> | 2023-12-18 18:59:02 +0100 |
|---|---|---|
| committer | Harald Anlauf <anlauf@gmx.de> | 2023-12-18 20:32:52 +0100 |
| commit | b77691a90fc8a7e917417ce747bf78669304f951 (patch) | |
| tree | 7a6a27ed6db2d95f978d35dd58107aa204b6a1e4 /libgfortran | |
| parent | f85fdf59c91fe4aa56633347268d144d3e075844 (diff) | |
| download | gcc-b77691a90fc8a7e917417ce747bf78669304f951.zip gcc-b77691a90fc8a7e917417ce747bf78669304f951.tar.gz gcc-b77691a90fc8a7e917417ce747bf78669304f951.tar.bz2 | |
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.
Diffstat (limited to 'libgfortran')
| -rw-r--r-- | libgfortran/intrinsics/date_and_time.c | 32 |
1 files changed, 29 insertions, 3 deletions
diff --git a/libgfortran/intrinsics/date_and_time.c b/libgfortran/intrinsics/date_and_time.c index 681a815..929bbdc 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 (); } |