Dear all,
the attached patch is a first attempt to fix some issues with the GNU
intrinsics STAT/LSTAT/FSTAT which are g77 heritage. This patch is
preparatory for dealing with the issue reported in PR82480 in that
the default version of theses intrinsics use INTEGER(KIND=4) results
that may overflow, unless -fdefault-integer-8 is used.
This patch consists of the following parts:
- correct keyword names from g77 to gfortran implementation and manual
- enhance checking of INTENT(OUT) arguments (VALUES, STATUS)
- correct error messages in runtime library
- for simplicity, variables have been consistently renamed in the
present context ("array" -> "values").
- for the INTEGER(KIND=4) versions the STATUS returns ERANGE if
an overflow is encountered.
The latter is certainly debatable, as one of the existing testcases
stat_{1,2}.f90 may fail on systems where e.g. an inode number is larger
than INT32_MAX may occur. Options are to drop the overflow check, or
to run those testcases with additional option -fdefault-integer-8.
Opinions?
Otherwise regtests here on x86_64-pc-linux-gnu without issues.
OK for mainline?
Thanks,
Harald
From 0d283e310b8b4d5bac6a1354168fe3340e89d6d8 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <[email protected]>
Date: Wed, 11 Jun 2025 21:25:09 +0200
Subject: [PATCH] Fortran: various fixes for STAT/LSTAT/FSTAT intrinsics
[PR82480]
The GNU intrinsics STAT/LSTAT/FSTAT were inherited from g77, but changed
the names of some keywords: FILE became NAME, and SARRAY became VALUES,
which are the keywords documented in the gfortran manual.
Adjust code and libgfortran error messages to reflect this change.
Furthermore, add compile-time checking that INTENT(OUT) arguments are
definable, and that array VALUES has at least size 13.
PR fortran/82480
gcc/fortran/ChangeLog:
* check.cc (gfc_check_fstat): Extend checks to INTENT(OUT) arguments.
(gfc_check_fstat_sub): Likewise.
(gfc_check_stat): Likewise.
(gfc_check_stat_sub): Likewise.
libgfortran/ChangeLog:
* intrinsics/stat.c (stat_i4_sub_0): Fix argument names. Rename
SARRAY to VALUES also in error message. Detect integer overflow
assigning any of the stat components to VALUES, and return ERANGE
in STATUS.
(stat_i4_sub): Fix argument names.
(lstat_i4_sub): Likewise.
(stat_i8_sub_0): Likewise.
(stat_i8_sub): Likewise.
(lstat_i8_sub): Likewise.
(stat_i4): Likewise.
(stat_i8): Likewise.
(lstat_i4): Likewise.
(lstat_i8): Likewise.
(fstat_i4_sub): Likewise.
(fstat_i8_sub): Likewise.
(fstat_i4): Likewise.
(fstat_i8): Likewise.
gcc/testsuite/ChangeLog:
* gfortran.dg/stat_3.f90: New test.
---
gcc/fortran/check.cc | 61 +++---
gcc/testsuite/gfortran.dg/stat_3.f90 | 46 +++++
libgfortran/intrinsics/stat.c | 272 +++++++++++++++------------
3 files changed, 226 insertions(+), 153 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/stat_3.f90
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index c8904df3b21..838d523f7c4 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -6507,7 +6507,7 @@ gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_exp
bool
-gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
+gfc_check_fstat (gfc_expr *unit, gfc_expr *values)
{
if (!type_check (unit, 0, BT_INTEGER))
return false;
@@ -6515,11 +6515,17 @@ gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
if (!scalar_check (unit, 0))
return false;
- if (!type_check (array, 1, BT_INTEGER)
+ if (!type_check (values, 1, BT_INTEGER)
|| !kind_value_check (unit, 0, gfc_default_integer_kind))
return false;
- if (!array_check (array, 1))
+ if (!array_check (values, 1))
+ return false;
+
+ if (!variable_check (values, 1, false))
+ return false;
+
+ if (!array_size_check (values, 1, 13))
return false;
return true;
@@ -6527,19 +6533,9 @@ gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
bool
-gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
+gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *values, gfc_expr *status)
{
- if (!type_check (unit, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (unit, 0))
- return false;
-
- if (!type_check (array, 1, BT_INTEGER)
- || !kind_value_check (array, 1, gfc_default_integer_kind))
- return false;
-
- if (!array_check (array, 1))
+ if (!gfc_check_fstat (unit, values))
return false;
if (status == NULL)
@@ -6552,6 +6548,9 @@ gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
if (!scalar_check (status, 2))
return false;
+ if (!variable_check (status, 2, false))
+ return false;
+
return true;
}
@@ -6589,18 +6588,24 @@ gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
bool
-gfc_check_stat (gfc_expr *name, gfc_expr *array)
+gfc_check_stat (gfc_expr *name, gfc_expr *values)
{
if (!type_check (name, 0, BT_CHARACTER))
return false;
if (!kind_value_check (name, 0, gfc_default_character_kind))
return false;
- if (!type_check (array, 1, BT_INTEGER)
- || !kind_value_check (array, 1, gfc_default_integer_kind))
+ if (!type_check (values, 1, BT_INTEGER)
+ || !kind_value_check (values, 1, gfc_default_integer_kind))
return false;
- if (!array_check (array, 1))
+ if (!array_check (values, 1))
+ return false;
+
+ if (!variable_check (values, 1, false))
+ return false;
+
+ if (!array_size_check (values, 1, 13))
return false;
return true;
@@ -6608,30 +6613,24 @@ gfc_check_stat (gfc_expr *name, gfc_expr *array)
bool
-gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
+gfc_check_stat_sub (gfc_expr *name, gfc_expr *values, gfc_expr *status)
{
- if (!type_check (name, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (name, 0, gfc_default_character_kind))
- return false;
-
- if (!type_check (array, 1, BT_INTEGER)
- || !kind_value_check (array, 1, gfc_default_integer_kind))
- return false;
-
- if (!array_check (array, 1))
+ if (!gfc_check_stat (name, values))
return false;
if (status == NULL)
return true;
if (!type_check (status, 2, BT_INTEGER)
- || !kind_value_check (array, 1, gfc_default_integer_kind))
+ || !kind_value_check (status, 2, gfc_default_integer_kind))
return false;
if (!scalar_check (status, 2))
return false;
+ if (!variable_check (status, 2, false))
+ return false;
+
return true;
}
diff --git a/gcc/testsuite/gfortran.dg/stat_3.f90 b/gcc/testsuite/gfortran.dg/stat_3.f90
new file mode 100644
index 00000000000..93ec1836a9a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/stat_3.f90
@@ -0,0 +1,46 @@
+! { dg-do compile }
+! PR fortran/82480 - checking of arguments to STAT/LSTAT/FSTAT
+
+subroutine sub1 ()
+ integer, parameter :: ik = kind(1)
+ integer(ik) :: buff12(12)
+ integer(ik) :: buff13(13)
+ integer(ik) :: unit = 10
+ integer(ik) :: ierr
+ character(len=64) :: name = "/etc/passwd"
+ ierr = stat (name, values= buff12) ! { dg-error "too small" }
+ ierr = stat (name, values= buff13)
+ ierr = lstat (name, values= buff12) ! { dg-error "too small" }
+ ierr = lstat (name, values= buff13)
+ ierr = fstat (unit, values= buff12) ! { dg-error "too small" }
+ ierr = fstat (unit, values= buff13)
+ ierr = stat (name, values=(buff13)) ! { dg-error "must be a variable" }
+ ierr = lstat (name, values=(buff13)) ! { dg-error "must be a variable" }
+ ierr = fstat (unit, values=(buff13)) ! { dg-error "must be a variable" }
+end
+
+subroutine sub2 ()
+ integer, parameter :: ik = kind(1)
+ integer(ik) :: buff12(12)
+ integer(ik), target :: buff13(13) = 0
+ integer(ik) :: unit = 10
+ integer(ik), target :: ierr = 0
+ character(len=64) :: name = "/etc/passwd"
+ integer(ik),pointer :: pbuf(:) => buff13
+ integer(ik),pointer :: perr => ierr
+ call stat (name, status=ierr, values= buff12) ! { dg-error "too small" }
+ call stat (name, status=ierr, values= buff13)
+ call lstat (name, status=ierr, values= buff12) ! { dg-error "too small" }
+ call lstat (name, status=ierr, values= buff13)
+ call fstat (unit, status=ierr, values= buff12) ! { dg-error "too small" }
+ call fstat (unit, status=ierr, values= buff13)
+ call stat (name, status=ierr, values=(buff13)) ! { dg-error "must be a variable" }
+ call lstat (name, status=ierr, values=(buff13)) ! { dg-error "must be a variable" }
+ call fstat (unit, status=ierr, values=(buff13)) ! { dg-error "must be a variable" }
+ call stat (name, status=(ierr),values=buff13) ! { dg-error "must be a variable" }
+ call lstat (name, status=(ierr),values=buff13) ! { dg-error "must be a variable" }
+ call fstat (unit, status=(ierr),values=buff13) ! { dg-error "must be a variable" }
+ call stat (name, status=perr, values= pbuf)
+ call lstat (name, status=perr, values= pbuf)
+ call fstat (unit, status=perr, values= pbuf)
+end
diff --git a/libgfortran/intrinsics/stat.c b/libgfortran/intrinsics/stat.c
index 8d32f223b24..eb2779f887b 100644
--- a/libgfortran/intrinsics/stat.c
+++ b/libgfortran/intrinsics/stat.c
@@ -35,35 +35,36 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#ifdef HAVE_STAT
-/* SUBROUTINE STAT(FILE, SARRAY, STATUS)
+/* SUBROUTINE STAT(NAME, VALUES, STATUS)
CHARACTER(len=*), INTENT(IN) :: FILE
- INTEGER, INTENT(OUT), :: SARRAY(13)
+ INTEGER, INTENT(OUT), :: VALUES(13)
INTEGER, INTENT(OUT), OPTIONAL :: STATUS
- FUNCTION STAT(FILE, SARRAY)
+ FUNCTION STAT(NAME, VALUES)
INTEGER STAT
CHARACTER(len=*), INTENT(IN) :: FILE
- INTEGER, INTENT(OUT), :: SARRAY(13) */
+ INTEGER, INTENT(OUT), :: VALUES(13) */
/*extern void stat_i4_sub_0 (char *, gfc_array_i4 *, GFC_INTEGER_4 *,
gfc_charlen_type, int);
internal_proto(stat_i4_sub_0);*/
static void
-stat_i4_sub_0 (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status,
+stat_i4_sub_0 (char *name, gfc_array_i4 *values, GFC_INTEGER_4 *status,
gfc_charlen_type name_len, int is_lstat __attribute__ ((unused)))
{
int val;
char *str;
struct stat sb;
+ bool ovf = false;
/* If the rank of the array is not 1, abort. */
- if (GFC_DESCRIPTOR_RANK (sarray) != 1)
- runtime_error ("Array rank of SARRAY is not 1.");
+ if (GFC_DESCRIPTOR_RANK (values) != 1)
+ runtime_error ("Array rank of VALUES is not 1.");
/* If the array is too small, abort. */
- if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
- runtime_error ("Array size of SARRAY is too small.");
+ if (GFC_DESCRIPTOR_EXTENT(values,0) < 13)
+ runtime_error ("Array size of VALUES is too small.");
/* Make a null terminated copy of the string. */
str = fc_strdup (name, name_len);
@@ -80,62 +81,75 @@ stat_i4_sub_0 (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status,
if (val == 0)
{
- index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
+ index_type stride = GFC_DESCRIPTOR_STRIDE(values,0);
/* Device ID */
- sarray->base_addr[0 * stride] = sb.st_dev;
+ ovf = INT32_MAX < sb.st_dev;
+ values->base_addr[0 * stride] = sb.st_dev;
/* Inode number */
- sarray->base_addr[1 * stride] = sb.st_ino;
+ ovf |= INT32_MAX < sb.st_ino;
+ values->base_addr[1 * stride] = sb.st_ino;
/* File mode */
- sarray->base_addr[2 * stride] = sb.st_mode;
+ ovf |= INT32_MAX < sb.st_mode;
+ values->base_addr[2 * stride] = sb.st_mode;
/* Number of (hard) links */
- sarray->base_addr[3 * stride] = sb.st_nlink;
+ ovf |= INT32_MAX < sb.st_nlink;
+ values->base_addr[3 * stride] = sb.st_nlink;
/* Owner's uid */
- sarray->base_addr[4 * stride] = sb.st_uid;
+ ovf |= INT32_MAX < sb.st_uid;
+ values->base_addr[4 * stride] = sb.st_uid;
/* Owner's gid */
- sarray->base_addr[5 * stride] = sb.st_gid;
+ ovf |= INT32_MAX < sb.st_gid;
+ values->base_addr[5 * stride] = sb.st_gid;
/* ID of device containing directory entry for file (0 if not available) */
#if HAVE_STRUCT_STAT_ST_RDEV
- sarray->base_addr[6 * stride] = sb.st_rdev;
+ ovf |= INT32_MAX < sb.st_rdev;
+ values->base_addr[6 * stride] = sb.st_rdev;
#else
- sarray->base_addr[6 * stride] = 0;
+ values->base_addr[6 * stride] = 0;
#endif
/* File size (bytes) */
- sarray->base_addr[7 * stride] = sb.st_size;
+ ovf |= INT32_MAX < sb.st_size;
+ values->base_addr[7 * stride] = sb.st_size;
/* Last access time */
- sarray->base_addr[8 * stride] = sb.st_atime;
+ ovf |= INT32_MAX < sb.st_atime;
+ values->base_addr[8 * stride] = sb.st_atime;
/* Last modification time */
- sarray->base_addr[9 * stride] = sb.st_mtime;
+ ovf |= INT32_MAX < sb.st_mtime;
+ values->base_addr[9 * stride] = sb.st_mtime;
/* Last file status change time */
- sarray->base_addr[10 * stride] = sb.st_ctime;
+ ovf |= INT32_MAX < sb.st_ctime;
+ values->base_addr[10 * stride] = sb.st_ctime;
/* Preferred I/O block size (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLKSIZE
- sarray->base_addr[11 * stride] = sb.st_blksize;
+ ovf |= INT32_MAX < sb.st_blksize;
+ values->base_addr[11 * stride] = sb.st_blksize;
#else
- sarray->base_addr[11 * stride] = -1;
+ values->base_addr[11 * stride] = -1;
#endif
/* Number of blocks allocated (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLOCKS
- sarray->base_addr[12 * stride] = sb.st_blocks;
+ ovf |= INT32_MAX < sb.st_blocks;
+ values->base_addr[12 * stride] = sb.st_blocks;
#else
- sarray->base_addr[12 * stride] = -1;
+ values->base_addr[12 * stride] = -1;
#endif
}
if (status != NULL)
- *status = (val == 0) ? 0 : errno;
+ *status = (val == 0) ? (ovf ? ERANGE : 0) : errno;
}
@@ -144,10 +158,10 @@ extern void stat_i4_sub (char *, gfc_array_i4 *, GFC_INTEGER_4 *,
iexport_proto(stat_i4_sub);
void
-stat_i4_sub (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status,
+stat_i4_sub (char *name, gfc_array_i4 *values, GFC_INTEGER_4 *status,
gfc_charlen_type name_len)
{
- stat_i4_sub_0 (name, sarray, status, name_len, 0);
+ stat_i4_sub_0 (name, values, status, name_len, 0);
}
iexport(stat_i4_sub);
@@ -157,17 +171,17 @@ extern void lstat_i4_sub (char *, gfc_array_i4 *, GFC_INTEGER_4 *,
iexport_proto(lstat_i4_sub);
void
-lstat_i4_sub (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status,
+lstat_i4_sub (char *name, gfc_array_i4 *values, GFC_INTEGER_4 *status,
gfc_charlen_type name_len)
{
- stat_i4_sub_0 (name, sarray, status, name_len, 1);
+ stat_i4_sub_0 (name, values, status, name_len, 1);
}
iexport(lstat_i4_sub);
static void
-stat_i8_sub_0 (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status,
+stat_i8_sub_0 (char *name, gfc_array_i8 *values, GFC_INTEGER_8 *status,
gfc_charlen_type name_len, int is_lstat __attribute__ ((unused)))
{
int val;
@@ -175,12 +189,12 @@ stat_i8_sub_0 (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status,
struct stat sb;
/* If the rank of the array is not 1, abort. */
- if (GFC_DESCRIPTOR_RANK (sarray) != 1)
- runtime_error ("Array rank of SARRAY is not 1.");
+ if (GFC_DESCRIPTOR_RANK (values) != 1)
+ runtime_error ("Array rank of VALUES is not 1.");
/* If the array is too small, abort. */
- if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
- runtime_error ("Array size of SARRAY is too small.");
+ if (GFC_DESCRIPTOR_EXTENT(values,0) < 13)
+ runtime_error ("Array size of VALUES is too small.");
/* Make a null terminated copy of the string. */
str = fc_strdup (name, name_len);
@@ -197,57 +211,57 @@ stat_i8_sub_0 (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status,
if (val == 0)
{
- index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
+ index_type stride = GFC_DESCRIPTOR_STRIDE(values,0);
/* Device ID */
- sarray->base_addr[0] = sb.st_dev;
+ values->base_addr[0] = sb.st_dev;
/* Inode number */
- sarray->base_addr[stride] = sb.st_ino;
+ values->base_addr[stride] = sb.st_ino;
/* File mode */
- sarray->base_addr[2 * stride] = sb.st_mode;
+ values->base_addr[2 * stride] = sb.st_mode;
/* Number of (hard) links */
- sarray->base_addr[3 * stride] = sb.st_nlink;
+ values->base_addr[3 * stride] = sb.st_nlink;
/* Owner's uid */
- sarray->base_addr[4 * stride] = sb.st_uid;
+ values->base_addr[4 * stride] = sb.st_uid;
/* Owner's gid */
- sarray->base_addr[5 * stride] = sb.st_gid;
+ values->base_addr[5 * stride] = sb.st_gid;
/* ID of device containing directory entry for file (0 if not available) */
#if HAVE_STRUCT_STAT_ST_RDEV
- sarray->base_addr[6 * stride] = sb.st_rdev;
+ values->base_addr[6 * stride] = sb.st_rdev;
#else
- sarray->base_addr[6 * stride] = 0;
+ values->base_addr[6 * stride] = 0;
#endif
/* File size (bytes) */
- sarray->base_addr[7 * stride] = sb.st_size;
+ values->base_addr[7 * stride] = sb.st_size;
/* Last access time */
- sarray->base_addr[8 * stride] = sb.st_atime;
+ values->base_addr[8 * stride] = sb.st_atime;
/* Last modification time */
- sarray->base_addr[9 * stride] = sb.st_mtime;
+ values->base_addr[9 * stride] = sb.st_mtime;
/* Last file status change time */
- sarray->base_addr[10 * stride] = sb.st_ctime;
+ values->base_addr[10 * stride] = sb.st_ctime;
/* Preferred I/O block size (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLKSIZE
- sarray->base_addr[11 * stride] = sb.st_blksize;
+ values->base_addr[11 * stride] = sb.st_blksize;
#else
- sarray->base_addr[11 * stride] = -1;
+ values->base_addr[11 * stride] = -1;
#endif
/* Number of blocks allocated (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLOCKS
- sarray->base_addr[12 * stride] = sb.st_blocks;
+ values->base_addr[12 * stride] = sb.st_blocks;
#else
- sarray->base_addr[12 * stride] = -1;
+ values->base_addr[12 * stride] = -1;
#endif
}
@@ -261,10 +275,10 @@ extern void stat_i8_sub (char *, gfc_array_i8 *, GFC_INTEGER_8 *,
iexport_proto(stat_i8_sub);
void
-stat_i8_sub (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status,
+stat_i8_sub (char *name, gfc_array_i8 *values, GFC_INTEGER_8 *status,
gfc_charlen_type name_len)
{
- stat_i8_sub_0 (name, sarray, status, name_len, 0);
+ stat_i8_sub_0 (name, values, status, name_len, 0);
}
iexport(stat_i8_sub);
@@ -275,10 +289,10 @@ extern void lstat_i8_sub (char *, gfc_array_i8 *, GFC_INTEGER_8 *,
iexport_proto(lstat_i8_sub);
void
-lstat_i8_sub (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status,
+lstat_i8_sub (char *name, gfc_array_i8 *values, GFC_INTEGER_8 *status,
gfc_charlen_type name_len)
{
- stat_i8_sub_0 (name, sarray, status, name_len, 1);
+ stat_i8_sub_0 (name, values, status, name_len, 1);
}
iexport(lstat_i8_sub);
@@ -288,10 +302,10 @@ extern GFC_INTEGER_4 stat_i4 (char *, gfc_array_i4 *, gfc_charlen_type);
export_proto(stat_i4);
GFC_INTEGER_4
-stat_i4 (char *name, gfc_array_i4 *sarray, gfc_charlen_type name_len)
+stat_i4 (char *name, gfc_array_i4 *values, gfc_charlen_type name_len)
{
GFC_INTEGER_4 val;
- stat_i4_sub (name, sarray, &val, name_len);
+ stat_i4_sub (name, values, &val, name_len);
return val;
}
@@ -299,32 +313,32 @@ extern GFC_INTEGER_8 stat_i8 (char *, gfc_array_i8 *, gfc_charlen_type);
export_proto(stat_i8);
GFC_INTEGER_8
-stat_i8 (char *name, gfc_array_i8 *sarray, gfc_charlen_type name_len)
+stat_i8 (char *name, gfc_array_i8 *values, gfc_charlen_type name_len)
{
GFC_INTEGER_8 val;
- stat_i8_sub (name, sarray, &val, name_len);
+ stat_i8_sub (name, values, &val, name_len);
return val;
}
-/* SUBROUTINE LSTAT(FILE, SARRAY, STATUS)
+/* SUBROUTINE LSTAT(NAME, VALUES, STATUS)
CHARACTER(len=*), INTENT(IN) :: FILE
- INTEGER, INTENT(OUT), :: SARRAY(13)
+ INTEGER, INTENT(OUT), :: VALUES(13)
INTEGER, INTENT(OUT), OPTIONAL :: STATUS
- FUNCTION LSTAT(FILE, SARRAY)
+ FUNCTION LSTAT(NAME, VALUES)
INTEGER LSTAT
CHARACTER(len=*), INTENT(IN) :: FILE
- INTEGER, INTENT(OUT), :: SARRAY(13) */
+ INTEGER, INTENT(OUT), :: VALUES(13) */
extern GFC_INTEGER_4 lstat_i4 (char *, gfc_array_i4 *, gfc_charlen_type);
export_proto(lstat_i4);
GFC_INTEGER_4
-lstat_i4 (char *name, gfc_array_i4 *sarray, gfc_charlen_type name_len)
+lstat_i4 (char *name, gfc_array_i4 *values, gfc_charlen_type name_len)
{
GFC_INTEGER_4 val;
- lstat_i4_sub (name, sarray, &val, name_len);
+ lstat_i4_sub (name, values, &val, name_len);
return val;
}
@@ -332,10 +346,10 @@ extern GFC_INTEGER_8 lstat_i8 (char *, gfc_array_i8 *, gfc_charlen_type);
export_proto(lstat_i8);
GFC_INTEGER_8
-lstat_i8 (char *name, gfc_array_i8 *sarray, gfc_charlen_type name_len)
+lstat_i8 (char *name, gfc_array_i8 *values, gfc_charlen_type name_len)
{
GFC_INTEGER_8 val;
- lstat_i8_sub (name, sarray, &val, name_len);
+ lstat_i8_sub (name, values, &val, name_len);
return val;
}
@@ -344,32 +358,33 @@ lstat_i8 (char *name, gfc_array_i8 *sarray, gfc_charlen_type name_len)
#ifdef HAVE_FSTAT
-/* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS)
+/* SUBROUTINE FSTAT(UNIT, VALUES, STATUS)
INTEGER, INTENT(IN) :: UNIT
- INTEGER, INTENT(OUT) :: SARRAY(13)
+ INTEGER, INTENT(OUT) :: VALUES(13)
INTEGER, INTENT(OUT), OPTIONAL :: STATUS
- FUNCTION FSTAT(UNIT, SARRAY)
+ FUNCTION FSTAT(UNIT, VALUES)
INTEGER FSTAT
INTEGER, INTENT(IN) :: UNIT
- INTEGER, INTENT(OUT) :: SARRAY(13) */
+ INTEGER, INTENT(OUT) :: VALUES(13) */
extern void fstat_i4_sub (GFC_INTEGER_4 *, gfc_array_i4 *, GFC_INTEGER_4 *);
iexport_proto(fstat_i4_sub);
void
-fstat_i4_sub (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray, GFC_INTEGER_4 *status)
+fstat_i4_sub (GFC_INTEGER_4 *unit, gfc_array_i4 *values, GFC_INTEGER_4 *status)
{
int val;
struct stat sb;
+ bool ovf = false;
/* If the rank of the array is not 1, abort. */
- if (GFC_DESCRIPTOR_RANK (sarray) != 1)
- runtime_error ("Array rank of SARRAY is not 1.");
+ if (GFC_DESCRIPTOR_RANK (values) != 1)
+ runtime_error ("Array rank of VALUES is not 1.");
/* If the array is too small, abort. */
- if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
- runtime_error ("Array size of SARRAY is too small.");
+ if (GFC_DESCRIPTOR_EXTENT(values,0) < 13)
+ runtime_error ("Array size of VALUES is too small.");
/* Convert Fortran unit number to C file descriptor. */
val = unit_to_fd (*unit);
@@ -378,62 +393,75 @@ fstat_i4_sub (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray, GFC_INTEGER_4 *status)
if (val == 0)
{
- index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
+ index_type stride = GFC_DESCRIPTOR_STRIDE(values,0);
/* Device ID */
- sarray->base_addr[0 * stride] = sb.st_dev;
+ ovf = INT32_MAX < sb.st_dev;
+ values->base_addr[0 * stride] = sb.st_dev;
/* Inode number */
- sarray->base_addr[1 * stride] = sb.st_ino;
+ ovf |= INT32_MAX < sb.st_ino;
+ values->base_addr[1 * stride] = sb.st_ino;
/* File mode */
- sarray->base_addr[2 * stride] = sb.st_mode;
+ ovf |= INT32_MAX < sb.st_mode;
+ values->base_addr[2 * stride] = sb.st_mode;
/* Number of (hard) links */
- sarray->base_addr[3 * stride] = sb.st_nlink;
+ ovf |= INT32_MAX < sb.st_nlink;
+ values->base_addr[3 * stride] = sb.st_nlink;
/* Owner's uid */
- sarray->base_addr[4 * stride] = sb.st_uid;
+ ovf |= INT32_MAX < sb.st_uid;
+ values->base_addr[4 * stride] = sb.st_uid;
/* Owner's gid */
- sarray->base_addr[5 * stride] = sb.st_gid;
+ ovf |= INT32_MAX < sb.st_gid;
+ values->base_addr[5 * stride] = sb.st_gid;
/* ID of device containing directory entry for file (0 if not available) */
#if HAVE_STRUCT_STAT_ST_RDEV
- sarray->base_addr[6 * stride] = sb.st_rdev;
+ ovf |= INT32_MAX < sb.st_rdev;
+ values->base_addr[6 * stride] = sb.st_rdev;
#else
- sarray->base_addr[6 * stride] = 0;
+ values->base_addr[6 * stride] = 0;
#endif
/* File size (bytes) */
- sarray->base_addr[7 * stride] = sb.st_size;
+ ovf |= INT32_MAX < sb.st_size;
+ values->base_addr[7 * stride] = sb.st_size;
/* Last access time */
- sarray->base_addr[8 * stride] = sb.st_atime;
+ ovf |= INT32_MAX < sb.st_atime;
+ values->base_addr[8 * stride] = sb.st_atime;
/* Last modification time */
- sarray->base_addr[9 * stride] = sb.st_mtime;
+ ovf |= INT32_MAX < sb.st_mtime;
+ values->base_addr[9 * stride] = sb.st_mtime;
/* Last file status change time */
- sarray->base_addr[10 * stride] = sb.st_ctime;
+ ovf |= INT32_MAX < sb.st_ctime;
+ values->base_addr[10 * stride] = sb.st_ctime;
/* Preferred I/O block size (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLKSIZE
- sarray->base_addr[11 * stride] = sb.st_blksize;
+ ovf |= INT32_MAX < sb.st_blksize;
+ values->base_addr[11 * stride] = sb.st_blksize;
#else
- sarray->base_addr[11 * stride] = -1;
+ values->base_addr[11 * stride] = -1;
#endif
/* Number of blocks allocated (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLOCKS
- sarray->base_addr[12 * stride] = sb.st_blocks;
+ ovf |= INT32_MAX < sb.st_blocks;
+ values->base_addr[12 * stride] = sb.st_blocks;
#else
- sarray->base_addr[12 * stride] = -1;
+ values->base_addr[12 * stride] = -1;
#endif
}
if (status != NULL)
- *status = (val == 0) ? 0 : errno;
+ *status = (val == 0) ? (ovf ? ERANGE : 0) : errno;
}
iexport(fstat_i4_sub);
@@ -441,18 +469,18 @@ extern void fstat_i8_sub (GFC_INTEGER_8 *, gfc_array_i8 *, GFC_INTEGER_8 *);
iexport_proto(fstat_i8_sub);
void
-fstat_i8_sub (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray, GFC_INTEGER_8 *status)
+fstat_i8_sub (GFC_INTEGER_8 *unit, gfc_array_i8 *values, GFC_INTEGER_8 *status)
{
int val;
struct stat sb;
/* If the rank of the array is not 1, abort. */
- if (GFC_DESCRIPTOR_RANK (sarray) != 1)
- runtime_error ("Array rank of SARRAY is not 1.");
+ if (GFC_DESCRIPTOR_RANK (values) != 1)
+ runtime_error ("Array rank of VALUES is not 1.");
/* If the array is too small, abort. */
- if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13)
- runtime_error ("Array size of SARRAY is too small.");
+ if (GFC_DESCRIPTOR_EXTENT(values,0) < 13)
+ runtime_error ("Array size of VALUES is too small.");
/* Convert Fortran unit number to C file descriptor. */
val = unit_to_fd ((int) *unit);
@@ -461,57 +489,57 @@ fstat_i8_sub (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray, GFC_INTEGER_8 *status)
if (val == 0)
{
- index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
+ index_type stride = GFC_DESCRIPTOR_STRIDE(values,0);
/* Device ID */
- sarray->base_addr[0] = sb.st_dev;
+ values->base_addr[0] = sb.st_dev;
/* Inode number */
- sarray->base_addr[stride] = sb.st_ino;
+ values->base_addr[stride] = sb.st_ino;
/* File mode */
- sarray->base_addr[2 * stride] = sb.st_mode;
+ values->base_addr[2 * stride] = sb.st_mode;
/* Number of (hard) links */
- sarray->base_addr[3 * stride] = sb.st_nlink;
+ values->base_addr[3 * stride] = sb.st_nlink;
/* Owner's uid */
- sarray->base_addr[4 * stride] = sb.st_uid;
+ values->base_addr[4 * stride] = sb.st_uid;
/* Owner's gid */
- sarray->base_addr[5 * stride] = sb.st_gid;
+ values->base_addr[5 * stride] = sb.st_gid;
/* ID of device containing directory entry for file (0 if not available) */
#if HAVE_STRUCT_STAT_ST_RDEV
- sarray->base_addr[6 * stride] = sb.st_rdev;
+ values->base_addr[6 * stride] = sb.st_rdev;
#else
- sarray->base_addr[6 * stride] = 0;
+ values->base_addr[6 * stride] = 0;
#endif
/* File size (bytes) */
- sarray->base_addr[7 * stride] = sb.st_size;
+ values->base_addr[7 * stride] = sb.st_size;
/* Last access time */
- sarray->base_addr[8 * stride] = sb.st_atime;
+ values->base_addr[8 * stride] = sb.st_atime;
/* Last modification time */
- sarray->base_addr[9 * stride] = sb.st_mtime;
+ values->base_addr[9 * stride] = sb.st_mtime;
/* Last file status change time */
- sarray->base_addr[10 * stride] = sb.st_ctime;
+ values->base_addr[10 * stride] = sb.st_ctime;
/* Preferred I/O block size (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLKSIZE
- sarray->base_addr[11 * stride] = sb.st_blksize;
+ values->base_addr[11 * stride] = sb.st_blksize;
#else
- sarray->base_addr[11 * stride] = -1;
+ values->base_addr[11 * stride] = -1;
#endif
/* Number of blocks allocated (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLOCKS
- sarray->base_addr[12 * stride] = sb.st_blocks;
+ values->base_addr[12 * stride] = sb.st_blocks;
#else
- sarray->base_addr[12 * stride] = -1;
+ values->base_addr[12 * stride] = -1;
#endif
}
@@ -524,10 +552,10 @@ extern GFC_INTEGER_4 fstat_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
export_proto(fstat_i4);
GFC_INTEGER_4
-fstat_i4 (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray)
+fstat_i4 (GFC_INTEGER_4 *unit, gfc_array_i4 *values)
{
GFC_INTEGER_4 val;
- fstat_i4_sub (unit, sarray, &val);
+ fstat_i4_sub (unit, values, &val);
return val;
}
@@ -535,10 +563,10 @@ extern GFC_INTEGER_8 fstat_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
export_proto(fstat_i8);
GFC_INTEGER_8
-fstat_i8 (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray)
+fstat_i8 (GFC_INTEGER_8 *unit, gfc_array_i8 *values)
{
GFC_INTEGER_8 val;
- fstat_i8_sub (unit, sarray, &val);
+ fstat_i8_sub (unit, values, &val);
return val;
}
--
2.43.0
