https://gcc.gnu.org/g:ce6abe54ff1548b744ce7cd216d820e48a062c3d
commit r16-1560-gce6abe54ff1548b744ce7cd216d820e48a062c3d
Author: Harald Anlauf <anl...@gmx.de>
Date: Tue Jun 17 21:09:32 2025 +0200
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.
Document that integer arguments are of default kind, and that overflows
in conversion to integer return -1 in VALUES.
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.
* intrinsic.texi: Adjust documentation.
libgfortran/ChangeLog:
* intrinsics/stat.c (stat_i4_sub_0): Fix argument names. Rename
SARRAY to VALUES also in error message. When array VALUES is
KIND=4, get only stat components that do not overflow INT32_MAX,
otherwise set the corresponding VALUES elements to -1.
(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.
Diff:
---
gcc/fortran/check.cc | 61 ++++----
gcc/fortran/intrinsic.texi | 24 ++-
gcc/testsuite/gfortran.dg/stat_3.f90 | 46 ++++++
libgfortran/intrinsics/stat.c | 274 +++++++++++++++++++----------------
4 files changed, 242 insertions(+), 163 deletions(-)
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index c8904df3b21c..838d523f7c40 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/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 583199564e4b..3103da3da093 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -7001,9 +7001,11 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{UNIT} @tab An open I/O unit number of type @code{INTEGER}.
-@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
-@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}.
Returns 0
-on success and a system specific error code otherwise.
+@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(13)}
+of the default kind.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}
+of the default kind.
+Returns 0 on success and a system specific error code otherwise.
@end multitable
@item @emph{Example}:
@@ -10306,8 +10308,10 @@ Subroutine, function
@multitable @columnfractions .15 .70
@item @var{NAME} @tab The type shall be @code{CHARACTER} of the default
kind, a valid path within the file system.
-@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
-@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}.
+@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(13)}
+of the default kind.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}
+of the default kind.
Returns 0 on success and a system specific error code otherwise.
@end multitable
@@ -14391,6 +14395,8 @@ The elements that are obtained and stored in the array
@code{VALUES}:
Not all these elements are relevant on all systems.
If an element is not relevant, it is returned as 0.
+If the value of an element would overflow the range of default integer,
+a -1 is returned instead.
This intrinsic is provided in both subroutine and function forms; however,
only one form can be used in any given program unit.
@@ -14402,9 +14408,11 @@ Subroutine, function
@multitable @columnfractions .15 .70
@item @var{NAME} @tab The type shall be @code{CHARACTER}, of the
default kind and a valid path within the file system.
-@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
-@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}.
Returns 0
-on success and a system specific error code otherwise.
+@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(13)}
+of the default kind.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}
+of the default kind.
+Returns 0 on success and a system specific error code otherwise.
@end multitable
@item @emph{Example}:
diff --git a/gcc/testsuite/gfortran.dg/stat_3.f90
b/gcc/testsuite/gfortran.dg/stat_3.f90
new file mode 100644
index 000000000000..93ec1836a9a9
--- /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 8d32f223b24f..63a57cd05eec 100644
--- a/libgfortran/intrinsics/stat.c
+++ b/libgfortran/intrinsics/stat.c
@@ -35,22 +35,22 @@ 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;
@@ -58,12 +58,12 @@ stat_i4_sub_0 (char *name, gfc_array_i4 *sarray,
GFC_INTEGER_4 *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);
@@ -80,57 +80,70 @@ 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);
+
+ /* Return -1 for any value overflowing INT32_MAX. */
+ for (int i = 0; i < 13; i++)
+ values->base_addr[i * stride] = -1;
/* Device ID */
- sarray->base_addr[0 * stride] = sb.st_dev;
+ if (sb.st_dev <= INT32_MAX)
+ values->base_addr[0 * stride] = sb.st_dev;
/* Inode number */
- sarray->base_addr[1 * stride] = sb.st_ino;
+ if (sb.st_ino <= INT32_MAX)
+ values->base_addr[1 * stride] = sb.st_ino;
/* File mode */
- sarray->base_addr[2 * stride] = sb.st_mode;
+ if (sb.st_mode <= INT32_MAX)
+ values->base_addr[2 * stride] = sb.st_mode;
/* Number of (hard) links */
- sarray->base_addr[3 * stride] = sb.st_nlink;
+ if (sb.st_nlink <= INT32_MAX)
+ values->base_addr[3 * stride] = sb.st_nlink;
/* Owner's uid */
- sarray->base_addr[4 * stride] = sb.st_uid;
+ if (sb.st_uid <= INT32_MAX)
+ values->base_addr[4 * stride] = sb.st_uid;
/* Owner's gid */
- sarray->base_addr[5 * stride] = sb.st_gid;
+ if (sb.st_gid <= INT32_MAX)
+ 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;
+ if (sb.st_rdev <= INT32_MAX)
+ 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;
+ if (sb.st_size <= INT32_MAX)
+ values->base_addr[7 * stride] = sb.st_size;
/* Last access time */
- sarray->base_addr[8 * stride] = sb.st_atime;
+ if (sb.st_atime <= INT32_MAX)
+ values->base_addr[8 * stride] = sb.st_atime;
/* Last modification time */
- sarray->base_addr[9 * stride] = sb.st_mtime;
+ if (sb.st_mtime <= INT32_MAX)
+ values->base_addr[9 * stride] = sb.st_mtime;
/* Last file status change time */
- sarray->base_addr[10 * stride] = sb.st_ctime;
+ if (sb.st_ctime <= INT32_MAX)
+ 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;
-#else
- sarray->base_addr[11 * stride] = -1;
+ if (sb.st_blksize <= INT32_MAX)
+ values->base_addr[11 * stride] = sb.st_blksize;
#endif
/* Number of blocks allocated (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLOCKS
- sarray->base_addr[12 * stride] = sb.st_blocks;
-#else
- sarray->base_addr[12 * stride] = -1;
+ if (sb.st_blocks <= INT32_MAX)
+ values->base_addr[12 * stride] = sb.st_blocks;
#endif
}
@@ -144,10 +157,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 +170,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 +188,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 +210,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 +274,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 +288,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 +301,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 +312,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 +345,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 +357,32 @@ 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;
/* 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,57 +391,70 @@ 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);
+
+ /* Return -1 for any value overflowing INT32_MAX. */
+ for (int i = 0; i < 13; i++)
+ values->base_addr[i * stride] = -1;
/* Device ID */
- sarray->base_addr[0 * stride] = sb.st_dev;
+ if (sb.st_dev <= INT32_MAX)
+ values->base_addr[0 * stride] = sb.st_dev;
/* Inode number */
- sarray->base_addr[1 * stride] = sb.st_ino;
+ if (sb.st_ino <= INT32_MAX)
+ values->base_addr[1 * stride] = sb.st_ino;
/* File mode */
- sarray->base_addr[2 * stride] = sb.st_mode;
+ if (sb.st_mode <= INT32_MAX)
+ values->base_addr[2 * stride] = sb.st_mode;
/* Number of (hard) links */
- sarray->base_addr[3 * stride] = sb.st_nlink;
+ if (sb.st_nlink <= INT32_MAX)
+ values->base_addr[3 * stride] = sb.st_nlink;
/* Owner's uid */
- sarray->base_addr[4 * stride] = sb.st_uid;
+ if (sb.st_uid <= INT32_MAX)
+ values->base_addr[4 * stride] = sb.st_uid;
/* Owner's gid */
- sarray->base_addr[5 * stride] = sb.st_gid;
+ if (sb.st_gid <= INT32_MAX)
+ 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;
+ if (sb.st_rdev <= INT32_MAX)
+ 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;
+ if (sb.st_size <= INT32_MAX)
+ values->base_addr[7 * stride] = sb.st_size;
/* Last access time */
- sarray->base_addr[8 * stride] = sb.st_atime;
+ if (sb.st_atime <= INT32_MAX)
+ values->base_addr[8 * stride] = sb.st_atime;
/* Last modification time */
- sarray->base_addr[9 * stride] = sb.st_mtime;
+ if (sb.st_mtime <= INT32_MAX)
+ values->base_addr[9 * stride] = sb.st_mtime;
/* Last file status change time */
- sarray->base_addr[10 * stride] = sb.st_ctime;
+ if (sb.st_ctime <= INT32_MAX)
+ 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;
-#else
- sarray->base_addr[11 * stride] = -1;
+ if (sb.st_blksize <= INT32_MAX)
+ values->base_addr[11 * stride] = sb.st_blksize;
#endif
/* Number of blocks allocated (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLOCKS
- sarray->base_addr[12 * stride] = sb.st_blocks;
-#else
- sarray->base_addr[12 * stride] = -1;
+ if (sb.st_blocks <= INT32_MAX)
+ values->base_addr[12 * stride] = sb.st_blocks;
#endif
}
@@ -441,18 +467,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 +487,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 +550,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 +561,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;
}
