[gcc r16-3724] Fortran: make STAT/LSTAT/FSTAT intrinsics generic [PR82480]
Harald Anlauf
anlauf@gcc.gnu.org
Tue Sep 9 16:11:54 GMT 2025
https://gcc.gnu.org/g:52d754a1a620efdbfe4873ae177a62433be4e4d9
commit r16-3724-g52d754a1a620efdbfe4873ae177a62433be4e4d9
Author: Harald Anlauf <anlauf@gmx.de>
Date: Mon Sep 8 21:21:15 2025 +0200
Fortran: make STAT/LSTAT/FSTAT intrinsics generic [PR82480]
PR fortran/82480
gcc/fortran/ChangeLog:
* check.cc (error_unsupported_kind): Helper function to report an
unsupported kind of an argument.
(check_minrange4): Helper function to report if an integer variable
does not have a decimal range of at least four.
(gfc_check_fstat): Adjust checks for generalization of instrinsic
function FSTAT.
(gfc_check_fstat_sub): Likewise for subroutine FSTAT.
(gfc_check_stat): Likewise for functio STAT.
(gfc_check_stat_sub): Likewise for subroutine STAT.
* intrinsic.texi: Document generalized versions of intrinsics
STAT/LSTAT/FSTAT.
* iresolve.cc (gfc_resolve_stat): STAT function result shall have
the same kind as the VALUES argument.
(gfc_resolve_lstat): Likewise for LSTAT.
(gfc_resolve_fstat): Likewise for FSTAT.
(gfc_resolve_stat_sub): Resolve proper library subroutine for STAT.
(gfc_resolve_lstat_sub): Likewise for LSTAT.
* trans-decl.cc (gfc_build_intrinsic_function_decls): Declare
fndecls for required subroutines in runtine library.
* trans-intrinsic.cc (conv_intrinsic_fstat_lstat_stat_sub): Emit
runtime wrapper code for the library functions, taking care of
possible kind conversion of the optional STATUS argument of the
subroutine versions of the intrinsics.
(gfc_conv_intrinsic_subroutine): Use it.
* trans.h (GTY): Declare prototypes.
gcc/testsuite/ChangeLog:
* gfortran.dg/stat_3.f90: Extend argument checking.
* gfortran.dg/stat_4.f90: New test.
Diff:
---
gcc/fortran/check.cc | 52 +++++++++++++--
gcc/fortran/intrinsic.texi | 44 ++++++------
gcc/fortran/iresolve.cc | 22 +++---
gcc/fortran/trans-decl.cc | 34 ++++++++++
gcc/fortran/trans-intrinsic.cc | 125 +++++++++++++++++++++++++++++++++++
gcc/fortran/trans.h | 6 ++
gcc/testsuite/gfortran.dg/stat_3.f90 | 13 ++++
gcc/testsuite/gfortran.dg/stat_4.f90 | 94 ++++++++++++++++++++++++++
8 files changed, 352 insertions(+), 38 deletions(-)
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 80aac89c3334..1f170131ae14 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -1107,6 +1107,36 @@ kind_value_check (gfc_expr *e, int n, int k)
}
+/* Error message for an actual argument with an unsupported kind value. */
+
+static void
+error_unsupported_kind (gfc_expr *e, int n)
+{
+ gfc_error ("Not supported: %qs argument of %qs intrinsic at %L with kind %d",
+ gfc_current_intrinsic_arg[n]->name,
+ gfc_current_intrinsic, &e->where, e->ts.kind);
+ return;
+}
+
+
+/* Check if the decimal exponent range of an integer variable is at least four
+ so that it is large enough to e.g. hold errno values and the values of
+ LIBERROR_* from libgfortran.h. */
+
+static bool
+check_minrange4 (gfc_expr *e, int n)
+{
+ if (e->ts.kind >= 2)
+ return true;
+
+ gfc_error ("%qs argument of %qs intrinsic at %L must have "
+ "a decimal exponent range of at least four",
+ gfc_current_intrinsic_arg[n]->name,
+ gfc_current_intrinsic, &e->where);
+ return false;
+}
+
+
/* Make sure an expression is a variable. */
static bool
@@ -6574,10 +6604,15 @@ gfc_check_fstat (gfc_expr *unit, gfc_expr *values)
if (!scalar_check (unit, 0))
return false;
- if (!type_check (values, 1, BT_INTEGER)
- || !kind_value_check (unit, 0, gfc_default_integer_kind))
+ if (!type_check (values, 1, BT_INTEGER))
return false;
+ if (values->ts.kind != 4 && values->ts.kind != 8)
+ {
+ error_unsupported_kind (values, 1);
+ return false;
+ }
+
if (!array_check (values, 1))
return false;
@@ -6601,7 +6636,7 @@ gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *values, gfc_expr *status)
return true;
if (!type_check (status, 2, BT_INTEGER)
- || !kind_value_check (status, 2, gfc_default_integer_kind))
+ || !check_minrange4 (status, 2))
return false;
if (!scalar_check (status, 2))
@@ -6654,10 +6689,15 @@ gfc_check_stat (gfc_expr *name, gfc_expr *values)
if (!kind_value_check (name, 0, gfc_default_character_kind))
return false;
- if (!type_check (values, 1, BT_INTEGER)
- || !kind_value_check (values, 1, gfc_default_integer_kind))
+ if (!type_check (values, 1, BT_INTEGER))
return false;
+ if (values->ts.kind != 4 && values->ts.kind != 8)
+ {
+ error_unsupported_kind (values, 1);
+ return false;
+ }
+
if (!array_check (values, 1))
return false;
@@ -6681,7 +6721,7 @@ gfc_check_stat_sub (gfc_expr *name, gfc_expr *values, gfc_expr *status)
return true;
if (!type_check (status, 2, BT_INTEGER)
- || !kind_value_check (status, 2, gfc_default_integer_kind))
+ || !check_minrange4 (status, 2))
return false;
if (!scalar_check (status, 2))
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 6b9f4cd809aa..9012c2a5746d 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -6992,7 +6992,7 @@ GNU extension
@end multitable
@item @emph{Description}:
-@code{FSTAT} is identical to @ref{STAT}, except that information about an
+@code{FSTAT} is identical to @ref{STAT}, except that information about an
already opened file is obtained.
The elements in @code{VALUES} are the same as described by @ref{STAT}.
@@ -7007,9 +7007,9 @@ Subroutine, function
@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, DIMENSION(13)}
-of the default kind.
+of either kind 4 or kind 8.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}
-of the default kind.
+of kind 2 or larger.
Returns 0 on success and a system specific error code otherwise.
@end multitable
@@ -10314,9 +10314,9 @@ Subroutine, function
@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, DIMENSION(13)}
-of the default kind.
+of either kind 4 or kind 8.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}
-of the default kind.
+of kind 2 or larger.
Returns 0 on success and a system specific error code otherwise.
@end multitable
@@ -14440,28 +14440,28 @@ GNU extension
@end multitable
@item @emph{Description}:
-This function returns information about a file. No permissions are required on
-the file itself, but execute (search) permission is required on all of the
+This function returns information about a file. No permissions are required on
+the file itself, but execute (search) permission is required on all of the
directories in path that lead to the file.
The elements that are obtained and stored in the array @code{VALUES}:
@multitable @columnfractions .15 .70
-@item @code{VALUES(1)} @tab Device ID
-@item @code{VALUES(2)} @tab Inode number
-@item @code{VALUES(3)} @tab File mode
-@item @code{VALUES(4)} @tab Number of links
-@item @code{VALUES(5)} @tab Owner's uid
-@item @code{VALUES(6)} @tab Owner's gid
-@item @code{VALUES(7)} @tab ID of device containing directory entry for file (0 if not available)
-@item @code{VALUES(8)} @tab File size (bytes)
-@item @code{VALUES(9)} @tab Last access time
-@item @code{VALUES(10)} @tab Last modification time
-@item @code{VALUES(11)} @tab Last file status change time
-@item @code{VALUES(12)} @tab Preferred I/O block size (-1 if not available)
+@item @code{VALUES(1)} @tab Device ID
+@item @code{VALUES(2)} @tab Inode number
+@item @code{VALUES(3)} @tab File mode
+@item @code{VALUES(4)} @tab Number of links
+@item @code{VALUES(5)} @tab Owner's uid
+@item @code{VALUES(6)} @tab Owner's gid
+@item @code{VALUES(7)} @tab ID of device containing directory entry for file (0 if not available)
+@item @code{VALUES(8)} @tab File size (bytes)
+@item @code{VALUES(9)} @tab Last access time
+@item @code{VALUES(10)} @tab Last modification time
+@item @code{VALUES(11)} @tab Last file status change time
+@item @code{VALUES(12)} @tab Preferred I/O block size (-1 if not available)
@item @code{VALUES(13)} @tab Number of blocks allocated (-1 if not available)
@end multitable
-Not all these elements are relevant on all systems.
+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.
@@ -14477,9 +14477,9 @@ Subroutine, function
@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, DIMENSION(13)}
-of the default kind.
+of either kind 4 or kind 8.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}
-of the default kind.
+of kind 2 or larger.
Returns 0 on success and a system specific error code otherwise.
@end multitable
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index da354ab5056e..a821332ecb2e 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3000,30 +3000,28 @@ gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
/* Resolve the g77 compatibility function STAT AND FSTAT. */
void
-gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
- gfc_expr *a ATTRIBUTE_UNUSED)
+gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED, gfc_expr *a)
{
f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+ f->ts.kind = a->ts.kind;
f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
}
void
-gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
- gfc_expr *a ATTRIBUTE_UNUSED)
+gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED, gfc_expr *a)
{
f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+ f->ts.kind = a->ts.kind;
f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
}
void
-gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
+gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a)
{
f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+ f->ts.kind = a->ts.kind;
if (n->ts.kind != f->ts.kind)
gfc_convert_type (n, &f->ts, 2);
@@ -4159,7 +4157,9 @@ void
gfc_resolve_stat_sub (gfc_code *c)
{
const char *name;
- name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
+ gfc_typespec *ts;
+ ts = &c->ext.actual->next->expr->ts;
+ name = gfc_get_string (PREFIX ("stat_i%d_sub"), ts->kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
@@ -4168,7 +4168,9 @@ void
gfc_resolve_lstat_sub (gfc_code *c)
{
const char *name;
- name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
+ gfc_typespec *ts;
+ ts = &c->ext.actual->next->expr->ts;
+ name = gfc_get_string (PREFIX ("lstat_i%d_sub"), ts->kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index b077cee86a38..f03144f94275 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -225,6 +225,12 @@ tree gfor_fndecl_iargc;
tree gfor_fndecl_kill;
tree gfor_fndecl_kill_sub;
tree gfor_fndecl_is_contiguous0;
+tree gfor_fndecl_fstat_i4_sub;
+tree gfor_fndecl_fstat_i8_sub;
+tree gfor_fndecl_lstat_i4_sub;
+tree gfor_fndecl_lstat_i8_sub;
+tree gfor_fndecl_stat_i4_sub;
+tree gfor_fndecl_stat_i8_sub;
/* Intrinsic functions implemented in Fortran. */
@@ -3910,6 +3916,34 @@ gfc_build_intrinsic_function_decls (void)
gfc_int4_type_node, 1, pvoid_type_node);
DECL_PURE_P (gfor_fndecl_is_contiguous0) = 1;
TREE_NOTHROW (gfor_fndecl_is_contiguous0) = 1;
+
+ gfor_fndecl_fstat_i4_sub = gfc_build_library_function_decl (
+ get_identifier (PREFIX ("fstat_i4_sub")), void_type_node,
+ 3, gfc_pint4_type_node, gfc_pint4_type_node, gfc_pint4_type_node);
+
+ gfor_fndecl_fstat_i8_sub = gfc_build_library_function_decl (
+ get_identifier (PREFIX ("fstat_i8_sub")), void_type_node,
+ 3, gfc_pint8_type_node, gfc_pint8_type_node, gfc_pint8_type_node);
+
+ gfor_fndecl_lstat_i4_sub = gfc_build_library_function_decl (
+ get_identifier (PREFIX ("lstat_i4_sub")), void_type_node,
+ 4, pchar_type_node, gfc_pint4_type_node, gfc_pint4_type_node,
+ gfc_charlen_type_node);
+
+ gfor_fndecl_lstat_i8_sub = gfc_build_library_function_decl (
+ get_identifier (PREFIX ("lstat_i8_sub")), void_type_node,
+ 4, pchar_type_node, gfc_pint8_type_node, gfc_pint8_type_node,
+ gfc_charlen_type_node);
+
+ gfor_fndecl_stat_i4_sub = gfc_build_library_function_decl (
+ get_identifier (PREFIX ("stat_i4_sub")), void_type_node,
+ 4, pchar_type_node, gfc_pint4_type_node, gfc_pint4_type_node,
+ gfc_charlen_type_node);
+
+ gfor_fndecl_stat_i8_sub = gfc_build_library_function_decl (
+ get_identifier (PREFIX ("stat_i8_sub")), void_type_node,
+ 4, pchar_type_node, gfc_pint8_type_node, gfc_pint8_type_node,
+ gfc_charlen_type_node);
}
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index e720b42355f4..b6691f58bee8 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -5871,6 +5871,125 @@ gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
}
+/* Emit code for fstat, lstat and stat intrinsic subroutines. */
+
+static tree
+conv_intrinsic_fstat_lstat_stat_sub (gfc_code *code)
+{
+ stmtblock_t block;
+ gfc_se se, se_stat;
+ tree unit;
+ tree name, slen;
+ tree vals;
+ tree arg3 = NULL_TREE;
+ tree stat = NULL_TREE ;
+ tree present = NULL_TREE;
+ tree tmp;
+ int kind;
+
+ gfc_init_block (&block);
+ gfc_init_se (&se, NULL);
+
+ switch (code->resolved_isym->id)
+ {
+ case GFC_ISYM_FSTAT:
+ /* Deal with the UNIT argument. */
+ gfc_conv_expr (&se, code->ext.actual->expr);
+ gfc_add_block_to_block (&block, &se.pre);
+ unit = gfc_evaluate_now (se.expr, &block);
+ unit = gfc_build_addr_expr (NULL_TREE, unit);
+ gfc_add_block_to_block (&block, &se.post);
+ break;
+
+ case GFC_ISYM_LSTAT:
+ case GFC_ISYM_STAT:
+ /* Deal with the NAME argument. */
+ gfc_conv_expr (&se, code->ext.actual->expr);
+ gfc_conv_string_parameter (&se);
+ gfc_add_block_to_block (&block, &se.pre);
+ name = se.expr;
+ slen = se.string_length;
+ gfc_add_block_to_block (&block, &se.post);
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+
+ /* Deal with the VALUES argument. */
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_descriptor (&se, code->ext.actual->next->expr);
+ vals = gfc_build_addr_expr (NULL_TREE, se.expr);
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_block_to_block (&block, &se.post);
+ kind = code->ext.actual->next->expr->ts.kind;
+
+ /* Deal with an optional STATUS. */
+ if (code->ext.actual->next->next->expr)
+ {
+ gfc_init_se (&se_stat, NULL);
+ gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
+ stat = gfc_create_var (gfc_get_int_type (kind), "_stat");
+ arg3 = gfc_build_addr_expr (NULL_TREE, stat);
+
+ /* Handle case of status being an optional dummy. */
+ gfc_symbol *sym = code->ext.actual->next->next->expr->symtree->n.sym;
+ if (sym->attr.dummy && sym->attr.optional)
+ {
+ present = gfc_conv_expr_present (sym);
+ arg3 = fold_build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (arg3), present, arg3,
+ fold_convert (TREE_TYPE (arg3),
+ null_pointer_node));
+ }
+ }
+
+ /* Call library function depending on KIND of VALUES argument. */
+ switch (code->resolved_isym->id)
+ {
+ case GFC_ISYM_FSTAT:
+ tmp = (kind == 4 ? gfor_fndecl_fstat_i4_sub : gfor_fndecl_fstat_i8_sub);
+ break;
+ case GFC_ISYM_LSTAT:
+ tmp = (kind == 4 ? gfor_fndecl_lstat_i4_sub : gfor_fndecl_lstat_i8_sub);
+ break;
+ case GFC_ISYM_STAT:
+ tmp = (kind == 4 ? gfor_fndecl_stat_i4_sub : gfor_fndecl_stat_i8_sub);
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ if (code->resolved_isym->id == GFC_ISYM_FSTAT)
+ tmp = build_call_expr_loc (input_location, tmp, 3, unit, vals,
+ stat ? arg3 : null_pointer_node);
+ else
+ tmp = build_call_expr_loc (input_location, tmp, 4, name, vals,
+ stat ? arg3 : null_pointer_node, slen);
+ gfc_add_expr_to_block (&block, tmp);
+
+ /* Handle kind conversion of status. */
+ if (stat && stat != se_stat.expr)
+ {
+ stmtblock_t block2;
+
+ gfc_init_block (&block2);
+ gfc_add_modify (&block2, se_stat.expr,
+ fold_convert (TREE_TYPE (se_stat.expr), stat));
+
+ if (present)
+ {
+ tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block2),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ gfc_add_block_to_block (&block, &block2);
+ }
+
+ return gfc_finish_block (&block);
+}
+
/* Emit code for minval or maxval intrinsic. There are many different cases
we need to handle. For performance reasons we sometimes create two
loops instead of one, where the second one is much simpler.
@@ -13352,6 +13471,12 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
res = conv_intrinsic_free (code);
break;
+ case GFC_ISYM_FSTAT:
+ case GFC_ISYM_LSTAT:
+ case GFC_ISYM_STAT:
+ res = conv_intrinsic_fstat_lstat_stat_sub (code);
+ break;
+
case GFC_ISYM_RANDOM_INIT:
res = conv_intrinsic_random_init (code);
break;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 55541845a6d6..1d04b22abc8d 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -983,6 +983,12 @@ extern GTY(()) tree gfor_fndecl_iargc;
extern GTY(()) tree gfor_fndecl_kill;
extern GTY(()) tree gfor_fndecl_kill_sub;
extern GTY(()) tree gfor_fndecl_is_contiguous0;
+extern GTY(()) tree gfor_fndecl_fstat_i4_sub;
+extern GTY(()) tree gfor_fndecl_fstat_i8_sub;
+extern GTY(()) tree gfor_fndecl_lstat_i4_sub;
+extern GTY(()) tree gfor_fndecl_lstat_i8_sub;
+extern GTY(()) tree gfor_fndecl_stat_i4_sub;
+extern GTY(()) tree gfor_fndecl_stat_i8_sub;
/* Implemented in Fortran. */
extern GTY(()) tree gfor_fndecl_sc_kind;
diff --git a/gcc/testsuite/gfortran.dg/stat_3.f90 b/gcc/testsuite/gfortran.dg/stat_3.f90
index 93ec1836a9a9..9bfff1eeb7d4 100644
--- a/gcc/testsuite/gfortran.dg/stat_3.f90
+++ b/gcc/testsuite/gfortran.dg/stat_3.f90
@@ -44,3 +44,16 @@ subroutine sub2 ()
call lstat (name, status=perr, values= pbuf)
call fstat (unit, status=perr, values= pbuf)
end
+
+subroutine sub3 ()
+ implicit none
+ integer(1) :: ierr1, unit1 = 10
+ integer(2) :: buff2(13)
+ integer(4) :: buff4(13)
+ integer(8) :: buff8(13)
+ character(len=32) :: name = "/etc/passwd"
+ ierr1 = stat (name,values=buff2) ! { dg-error "with kind 2" }
+ call fstat (unit1, values=buff2) ! { dg-error "with kind 2" }
+ call fstat (unit1, values=buff4, status=ierr1) ! { dg-error "at least four" }
+ call lstat (name, values=buff8, status=ierr1) ! { dg-error "at least four" }
+end
diff --git a/gcc/testsuite/gfortran.dg/stat_4.f90 b/gcc/testsuite/gfortran.dg/stat_4.f90
new file mode 100644
index 000000000000..c2d36ffc819f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/stat_4.f90
@@ -0,0 +1,94 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original" }
+! PR fortran/82480 - make STAT/LSTAT/FSTAT generic
+
+subroutine fstat_sub_wrapper (unit, values8, status, opt_status4, opt_status8)
+ implicit none
+ integer(1), intent(in) :: unit
+ integer(8), intent(out) :: values8(:)
+ integer(2), intent(out) :: status
+ integer(4), intent(out), optional :: opt_status4
+ integer(8), intent(out), optional :: opt_status8
+ call fstat (unit, values8, status)
+ call fstat (unit, values8, opt_status4)
+ call fstat (unit, values8, opt_status8)
+end
+
+subroutine stat_sub_wrapper (name, values4, status, opt_status4, opt_status8)
+ implicit none
+ character(*), intent(in) :: name
+ integer(4), intent(out) :: values4(:)
+ integer(2), intent(out) :: status
+ integer(4), intent(out), optional :: opt_status4
+ integer(8), intent(out), optional :: opt_status8
+ call stat (name, values4, status)
+ call lstat (name, values4, status)
+ call stat (name, values4, opt_status4)
+ call lstat (name, values4, opt_status4)
+ call stat (name, values4, opt_status8)
+ call lstat (name, values4, opt_status8)
+end
+
+subroutine sub1 ()
+ implicit none
+ character(len=32) :: name = "/etc/passwd"
+ integer(1) :: unit1 = 10
+ integer(4) :: unit4 = 10, buff4(13)
+ integer(8) :: unit8 = 10, buff8(13)
+ integer :: ierr
+ ierr = fstat (unit1, values=buff4)
+ ierr = fstat (unit1, values=buff8)
+ ierr = fstat (unit4, values=buff4)
+ ierr = fstat (unit4, values=buff8)
+ ierr = fstat (unit8, values=buff4)
+ ierr = fstat (unit8, values=buff8)
+ ierr = stat (name, values=buff4)
+ ierr = stat (name, values=buff8)
+ ierr = lstat (name, values=buff4)
+ ierr = lstat (name, values=buff8)
+end
+
+subroutine sub2 ()
+ implicit none
+ integer(2) :: ierr2, unit2 = 10
+ integer(4) :: ierr4, unit4 = 10, buff4(13)
+ integer(8) :: ierr8, unit8 = 10, buff8(13)
+ character(len=32) :: name = "/etc/passwd"
+ call fstat (unit2, values=buff4)
+ call fstat (unit2, values=buff8)
+ call fstat (unit4, values=buff4)
+ call fstat (unit4, values=buff8)
+ call fstat (unit8, values=buff4)
+ call fstat (unit8, values=buff8)
+ call stat (name, values=buff4)
+ call lstat (name, values=buff4)
+ call stat (name, values=buff8)
+ call lstat (name, values=buff8)
+ call fstat (unit4, values=buff4, status=ierr2)
+ call fstat (unit4, values=buff4, status=ierr4)
+ call fstat (unit4, values=buff4, status=ierr8)
+ call fstat (unit4, values=buff8, status=ierr2)
+ call fstat (unit4, values=buff8, status=ierr4)
+ call fstat (unit4, values=buff8, status=ierr8)
+ call stat (name, values=buff4, status=ierr4)
+ call lstat (name, values=buff4, status=ierr4)
+ call stat (name, values=buff4, status=ierr8)
+ call lstat (name, values=buff4, status=ierr8)
+ call stat (name, values=buff8, status=ierr4)
+ call lstat (name, values=buff8, status=ierr4)
+end
+
+! { dg-final { scan-tree-dump-times "_gfortran_fstat_i4_sub" 6 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_lstat_i4_sub" 6 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_stat_i4_sub" 6 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_fstat_i8_sub" 9 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_lstat_i8_sub" 2 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_stat_i8_sub" 2 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_fstat_i4 " 3 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_fstat_i8 " 3 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_lstat_i4 " 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_lstat_i8 " 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_stat_i4 " 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_stat_i8 " 1 "original" } }
+! { dg-final { scan-tree-dump-times "opt_status4" 11 "original" } }
+! { dg-final { scan-tree-dump-times "opt_status8" 11 "original" } }
More information about the Gcc-cvs
mailing list