}
+/* 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
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;
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))
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;
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))
@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}.
@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
@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
@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.
@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
/* 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);
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);
}
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);
}
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. */
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);
}
}
+/* 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.
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;
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;
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
--- /dev/null
+! { 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" } }
projects / thirdparty / gcc.git / commitdiff
