Am 17.06.25 um 19:44 schrieb Steve Kargl:
On Tue, Jun 17, 2025 at 12:05:34PM +0300, Janne Blomqvist wrote:
On Mon, Jun 16, 2025 at 9:41 PM Harald Anlauf <anl...@gmx.de> wrote:
Am 16.06.25 um 02:18 schrieb Steve Kargl:
Harald,
I did a quick glance at the patch and did not see anything that
jumped out as needing a change. OK to commit.
Earlier today I came to the same conclusion that -1 on overflow is
probably the right thing to do. Gfortran would need a way to
supply the value of ERANGE (on all supported targets) so a
user can write a test. Yes, POSIX seems to define ERANGE as
34, but is that guaranteed on non-POSIX targets?
After thinking some more, I am struggling with these issues:
- ERANGE may not be defined, and the value of ERANGE may not
be portable between targets. How to handle that on the
Fortran side?
intrinsics/getcwd.c uses ERANGE unconditionally, so it seems all
targets that GFortran supports do define ERANGE. As for the value,
POSIX does not specify numerical values that the errno constants
should take, though it seems 34 is more or less universal on Unix
systems. Also it seems windows uses 34. I'd say just use ERANGE if
appropriate, and if some target defines it differently then it's up to
the user to deal with it.
I think your last sentence is the problem with returning ERANGE.
If gfortran returns ERANGE, then gfortran should also have a facility
that a user can query for the actual value. Walt mentions PXF in
another reply. I have a copy of IEEE Std 1003.9-1992 (aka POSIX
FORTRAN77 Language Interface - Part 1). I never found the time
to implement (parts of) it.
It should also be noted that on FreeBSD (and likely other UNIX-like
systems), one finds
% man 2 stat
...
RETURN VALUES
Upon successful completion, the value 0 is returned; otherwise
the value -1 is returned and the global variable errno is set
to indicate the error.
Note, ERANGE is not documented as a value to which errno can be set.
- my initial proposal to return ERANGE has the potentially confusing
effect that stat(3) may be successful, only the conversion to
integer(kind=4) has an overflow in some component. Is it then
helpful to return ERANGE? Or just return -1 for those components
and document this new behavior?
Good point. I'd say set only the overflowing component to -1 and
document the behavior. It's possible the user is interested in some
component that doesn't overflow, and returning ERANGE would break
backwards compatibility?
As an aside, I note the documentation for [F,L,]STAT says the VALUES
array and STATUS should be INTEGER(4), which isn't correct is it? It
should be default kind INTEGER?
We probably want to make these GNU extensions generic. I did this
for kill() and there are additional patches in
https://gcc.gnu.org/bugzilla/show_bug.cgi?id=30372
for umask() and unlink().
And don't forget that returning ERANGE needs adjustment of
testcases, where the only portable solution I have is the
specification of -fdefault-integer-8 ...
That might be a topic for a follow-up patch, but it would be useful to
be able to use the kind=8 version without having to redefine the
default integer size (which might need some additional headscratching
to deal with VALUES of INTEGER(kind=8) and STATUS of default kind..).
And then the documentation should recommend using that version in
order to avoid overflows.
Personally, I would like to see -fdefault-integer-8 deprecated, but
that ship sailed long ago.
Most intrinsic subprograms specified in the Fortran are generic.
Perhaps, gfortran's extension should follow suit.
OK, here is the conservative version along what Janne suggested,
with a documentation update: as a matter of fact, we currently
do support only default integer (which is kind=4, unless
-fdefault-integer-8 is specified) in the frontend,
We return -1 for elements where there would be overflow, but nothing
like ERANGE or so in STATUS. If someone strongly feels that an error
should be returned, and a mechanism to make it possible to portably
detect this, this should become a separate PR.
With this version, no tweaking of existing tests is needed.
I intend to commit this within the next 24-48 hours as part 1
if it is ok.
Thanks,
Harald
From 6fa2c8adae313d481b8bc56b7a2cb5cebdd6d95a Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Tue, 17 Jun 2025 21:09:32 +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.
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.
---
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(-)
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/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 583199564e4..3103da3da09 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 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..63a57cd05ee 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;
}
--
2.43.0
