procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/38536 (ICE with C_LOC in resolve.c due to not properly going through expr->ref)

Browse source 
2013-03-25  Tobias Burnus  <burnus@net-b.de>

        PR fortran/38536
        PR fortran/38813
        PR fortran/38894
        PR fortran/39288
        PR fortran/40963
        PR fortran/45824
        PR fortran/47023
        PR fortran/47034
        PR fortran/49023
        PR fortran/50269
        PR fortran/50612
        PR fortran/52426
        PR fortran/54263
        PR fortran/55343
        PR fortran/55444
        PR fortran/55574
        PR fortran/56079
        PR fortran/56378
        * check.c (gfc_var_strlen): Properly handle 0-sized string.
        (gfc_check_c_sizeof): Use is_c_interoperable, add checks.
        (is_c_interoperable, gfc_check_c_associated, gfc_check_c_f_pointer,
        gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc): New
        functions.
        * expr.c (check_inquiry): Add c_sizeof, compiler_version and
        compiler_options.
        (gfc_check_pointer_assign): Refine function result check.
        gfortran.h (gfc_isym_id): Add GFC_ISYM_C_ASSOCIATED,
        GFC_ISYM_C_F_POINTER, GFC_ISYM_C_F_PROCPOINTER, GFC_ISYM_C_FUNLOC,
        GFC_ISYM_C_LOC.
        (iso_fortran_env_symbol, iso_c_binding_symbol): Handle
        NAMED_SUBROUTINE.
        (generate_isocbinding_symbol): Update prototype.
        (get_iso_c_sym): Remove.
        (gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New prototypes.
        * intrinsic.c (gfc_intrinsic_subroutine_by_id): New function.
        (gfc_intrinsic_sub_interface): Use it.
        (add_functions, add_subroutines): Add missing C-binding intrinsics.
        (gfc_intrinsic_func_interface): Add special case for c_loc.
        gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New functions.
        (gfc_intrinsic_func_interface, gfc_intrinsic_sub_interface): Use them.
        * intrinsic.h (gfc_check_c_associated, gfc_check_c_f_pointer,
        gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc,
        gfc_resolve_c_loc, gfc_resolve_c_funloc): New prototypes.
        * iresolve.c (gfc_resolve_c_loc, gfc_resolve_c_funloc): New
        functions.
        * iso-c-binding.def: Split PROCEDURE into NAMED_SUBROUTINE and
        NAMED_FUNCTION.
        * iso-fortran-env.def: Add NAMED_SUBROUTINE for completeness.
        * module.c (create_intrinsic_function): Support subroutines and
        derived-type results.
        (use_iso_fortran_env_module): Update calls.
        (import_iso_c_binding_module): Ditto; update calls to
        generate_isocbinding_symbol.
        * resolve.c (find_arglists): Skip for intrinsic symbols.
        (gfc_resolve_intrinsic): Find intrinsic subs via id.
        (is_scalar_expr_ptr, gfc_iso_c_func_interface,
        set_name_and_label, gfc_iso_c_sub_interface): Remove.
        (resolve_function, resolve_specific_s0): Remove calls to those.
        (resolve_structure_cons): Fix handling.
        * symbol.c (gen_special_c_interop_ptr): Update c_ptr/c_funptr
        generation.
        (gen_cptr_param, gen_fptr_param, gen_shape_param,
        build_formal_args, get_iso_c_sym): Remove.
        (std_for_isocbinding_symbol): Handle NAMED_SUBROUTINE.
        (generate_isocbinding_symbol): Support hidden symbols and
        using c_ptr/c_funptr symtrees for nullptr defs.
        * target-memory.c (gfc_target_encode_expr): Fix handling
        of c_ptr/c_funptr.
        * trans-expr.c (conv_isocbinding_procedure): Remove.
        (gfc_conv_procedure_call): Remove call to it.
        (gfc_trans_subcomponent_assign, gfc_conv_expr): Update handling
        of c_ptr/c_funptr.
        * trans-intrinsic.c (conv_isocbinding_function,
        conv_isocbinding_subroutine): New.
        (gfc_conv_intrinsic_function, gfc_conv_intrinsic_subroutine):
        Call them.
        * trans-io.c (transfer_expr): Fix handling of c_ptr/c_funptr.
        * trans-types.c (gfc_typenode_for_spec,
        gfc_get_derived_type): Ditto.
        (gfc_init_c_interop_kinds): Handle NAMED_SUBROUTINE.

2013-03-25  Tobias Burnus  <burnus@net-b.de>

        PR fortran/38536
        PR fortran/38813
        PR fortran/38894
        PR fortran/39288
        PR fortran/40963
        PR fortran/45824
        PR fortran/47023
        PR fortran/47034
        PR fortran/49023
        PR fortran/50269
        PR fortran/50612
        PR fortran/52426
        PR fortran/54263
        PR fortran/55343
        PR fortran/55444
        PR fortran/55574
        PR fortran/56079
        PR fortran/56378
        * gfortran.dg/c_assoc_2.f03: Update dg-error wording.
        * gfortran.dg/c_f_pointer_shape_test.f90: Ditto.
        * gfortran.dg/c_f_pointer_shape_tests_3.f03: Ditto.
        * gfortran.dg/c_f_pointer_tests_5.f90: Ditto.
        * gfortran.dg/c_funloc_tests_2.f03: Ditto.
        * gfortran.dg/c_funloc_tests_5.f03: Ditto.
        * gfortran.dg/c_funloc_tests_6.f90: Ditto.
        * gfortran.dg/c_loc_tests_10.f03: Add -std=f2008.
        * gfortran.dg/c_loc_tests_11.f03: Ditto, update dg-error.
        * gfortran.dg/c_loc_tests_16.f90: Ditto.
        * gfortran.dg/c_loc_tests_4.f03: Ditto.
        * gfortran.dg/c_loc_tests_15.f90: Update dg-error wording.
        * gfortran.dg/c_loc_tests_3.f03: Valid since F2003 TC5.
        * gfortran.dg/c_loc_tests_8.f03: Ditto.
        * gfortran.dg/c_ptr_tests_14.f90: Update scan-tree-dump-times.
        * gfortran.dg/c_ptr_tests_15.f90: Ditto.
        * gfortran.dg/c_sizeof_1.f90: Fix invalid code.
        * gfortran.dg/iso_c_binding_init_expr.f03: Update dg-error wording.
        * gfortran.dg/pr32601_1.f03: Ditto.
        * gfortran.dg/storage_size_2.f08: Remove dg-error.
        * gfortran.dg/blockdata_7.f90: New.
        * gfortran.dg/c_assoc_4.f90: New.
        * gfortran.dg/c_f_pointer_tests_6.f90: New.
        * gfortran.dg/c_f_pointer_tests_7.f90: New.
        * gfortran.dg/c_funloc_tests_8.f90: New.
        * gfortran.dg/c_loc_test_17.f90: New.
        * gfortran.dg/c_loc_test_18.f90: New.
        * gfortran.dg/c_loc_test_19.f90: New.
        * gfortran.dg/c_loc_test_20.f90: New.
        * gfortran.dg/c_sizeof_5.f90: New.
        * gfortran.dg/iso_c_binding_rename_3.f90: New.
        * gfortran.dg/transfer_resolve_2.f90: New.
        * gfortran.dg/transfer_resolve_3.f90: New.
        * gfortran.dg/transfer_resolve_4.f90: New.
        * gfortran.dg/pr32601.f03: Update dg-error.
        * gfortran.dg/c_ptr_tests_13.f03: Update dg-error.
        * gfortran.dg/c_ptr_tests_9.f03: Fix test case.

From-SVN: r197053
This commit is contained in:
Tobias Burnus 2013-03-25 16:40:26 +01:00 • committed by Tobias Burnus
parent a5a4c20a5c
commit cadddfdda2
56 changed files with 1626 additions and 1514 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

83
gcc/fortran/ChangeLog
View file

@ -1,3 +1,86 @@
2013-03-25 Tobias Burnus <burnus@net-b.de>
PR fortran/38536
PR fortran/38813
PR fortran/38894
PR fortran/39288
PR fortran/40963
PR fortran/45824
PR fortran/47023
PR fortran/47034
PR fortran/49023
PR fortran/50269
PR fortran/50612
PR fortran/52426
PR fortran/54263
PR fortran/55343
PR fortran/55444
PR fortran/55574
PR fortran/56079
PR fortran/56378
* check.c (gfc_var_strlen): Properly handle 0-sized string.
(gfc_check_c_sizeof): Use is_c_interoperable, add checks.
(is_c_interoperable, gfc_check_c_associated, gfc_check_c_f_pointer,
gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc): New
functions.
* expr.c (check_inquiry): Add c_sizeof, compiler_version and
compiler_options.
(gfc_check_pointer_assign): Refine function result check.
gfortran.h (gfc_isym_id): Add GFC_ISYM_C_ASSOCIATED,
GFC_ISYM_C_F_POINTER, GFC_ISYM_C_F_PROCPOINTER, GFC_ISYM_C_FUNLOC,
GFC_ISYM_C_LOC.
(iso_fortran_env_symbol, iso_c_binding_symbol): Handle
NAMED_SUBROUTINE.
(generate_isocbinding_symbol): Update prototype.
(get_iso_c_sym): Remove.
(gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New prototypes.
* intrinsic.c (gfc_intrinsic_subroutine_by_id): New function.
(gfc_intrinsic_sub_interface): Use it.
(add_functions, add_subroutines): Add missing C-binding intrinsics.
(gfc_intrinsic_func_interface): Add special case for c_loc.
gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New functions.
(gfc_intrinsic_func_interface, gfc_intrinsic_sub_interface): Use them.
* intrinsic.h (gfc_check_c_associated, gfc_check_c_f_pointer,
gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc,
gfc_resolve_c_loc, gfc_resolve_c_funloc): New prototypes.
* iresolve.c (gfc_resolve_c_loc, gfc_resolve_c_funloc): New
functions.
* iso-c-binding.def: Split PROCEDURE into NAMED_SUBROUTINE and
NAMED_FUNCTION.
* iso-fortran-env.def: Add NAMED_SUBROUTINE for completeness.
* module.c (create_intrinsic_function): Support subroutines and
derived-type results.
(use_iso_fortran_env_module): Update calls.
(import_iso_c_binding_module): Ditto; update calls to
generate_isocbinding_symbol.
* resolve.c (find_arglists): Skip for intrinsic symbols.
(gfc_resolve_intrinsic): Find intrinsic subs via id.
(is_scalar_expr_ptr, gfc_iso_c_func_interface,
set_name_and_label, gfc_iso_c_sub_interface): Remove.
(resolve_function, resolve_specific_s0): Remove calls to those.
(resolve_structure_cons): Fix handling.
* symbol.c (gen_special_c_interop_ptr): Update c_ptr/c_funptr
generation.
(gen_cptr_param, gen_fptr_param, gen_shape_param,
build_formal_args, get_iso_c_sym): Remove.
(std_for_isocbinding_symbol): Handle NAMED_SUBROUTINE.
(generate_isocbinding_symbol): Support hidden symbols and
using c_ptr/c_funptr symtrees for nullptr defs.
* target-memory.c (gfc_target_encode_expr): Fix handling
of c_ptr/c_funptr.
* trans-expr.c (conv_isocbinding_procedure): Remove.
(gfc_conv_procedure_call): Remove call to it.
(gfc_trans_subcomponent_assign, gfc_conv_expr): Update handling
of c_ptr/c_funptr.
* trans-intrinsic.c (conv_isocbinding_function,
conv_isocbinding_subroutine): New.
(gfc_conv_intrinsic_function, gfc_conv_intrinsic_subroutine):
Call them.
* trans-io.c (transfer_expr): Fix handling of c_ptr/c_funptr.
* trans-types.c (gfc_typenode_for_spec,
gfc_get_derived_type): Ditto.
(gfc_init_c_interop_kinds): Handle NAMED_SUBROUTINE.
2013-03-18 Tobias Burnus <burnus@net-b.de>
* gfortran.h (gfc_option_t): Remove flag_whole_file.

397
gcc/fortran/check.c
View file

@ -693,14 +693,19 @@ gfc_var_strlen (const gfc_expr *a)
{
long start_a, end_a;
if (ra->u.ss.start->expr_type == EXPR_CONSTANT
if (!ra->u.ss.end)
return -1;
if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT)
&& ra->u.ss.end->expr_type == EXPR_CONSTANT)
{
start_a = mpz_get_si (ra->u.ss.start->value.integer);
start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer)
: 1;
end_a = mpz_get_si (ra->u.ss.end->value.integer);
return end_a - start_a + 1;
return (end_a < start_a) ? 0 : end_a - start_a + 1;
}
else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
else if (ra->u.ss.start
&& gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
return 1;
else
return -1;
@ -3621,17 +3626,395 @@ gfc_check_sizeof (gfc_expr *arg)
}
/* Check whether an expression is interoperable. When returning false,
msg is set to a string telling why the expression is not interoperable,
otherwise, it is set to NULL. The msg string can be used in diagnostics.
If all_len_okay is true, all length-type parameters (for character) are
allowed. Required for C_LOC (cf. Fortran 2003corr5 or Fortran 2008). */
static bool
is_c_interoperable (gfc_expr *expr, const char **msg, bool all_len_okay)
{
*msg = NULL;
if (expr->ts.type == BT_CLASS)
{
*msg = "Expression is polymorphic";
return false;
}
if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c
&& !expr->ts.u.derived->ts.is_iso_c)
{
*msg = "Expression is a noninteroperable derived type";
return false;
}
if (expr->ts.type == BT_PROCEDURE)
{
*msg = "Procedure unexpected as argument";
return false;
}
if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL)
{
int i;
for (i = 0; gfc_logical_kinds[i].kind; i++)
if (gfc_logical_kinds[i].kind == expr->ts.kind)
return true;
*msg = "Extension to use a non-C_Bool-kind LOGICAL";
return false;
}
if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER
&& expr->ts.kind != 1)
{
*msg = "Extension to use a non-C_CHAR-kind CHARACTER";
return false;
}
if (expr->ts.type == BT_CHARACTER) {
if (expr->ts.deferred)
{
/* TS 29113 allows deferred-length strings as dummy arguments,
but it is not an interoperable type. */
*msg = "Expression shall not be a deferred-length string";
return false;
}
if (expr->ts.u.cl && expr->ts.u.cl->length
&& gfc_simplify_expr (expr, 0) == FAILURE)
gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
if (!all_len_okay && expr->ts.u.cl
&& (!expr->ts.u.cl->length
|| expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0))
{
*msg = "Type shall have a character length of 1";
return false;
}
}
/* Note: The following checks are about interoperatable variables, Fortran
15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
is allowed, e.g. assumed-shape arrays with TS 29113. */
if (gfc_is_coarray (expr))
{
*msg = "Coarrays are not interoperable";
return false;
}
if (expr->rank > 0 && expr->expr_type != EXPR_ARRAY)
{
gfc_array_ref *ar = gfc_find_array_ref (expr);
if (ar->type != AR_FULL)
{
*msg = "Only whole-arrays are interoperable";
return false;
}
if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE)
{
*msg = "Only explicit-size and assumed-size arrays are interoperable";
return false;
}
}
return true;
}
gfc_try
gfc_check_c_sizeof (gfc_expr *arg)
{
if (gfc_verify_c_interop (&arg->ts) != SUCCESS)
const char *msg;
if (is_c_interoperable (arg, &msg, false) != SUCCESS)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
"interoperable data entity",
"interoperable data entity: %s",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where);
&arg->where, msg);
return FAILURE;
}
if (arg->rank && arg->expr_type == EXPR_VARIABLE
&& arg->symtree->n.sym->as != NULL
&& arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
&& arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
"assumed-size array", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &arg->where);
return FAILURE;
}
return SUCCESS;
}
gfc_try
gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
{
if (c_ptr_1->ts.type != BT_DERIVED
|| c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
|| (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
&& c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
{
gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
"type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
return FAILURE;
}
if (scalar_check (c_ptr_1, 0) == FAILURE)
return FAILURE;
if (c_ptr_2
&& (c_ptr_2->ts.type != BT_DERIVED
|| c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
|| (c_ptr_1->ts.u.derived->intmod_sym_id
!= c_ptr_2->ts.u.derived->intmod_sym_id)))
{
gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
"same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
gfc_typename (&c_ptr_1->ts),
gfc_typename (&c_ptr_2->ts));
return FAILURE;
}
if (c_ptr_2 && scalar_check (c_ptr_2, 1) == FAILURE)
return FAILURE;
return SUCCESS;
}
gfc_try
gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
{
symbol_attribute attr;
const char *msg;
if (cptr->ts.type != BT_DERIVED
|| cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
|| cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
{
gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
"type TYPE(C_PTR)", &cptr->where);
return FAILURE;
}
if (scalar_check (cptr, 0) == FAILURE)
return FAILURE;
attr = gfc_expr_attr (fptr);
if (!attr.pointer)
{
gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
&fptr->where);
return FAILURE;
}
if (fptr->ts.type == BT_CLASS)
{
gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
&fptr->where);
return FAILURE;
}
if (gfc_is_coindexed (fptr))
{
gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
"coindexed", &fptr->where);
return FAILURE;
}
if (fptr->rank == 0 && shape)
{
gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
"FPTR", &fptr->where);
return FAILURE;
}
else if (fptr->rank && !shape)
{
gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
"FPTR at %L", &fptr->where);
return FAILURE;
}
if (shape && rank_check (shape, 2, 1) == FAILURE)
return FAILURE;
if (shape && type_check (shape, 2, BT_INTEGER) == FAILURE)
return FAILURE;
if (shape)
{
mpz_t size;
if (gfc_array_size (shape, &size) == SUCCESS
&& mpz_cmp_ui (size, fptr->rank) != 0)
{
mpz_clear (size);
gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
"size as the RANK of FPTR", &shape->where);
return FAILURE;
}
mpz_clear (size);
}
if (fptr->ts.type == BT_CLASS)
{
gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
return FAILURE;
}
if (!is_c_interoperable (fptr, &msg, false) && fptr->rank)
return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable array FPTR "
"at %L to C_F_POINTER: %s", &fptr->where, msg);
return SUCCESS;
}
gfc_try
gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
{
symbol_attribute attr;
if (cptr->ts.type != BT_DERIVED
|| cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
|| cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)
{
gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
"type TYPE(C_FUNPTR)", &cptr->where);
return FAILURE;
}
if (scalar_check (cptr, 0) == FAILURE)
return FAILURE;
attr = gfc_expr_attr (fptr);
if (!attr.proc_pointer)
{
gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
"pointer", &fptr->where);
return FAILURE;
}
if (gfc_is_coindexed (fptr))
{
gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
"coindexed", &fptr->where);
return FAILURE;
}
if (!attr.is_bind_c)
return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable procedure "
"pointer at %L to C_F_PROCPOINTER", &fptr->where);
return SUCCESS;
}
gfc_try
gfc_check_c_funloc (gfc_expr *x)
{
symbol_attribute attr;
if (gfc_is_coindexed (x))
{
gfc_error ("Argument X at %L to C_FUNLOC shall not be "
"coindexed", &x->where);
return FAILURE;
}
attr = gfc_expr_attr (x);
if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE
&& x->symtree->n.sym == x->symtree->n.sym->result)
{
gfc_namespace *ns = gfc_current_ns;
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (x->symtree->n.sym == ns->proc_name)
{
gfc_error ("Function result '%s' at %L is invalid as X argument "
"to C_FUNLOC", x->symtree->n.sym->name, &x->where);
return FAILURE;
}
}
if (attr.flavor != FL_PROCEDURE)
{
gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
"or a procedure pointer", &x->where);
return FAILURE;
}
if (!attr.is_bind_c)
return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable procedure "
"at %L to C_FUNLOC", &x->where);
return SUCCESS;
}
gfc_try
gfc_check_c_loc (gfc_expr *x)
{
symbol_attribute attr;
const char *msg;
if (gfc_is_coindexed (x))
{
gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where);
return FAILURE;
}
if (x->ts.type == BT_CLASS)
{
gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
&x->where);
return FAILURE;
}
attr = gfc_expr_attr (x);
if (!attr.pointer
&& (x->expr_type != EXPR_VARIABLE || !attr.target
|| attr.flavor == FL_PARAMETER))
{
gfc_error ("Argument X at %L to C_LOC shall have either "
"the POINTER or the TARGET attribute", &x->where);
return FAILURE;
}
if (x->ts.type == BT_CHARACTER
&& gfc_var_strlen (x) == 0)
{
gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
"string", &x->where);
return FAILURE;
}
if (!is_c_interoperable (x, &msg, true))
{
if (x->ts.type == BT_CLASS)
{
gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
&x->where);
return FAILURE;
}
if (x->rank
&& gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable array at %L as"
" argument to C_LOC: %s", &x->where, msg) == FAILURE)
return FAILURE;
}
return SUCCESS;
}

47
gcc/fortran/expr.c
View file

@ -2256,7 +2256,7 @@ check_inquiry (gfc_expr *e, int not_restricted)
"new_line", NULL
};
int i;
int i = 0;
gfc_actual_arglist *ap;
if (!e->value.function.isym
@ -2267,17 +2267,31 @@ check_inquiry (gfc_expr *e, int not_restricted)
if (e->symtree == NULL)
return MATCH_NO;
name = e->symtree->n.sym->name;
if (e->symtree->n.sym->from_intmod)
{
if (e->symtree->n.sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
&& e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
return MATCH_NO;
functions = (gfc_option.warn_std & GFC_STD_F2003)
if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING
&& e->symtree->n.sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
return MATCH_NO;
}
else
{
name = e->symtree->n.sym->name;
functions = (gfc_option.warn_std & GFC_STD_F2003)
? inquiry_func_f2003 : inquiry_func_f95;
for (i = 0; functions[i]; i++)
if (strcmp (functions[i], name) == 0)
break;
for (i = 0; functions[i]; i++)
if (strcmp (functions[i], name) == 0)
break;
if (functions[i] == NULL)
return MATCH_ERROR;
if (functions[i] == NULL)
return MATCH_ERROR;
}
/* At this point we have an inquiry function with a variable argument. The
type of the variable might be undefined, but we need it now, because the
@ -3429,13 +3443,18 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
attr = gfc_expr_attr (rvalue);
}
/* Check for result of embracing function. */
if (sym == gfc_current_ns->proc_name
&& sym->attr.function && sym->result == sym)
if (sym->attr.function && sym->result == sym)
{
gfc_error ("Function result '%s' is invalid as proc-target "
"in procedure pointer assignment at %L",
sym->name, &rvalue->where);
return FAILURE;
gfc_namespace *ns;
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (sym == ns->proc_name)
{
gfc_error ("Function result '%s' is invalid as proc-target "
"in procedure pointer assignment at %L",
sym->name, &rvalue->where);
return FAILURE;
}
}
}
if (attr.abstract)

19
gcc/fortran/gfortran.h
View file

@ -343,6 +343,11 @@ enum gfc_isym_id
GFC_ISYM_CPU_TIME,
GFC_ISYM_CSHIFT,
GFC_ISYM_CTIME,
GFC_ISYM_C_ASSOCIATED,
GFC_ISYM_C_F_POINTER,
GFC_ISYM_C_F_PROCPOINTER,
GFC_ISYM_C_FUNLOC,
GFC_ISYM_C_LOC,
GFC_ISYM_C_SIZEOF,
GFC_ISYM_DATE_AND_TIME,
GFC_ISYM_DBLE,
@ -610,6 +615,7 @@ gfc_reverse;
#define NAMED_INTCST(a,b,c,d) a,
#define NAMED_KINDARRAY(a,b,c,d) a,
#define NAMED_FUNCTION(a,b,c,d) a,
#define NAMED_SUBROUTINE(a,b,c,d) a,
#define NAMED_DERIVED_TYPE(a,b,c,d) a,
typedef enum
{
@ -621,6 +627,7 @@ iso_fortran_env_symbol;
#undef NAMED_INTCST
#undef NAMED_KINDARRAY
#undef NAMED_FUNCTION
#undef NAMED_SUBROUTINE
#undef NAMED_DERIVED_TYPE
#define NAMED_INTCST(a,b,c,d) a,
@ -630,8 +637,8 @@ iso_fortran_env_symbol;
#define NAMED_CHARKNDCST(a,b,c) a,
#define NAMED_CHARCST(a,b,c) a,
#define DERIVED_TYPE(a,b,c) a,
#define PROCEDURE(a,b) a,
#define NAMED_FUNCTION(a,b,c,d) a,
#define NAMED_SUBROUTINE(a,b,c,d) a,
typedef enum
{
ISOCBINDING_INVALID = -1,
@ -647,8 +654,8 @@ iso_c_binding_symbol;
#undef NAMED_CHARKNDCST
#undef NAMED_CHARCST
#undef DERIVED_TYPE
#undef PROCEDURE
#undef NAMED_FUNCTION
#undef NAMED_SUBROUTINE
typedef enum
{
@ -2635,8 +2642,8 @@ gfc_try gfc_verify_c_interop_param (gfc_symbol *);
gfc_try verify_bind_c_sym (gfc_symbol *, gfc_typespec *, int, gfc_common_head *);
gfc_try verify_bind_c_derived_type (gfc_symbol *);
gfc_try verify_com_block_vars_c_interop (gfc_common_head *);
void generate_isocbinding_symbol (const char *, iso_c_binding_symbol, const char *);
gfc_symbol *get_iso_c_sym (gfc_symbol *, char *, const char *, int);
gfc_symtree *generate_isocbinding_symbol (const char *, iso_c_binding_symbol,
const char *, gfc_symtree *, bool);
int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **, bool);
int gfc_get_ha_symbol (const char *, gfc_symbol **);
int gfc_get_ha_sym_tree (const char *, gfc_symtree **);
@ -2707,6 +2714,10 @@ int gfc_intrinsic_actual_ok (const char *, const bool);
gfc_intrinsic_sym *gfc_find_function (const char *);
gfc_intrinsic_sym *gfc_find_subroutine (const char *);
gfc_intrinsic_sym *gfc_intrinsic_function_by_id (gfc_isym_id);
gfc_intrinsic_sym *gfc_intrinsic_subroutine_by_id (gfc_isym_id);
gfc_isym_id gfc_isym_id_by_intmod (intmod_id, int);
gfc_isym_id gfc_isym_id_by_intmod_sym (gfc_symbol *);
match gfc_intrinsic_func_interface (gfc_expr *, int);
match gfc_intrinsic_sub_interface (gfc_code *, int);

107
gcc/fortran/intrinsic.c
View file

@ -810,6 +810,57 @@ find_sym (gfc_intrinsic_sym *start, int n, const char *name)
}
gfc_isym_id
gfc_isym_id_by_intmod (intmod_id from_intmod, int intmod_sym_id)
{
if (from_intmod == INTMOD_ISO_C_BINDING)
return (gfc_isym_id) c_interop_kinds_table[intmod_sym_id].value;
else if (from_intmod == INTMOD_ISO_FORTRAN_ENV)
switch (intmod_sym_id)
{
#define NAMED_SUBROUTINE(a,b,c,d) \
case a: \
return (gfc_isym_id) c;
#define NAMED_FUNCTION(a,b,c,d) \
case a: \
return (gfc_isym_id) c;
#include "iso-fortran-env.def"
default:
gcc_unreachable ();
}
else
{
gcc_unreachable ();
}
return (gfc_isym_id) 0;
}
gfc_isym_id
gfc_isym_id_by_intmod_sym (gfc_symbol *sym)
{
return gfc_isym_id_by_intmod (sym->from_intmod, sym->intmod_sym_id);
}
gfc_intrinsic_sym *
gfc_intrinsic_subroutine_by_id (gfc_isym_id id)
{
gfc_intrinsic_sym *start = subroutines;
int n = nsub;
while (true)
{
gcc_assert (n > 0);
if (id == start->id)
return start;
start++;
n--;
}
}
gfc_intrinsic_sym *
gfc_intrinsic_function_by_id (gfc_isym_id id)
{
@ -2652,9 +2703,28 @@ add_functions (void)
make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
/* C_SIZEOF is part of ISO_C_BINDING. */
/* The following functions are part of ISO_C_BINDING. */
add_sym_2 ("c_associated", GFC_ISYM_C_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO,
BT_LOGICAL, dl, GFC_STD_F2003, gfc_check_c_associated, NULL, NULL,
"C_PTR_1", BT_VOID, 0, REQUIRED,
"C_PTR_2", BT_VOID, 0, OPTIONAL);
make_from_module();
add_sym_1 ("c_loc", GFC_ISYM_C_LOC, CLASS_INQUIRY, ACTUAL_NO,
BT_VOID, 0, GFC_STD_F2003,
gfc_check_c_loc, NULL, gfc_resolve_c_loc,
x, BT_UNKNOWN, 0, REQUIRED);
make_from_module();
add_sym_1 ("c_funloc", GFC_ISYM_C_FUNLOC, CLASS_INQUIRY, ACTUAL_NO,
BT_VOID, 0, GFC_STD_F2003,
gfc_check_c_funloc, NULL, gfc_resolve_c_funloc,
x, BT_UNKNOWN, 0, REQUIRED);
make_from_module();
add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, ii, GFC_STD_F2008, gfc_check_c_sizeof, NULL, NULL,
BT_INTEGER, gfc_index_integer_kind, GFC_STD_F2008,
gfc_check_c_sizeof, NULL, NULL,
x, BT_UNKNOWN, 0, REQUIRED);
make_from_module();
@ -3056,6 +3126,22 @@ add_subroutines (void)
pt, BT_INTEGER, di, OPTIONAL, INTENT_IN,
gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
/* The following subroutines are part of ISO_C_BINDING. */
add_sym_3s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0,
GFC_STD_F2003, gfc_check_c_f_pointer, NULL, NULL,
"cptr", BT_VOID, 0, REQUIRED, INTENT_IN,
"fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT,
"shape", BT_INTEGER, di, OPTIONAL, INTENT_IN);
make_from_module();
add_sym_2s ("c_f_procpointer", GFC_ISYM_C_F_PROCPOINTER, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F2003, gfc_check_c_f_procpointer,
NULL, NULL,
"cptr", BT_VOID, 0, REQUIRED, INTENT_IN,
"fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
make_from_module();
/* More G77 compatibility garbage. */
add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
@ -4078,8 +4164,8 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
if (expr->symtree->n.sym->intmod_sym_id)
{
int id = expr->symtree->n.sym->intmod_sym_id;
isym = specific = gfc_intrinsic_function_by_id ((gfc_isym_id) id);
gfc_isym_id id = gfc_isym_id_by_intmod_sym (expr->symtree->n.sym);
isym = specific = gfc_intrinsic_function_by_id (id);
}
else
isym = specific = gfc_find_function (name);
@ -4105,12 +4191,12 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
gfc_current_intrinsic_where = &expr->where;
/* Bypass the generic list for min and max. */
/* Bypass the generic list for min, max and ISO_C_Binding's c_loc. */
if (isym->check.f1m == gfc_check_min_max)
{
init_arglist (isym);
if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
if (isym->check.f1m (expr->value.function.actual) == SUCCESS)
goto got_specific;
if (!error_flag)
@ -4192,7 +4278,14 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
name = c->symtree->n.sym->name;
isym = gfc_find_subroutine (name);
if (c->symtree->n.sym->intmod_sym_id)
{
gfc_isym_id id;
id = gfc_isym_id_by_intmod_sym (c->symtree->n.sym);
isym = gfc_intrinsic_subroutine_by_id (id);
}
else
isym = gfc_find_subroutine (name);
if (isym == NULL)
return MATCH_NO;

7
gcc/fortran/intrinsic.h
View file

@ -143,6 +143,11 @@ gfc_try gfc_check_size (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_sign (gfc_expr *, gfc_expr *);
gfc_try gfc_check_signal (gfc_expr *, gfc_expr *);
gfc_try gfc_check_sizeof (gfc_expr *);
gfc_try gfc_check_c_associated (gfc_expr *, gfc_expr *);
gfc_try gfc_check_c_f_pointer (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_c_f_procpointer (gfc_expr *, gfc_expr *);
gfc_try gfc_check_c_funloc (gfc_expr *);
gfc_try gfc_check_c_loc (gfc_expr *);
gfc_try gfc_check_c_sizeof (gfc_expr *);
gfc_try gfc_check_sngl (gfc_expr *);
gfc_try gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *);
@ -421,6 +426,8 @@ void gfc_resolve_atomic_ref (gfc_code *);
void gfc_resolve_besn (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *a);
void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_c_loc (gfc_expr *, gfc_expr *);
void gfc_resolve_c_funloc (gfc_expr *, gfc_expr *);
void gfc_resolve_ceiling (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_char (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_chdir (gfc_expr *, gfc_expr *);

14
gcc/fortran/iresolve.c
View file

@ -500,6 +500,20 @@ gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
}
void
gfc_resolve_c_loc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
{
f->ts = f->value.function.isym->ts;
}
void
gfc_resolve_c_funloc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
{
f->ts = f->value.function.isym->ts;
}
void
gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{

32
gcc/fortran/iso-c-binding.def
View file

@ -43,6 +43,10 @@ along with GCC; see the file COPYING3. If not see
# define NAMED_FUNCTION(a,b,c,d)
#endif
#ifndef NAMED_SUBROUTINE
# define NAMED_SUBROUTINE(a,b,c,d)
#endif
/* The arguments to NAMED_*CST are:
-- an internal name
-- the symbol name in the module, as seen by Fortran code
@ -165,26 +169,26 @@ DERIVED_TYPE (ISOCBINDING_FUNPTR, "c_funptr", \
DERIVED_TYPE (ISOCBINDING_NULL_FUNPTR, "c_null_funptr", \
get_int_kind_from_node (ptr_type_node))
#ifndef PROCEDURE
# define PROCEDURE(a,b)
#endif
PROCEDURE (ISOCBINDING_F_POINTER, "c_f_pointer")
PROCEDURE (ISOCBINDING_ASSOCIATED, "c_associated")
PROCEDURE (ISOCBINDING_LOC, "c_loc")
PROCEDURE (ISOCBINDING_FUNLOC, "c_funloc")
PROCEDURE (ISOCBINDING_F_PROCPOINTER, "c_f_procpointer")
/* The arguments to NAMED_FUNCTIONS are:
/* The arguments to NAMED_FUNCTIONS and NAMED_SUBROUTINES are:
-- the ISYM
-- the symbol name in the module, as seen by Fortran code
-- the Fortran standard */
NAMED_SUBROUTINE (ISOCBINDING_F_POINTER, "c_f_pointer",
GFC_ISYM_C_F_POINTER, GFC_STD_F2003)
NAMED_SUBROUTINE (ISOCBINDING_F_PROCPOINTER, "c_f_procpointer",
GFC_ISYM_C_F_PROCPOINTER, GFC_STD_F2003)
NAMED_FUNCTION (ISOCBINDING_ASSOCIATED, "c_associated",
GFC_ISYM_C_ASSOCIATED, GFC_STD_F2003)
NAMED_FUNCTION (ISOCBINDING_FUNLOC, "c_funloc",
GFC_ISYM_C_FUNLOC, GFC_STD_F2003)
NAMED_FUNCTION (ISOCBINDING_LOC, "c_loc",
GFC_ISYM_C_LOC, GFC_STD_F2003)
NAMED_FUNCTION (ISOCBINDING_C_SIZEOF, "c_sizeof", \
GFC_ISYM_C_SIZEOF, GFC_STD_F2008)
#undef NAMED_INTCST
#undef NAMED_REALCST
#undef NAMED_CMPXCST
@ -192,5 +196,5 @@ NAMED_FUNCTION (ISOCBINDING_C_SIZEOF, "c_sizeof", \
#undef NAMED_CHARCST
#undef NAMED_CHARKNDCST
#undef DERIVED_TYPE
#undef PROCEDURE
#undef NAMED_FUNCTION
#undef NAMED_SUBROUTINE

5
gcc/fortran/iso-fortran-env.def
View file

@ -27,6 +27,10 @@ along with GCC; see the file COPYING3. If not see
# define NAMED_KINDARRAY(a,b,c,d)
#endif
#ifndef NAMED_SUBROUTINE
# define NAMED_SUBROUTINE(a,b,c,d)
#endif
#ifndef NAMED_FUNCTION
# define NAMED_FUNCTION(a,b,c,d)
#endif
@ -120,4 +124,5 @@ NAMED_DERIVED_TYPE (ISOFORTRAN_LOCK_TYPE, "lock_type", \
#undef NAMED_INTCST
#undef NAMED_KINDARRAY
#undef NAMED_FUNCTION
#undef NAMED_SUBROUTINE
#undef NAMED_DERIVED_TYPE

206
gcc/fortran/module.c
View file

@ -5570,8 +5570,9 @@ gfc_dump_module (const char *name, int dump_flag)
static void
create_intrinsic_function (const char *name, gfc_isym_id id,
const char *modname, intmod_id module)
create_intrinsic_function (const char *name, int id,
const char *modname, intmod_id module,
bool subroutine, gfc_symbol *result_type)
{
gfc_intrinsic_sym *isym;
gfc_symtree *tmp_symtree;
@ -5588,7 +5589,30 @@ create_intrinsic_function (const char *name, gfc_isym_id id,
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
sym = tmp_symtree->n.sym;
isym = gfc_intrinsic_function_by_id (id);
if (subroutine)
{
gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
isym = gfc_intrinsic_subroutine_by_id (isym_id);
sym->attr.subroutine = 1;
}
else
{
gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
isym = gfc_intrinsic_function_by_id (isym_id);
sym->attr.function = 1;
if (result_type)
{
sym->ts.type = BT_DERIVED;
sym->ts.u.derived = result_type;
sym->ts.is_c_interop = 1;
isym->ts.f90_type = BT_VOID;
isym->ts.type = BT_DERIVED;
isym->ts.f90_type = BT_VOID;
isym->ts.u.derived = result_type;
isym->ts.is_c_interop = 1;
}
}
gcc_assert (isym);
sym->attr.flavor = FL_PROCEDURE;
@ -5609,11 +5633,13 @@ create_intrinsic_function (const char *name, gfc_isym_id id,
static void
import_iso_c_binding_module (void)
{
gfc_symbol *mod_sym = NULL;
gfc_symtree *mod_symtree = NULL;
gfc_symbol *mod_sym = NULL, *return_type;
gfc_symtree *mod_symtree = NULL, *tmp_symtree;
gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
const char *iso_c_module_name = "__iso_c_binding";
gfc_use_rename *u;
int i;
bool want_c_ptr = false, want_c_funptr = false;
/* Look only in the current namespace. */
mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
@ -5636,6 +5662,57 @@ import_iso_c_binding_module (void)
mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
}
/* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
need C_(FUN)PTR. */
for (u = gfc_rename_list; u; u = u->next)
{
if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name,
u->use_name) == 0)
want_c_ptr = true;
else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name,
u->use_name) == 0)
want_c_ptr = true;
else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name,
u->use_name) == 0)
want_c_funptr = true;
else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name,
u->use_name) == 0)
want_c_funptr = true;
else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
u->use_name) == 0)
{
c_ptr = generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol)
ISOCBINDING_PTR,
u->local_name[0] ? u->local_name
: u->use_name,
NULL, false);
}
else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
u->use_name) == 0)
{
c_funptr
= generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol)
ISOCBINDING_FUNPTR,
u->local_name[0] ? u->local_name
: u->use_name,
NULL, false);
}
}
if ((want_c_ptr || !only_flag) && !c_ptr)
c_ptr = generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol)
ISOCBINDING_PTR,
NULL, NULL, only_flag);
if ((want_c_funptr || !only_flag) && !c_funptr)
c_funptr = generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol)
ISOCBINDING_FUNPTR,
NULL, NULL, only_flag);
/* Generate the symbols for the named constants representing
the kinds for intrinsic data types. */
for (i = 0; i < ISOCBINDING_NUMBER; i++)
@ -5656,29 +5733,27 @@ import_iso_c_binding_module (void)
not_in_std = (gfc_option.allow_std & d) == 0; \
name = b; \
break;
#include "iso-c-binding.def"
#undef NAMED_FUNCTION
#define NAMED_SUBROUTINE(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
name = b; \
break;
#define NAMED_INTCST(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
name = b; \
break;
#include "iso-c-binding.def"
#undef NAMED_INTCST
#define NAMED_REALCST(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
name = b; \
break;
#include "iso-c-binding.def"
#undef NAMED_REALCST
#define NAMED_CMPXCST(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
name = b; \
break;
#include "iso-c-binding.def"
#undef NAMED_CMPXCST
default:
not_in_std = false;
name = "";
@ -5694,21 +5769,44 @@ import_iso_c_binding_module (void)
switch (i)
{
#define NAMED_FUNCTION(a,b,c,d) \
case a: \
if (a == ISOCBINDING_LOC) \
return_type = c_ptr->n.sym; \
else if (a == ISOCBINDING_FUNLOC) \
return_type = c_funptr->n.sym; \
else \
return_type = NULL; \
create_intrinsic_function (u->local_name[0] \
? u->local_name : u->use_name, \
a, iso_c_module_name, \
INTMOD_ISO_C_BINDING, false, \
return_type); \
break;
#define NAMED_SUBROUTINE(a,b,c,d) \
case a: \
create_intrinsic_function (u->local_name[0] ? u->local_name \
: u->use_name, \
(gfc_isym_id) c, \
iso_c_module_name, \
INTMOD_ISO_C_BINDING); \
a, iso_c_module_name, \
INTMOD_ISO_C_BINDING, true, NULL); \
break;
#include "iso-c-binding.def"
#undef NAMED_FUNCTION
case ISOCBINDING_PTR:
case ISOCBINDING_FUNPTR:
/* Already handled above. */
break;
default:
if (i == ISOCBINDING_NULL_PTR)
tmp_symtree = c_ptr;
else if (i == ISOCBINDING_NULL_FUNPTR)
tmp_symtree = c_funptr;
else
tmp_symtree = NULL;
generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol) i,
u->local_name[0] ? u->local_name
: u->use_name);
u->local_name[0]
? u->local_name : u->use_name,
tmp_symtree, false);
}
}
@ -5722,30 +5820,27 @@ import_iso_c_binding_module (void)
if ((gfc_option.allow_std & d) == 0) \
continue; \
break;
#include "iso-c-binding.def"
#undef NAMED_FUNCTION
#define NAMED_SUBROUTINE(a,b,c,d) \
case a: \
if ((gfc_option.allow_std & d) == 0) \
continue; \
break;
#define NAMED_INTCST(a,b,c,d) \
case a: \
if ((gfc_option.allow_std & d) == 0) \
continue; \
break;
#include "iso-c-binding.def"
#undef NAMED_INTCST
#define NAMED_REALCST(a,b,c,d) \
case a: \
if ((gfc_option.allow_std & d) == 0) \
continue; \
break;
#include "iso-c-binding.def"
#undef NAMED_REALCST
#define NAMED_CMPXCST(a,b,c,d) \
case a: \
if ((gfc_option.allow_std & d) == 0) \
continue; \
break;
#include "iso-c-binding.def"
#undef NAMED_CMPXCST
default:
; /* Not GFC_STD_* versioned. */
}
@ -5754,16 +5849,37 @@ import_iso_c_binding_module (void)
{
#define NAMED_FUNCTION(a,b,c,d) \
case a: \
create_intrinsic_function (b, (gfc_isym_id) c, \
iso_c_module_name, \
INTMOD_ISO_C_BINDING); \
if (a == ISOCBINDING_LOC) \
return_type = c_ptr->n.sym; \
else if (a == ISOCBINDING_FUNLOC) \
return_type = c_funptr->n.sym; \
else \
return_type = NULL; \
create_intrinsic_function (b, a, iso_c_module_name, \
INTMOD_ISO_C_BINDING, false, \
return_type); \
break;
#define NAMED_SUBROUTINE(a,b,c,d) \
case a: \
create_intrinsic_function (b, a, iso_c_module_name, \
INTMOD_ISO_C_BINDING, true, NULL); \
break;
#include "iso-c-binding.def"
#undef NAMED_FUNCTION
case ISOCBINDING_PTR:
case ISOCBINDING_FUNPTR:
/* Already handled above. */
break;
default:
if (i == ISOCBINDING_NULL_PTR)
tmp_symtree = c_ptr;
else if (i == ISOCBINDING_NULL_FUNPTR)
tmp_symtree = c_funptr;
else
tmp_symtree = NULL;
generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol) i, NULL);
(iso_c_binding_symbol) i, NULL,
tmp_symtree, false);
}
}
}
@ -5917,23 +6033,16 @@ use_iso_fortran_env_module (void)
intmod_sym symbol[] = {
#define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
#include "iso-fortran-env.def"
#undef NAMED_INTCST
#define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
#include "iso-fortran-env.def"
#undef NAMED_KINDARRAY
#define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
#include "iso-fortran-env.def"
#undef NAMED_DERIVED_TYPE
#define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
#define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
#include "iso-fortran-env.def"
#undef NAMED_FUNCTION
{ ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
i = 0;
#define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
#include "iso-fortran-env.def"
#undef NAMED_INTCST
/* Generate the symbol for the module itself. */
mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
@ -5985,7 +6094,6 @@ use_iso_fortran_env_module (void)
#define NAMED_INTCST(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
#undef NAMED_INTCST
create_int_parameter (u->local_name[0] ? u->local_name
: u->use_name,
symbol[i].value, mod,
@ -6008,7 +6116,6 @@ use_iso_fortran_env_module (void)
symbol[i].id); \
break;
#include "iso-fortran-env.def"
#undef NAMED_KINDARRAY
#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
case a:
@ -6018,16 +6125,15 @@ use_iso_fortran_env_module (void)
mod, INTMOD_ISO_FORTRAN_ENV,
symbol[i].id);
break;
#undef NAMED_DERIVED_TYPE
#define NAMED_FUNCTION(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
#undef NAMED_FUNCTION
create_intrinsic_function (u->local_name[0] ? u->local_name
: u->use_name,
(gfc_isym_id) symbol[i].value, mod,
INTMOD_ISO_FORTRAN_ENV);
symbol[i].id, mod,
INTMOD_ISO_FORTRAN_ENV, false,
NULL);
break;
default:
@ -6054,7 +6160,6 @@ use_iso_fortran_env_module (void)
#define NAMED_INTCST(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
#undef NAMED_INTCST
create_int_parameter (symbol[i].name, symbol[i].value, mod,
INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
break;
@ -6071,7 +6176,6 @@ use_iso_fortran_env_module (void)
INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
break;
#include "iso-fortran-env.def"
#undef NAMED_KINDARRAY
#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
case a:
@ -6079,15 +6183,13 @@ use_iso_fortran_env_module (void)
create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
symbol[i].id);
break;
#undef NAMED_DERIVED_TYPE
#define NAMED_FUNCTION(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
#undef NAMED_FUNCTION
create_intrinsic_function (symbol[i].name,
(gfc_isym_id) symbol[i].value, mod,
INTMOD_ISO_FORTRAN_ENV);
create_intrinsic_function (symbol[i].name, symbol[i].id, mod,
INTMOD_ISO_FORTRAN_ENV, false,
NULL);
break;
default:

612
gcc/fortran/resolve.c
View file

@ -520,7 +520,7 @@ static void
find_arglists (gfc_symbol *sym)
{
if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
|| sym->attr.flavor == FL_DERIVED)
|| sym->attr.flavor == FL_DERIVED || sym->attr.intrinsic)
return;
resolve_formal_arglist (sym);
@ -1038,23 +1038,6 @@ resolve_structure_cons (gfc_expr *expr, int init)
cons = gfc_constructor_first (expr->value.constructor);
/* See if the user is trying to invoke a structure constructor for one of
the iso_c_binding derived types. */
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
&& expr->ts.u.derived->ts.is_iso_c && cons
&& (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
{
gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
expr->ts.u.derived->name, &(expr->where));
return FAILURE;
}
/* Return if structure constructor is c_null_(fun)prt. */
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
&& expr->ts.u.derived->ts.is_iso_c && cons
&& cons->expr && cons->expr->expr_type == EXPR_NULL)
return SUCCESS;
/* A constructor may have references if it is the result of substituting a
parameter variable. In this case we just pull out the component we
want. */
@ -1180,7 +1163,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
if (cons->expr->expr_type == EXPR_NULL
&& !(comp->attr.pointer || comp->attr.allocatable
|| comp->attr.proc_pointer
|| comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
|| (comp->ts.type == BT_CLASS
&& (CLASS_DATA (comp)->attr.class_pointer
|| CLASS_DATA (comp)->attr.allocatable))))
@ -1562,12 +1545,20 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
gfc_find_subroutine directly to check whether it is a function or
subroutine. */
if (sym->intmod_sym_id)
isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
if (sym->intmod_sym_id && sym->attr.subroutine)
{
gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
isym = gfc_intrinsic_subroutine_by_id (id);
}
else if (sym->intmod_sym_id)
{
gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
isym = gfc_intrinsic_function_by_id (id);
}
else if (!sym->attr.subroutine)
isym = gfc_find_function (sym->name);
if (isym)
if (isym && !sym->attr.subroutine)
{
if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
&& !sym->attr.implicit_type)
@ -1580,7 +1571,7 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
sym->ts = isym->ts;
}
else if ((isym = gfc_find_subroutine (sym->name)))
else if (isym || (isym = gfc_find_subroutine (sym->name)))
{
if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
{
@ -2719,366 +2710,6 @@ pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
}
static gfc_try
is_scalar_expr_ptr (gfc_expr *expr)
{
gfc_try retval = SUCCESS;
gfc_ref *ref;
int start;
int end;
/* See if we have a gfc_ref, which means we have a substring, array
reference, or a component. */
if (expr->ref != NULL)
{
ref = expr->ref;
while (ref->next != NULL)
ref = ref->next;
switch (ref->type)
{
case REF_SUBSTRING:
if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
|| gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
retval = FAILURE;
break;
case REF_ARRAY:
if (ref->u.ar.type == AR_ELEMENT)
retval = SUCCESS;
else if (ref->u.ar.type == AR_FULL)
{
/* The user can give a full array if the array is of size 1. */
if (ref->u.ar.as != NULL
&& ref->u.ar.as->rank == 1
&& ref->u.ar.as->type == AS_EXPLICIT
&& ref->u.ar.as->lower[0] != NULL
&& ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
&& ref->u.ar.as->upper[0] != NULL
&& ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
{
/* If we have a character string, we need to check if
its length is one. */
if (expr->ts.type == BT_CHARACTER)
{
if (expr->ts.u.cl == NULL
|| expr->ts.u.cl->length == NULL
|| mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
!= 0)
retval = FAILURE;
}
else
{
/* We have constant lower and upper bounds. If the
difference between is 1, it can be considered a
scalar.
FIXME: Use gfc_dep_compare_expr instead. */
start = (int) mpz_get_si
(ref->u.ar.as->lower[0]->value.integer);
end = (int) mpz_get_si
(ref->u.ar.as->upper[0]->value.integer);
if (end - start + 1 != 1)
retval = FAILURE;
}
}
else
retval = FAILURE;
}
else
retval = FAILURE;
break;
default:
retval = SUCCESS;
break;
}
}
else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
{
/* Character string. Make sure it's of length 1. */
if (expr->ts.u.cl == NULL
|| expr->ts.u.cl->length == NULL
|| mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
retval = FAILURE;
}
else if (expr->rank != 0)
retval = FAILURE;
return retval;
}
/* Match one of the iso_c_binding functions (c_associated or c_loc)
and, in the case of c_associated, set the binding label based on
the arguments. */
static gfc_try
gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
gfc_symbol **new_sym)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
int optional_arg = 0;
gfc_try retval = SUCCESS;
gfc_symbol *args_sym;
gfc_typespec *arg_ts;
symbol_attribute arg_attr;
if (args->expr->expr_type == EXPR_CONSTANT
|| args->expr->expr_type == EXPR_OP
|| args->expr->expr_type == EXPR_NULL)
{
gfc_error ("Argument to '%s' at %L is not a variable",
sym->name, &(args->expr->where));
return FAILURE;
}
args_sym = args->expr->symtree->n.sym;
/* The typespec for the actual arg should be that stored in the expr
and not necessarily that of the expr symbol (args_sym), because
the actual expression could be a part-ref of the expr symbol. */
arg_ts = &(args->expr->ts);
arg_attr = gfc_expr_attr (args->expr);
if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
/* If the user gave two args then they are providing something for
the optional arg (the second cptr). Therefore, set the name and
binding label to the c_associated for two cptrs. Otherwise,
set c_associated to expect one cptr. */
if (args->next)
{
/* two args. */
sprintf (name, "%s_2", sym->name);
optional_arg = 1;
}
else
{
/* one arg. */
sprintf (name, "%s_1", sym->name);
optional_arg = 0;
}
/* Get a new symbol for the version of c_associated that
will get called. */
*new_sym = get_iso_c_sym (sym, name, NULL, optional_arg);
}
else if (sym->intmod_sym_id == ISOCBINDING_LOC
|| sym->intmod_sym_id == ISOCBINDING_FUNLOC)
{
sprintf (name, "%s", sym->name);
/* Error check the call. */
if (args->next != NULL)
{
gfc_error_now ("More actual than formal arguments in '%s' "
"call at %L", name, &(args->expr->where));
retval = FAILURE;
}
else if (sym->intmod_sym_id == ISOCBINDING_LOC)
{
gfc_ref *ref;
bool seen_section;
/* Make sure we have either the target or pointer attribute. */
if (!arg_attr.target && !arg_attr.pointer)
{
gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
"a TARGET or an associated pointer",
args_sym->name,
sym->name, &(args->expr->where));
retval = FAILURE;
}
if (gfc_is_coindexed (args->expr))
{
gfc_error_now ("Coindexed argument not permitted"
" in '%s' call at %L", name,
&(args->expr->where));
retval = FAILURE;
}
/* Follow references to make sure there are no array
sections. */
seen_section = false;
for (ref=args->expr->ref; ref; ref = ref->next)
{
if (ref->type == REF_ARRAY)
{
if (ref->u.ar.type == AR_SECTION)
seen_section = true;
if (ref->u.ar.type != AR_ELEMENT)
{
gfc_ref *r;
for (r = ref->next; r; r=r->next)
if (r->type == REF_COMPONENT)
{
gfc_error_now ("Array section not permitted"
" in '%s' call at %L", name,
&(args->expr->where));
retval = FAILURE;
break;
}
}
}
}
if (seen_section && retval == SUCCESS)
gfc_warning ("Array section in '%s' call at %L", name,
&(args->expr->where));
/* See if we have interoperable type and type param. */
if (gfc_verify_c_interop (arg_ts) == SUCCESS
|| gfc_check_any_c_kind (arg_ts) == SUCCESS)
{
if (args_sym->attr.target == 1)
{
/* Case 1a, section 15.1.2.5, J3/04-007: variable that
has the target attribute and is interoperable. */
/* Case 1b, section 15.1.2.5, J3/04-007: allocated
allocatable variable that has the TARGET attribute and
is not an array of zero size. */
if (args_sym->attr.allocatable == 1)
{
if (args_sym->attr.dimension != 0
&& (args_sym->as && args_sym->as->rank == 0))
{
gfc_error_now ("Allocatable variable '%s' used as a "
"parameter to '%s' at %L must not be "
"an array of zero size",
args_sym->name, sym->name,
&(args->expr->where));
retval = FAILURE;
}
}
else
{
/* A non-allocatable target variable with C
interoperable type and type parameters must be
interoperable. */
if (args_sym && args_sym->attr.dimension)
{
if (args_sym->as->type == AS_ASSUMED_SHAPE)
{
gfc_error ("Assumed-shape array '%s' at %L "
"cannot be an argument to the "
"procedure '%s' because "
"it is not C interoperable",
args_sym->name,
&(args->expr->where), sym->name);
retval = FAILURE;
}
else if (args_sym->as->type == AS_DEFERRED)
{
gfc_error ("Deferred-shape array '%s' at %L "
"cannot be an argument to the "
"procedure '%s' because "
"it is not C interoperable",
args_sym->name,
&(args->expr->where), sym->name);
retval = FAILURE;
}
}
/* Make sure it's not a character string. Arrays of
any type should be ok if the variable is of a C
interoperable type. */
if (arg_ts->type == BT_CHARACTER)
if (arg_ts->u.cl != NULL
&& (arg_ts->u.cl->length == NULL
|| arg_ts->u.cl->length->expr_type
!= EXPR_CONSTANT
|| mpz_cmp_si
(arg_ts->u.cl->length->value.integer, 1)
!= 0)
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
gfc_error_now ("CHARACTER argument '%s' to '%s' "
"at %L must have a length of 1",
args_sym->name, sym->name,
&(args->expr->where));
retval = FAILURE;
}
}
}
else if (arg_attr.pointer
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
/* Case 1c, section 15.1.2.5, J3/04-007: an associated
scalar pointer. */
gfc_error_now ("Argument '%s' to '%s' at %L must be an "
"associated scalar POINTER", args_sym->name,
sym->name, &(args->expr->where));
retval = FAILURE;
}
}
else
{
/* The parameter is not required to be C interoperable. If it
is not C interoperable, it must be a nonpolymorphic scalar
with no length type parameters. It still must have either
the pointer or target attribute, and it can be
allocatable (but must be allocated when c_loc is called). */
if (args->expr->rank != 0
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
"scalar", args_sym->name, sym->name,
&(args->expr->where));
retval = FAILURE;
}
else if (arg_ts->type == BT_CHARACTER
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
gfc_error_now ("CHARACTER argument '%s' to '%s' at "
"%L must have a length of 1",
args_sym->name, sym->name,
&(args->expr->where));
retval = FAILURE;
}
else if (arg_ts->type == BT_CLASS)
{
gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
"polymorphic", args_sym->name, sym->name,
&(args->expr->where));
retval = FAILURE;
}
}
}
else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
{
if (args_sym->attr.flavor != FL_PROCEDURE)
{
/* TODO: Update this error message to allow for procedure
pointers once they are implemented. */
gfc_error_now ("Argument '%s' to '%s' at %L must be a "
"procedure",
args_sym->name, sym->name,
&(args->expr->where));
retval = FAILURE;
}
else if (args_sym->attr.is_bind_c != 1
&& gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
"argument '%s' to '%s' at %L",
args_sym->name, sym->name,
&(args->expr->where)) == FAILURE)
retval = FAILURE;
}
/* for c_loc/c_funloc, the new symbol is the same as the old one */
*new_sym = sym;
}
else
{
gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
"iso_c_binding function: '%s'!\n", sym->name);
}
return retval;
}
/* Resolve a function call, which means resolving the arguments, then figuring
out which entity the name refers to. */
@ -3141,19 +2772,6 @@ resolve_function (gfc_expr *expr)
inquiry_argument = false;
/* Need to setup the call to the correct c_associated, depending on
the number of cptrs to user gives to compare. */
if (sym && sym->attr.is_iso_c == 1)
{
if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
== FAILURE)
return FAILURE;
/* Get the symtree for the new symbol (resolved func).
the old one will be freed later, when it's no longer used. */
gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
}
/* Resume assumed_size checking. */
need_full_assumed_size--;
@ -3236,6 +2854,7 @@ resolve_function (gfc_expr *expr)
&& GENERIC_ID != GFC_ISYM_LBOUND
&& GENERIC_ID != GFC_ISYM_LEN
&& GENERIC_ID != GFC_ISYM_LOC
&& GENERIC_ID != GFC_ISYM_C_LOC
&& GENERIC_ID != GFC_ISYM_PRESENT)
{
/* Array intrinsics must also have the last upper bound of an
@ -3438,190 +3057,6 @@ generic:
}
/* Set the name and binding label of the subroutine symbol in the call
expression represented by 'c' to include the type and kind of the
second parameter. This function is for resolving the appropriate
version of c_f_pointer() and c_f_procpointer(). For example, a
call to c_f_pointer() for a default integer pointer could have a
name of c_f_pointer_i4. If no second arg exists, which is an error
for these two functions, it defaults to the generic symbol's name
and binding label. */
static void
set_name_and_label (gfc_code *c, gfc_symbol *sym,
char *name, const char **binding_label)
{
gfc_expr *arg = NULL;
char type;
int kind;
/* The second arg of c_f_pointer and c_f_procpointer determines
the type and kind for the procedure name. */
arg = c->ext.actual->next->expr;
if (arg != NULL)
{
/* Set up the name to have the given symbol's name,
plus the type and kind. */
/* a derived type is marked with the type letter 'u' */
if (arg->ts.type == BT_DERIVED)
{
type = 'd';
kind = 0; /* set the kind as 0 for now */
}
else
{
type = gfc_type_letter (arg->ts.type);
kind = arg->ts.kind;
}
if (arg->ts.type == BT_CHARACTER)
/* Kind info for character strings not needed. */
kind = 0;
sprintf (name, "%s_%c%d", sym->name, type, kind);
/* Set up the binding label as the given symbol's label plus
the type and kind. */
*binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
kind);
}
else
{
/* If the second arg is missing, set the name and label as
was, cause it should at least be found, and the missing
arg error will be caught by compare_parameters(). */
sprintf (name, "%s", sym->name);
*binding_label = sym->binding_label;
}
return;
}
/* Resolve a generic version of the iso_c_binding procedure given
(sym) to the specific one based on the type and kind of the
argument(s). Currently, this function resolves c_f_pointer() and
c_f_procpointer based on the type and kind of the second argument
(FPTR). Other iso_c_binding procedures aren't specially handled.
Upon successfully exiting, c->resolved_sym will hold the resolved
symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
otherwise. */
match
gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
{
gfc_symbol *new_sym;
/* this is fine, since we know the names won't use the max */
char name[GFC_MAX_SYMBOL_LEN + 1];
const char* binding_label;
/* default to success; will override if find error */
match m = MATCH_YES;
/* Make sure the actual arguments are in the necessary order (based on the
formal args) before resolving. */
if (gfc_procedure_use (sym, &c->ext.actual, &(c->loc)) == FAILURE)
{
c->resolved_sym = sym;
return MATCH_ERROR;
}
if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
(sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
{
set_name_and_label (c, sym, name, &binding_label);
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
{
if (c->ext.actual != NULL && c->ext.actual->next != NULL)
{
gfc_actual_arglist *arg1 = c->ext.actual;
gfc_actual_arglist *arg2 = c->ext.actual->next;
gfc_actual_arglist *arg3 = c->ext.actual->next->next;
/* Check first argument (CPTR). */
if (arg1->expr->ts.type != BT_DERIVED
|| arg1->expr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
{
gfc_error ("Argument CPTR to C_F_POINTER at %L shall have "
"the type C_PTR", &arg1->expr->where);
m = MATCH_ERROR;
}
/* Check second argument (FPTR). */
if (arg2->expr->ts.type == BT_CLASS)
{
gfc_error ("Argument FPTR to C_F_POINTER at %L must not be "
"polymorphic", &arg2->expr->where);
m = MATCH_ERROR;
}
/* Make sure we got a third arg (SHAPE) if the second arg has
non-zero rank. We must also check that the type and rank are
correct since we short-circuit this check in
gfc_procedure_use() (called above to sort actual args). */
if (arg2->expr->rank != 0)
{
if (arg3 == NULL || arg3->expr == NULL)
{
m = MATCH_ERROR;
gfc_error ("Missing SHAPE argument for call to %s at %L",
sym->name, &c->loc);
}
else if (arg3->expr->ts.type != BT_INTEGER
|| arg3->expr->rank != 1)
{
m = MATCH_ERROR;
gfc_error ("SHAPE argument for call to %s at %L must be "
"a rank 1 INTEGER array", sym->name, &c->loc);
}
}
}
}
else /* ISOCBINDING_F_PROCPOINTER. */
{
if (c->ext.actual
&& (c->ext.actual->expr->ts.type != BT_DERIVED
|| c->ext.actual->expr->ts.u.derived->intmod_sym_id
!= ISOCBINDING_FUNPTR))
{
gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type "
"C_FUNPTR", &c->ext.actual->expr->where);
m = MATCH_ERROR;
}
if (c->ext.actual && c->ext.actual->next
&& !gfc_expr_attr (c->ext.actual->next->expr).is_bind_c
&& gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
"procedure-pointer at %L to C_F_FUNPOINTER",
&c->ext.actual->next->expr->where)
== FAILURE)
m = MATCH_ERROR;
}
if (m != MATCH_ERROR)
{
/* the 1 means to add the optional arg to formal list */
new_sym = get_iso_c_sym (sym, name, binding_label, 1);
/* for error reporting, say it's declared where the original was */
new_sym->declared_at = sym->declared_at;
}
}
else
{
/* no differences for c_loc or c_funloc */
new_sym = sym;
}
/* set the resolved symbol */
if (m != MATCH_ERROR)
c->resolved_sym = new_sym;
else
c->resolved_sym = sym;
return m;
}
/* Resolve a subroutine call known to be specific. */
static match
@ -3629,12 +3064,6 @@ resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
{
match m;
if(sym->attr.is_iso_c)
{
m = gfc_iso_c_sub_interface (c,sym);
return m;
}
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
{
if (sym->attr.dummy)
@ -8767,7 +8196,16 @@ resolve_transfer (gfc_code *code)
return;
}
if (derived_inaccessible (ts->u.derived))
/* C_PTR and C_FUNPTR have private components which means they can not
be printed. However, if -std=gnu and not -pedantic, allow
the component to be printed to help debugging. */
if (ts->u.derived->ts.f90_type == BT_VOID)
{
if (gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L cannot "
"have PRIVATE components", &code->loc) == FAILURE)
return;
}
else if (derived_inaccessible (ts->u.derived))
{
gfc_error ("Data transfer element at %L cannot have "
"PRIVATE components",&code->loc);

615
gcc/fortran/symbol.c
View file

@ -3939,75 +3939,32 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
static gfc_try
gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
const char *module_name)
gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree)
{
gfc_symtree *tmp_symtree;
gfc_symbol *tmp_sym;
gfc_constructor *c;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
if (tmp_symtree != NULL)
tmp_sym = tmp_symtree->n.sym;
else
{
tmp_sym = NULL;
gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
"create symbol for %s", ptr_name);
}
gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym);
dt_symtree->n.sym->attr.referenced = 1;
tmp_sym->ts.is_c_interop = 1;
tmp_sym->attr.is_c_interop = 1;
tmp_sym->attr.is_bind_c = 1;
tmp_sym->ts.is_c_interop = 1;
tmp_sym->ts.is_iso_c = 1;
tmp_sym->ts.type = BT_DERIVED;
tmp_sym->ts.f90_type = BT_VOID;
tmp_sym->attr.flavor = FL_PARAMETER;
/* The c_ptr and c_funptr derived types will provide the
definition for c_null_ptr and c_null_funptr, respectively. */
if (ptr_id == ISOCBINDING_NULL_PTR)
tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
else
tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
if (tmp_sym->ts.u.derived == NULL)
{
/* This can occur if the user forgot to declare c_ptr or
c_funptr and they're trying to use one of the procedures
that has arg(s) of the missing type. In this case, a
regular version of the thing should have been put in the
current ns. */
generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
(const char *) (ptr_id == ISOCBINDING_NULL_PTR
? "c_ptr"
: "c_funptr"));
tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
}
/* Module name is some mangled version of iso_c_binding. */
tmp_sym->module = gfc_get_string (module_name);
/* Say it's from the iso_c_binding module. */
tmp_sym->attr.is_iso_c = 1;
tmp_sym->attr.use_assoc = 1;
tmp_sym->attr.is_bind_c = 1;
/* Since we never generate a call to this symbol, don't set the
binding_label. */
tmp_sym->ts.u.derived = dt_symtree->n.sym;
/* Set the c_address field of c_null_ptr and c_null_funptr to
the value of NULL. */
tmp_sym->value = gfc_get_expr ();
tmp_sym->value->expr_type = EXPR_STRUCTURE;
tmp_sym->value->ts.type = BT_DERIVED;
tmp_sym->value->ts.f90_type = BT_VOID;
tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
c = gfc_constructor_first (tmp_sym->value->value.constructor);
c->expr = gfc_get_expr ();
c->expr->expr_type = EXPR_NULL;
c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
c->expr->ts.is_iso_c = 1;
return SUCCESS;
@ -4040,200 +3997,6 @@ add_formal_arg (gfc_formal_arglist **head,
}
/* Generates a symbol representing the CPTR argument to an
iso_c_binding procedure. Also, create a gfc_formal_arglist for the
CPTR and add it to the provided argument list. */
static void
gen_cptr_param (gfc_formal_arglist **head,
gfc_formal_arglist **tail,
const char *module_name,
gfc_namespace *ns, const char *c_ptr_name,
int iso_c_sym_id)
{
gfc_symbol *param_sym = NULL;
gfc_symbol *c_ptr_sym = NULL;
gfc_symtree *param_symtree = NULL;
gfc_formal_arglist *formal_arg = NULL;
const char *c_ptr_in;
const char *c_ptr_type = NULL;
if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
c_ptr_type = "c_funptr";
else
c_ptr_type = "c_ptr";
if(c_ptr_name == NULL)
c_ptr_in = "gfc_cptr__";
else
c_ptr_in = c_ptr_name;
gfc_get_sym_tree (c_ptr_in, ns, &param_symtree, false);
if (param_symtree != NULL)
param_sym = param_symtree->n.sym;
else
gfc_internal_error ("gen_cptr_param(): Unable to "
"create symbol for %s", c_ptr_in);
/* Set up the appropriate fields for the new c_ptr param sym. */
param_sym->refs++;
param_sym->attr.flavor = FL_DERIVED;
param_sym->ts.type = BT_DERIVED;
param_sym->attr.intent = INTENT_IN;
param_sym->attr.dummy = 1;
/* This will pass the ptr to the iso_c routines as a (void *). */
param_sym->attr.value = 1;
param_sym->attr.use_assoc = 1;
/* Get the symbol for c_ptr or c_funptr, no matter what it's name is
(user renamed). */
if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
else
c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
if (c_ptr_sym == NULL)
{
/* This can happen if the user did not define c_ptr but they are
trying to use one of the iso_c_binding functions that need it. */
if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
(const char *)c_ptr_type);
else
generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
(const char *)c_ptr_type);
gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
}
param_sym->ts.u.derived = c_ptr_sym;
param_sym->module = gfc_get_string (module_name);
/* Make new formal arg. */
formal_arg = gfc_get_formal_arglist ();
/* Add arg to list of formal args (the CPTR arg). */
add_formal_arg (head, tail, formal_arg, param_sym);
/* Validate changes. */
gfc_commit_symbol (param_sym);
}
/* Generates a symbol representing the FPTR argument to an
iso_c_binding procedure. Also, create a gfc_formal_arglist for the
FPTR and add it to the provided argument list. */
static void
gen_fptr_param (gfc_formal_arglist **head,
gfc_formal_arglist **tail,
const char *module_name,
gfc_namespace *ns, const char *f_ptr_name, int proc)
{
gfc_symbol *param_sym = NULL;
gfc_symtree *param_symtree = NULL;
gfc_formal_arglist *formal_arg = NULL;
const char *f_ptr_out = "gfc_fptr__";
if (f_ptr_name != NULL)
f_ptr_out = f_ptr_name;
gfc_get_sym_tree (f_ptr_out, ns, &param_symtree, false);
if (param_symtree != NULL)
param_sym = param_symtree->n.sym;
else
gfc_internal_error ("generateFPtrParam(): Unable to "
"create symbol for %s", f_ptr_out);
/* Set up the necessary fields for the fptr output param sym. */
param_sym->refs++;
if (proc)
param_sym->attr.proc_pointer = 1;
else
param_sym->attr.pointer = 1;
param_sym->attr.dummy = 1;
param_sym->attr.use_assoc = 1;
/* ISO C Binding type to allow any pointer type as actual param. */
param_sym->ts.type = BT_VOID;
param_sym->module = gfc_get_string (module_name);
/* Make the arg. */
formal_arg = gfc_get_formal_arglist ();
/* Add arg to list of formal args. */
add_formal_arg (head, tail, formal_arg, param_sym);
/* Validate changes. */
gfc_commit_symbol (param_sym);
}
/* Generates a symbol representing the optional SHAPE argument for the
iso_c_binding c_f_pointer() procedure. Also, create a
gfc_formal_arglist for the SHAPE and add it to the provided
argument list. */
static void
gen_shape_param (gfc_formal_arglist **head,
gfc_formal_arglist **tail,
const char *module_name,
gfc_namespace *ns, const char *shape_param_name)
{
gfc_symbol *param_sym = NULL;
gfc_symtree *param_symtree = NULL;
gfc_formal_arglist *formal_arg = NULL;
const char *shape_param = "gfc_shape_array__";
if (shape_param_name != NULL)
shape_param = shape_param_name;
gfc_get_sym_tree (shape_param, ns, &param_symtree, false);
if (param_symtree != NULL)
param_sym = param_symtree->n.sym;
else
gfc_internal_error ("generateShapeParam(): Unable to "
"create symbol for %s", shape_param);
/* Set up the necessary fields for the shape input param sym. */
param_sym->refs++;
param_sym->attr.dummy = 1;
param_sym->attr.use_assoc = 1;
/* Integer array, rank 1, describing the shape of the object. Make it's
type BT_VOID initially so we can accept any type/kind combination of
integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
of BT_INTEGER type. */
param_sym->ts.type = BT_VOID;
/* Initialize the kind to default integer. However, it will be overridden
during resolution to match the kind of the SHAPE parameter given as
the actual argument (to allow for any valid integer kind). */
param_sym->ts.kind = gfc_default_integer_kind;
param_sym->as = gfc_get_array_spec ();
param_sym->as->rank = 1;
param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
NULL, 1);
/* The extent is unknown until we get it. The length give us
the rank the incoming pointer. */
param_sym->as->type = AS_ASSUMED_SHAPE;
/* The arg is also optional; it is required iff the second arg
(fptr) is to an array, otherwise, it's ignored. */
param_sym->attr.optional = 1;
param_sym->attr.intent = INTENT_IN;
param_sym->attr.dimension = 1;
param_sym->module = gfc_get_string (module_name);
/* Make the arg. */
formal_arg = gfc_get_formal_arglist ();
/* Add arg to list of formal args. */
add_formal_arg (head, tail, formal_arg, param_sym);
/* Validate changes. */
gfc_commit_symbol (param_sym);
}
/* Add a procedure interface to the given symbol (i.e., store a
reference to the list of formal arguments). */
@ -4314,74 +4077,6 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
}
/* Builds the parameter list for the iso_c_binding procedure
c_f_pointer or c_f_procpointer. The old_sym typically refers to a
generic version of either the c_f_pointer or c_f_procpointer
functions. The new_proc_sym represents a "resolved" version of the
symbol. The functions are resolved to match the types of their
parameters; for example, c_f_pointer(cptr, fptr) would resolve to
something similar to c_f_pointer_i4 if the type of data object fptr
pointed to was a default integer. The actual name of the resolved
procedure symbol is further mangled with the module name, etc., but
the idea holds true. */
static void
build_formal_args (gfc_symbol *new_proc_sym,
gfc_symbol *old_sym, int add_optional_arg)
{
gfc_formal_arglist *head = NULL, *tail = NULL;
gfc_namespace *parent_ns = NULL;
parent_ns = gfc_current_ns;
/* Create a new namespace, which will be the formal ns (namespace
of the formal args). */
gfc_current_ns = gfc_get_namespace(parent_ns, 0);
gfc_current_ns->proc_name = new_proc_sym;
/* Generate the params. */
if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
{
gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
gfc_current_ns, "cptr", old_sym->intmod_sym_id);
gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
gfc_current_ns, "fptr", 1);
}
else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
{
gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
gfc_current_ns, "cptr", old_sym->intmod_sym_id);
gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
gfc_current_ns, "fptr", 0);
/* If we're dealing with c_f_pointer, it has an optional third arg. */
gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
gfc_current_ns, "shape");
}
else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
/* c_associated has one required arg and one optional; both
are c_ptrs. */
gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
if (add_optional_arg)
{
gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
/* The last param is optional so mark it as such. */
tail->sym->attr.optional = 1;
}
}
/* Add the interface (store formal args to new_proc_sym). */
add_proc_interface (new_proc_sym, IFSRC_DECL, head);
/* Set up the formal_ns pointer to the one created for the
new procedure so it'll get cleaned up during gfc_free_symbol(). */
new_proc_sym->formal_ns = gfc_current_ns;
gfc_current_ns = parent_ns;
}
static int
std_for_isocbinding_symbol (int id)
{
@ -4396,8 +4091,12 @@ std_for_isocbinding_symbol (int id)
#define NAMED_FUNCTION(a,b,c,d) \
case a:\
return d;
#define NAMED_SUBROUTINE(a,b,c,d) \
case a:\
return d;
#include "iso-c-binding.def"
#undef NAMED_FUNCTION
#undef NAMED_SUBROUTINE
default:
return GFC_STD_F2003;
@ -4412,23 +4111,29 @@ std_for_isocbinding_symbol (int id)
reported. If the user does not give an 'only' clause, all
iso_c_binding symbols are generated. If a list of specific kinds
is given, it must have a NULL in the first empty spot to mark the
end of the list. */
end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
point to the symtree for c_(fun)ptr. */
void
gfc_symtree *
generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
const char *local_name)
const char *local_name, gfc_symtree *dt_symtree,
bool hidden)
{
const char *const name = (local_name && local_name[0]) ? local_name
: c_interop_kinds_table[s].name;
gfc_symtree *tmp_symtree = NULL;
const char *const name = (local_name && local_name[0])
? local_name : c_interop_kinds_table[s].name;
gfc_symtree *tmp_symtree;
gfc_symbol *tmp_sym = NULL;
int index;
if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
return;
return NULL;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
if (hidden
&& (!tmp_symtree || !tmp_symtree->n.sym
|| tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING
|| tmp_symtree->n.sym->intmod_sym_id != s))
tmp_symtree = NULL;
/* Already exists in this scope so don't re-add it. */
if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
@ -4446,21 +4151,40 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
gfc_derived_types = dt_list;
}
return;
return tmp_symtree;
}
/* Create the sym tree in the current ns. */
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
if (tmp_symtree)
tmp_sym = tmp_symtree->n.sym;
if (hidden)
{
tmp_symtree = gfc_get_unique_symtree (gfc_current_ns);
tmp_sym = gfc_new_symbol (name, gfc_current_ns);
/* Add to the list of tentative symbols. */
latest_undo_chgset->syms.safe_push (tmp_sym);
tmp_sym->old_symbol = NULL;
tmp_sym->mark = 1;
tmp_sym->gfc_new = 1;
tmp_symtree->n.sym = tmp_sym;
tmp_sym->refs++;
}
else
gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
"create symbol");
{
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
gcc_assert (tmp_symtree);
tmp_sym = tmp_symtree->n.sym;
}
/* Say what module this symbol belongs to. */
tmp_sym->module = gfc_get_string (mod_name);
tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
tmp_sym->intmod_sym_id = s;
tmp_sym->attr.is_iso_c = 1;
tmp_sym->attr.use_assoc = 1;
gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR
|| s == ISOCBINDING_NULL_PTR);
switch (s)
{
@ -4490,11 +4214,6 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
/* Tell what f90 type this c interop kind is valid. */
tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
/* Say it's from the iso_c_binding module. */
tmp_sym->attr.is_iso_c = 1;
/* Make it use associated. */
tmp_sym->attr.use_assoc = 1;
break;
@ -4531,70 +4250,69 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
/* Tell what f90 type this c interop kind is valid. */
tmp_sym->ts.f90_type = BT_CHARACTER;
/* Say it's from the iso_c_binding module. */
tmp_sym->attr.is_iso_c = 1;
/* Make it use associated. */
tmp_sym->attr.use_assoc = 1;
break;
case ISOCBINDING_PTR:
case ISOCBINDING_FUNPTR:
{
gfc_interface *intr, *head;
gfc_symbol *dt_sym;
const char *hidden_name;
gfc_dt_list **dt_list_ptr = NULL;
gfc_component *tmp_comp = NULL;
char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
hidden_name = gfc_get_string ("%c%s",
(char) TOUPPER ((unsigned char) tmp_sym->name[0]),
&tmp_sym->name[1]);
/* Generate real derived type. */
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
hidden_name);
if (tmp_symtree != NULL)
gcc_unreachable ();
gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
if (tmp_symtree)
dt_sym = tmp_symtree->n.sym;
if (hidden)
dt_sym = tmp_sym;
else
gcc_unreachable ();
{
const char *hidden_name;
gfc_interface *intr, *head;
/* Generate an artificial generic function. */
dt_sym->name = gfc_get_string (tmp_sym->name);
head = tmp_sym->generic;
intr = gfc_get_interface ();
intr->sym = dt_sym;
intr->where = gfc_current_locus;
intr->next = head;
tmp_sym->generic = intr;
hidden_name = gfc_get_string ("%c%s",
(char) TOUPPER ((unsigned char)
tmp_sym->name[0]),
&tmp_sym->name[1]);
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
hidden_name);
gcc_assert (tmp_symtree == NULL);
gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
dt_sym = tmp_symtree->n.sym;
dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR
? "c_ptr" : "c_funptr");
if (!tmp_sym->attr.generic
&& gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
== FAILURE)
return;
/* Generate an artificial generic function. */
head = tmp_sym->generic;
intr = gfc_get_interface ();
intr->sym = dt_sym;
intr->where = gfc_current_locus;
intr->next = head;
tmp_sym->generic = intr;
if (!tmp_sym->attr.function
&& gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
== FAILURE)
return;
if (!tmp_sym->attr.generic
&& gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
== FAILURE)
return NULL;
if (!tmp_sym->attr.function
&& gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
== FAILURE)
return NULL;
}
/* Say what module this symbol belongs to. */
dt_sym->module = gfc_get_string (mod_name);
dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
dt_sym->intmod_sym_id = s;
dt_sym->attr.use_assoc = 1;
/* Initialize an integer constant expression node. */
dt_sym->attr.flavor = FL_DERIVED;
dt_sym->ts.is_c_interop = 1;
dt_sym->attr.is_c_interop = 1;
dt_sym->attr.is_iso_c = 1;
dt_sym->attr.private_comp = 1;
dt_sym->component_access = ACCESS_PRIVATE;
dt_sym->ts.is_iso_c = 1;
dt_sym->ts.type = BT_DERIVED;
dt_sym->ts.f90_type = BT_VOID;
/* A derived type must have the bind attribute to be
interoperable (J3/04-007, Section 15.2.3), even though
@ -4617,15 +4335,9 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
(*dt_list_ptr)->derived = dt_sym;
(*dt_list_ptr)->next = NULL;
/* Set up the component of the derived type, which will be
an integer with kind equal to c_ptr_size. Mangle the name of
the field for the c_address to prevent the curious user from
trying to access it from Fortran. */
sprintf (comp_name, "__%s_%s", dt_sym->name, "c_address");
gfc_add_component (dt_sym, comp_name, &tmp_comp);
gfc_add_component (dt_sym, "c_address", &tmp_comp);
if (tmp_comp == NULL)
gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
"create component for c_address");
gcc_unreachable ();
tmp_comp->ts.type = BT_INTEGER;
@ -4635,163 +4347,24 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
/* The kinds for c_ptr and c_funptr are the same. */
index = get_c_kind ("c_ptr", c_interop_kinds_table);
tmp_comp->ts.kind = c_interop_kinds_table[index].value;
tmp_comp->attr.pointer = 0;
tmp_comp->attr.dimension = 0;
tmp_comp->attr.access = ACCESS_PRIVATE;
/* Mark the component as C interoperable. */
tmp_comp->ts.is_c_interop = 1;
/* Make it use associated (iso_c_binding module). */
dt_sym->attr.use_assoc = 1;
}
break;
case ISOCBINDING_NULL_PTR:
case ISOCBINDING_NULL_FUNPTR:
gen_special_c_interop_ptr (s, name, mod_name);
gen_special_c_interop_ptr (tmp_sym, dt_symtree);
break;
case ISOCBINDING_F_POINTER:
case ISOCBINDING_ASSOCIATED:
case ISOCBINDING_LOC:
case ISOCBINDING_FUNLOC:
case ISOCBINDING_F_PROCPOINTER:
tmp_sym->attr.proc = PROC_MODULE;
/* Use the procedure's name as it is in the iso_c_binding module for
setting the binding label in case the user renamed the symbol. */
tmp_sym->binding_label =
gfc_get_string ("%s_%s", mod_name,
c_interop_kinds_table[s].name);
tmp_sym->attr.is_iso_c = 1;
if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
tmp_sym->attr.subroutine = 1;
else
{
/* TODO! This needs to be finished more for the expr of the
function or something!
This may not need to be here, because trying to do c_loc
as an external. */
if (s == ISOCBINDING_ASSOCIATED)
{
tmp_sym->attr.function = 1;
tmp_sym->ts.type = BT_LOGICAL;
tmp_sym->ts.kind = gfc_default_logical_kind;
tmp_sym->result = tmp_sym;
}
else
{
/* Here, we're taking the simple approach. We're defining
c_loc as an external identifier so the compiler will put
what we expect on the stack for the address we want the
C address of. */
tmp_sym->ts.type = BT_DERIVED;
if (s == ISOCBINDING_LOC)
tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ISOCBINDING_PTR);
else
tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
if (tmp_sym->ts.u.derived == NULL)
{
/* Create the necessary derived type so we can continue
processing the file. */
generate_isocbinding_symbol
(mod_name, s == ISOCBINDING_FUNLOC
? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
(const char *)(s == ISOCBINDING_FUNLOC
? "c_funptr" : "c_ptr"));
tmp_sym->ts.u.derived =
get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR);
}
/* The function result is itself (no result clause). */
tmp_sym->result = tmp_sym;
tmp_sym->attr.external = 1;
tmp_sym->attr.use_assoc = 0;
tmp_sym->attr.pure = 1;
tmp_sym->attr.if_source = IFSRC_UNKNOWN;
tmp_sym->attr.proc = PROC_UNKNOWN;
}
}
tmp_sym->attr.flavor = FL_PROCEDURE;
tmp_sym->attr.contained = 0;
/* Try using this builder routine, with the new and old symbols
both being the generic iso_c proc sym being created. This
will create the formal args (and the new namespace for them).
Don't build an arg list for c_loc because we're going to treat
c_loc as an external procedure. */
if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
/* The 1 says to add any optional args, if applicable. */
build_formal_args (tmp_sym, tmp_sym, 1);
/* Set this after setting up the symbol, to prevent error messages. */
tmp_sym->attr.use_assoc = 1;
/* This symbol will not be referenced directly. It will be
resolved to the implementation for the given f90 kind. */
tmp_sym->attr.referenced = 0;
break;
default:
gcc_unreachable ();
}
gfc_commit_symbol (tmp_sym);
}
/* Creates a new symbol based off of an old iso_c symbol, with a new
binding label. This function can be used to create a new,
resolved, version of a procedure symbol for c_f_pointer or
c_f_procpointer that is based on the generic symbols. A new
parameter list is created for the new symbol using
build_formal_args(). The add_optional_flag specifies whether the
to add the optional SHAPE argument. The new symbol is
returned. */
gfc_symbol *
get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
const char *new_binding_label, int add_optional_arg)
{
gfc_symtree *new_symtree = NULL;
/* See if we have a symbol by that name already available, looking
through any parent namespaces. */
gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
if (new_symtree != NULL)
/* Return the existing symbol. */
return new_symtree->n.sym;
/* Create the symtree/symbol, with attempted host association. */
gfc_get_ha_sym_tree (new_name, &new_symtree);
if (new_symtree == NULL)
gfc_internal_error ("get_iso_c_sym(): Unable to create "
"symtree for '%s'", new_name);
/* Now fill in the fields of the resolved symbol with the old sym. */
new_symtree->n.sym->binding_label = new_binding_label;
new_symtree->n.sym->attr = old_sym->attr;
new_symtree->n.sym->ts = old_sym->ts;
new_symtree->n.sym->module = gfc_get_string (old_sym->module);
new_symtree->n.sym->from_intmod = old_sym->from_intmod;
new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
if (old_sym->attr.function)
new_symtree->n.sym->result = new_symtree->n.sym;
/* Build the formal arg list. */
build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
gfc_commit_symbol (new_symtree->n.sym);
return new_symtree->n.sym;
return tmp_symtree;
}

11
gcc/fortran/target-memory.c
View file

@ -316,6 +316,17 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
}
case BT_DERIVED:
if (source->ts.u.derived->ts.f90_type == BT_VOID)
{
gfc_constructor *c;
gcc_assert (source->expr_type == EXPR_STRUCTURE);
c = gfc_constructor_first (source->value.constructor);
gcc_assert (c->expr->expr_type == EXPR_CONSTANT
&& c->expr->ts.type == BT_INTEGER);
return encode_integer (gfc_index_integer_kind, c->expr->value.integer,
buffer, buffer_size);
}
return encode_derived (source, buffer, buffer_size);
default:
gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");

238
gcc/fortran/trans-expr.c
View file

@ -3695,229 +3695,6 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
}
/* The following routine generates code for the intrinsic
procedures from the ISO_C_BINDING module:
* C_LOC (function)
* C_FUNLOC (function)
* C_F_POINTER (subroutine)
* C_F_PROCPOINTER (subroutine)
* C_ASSOCIATED (function)
One exception which is not handled here is C_F_POINTER with non-scalar
arguments. Returns 1 if the call was replaced by inline code (else: 0). */
static int
conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
gfc_actual_arglist * arg)
{
gfc_symbol *fsym;
if (sym->intmod_sym_id == ISOCBINDING_LOC)
{
if (arg->expr->rank == 0)
gfc_conv_expr_reference (se, arg->expr);
else
{
int f;
/* This is really the actual arg because no formal arglist is
created for C_LOC. */
fsym = arg->expr->symtree->n.sym;
/* We should want it to do g77 calling convention. */
f = (fsym != NULL)
&& !(fsym->attr.pointer || fsym->attr.allocatable)
&& fsym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit;
gfc_conv_array_parameter (se, arg->expr, f, NULL, NULL, NULL);
}
/* TODO -- the following two lines shouldn't be necessary, but if
they're removed, a bug is exposed later in the code path.
This workaround was thus introduced, but will have to be
removed; please see PR 35150 for details about the issue. */
se->expr = convert (pvoid_type_node, se->expr);
se->expr = gfc_evaluate_now (se->expr, &se->pre);
return 1;
}
else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
{
arg->expr->ts.type = sym->ts.u.derived->ts.type;
arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
gfc_conv_expr_reference (se, arg->expr);
return 1;
}
else if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
|| sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
{
/* Convert c_f_pointer and c_f_procpointer. */
gfc_se cptrse;
gfc_se fptrse;
gfc_se shapese;
gfc_ss *shape_ss;
tree desc, dim, tmp, stride, offset;
stmtblock_t body, block;
gfc_loopinfo loop;
gfc_init_se (&cptrse, NULL);
gfc_conv_expr (&cptrse, arg->expr);
gfc_add_block_to_block (&se->pre, &cptrse.pre);
gfc_add_block_to_block (&se->post, &cptrse.post);
gfc_init_se (&fptrse, NULL);
if (arg->next->expr->rank == 0)
{
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
|| gfc_is_proc_ptr_comp (arg->next->expr))
fptrse.want_pointer = 1;
gfc_conv_expr (&fptrse, arg->next->expr);
gfc_add_block_to_block (&se->pre, &fptrse.pre);
gfc_add_block_to_block (&se->post, &fptrse.post);
if (arg->next->expr->symtree->n.sym->attr.proc_pointer
&& arg->next->expr->symtree->n.sym->attr.dummy)
fptrse.expr = build_fold_indirect_ref_loc (input_location,
fptrse.expr);
se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
TREE_TYPE (fptrse.expr),
fptrse.expr,
fold_convert (TREE_TYPE (fptrse.expr),
cptrse.expr));
return 1;
}
gfc_start_block (&block);
/* Get the descriptor of the Fortran pointer. */
fptrse.descriptor_only = 1;
gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
gfc_add_block_to_block (&block, &fptrse.pre);
desc = fptrse.expr;
/* Set data value, dtype, and offset. */
tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
gfc_conv_descriptor_data_set (&block, desc,
fold_convert (tmp, cptrse.expr));
gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
gfc_get_dtype (TREE_TYPE (desc)));
/* Start scalarization of the bounds, using the shape argument. */
shape_ss = gfc_walk_expr (arg->next->next->expr);
gcc_assert (shape_ss != gfc_ss_terminator);
gfc_init_se (&shapese, NULL);
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, shape_ss);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop, &arg->next->expr->where);
gfc_mark_ss_chain_used (shape_ss, 1);
gfc_copy_loopinfo_to_se (&shapese, &loop);
shapese.ss = shape_ss;
stride = gfc_create_var (gfc_array_index_type, "stride");
offset = gfc_create_var (gfc_array_index_type, "offset");
gfc_add_modify (&block, stride, gfc_index_one_node);
gfc_add_modify (&block, offset, gfc_index_zero_node);
/* Loop body. */
gfc_start_scalarized_body (&loop, &body);
dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
loop.loopvar[0], loop.from[0]);
/* Set bounds and stride. */
gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
gfc_conv_expr (&shapese, arg->next->next->expr);
gfc_add_block_to_block (&body, &shapese.pre);
gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
gfc_add_block_to_block (&body, &shapese.post);
/* Calculate offset. */
gfc_add_modify (&body, offset,
fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, stride));
/* Update stride. */
gfc_add_modify (&body, stride,
fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, stride,
fold_convert (gfc_array_index_type,
shapese.expr)));
/* Finish scalarization loop. */
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
gfc_add_block_to_block (&block, &fptrse.post);
gfc_cleanup_loop (&loop);
gfc_add_modify (&block, offset,
fold_build1_loc (input_location, NEGATE_EXPR,
gfc_array_index_type, offset));
gfc_conv_descriptor_offset_set (&block, desc, offset);
se->expr = gfc_finish_block (&block);
return 1;
}
else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
gfc_se arg1se;
gfc_se arg2se;
/* Build the addr_expr for the first argument. The argument is
already an *address* so we don't need to set want_pointer in
the gfc_se. */
gfc_init_se (&arg1se, NULL);
gfc_conv_expr (&arg1se, arg->expr);
gfc_add_block_to_block (&se->pre, &arg1se.pre);
gfc_add_block_to_block (&se->post, &arg1se.post);
/* See if we were given two arguments. */
if (arg->next == NULL)
/* Only given one arg so generate a null and do a
not-equal comparison against the first arg. */
se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
arg1se.expr,
fold_convert (TREE_TYPE (arg1se.expr),
null_pointer_node));
else
{
tree eq_expr;
tree not_null_expr;
/* Given two arguments so build the arg2se from second arg. */
gfc_init_se (&arg2se, NULL);
gfc_conv_expr (&arg2se, arg->next->expr);
gfc_add_block_to_block (&se->pre, &arg2se.pre);
gfc_add_block_to_block (&se->post, &arg2se.post);
/* Generate test to compare that the two args are equal. */
eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
arg1se.expr, arg2se.expr);
/* Generate test to ensure that the first arg is not null. */
not_null_expr = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node,
arg1se.expr, null_pointer_node);
/* Finally, the generated test must check that both arg1 is not
NULL and that it is equal to the second arg. */
se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
boolean_type_node,
not_null_expr, eq_expr);
}
return 1;
}
/* Nothing was done. */
return 0;
}
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
Return nonzero, if the call has alternate specifiers.
@ -3964,10 +3741,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
len = NULL_TREE;
gfc_clear_ts (&ts);
if (sym->from_intmod == INTMOD_ISO_C_BINDING
&& conv_isocbinding_procedure (se, sym, args))
return 0;
comp = gfc_get_proc_ptr_comp (expr);
if (se->ss != NULL)
@ -6013,7 +5786,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
gfc_add_expr_to_block (&block, tmp);
}
}
else if (expr->ts.type == BT_DERIVED)
else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
{
if (expr->expr_type != EXPR_STRUCTURE)
{
@ -6224,8 +5997,7 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
null_pointer_node. C_PTR and C_FUNPTR are converted to match the
typespec for the C_PTR and C_FUNPTR symbols, which has already been
updated to be an integer with a kind equal to the size of a (void *). */
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
&& expr->ts.u.derived->attr.is_iso_c)
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID)
{
if (expr->expr_type == EXPR_VARIABLE
&& (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
@ -6240,9 +6012,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
{
/* Update the type/kind of the expression to be what the new
type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
expr->ts.type = expr->ts.u.derived->ts.type;
expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
expr->ts.kind = expr->ts.u.derived->ts.kind;
expr->ts.type = BT_INTEGER;
expr->ts.f90_type = BT_VOID;
expr->ts.kind = gfc_index_integer_kind;
}
}

214
gcc/fortran/trans-intrinsic.c
View file

@ -6301,6 +6301,208 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
se->expr = temp_var;
}
/* The following routine generates code for the intrinsic
functions from the ISO_C_BINDING module:
* C_LOC
* C_FUNLOC
* C_ASSOCIATED */
static void
conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
{
gfc_actual_arglist *arg = expr->value.function.actual;
if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
{
if (arg->expr->rank == 0)
gfc_conv_expr_reference (se, arg->expr);
else
gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
/* TODO -- the following two lines shouldn't be necessary, but if
they're removed, a bug is exposed later in the code path.
This workaround was thus introduced, but will have to be
removed; please see PR 35150 for details about the issue. */
se->expr = convert (pvoid_type_node, se->expr);
se->expr = gfc_evaluate_now (se->expr, &se->pre);
}
else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
gfc_conv_expr_reference (se, arg->expr);
else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
{
gfc_se arg1se;
gfc_se arg2se;
/* Build the addr_expr for the first argument. The argument is
already an *address* so we don't need to set want_pointer in
the gfc_se. */
gfc_init_se (&arg1se, NULL);
gfc_conv_expr (&arg1se, arg->expr);
gfc_add_block_to_block (&se->pre, &arg1se.pre);
gfc_add_block_to_block (&se->post, &arg1se.post);
/* See if we were given two arguments. */
if (arg->next->expr == NULL)
/* Only given one arg so generate a null and do a
not-equal comparison against the first arg. */
se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
arg1se.expr,
fold_convert (TREE_TYPE (arg1se.expr),
null_pointer_node));
else
{
tree eq_expr;
tree not_null_expr;
/* Given two arguments so build the arg2se from second arg. */
gfc_init_se (&arg2se, NULL);
gfc_conv_expr (&arg2se, arg->next->expr);
gfc_add_block_to_block (&se->pre, &arg2se.pre);
gfc_add_block_to_block (&se->post, &arg2se.post);
/* Generate test to compare that the two args are equal. */
eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
arg1se.expr, arg2se.expr);
/* Generate test to ensure that the first arg is not null. */
not_null_expr = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node,
arg1se.expr, null_pointer_node);
/* Finally, the generated test must check that both arg1 is not
NULL and that it is equal to the second arg. */
se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
boolean_type_node,
not_null_expr, eq_expr);
}
}
else
gcc_unreachable ();
}
/* The following routine generates code for the intrinsic
subroutines from the ISO_C_BINDING module:
* C_F_POINTER
* C_F_PROCPOINTER. */
static tree
conv_isocbinding_subroutine (gfc_code *code)
{
gfc_se se;
gfc_se cptrse;
gfc_se fptrse;
gfc_se shapese;
gfc_ss *shape_ss;
tree desc, dim, tmp, stride, offset;
stmtblock_t body, block;
gfc_loopinfo loop;
gfc_actual_arglist *arg = code->ext.actual;
gfc_init_se (&se, NULL);
gfc_init_se (&cptrse, NULL);
gfc_conv_expr (&cptrse, arg->expr);
gfc_add_block_to_block (&se.pre, &cptrse.pre);
gfc_add_block_to_block (&se.post, &cptrse.post);
gfc_init_se (&fptrse, NULL);
if (arg->next->expr->rank == 0)
{
fptrse.want_pointer = 1;
gfc_conv_expr (&fptrse, arg->next->expr);
gfc_add_block_to_block (&se.pre, &fptrse.pre);
gfc_add_block_to_block (&se.post, &fptrse.post);
if (arg->next->expr->symtree->n.sym->attr.proc_pointer
&& arg->next->expr->symtree->n.sym->attr.dummy)
fptrse.expr = build_fold_indirect_ref_loc (input_location,
fptrse.expr);
se.expr = fold_build2_loc (input_location, MODIFY_EXPR,
TREE_TYPE (fptrse.expr),
fptrse.expr,
fold_convert (TREE_TYPE (fptrse.expr),
cptrse.expr));
gfc_add_expr_to_block (&se.pre, se.expr);
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
}
gfc_start_block (&block);
/* Get the descriptor of the Fortran pointer. */
fptrse.descriptor_only = 1;
gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
gfc_add_block_to_block (&block, &fptrse.pre);
desc = fptrse.expr;
/* Set data value, dtype, and offset. */
tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
gfc_get_dtype (TREE_TYPE (desc)));
/* Start scalarization of the bounds, using the shape argument. */
shape_ss = gfc_walk_expr (arg->next->next->expr);
gcc_assert (shape_ss != gfc_ss_terminator);
gfc_init_se (&shapese, NULL);
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, shape_ss);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop, &arg->next->expr->where);
gfc_mark_ss_chain_used (shape_ss, 1);
gfc_copy_loopinfo_to_se (&shapese, &loop);
shapese.ss = shape_ss;
stride = gfc_create_var (gfc_array_index_type, "stride");
offset = gfc_create_var (gfc_array_index_type, "offset");
gfc_add_modify (&block, stride, gfc_index_one_node);
gfc_add_modify (&block, offset, gfc_index_zero_node);
/* Loop body. */
gfc_start_scalarized_body (&loop, &body);
dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
loop.loopvar[0], loop.from[0]);
/* Set bounds and stride. */
gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
gfc_conv_expr (&shapese, arg->next->next->expr);
gfc_add_block_to_block (&body, &shapese.pre);
gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
gfc_add_block_to_block (&body, &shapese.post);
/* Calculate offset. */
gfc_add_modify (&body, offset,
fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, stride));
/* Update stride. */
gfc_add_modify (&body, stride,
fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, stride,
fold_convert (gfc_array_index_type,
shapese.expr)));
/* Finish scalarization loop. */
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
gfc_add_block_to_block (&block, &fptrse.post);
gfc_cleanup_loop (&loop);
gfc_add_modify (&block, offset,
fold_build1_loc (input_location, NEGATE_EXPR,
gfc_array_index_type, offset));
gfc_conv_descriptor_offset_set (&block, desc, offset);
gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
}
/* Generate code for an intrinsic function. Some map directly to library
calls, others get special handling. In some cases the name of the function
used depends on the type specifiers. */
@ -6476,6 +6678,12 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
break;
case GFC_ISYM_C_ASSOCIATED:
case GFC_ISYM_C_FUNLOC:
case GFC_ISYM_C_LOC:
conv_isocbinding_function (se, expr);
break;
case GFC_ISYM_ACHAR:
case GFC_ISYM_CHAR:
gfc_conv_intrinsic_char (se, expr);
@ -7585,6 +7793,12 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
res = conv_intrinsic_atomic_ref (code);
break;
case GFC_ISYM_C_F_POINTER:
case GFC_ISYM_C_F_PROCPOINTER:
res = conv_isocbinding_subroutine (code);
break;
default:
res = NULL_TREE;
break;

16
gcc/fortran/trans-io.c
View file

@ -2026,20 +2026,8 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
&& ts->u.derived != NULL
&& (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
{
/* C_PTR and C_FUNPTR have private components which means they can not
be printed. However, if -std=gnu and not -pedantic, allow
the component to be printed to help debugging. */
if (gfc_notification_std (GFC_STD_GNU) != SILENT)
{
gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
ts->u.derived->name, code != NULL ? &(code->loc) :
&gfc_current_locus);
return;
}
ts->type = ts->u.derived->ts.type;
ts->kind = ts->u.derived->ts.kind;
ts->f90_type = ts->u.derived->ts.f90_type;
ts->type = BT_INTEGER;
ts->kind = gfc_index_integer_kind;
}
kind = ts->kind;

17
gcc/fortran/trans-types.c
View file

@ -338,12 +338,11 @@ gfc_init_c_interop_kinds (void)
strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
c_interop_kinds_table[a].f90_type = BT_DERIVED; \
c_interop_kinds_table[a].value = c;
#define PROCEDURE(a,b) \
#define NAMED_FUNCTION(a,b,c,d) \
strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
c_interop_kinds_table[a].value = 0;
#include "iso-c-binding.def"
#define NAMED_FUNCTION(a,b,c,d) \
c_interop_kinds_table[a].value = c;
#define NAMED_SUBROUTINE(a,b,c,d) \
strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
c_interop_kinds_table[a].value = c;
@ -1111,11 +1110,11 @@ gfc_typenode_for_spec (gfc_typespec * spec)
type and kind to fit a (void *) and the basetype returned was a
ptr_type_node. We need to pass up this new information to the
symbol that was declared of type C_PTR or C_FUNPTR. */
if (spec->u.derived->attr.is_iso_c)
if (spec->u.derived->ts.f90_type == BT_VOID)
{
spec->type = spec->u.derived->ts.type;
spec->kind = spec->u.derived->ts.kind;
spec->f90_type = spec->u.derived->ts.f90_type;
spec->type = BT_INTEGER;
spec->kind = gfc_index_integer_kind;
spec->f90_type = BT_VOID;
}
break;
case BT_VOID:
@ -2349,7 +2348,7 @@ gfc_get_derived_type (gfc_symbol * derived)
derived = gfc_find_dt_in_generic (derived);
/* See if it's one of the iso_c_binding derived types. */
if (derived->attr.is_iso_c == 1)
if (derived->attr.is_iso_c == 1 || derived->ts.f90_type == BT_VOID)
{
if (derived->backend_decl)
return derived->backend_decl;

58
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,61 @@
2013-03-25 Tobias Burnus <burnus@net-b.de>
PR fortran/38536
PR fortran/38813
PR fortran/38894
PR fortran/39288
PR fortran/40963
PR fortran/45824
PR fortran/47023
PR fortran/47034
PR fortran/49023
PR fortran/50269
PR fortran/50612
PR fortran/52426
PR fortran/54263
PR fortran/55343
PR fortran/55444
PR fortran/55574
PR fortran/56079
PR fortran/56378
* gfortran.dg/c_assoc_2.f03: Update dg-error wording.
* gfortran.dg/c_f_pointer_shape_test.f90: Ditto.
* gfortran.dg/c_f_pointer_shape_tests_3.f03: Ditto.
* gfortran.dg/c_f_pointer_tests_5.f90: Ditto.
* gfortran.dg/c_funloc_tests_2.f03: Ditto.
* gfortran.dg/c_funloc_tests_5.f03: Ditto.
* gfortran.dg/c_funloc_tests_6.f90: Ditto.
* gfortran.dg/c_loc_tests_10.f03: Add -std=f2008.
* gfortran.dg/c_loc_tests_11.f03: Ditto, update dg-error.
* gfortran.dg/c_loc_tests_16.f90: Ditto.
* gfortran.dg/c_loc_tests_4.f03: Ditto.
* gfortran.dg/c_loc_tests_15.f90: Update dg-error wording.
* gfortran.dg/c_loc_tests_3.f03: Valid since F2003 TC5.
* gfortran.dg/c_loc_tests_8.f03: Ditto.
* gfortran.dg/c_ptr_tests_14.f90: Update scan-tree-dump-times.
* gfortran.dg/c_ptr_tests_15.f90: Ditto.
* gfortran.dg/c_sizeof_1.f90: Fix invalid code.
* gfortran.dg/iso_c_binding_init_expr.f03: Update dg-error wording.
* gfortran.dg/pr32601_1.f03: Ditto.
* gfortran.dg/storage_size_2.f08: Remove dg-error.
* gfortran.dg/blockdata_7.f90: New.
* gfortran.dg/c_assoc_4.f90: New.
* gfortran.dg/c_f_pointer_tests_6.f90: New.
* gfortran.dg/c_f_pointer_tests_7.f90: New.
* gfortran.dg/c_funloc_tests_8.f90: New.
* gfortran.dg/c_loc_test_17.f90: New.
* gfortran.dg/c_loc_test_18.f90: New.
* gfortran.dg/c_loc_test_19.f90: New.
* gfortran.dg/c_loc_test_20.f90: New.
* gfortran.dg/c_sizeof_5.f90: New.
* gfortran.dg/iso_c_binding_rename_3.f90: New.
* gfortran.dg/transfer_resolve_2.f90: New.
* gfortran.dg/transfer_resolve_3.f90: New.
* gfortran.dg/transfer_resolve_4.f90: New.
* gfortran.dg/pr32601.f03: Update dg-error.
* gfortran.dg/c_ptr_tests_13.f03: Update dg-error.
* gfortran.dg/c_ptr_tests_9.f03: Fix test case.
2013-03-25 Kyrylo Tkachov <kyrylo.tkachov@arm.com>
* gcc.target/arm/vseleqdf.c: New test.

16
gcc/testsuite/gfortran.dg/blockdata_7.f90 Normal file
View file

@ -0,0 +1,16 @@
! { dg-do compile }
!
! PR fortran/55444
!
! Contributed by Henrik Holst
!
BLOCKDATA
! USE ISO_C_BINDING, ONLY: C_INT, C_FLOAT ! WORKS
USE :: ISO_C_BINDING ! FAILS
INTEGER(C_INT) X
REAL(C_FLOAT) Y
COMMON /FOO/ X,Y
BIND(C,NAME='fortranStuff') /FOO/
DATA X /1/
DATA Y /2.0/
END BLOCKDATA

8
gcc/testsuite/gfortran.dg/c_assoc_2.f03
View file

@ -16,19 +16,19 @@ contains
call abort()
end if
if(.not. c_associated(my_c_ptr, my_c_ptr, my_c_ptr)) then ! { dg-error "More actual than formal arguments" }
if(.not. c_associated(my_c_ptr, my_c_ptr, my_c_ptr)) then ! { dg-error "Too many arguments in call" }
call abort()
end if
if(.not. c_associated()) then ! { dg-error "Missing argument" }
if(.not. c_associated()) then ! { dg-error "Missing actual argument 'C_PTR_1' in call to 'c_associated'" }
call abort()
end if ! { dg-error "Expecting END SUBROUTINE" }
end if
if(.not. c_associated(my_c_ptr_2)) then
call abort()
end if
if(.not. c_associated(my_integer)) then ! { dg-error "Type mismatch" }
if(.not. c_associated(my_integer)) then ! { dg-error "shall have the type TYPE.C_PTR. or TYPE.C_FUNPTR." }
call abort()
end if
end subroutine sub0

14
gcc/testsuite/gfortran.dg/c_assoc_4.f90 Normal file
View file

@ -0,0 +1,14 @@
! { dg-do compile }
!
! PR fortran/49023
!
PROGRAM test
USE, INTRINSIC :: iso_c_binding
IMPLICIT NONE
TYPE (C_PTR) :: x, y
PRINT *, C_ASSOCIATED([x,y]) ! { dg-error "'C_PTR_1' argument of 'c_associated' intrinsic at .1. must be a scalar" }
END PROGRAM test

2
gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90
View file

@ -13,7 +13,7 @@ contains
type(c_ptr), value :: cPtr
myArrayPtr => myArray
call c_f_pointer(cPtr, myArrayPtr) ! { dg-error "Missing SHAPE argument" }
call c_f_pointer(cPtr, myArrayPtr) ! { dg-error "Expected SHAPE argument to C_F_POINTER with array FPTR" }
end subroutine test_0
end module c_f_pointer_shape_test

4
gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03
View file

@ -8,7 +8,7 @@ contains
type(c_ptr), value :: my_c_array
integer(c_int), dimension(:), pointer :: my_array_ptr
call c_f_pointer(my_c_array, my_array_ptr, (/ 10.0 /)) ! { dg-error "must be a rank 1 INTEGER array" }
call c_f_pointer(my_c_array, my_array_ptr, (/ 10.0 /)) ! { dg-error "must be INTEGER" }
end subroutine sub0
subroutine sub1(my_c_array) bind(c)
@ -17,6 +17,6 @@ contains
integer(c_int), dimension(1,1) :: shape
shape(1,1) = 10
call c_f_pointer(my_c_array, my_array_ptr, shape) ! { dg-error "must be a rank 1 INTEGER array" }
call c_f_pointer(my_c_array, my_array_ptr, shape) ! { dg-error "must be of rank 1" }
end subroutine sub1
end module c_f_pointer_shape_tests_3

2
gcc/testsuite/gfortran.dg/c_f_pointer_tests_5.f90
View file

@ -9,5 +9,5 @@ type :: nc
end type
type(c_ptr) :: cSelf
class(nc), pointer :: self
call c_f_pointer(cSelf, self) ! { dg-error "must not be polymorphic" }
call c_f_pointer(cSelf, self) ! { dg-error "shall not be polymorphic" }
end

43
gcc/testsuite/gfortran.dg/c_f_pointer_tests_6.f90 Normal file
View file

@ -0,0 +1,43 @@
! { dg-do compile }
!
! PR fortran/38894
!
!
subroutine test2
use iso_c_binding
type(c_funptr) :: fun
type(c_ptr) :: fptr
procedure(), pointer :: bar
integer, pointer :: bari
call c_f_procpointer(fptr,bar) ! { dg-error "Argument CPTR at .1. to C_F_PROCPOINTER shall have the type TYPE.C_FUNPTR." }
call c_f_pointer(fun,bari) ! { dg-error "Argument CPTR at .1. to C_F_POINTER shall have the type TYPE.C_PTR." }
fun = fptr ! { dg-error "Can't convert TYPE.c_ptr. to TYPE.c_funptr." }
end
subroutine test()
use iso_c_binding, c_ptr2 => c_ptr
type(c_ptr2) :: fun
procedure(), pointer :: bar
integer, pointer :: foo
call c_f_procpointer(fun,bar) ! { dg-error "Argument CPTR at .1. to C_F_PROCPOINTER shall have the type TYPE.C_FUNPTR." }
call c_f_pointer(fun,foo) ! OK
end
module rename
use, intrinsic :: iso_c_binding, only: my_c_ptr_0 => c_ptr
end module rename
program p
use, intrinsic :: iso_c_binding, my_c_ptr => c_ptr
type(my_c_ptr) :: my_ptr
print *,c_associated(my_ptr)
contains
subroutine sub()
use rename ! (***)
type(my_c_ptr_0) :: my_ptr2
type(c_funptr) :: myfun
print *,c_associated(my_ptr,my_ptr2)
print *,c_associated(my_ptr,myfun) ! { dg-error "Argument C_PTR_2 at .1. to C_ASSOCIATED shall have the same type as C_PTR_1: TYPE.c_ptr. instead of TYPE.c_funptr." }
end subroutine
end

9
gcc/testsuite/gfortran.dg/c_f_pointer_tests_7.f90 Normal file
View file

@ -0,0 +1,9 @@
! { dg-do compile }
!
! PR fortran/54263
!
use iso_c_binding
type(c_ptr) :: cp
integer, pointer :: p
call c_f_pointer (cp, p, shape=[2]) ! { dg-error "Unexpected SHAPE argument at .1. to C_F_POINTER with scalar FPTR" }
end

6
gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03
View file

@ -8,9 +8,9 @@ contains
type(c_funptr) :: my_c_funptr
integer :: my_local_variable
my_c_funptr = c_funloc() ! { dg-error "Missing argument" }
my_c_funptr = c_funloc() ! { dg-error "Missing actual argument 'x' in call to 'c_funloc'" }
my_c_funptr = c_funloc(sub0)
my_c_funptr = c_funloc(sub0, sub0) ! { dg-error "More actual than formal" }
my_c_funptr = c_funloc(my_local_variable) ! { dg-error "must be a procedure" }
my_c_funptr = c_funloc(sub0, sub0) ! { dg-error "Too many arguments in call to 'c_funloc'" }
my_c_funptr = c_funloc(my_local_variable) ! { dg-error "Argument X at .1. to C_FUNLOC shall be a procedure or a procedure pointer" }
end subroutine sub0
end module c_funloc_tests_2

4
gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03
View file

@ -8,9 +8,9 @@ contains
subroutine sub0() bind(c)
type(c_funptr) :: my_c_funptr
my_c_funptr = c_funloc(sub1) ! { dg-error "TS 29113: Noninteroperable argument" }
my_c_funptr = c_funloc(sub1) ! { dg-error "TS 29113: Noninteroperable procedure at .1. to C_FUNLOC" }
my_c_funptr = c_funloc(func0) ! { dg-error "TS 29113: Noninteroperable argument" }
my_c_funptr = c_funloc(func0) ! { dg-error "TS 29113: Noninteroperable procedure at .1. to C_FUNLOC" }
end subroutine sub0
subroutine sub1()

8
gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90
View file

@ -23,9 +23,9 @@ procedure(integer), pointer :: fint
cp = c_funloc (sub) ! { dg-error "Can't convert TYPE.c_funptr. to TYPE.c_ptr." })
cfp = c_loc (int) ! { dg-error "Can't convert TYPE.c_ptr. to TYPE.c_funptr." }
call c_f_pointer (cfp, int) ! { dg-error "Argument CPTR to C_F_POINTER at .1. shall have the type C_PTR" }
call c_f_procpointer (cp, fsub) ! { dg-error "Argument at .1. to C_F_FUNPOINTER shall have the type C_FUNPTR" }
call c_f_pointer (cfp, int) ! { dg-error "Argument CPTR at .1. to C_F_POINTER shall have the type TYPE.C_PTR." }
call c_f_procpointer (cp, fsub) ! { dg-error "Argument CPTR at .1. to C_F_PROCPOINTER shall have the type TYPE.C_FUNPTR." }
cfp = c_funloc (noCsub) ! { dg-error "TS 29113: Noninteroperable argument 'nocsub' to 'c_funloc'" }
call c_f_procpointer (cfp, fint) ! { dg-error "TS 29113: Noninteroperable procedure-pointer at .1. to C_F_FUNPOINTER" }
cfp = c_funloc (noCsub) ! { dg-error "TS 29113: Noninteroperable procedure at .1. to C_FUNLOC" }
call c_f_procpointer (cfp, fint) ! { dg-error "TS 29113: Noninteroperable procedure pointer at .1. to C_F_PROCPOINTER" }
end

49
gcc/testsuite/gfortran.dg/c_funloc_tests_8.f90 Normal file
View file

@ -0,0 +1,49 @@
! { dg-do compile }
!
! PR fortran/50612
! PR fortran/47023
!
subroutine test
use iso_c_binding
implicit none
external foo
procedure(), pointer :: pp
print *, c_sizeof(pp) ! { dg-error "Procedure unexpected as argument" }
print *, c_sizeof(foo) ! { dg-error "Procedure unexpected as argument" }
print *, c_sizeof(bar) ! { dg-error "Procedure unexpected as argument" }
contains
subroutine bar()
end subroutine bar
end
integer function foo2()
procedure(), pointer :: ptr
ptr => foo2 ! { dg-error "Function result 'foo2' is invalid as proc-target in procedure pointer assignment" }
foo2 = 7
block
ptr => foo2 ! { dg-error "Function result 'foo2' is invalid as proc-target in procedure pointer assignment" }
end block
contains
subroutine foo()
ptr => foo2 ! { dg-error "Function result 'foo2' is invalid as proc-target in procedure pointer assignment" }
end subroutine foo
end function foo2
module m2
contains
integer function foo(i, fptr) bind(C)
use iso_c_binding
implicit none
integer :: i
type(c_funptr) :: fptr
fptr = c_funloc(foo) ! { dg-error "Function result 'foo' at .1. is invalid as X argument to C_FUNLOC" }
block
fptr = c_funloc(foo) ! { dg-error "Function result 'foo' at .1. is invalid as X argument to C_FUNLOC" }
end block
foo = 42*i
contains
subroutine bar()
fptr = c_funloc(foo) ! { dg-error "Function result 'foo' at .1. is invalid as X argument to C_FUNLOC" }
end subroutine bar
end function foo
end module m2

28
gcc/testsuite/gfortran.dg/c_loc_test_17.f90 Normal file
View file

@ -0,0 +1,28 @@
! { dg-do compile }
! { dg-options "" }
!
! PR fortran/56378
! PR fortran/52426
!
! Contributed by David Sagan & Joost VandeVondele
!
module t
use, intrinsic :: iso_c_binding
interface fvec2vec
module procedure int_fvec2vec
end interface
contains
function int_fvec2vec (f_vec, n) result (c_vec)
integer f_vec(:)
integer(c_int), target :: c_vec(n)
end function int_fvec2vec
subroutine lat_to_c (Fp, C) bind(c)
integer, allocatable :: ic(:)
call lat_to_c2 (c_loc(fvec2vec(ic, n1_ic))) ! { dg-error "Argument X at .1. to C_LOC shall have either the POINTER or the TARGET attribute" }
end subroutine lat_to_c
end module
use iso_c_binding
print *, c_loc([1]) ! { dg-error "Argument X at .1. to C_LOC shall have either the POINTER or the TARGET attribute" }
end

21
gcc/testsuite/gfortran.dg/c_loc_test_18.f90 Normal file
View file

@ -0,0 +1,21 @@
! { dg-do compile }
!
! PR fortran/39288
!
! From IR F03/0129, cf.
! Fortran 2003, Technical Corrigendum 5
!
! Was invalid before.
SUBROUTINE S(A,I,K)
USE ISO_C_BINDING
CHARACTER(*),TARGET :: A
CHARACTER(:),ALLOCATABLE,TARGET :: B
TYPE(C_PTR) P1,P2,P3,P4,P5
P1 = C_LOC(A(1:1)) ! *1
P2 = C_LOC(A(I:I)) ! *2
P3 = C_LOC(A(1:)) ! *3
P4 = C_LOC(A(I:K)) ! *4
ALLOCATE(CHARACTER(1)::B)
P5 = C_LOC(B) ! *5
END SUBROUTINE

17
gcc/testsuite/gfortran.dg/c_loc_test_19.f90 Normal file
View file

@ -0,0 +1,17 @@
! { dg-do compile }
! { dg-options "-std=f2003" }
!
! PR fortran/50269
!
Program gf
Use iso_c_binding
Real( c_double ), Dimension( 1:10 ), Target :: a
Call test( a )
Contains
Subroutine test( aa )
Real( c_double ), Dimension( : ), Target :: aa
Type( c_ptr ), Pointer :: b
b = c_loc( aa( 1 ) ) ! was rejected before.
b = c_loc( aa ) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC: Only explicit-size and assumed-size arrays are interoperable" }
End Subroutine test
End Program gf

34
gcc/testsuite/gfortran.dg/c_loc_test_20.f90 Normal file
View file

@ -0,0 +1,34 @@
! { dg-do run }
!
! PR fortran/38829
! PR fortran/40963
! PR fortran/38813
!
!
program testcloc
use, intrinsic :: iso_c_binding
implicit none
type obj
real :: array(10,10)
real, allocatable :: array2(:,:)
end type
type(obj), target :: obj1
type(c_ptr) :: cptr
integer :: i
real, pointer :: array(:)
allocate (obj1%array2(10,10))
obj1%array = reshape ([(i, i=1,100)], shape (obj1%array))
obj1%array2 = reshape ([(i, i=1,100)], shape (obj1%array))
cptr = c_loc (obj1%array)
call c_f_pointer (cptr, array, shape=[100])
if (any (array /= [(i, i=1,100)])) call abort ()
cptr = c_loc (obj1%array2)
call c_f_pointer (cptr, array, shape=[100])
if (any (array /= [(i, i=1,100)])) call abort ()
end program testcloc

3
gcc/testsuite/gfortran.dg/c_loc_tests_10.f03
View file

@ -1,8 +1,9 @@
! { dg-do compile }
! { dg-options "-std=f2008" }
subroutine aaa(in)
use iso_c_binding
implicit none
integer(KIND=C_int), DIMENSION(:), TARGET :: in
type(c_ptr) :: cptr
cptr = c_loc(in) ! { dg-error "not C interoperable" }
cptr = c_loc(in) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC" }
end subroutine aaa

10
gcc/testsuite/gfortran.dg/c_loc_tests_11.f03
View file

@ -1,4 +1,6 @@
! { dg-do compile }
! { dg-options "-std=f2008" }
!
! Test argument checking for C_LOC with subcomponent parameters.
module c_vhandle_mod
use iso_c_binding
@ -29,9 +31,9 @@ contains
integer(c_int), intent(in) :: handle
if (.true.) then ! The ultimate component is an allocatable target
get_double_vector_address = c_loc(dbv_pool(handle)%v)
get_double_vector_address = c_loc(dbv_pool(handle)%v) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC: Only explicit-size and assumed-size arrays are interoperable" }
else
get_double_vector_address = c_loc(vv)
get_double_vector_address = c_loc(vv) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC: Only explicit-size and assumed-size arrays are interoperable" }
endif
end function get_double_vector_address
@ -39,9 +41,9 @@ contains
type(c_ptr) function get_foo_address(handle)
integer(c_int), intent(in) :: handle
get_foo_address = c_loc(foo_pool(handle)%v)
get_foo_address = c_loc(foo_pool(handle)%v)
get_foo_address = c_loc(foo_pool2(handle)%v) ! { dg-error "must be a scalar" }
get_foo_address = c_loc(foo_pool2(handle)%v) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC: Expression is a noninteroperable derived type" }
end function get_foo_address

2
gcc/testsuite/gfortran.dg/c_loc_tests_15.f90
View file

@ -11,6 +11,6 @@
type(c_ptr) :: tt_cptr
class(t), pointer :: tt_fptr
if (associated(tt_fptr)) tt_cptr = c_loc(tt_fptr) ! { dg-error "must not be polymorphic" }
if (associated(tt_fptr)) tt_cptr = c_loc(tt_fptr) ! { dg-error "shall not be polymorphic" }
end

10
gcc/testsuite/gfortran.dg/c_loc_tests_16.f90
View file

@ -1,5 +1,5 @@
! { dg-do compile }
! { dg-options "-fcoarray=single" }
! { dg-options "-fcoarray=single -std=f2008" }
! PR 38536 - array sections as arguments to c_loc are illegal.
use iso_c_binding
type, bind(c) :: t1
@ -18,8 +18,8 @@
integer(c_int), target :: x[*]
type(C_PTR) :: p
p = c_loc(tt%t%i(1)) ! { dg-error "Array section not permitted" }
p = c_loc(n(1:2)) ! { dg-warning "Array section" }
p = c_loc(ttt%t(5,1:2)%i(1)) ! { dg-error "Array section not permitted" }
p = c_loc(x[1]) ! { dg-error "Coindexed argument not permitted" }
p = c_loc(tt%t%i(1))
p = c_loc(n(1:2)) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC: Only whole-arrays are interoperable" }
p = c_loc(ttt%t(5,1:2)%i(1)) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC: Only whole-arrays are interoperable" }
p = c_loc(x[1]) ! { dg-error "shall not be coindexed" }
end

14
gcc/testsuite/gfortran.dg/c_loc_tests_17.f90 Normal file
View file

@ -0,0 +1,14 @@
! { dg-do compile }
!
! PR fortran/55574
! The following code used to be accepted because C_LOC pulls in C_PTR
! implicitly.
!
! Contributed by Valery Weber <valeryweber@hotmail.com>
!
program aaaa
use iso_c_binding, only : c_loc
integer, target :: i
type(C_PTR) :: f_ptr ! { dg-error "being used before it is defined" }
f_ptr=c_loc(i) ! { dg-error "Can't convert" }
end program aaaa

2
gcc/testsuite/gfortran.dg/c_loc_tests_3.f03
View file

@ -3,6 +3,6 @@ use iso_c_binding
implicit none
character(kind=c_char,len=256),target :: arg
type(c_ptr),pointer :: c
c = c_loc(arg) ! { dg-error "must have a length of 1" }
c = c_loc(arg) ! OK since Fortran 2003, Tech Corrigenda 5; IR F03/0129
end

4
gcc/testsuite/gfortran.dg/c_loc_tests_4.f03
View file

@ -1,4 +1,6 @@
! { dg-do compile }
! { dg-options "-std=f2008" }
!
module c_loc_tests_4
use, intrinsic :: iso_c_binding
implicit none
@ -10,6 +12,6 @@ contains
type(c_ptr) :: my_c_ptr
my_array_ptr => my_array
my_c_ptr = c_loc(my_array_ptr) ! { dg-error "must be an associated scalar POINTER" }
my_c_ptr = c_loc(my_array_ptr) ! { dg-error "Noninteroperable array at .1. as argument to C_LOC: Only explicit-size and assumed-size arrays are interoperable" }
end subroutine sub0
end module c_loc_tests_4

2
gcc/testsuite/gfortran.dg/c_loc_tests_8.f03
View file

@ -7,7 +7,7 @@ contains
SUBROUTINE glutInit_f03()
TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR
character(kind=c_char, len=5), target :: string="hello"
argv(1)=C_LOC(string) ! { dg-error "must have a length of 1" }
argv(1)=C_LOC(string) ! OK since Fortran 2003, Tech Corrigenda 5; IR F03/0129
END SUBROUTINE
end module x

4
gcc/testsuite/gfortran.dg/c_ptr_tests_13.f03
View file

@ -10,6 +10,6 @@ program main
integer(C_INTPTR_T) p
type(C_PTR) cptr
p = 0
cptr = C_PTR(p+1) ! { dg-error "Components of structure constructor" }
cptr = C_PTR(1) ! { dg-error "Components of structure constructor" }
cptr = C_PTR(p+1) ! { dg-error "is a PRIVATE component of 'c_ptr'" }
cptr = C_PTR(1) ! { dg-error "is a PRIVATE component of 'c_ptr'" }
end program main

6
gcc/testsuite/gfortran.dg/c_ptr_tests_14.f90
View file

@ -39,8 +39,10 @@ program test
if(c_associated(file%gsl_func)) call abort()
end program test
! { dg-final { scan-tree-dump-times "gsl_file = 0B" 1 "original" } }
! { dg-final { scan-tree-dump-times "gsl_func = 0B" 1 "original" } }
! { dg-final { scan-tree-dump-times "c_funptr.\[0-9\]+ = 0B;" 1 "original" } }
! { dg-final { scan-tree-dump-times "fgsl_file.\[0-9\]+.gsl_func = c_funptr.\[0-9\]+;" 1 "original" } }
! { dg-final { scan-tree-dump-times "c_ptr.\[0-9\]+ = 0B;" 1 "original" } }
! { dg-final { scan-tree-dump-times "fgsl_file.\[0-9\]+.gsl_file = c_ptr.\[0-9\]+;" 1 "original" } }
! { dg-final { scan-tree-dump-times "NIptr = 0B" 0 "original" } }
! { dg-final { scan-tree-dump-times "NIfunptr = 0B" 0 "original" } }

6
gcc/testsuite/gfortran.dg/c_ptr_tests_15.f90
View file

@ -41,8 +41,10 @@ program test
if(c_associated(file%gsl_func)) call abort()
end program test
! { dg-final { scan-tree-dump-times "gsl_file = 0B" 1 "original" } }
! { dg-final { scan-tree-dump-times "gsl_func = 0B" 1 "original" } }
! { dg-final { scan-tree-dump-times "c_funptr.\[0-9\]+ = 0B;" 1 "original" } }
! { dg-final { scan-tree-dump-times "fgsl_file.\[0-9\]+.gsl_func = c_funptr.\[0-9\]+;" 1 "original" } }
! { dg-final { scan-tree-dump-times "c_ptr.\[0-9\]+ = 0B;" 1 "original" } }
! { dg-final { scan-tree-dump-times "fgsl_file.\[0-9\]+.gsl_file = c_ptr.\[0-9\]+;" 1 "original" } }
! { dg-final { scan-tree-dump-times "NIptr = 0B" 0 "original" } }
! { dg-final { scan-tree-dump-times "NIfunptr = 0B" 0 "original" } }

4
gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03
View file

@ -16,9 +16,9 @@ contains
type(myF90Derived), pointer :: my_f90_type_ptr
my_f90_type%my_c_ptr = c_null_ptr
print *, 'my_f90_type is: ', my_f90_type
print *, 'my_f90_type is: ', my_f90_type%my_c_ptr
my_f90_type_ptr => my_f90_type
print *, 'my_f90_type_ptr is: ', my_f90_type_ptr
print *, 'my_f90_type_ptr is: ', my_f90_type_ptr%my_c_ptr
end subroutine sub0
end module c_ptr_tests_9

11
gcc/testsuite/gfortran.dg/c_sizeof_1.f90
View file

@ -4,7 +4,8 @@
use iso_c_binding, only: c_int, c_char, c_ptr, c_intptr_t, c_null_ptr, c_sizeof
integer(kind=c_int) :: i, j(10)
character(kind=c_char,len=4),parameter :: str(1) = "abcd"
character(kind=c_char,len=4),parameter :: str(1 ) = "abcd"
character(kind=c_char,len=1),parameter :: str2(4) = ["a","b","c","d"]
type(c_ptr) :: cptr
integer(c_intptr_t) :: iptr
@ -15,13 +16,13 @@ if (i /= 4) call abort()
i = c_sizeof(j)
if (i /= 40) call abort()
i = c_sizeof(str)
i = c_sizeof(str2)
if (i /= 4) call abort()
i = c_sizeof(str(1))
if (i /= 4) call abort()
i = c_sizeof(str2(1))
if (i /= 1) call abort()
i = c_sizeof(str(1)(1:3))
i = c_sizeof(str2(1:3))
if (i /= 3) call abort()
write(*,*) c_sizeof(cptr), c_sizeof(iptr), c_sizeof(C_NULL_PTR)

12
gcc/testsuite/gfortran.dg/c_sizeof_5.f90 Normal file
View file

@ -0,0 +1,12 @@
! { dg-do run }
! { dg-options "-fcray-pointer" }
!
use iso_c_binding
real target(10)
real pointee(10)
pointer (ipt, pointee)
integer(c_intptr_t) :: int_cptr
real :: x
if (c_sizeof(ipt) /= c_sizeof(int_cptr)) call abort()
if (c_sizeof(pointee) /= c_sizeof(x)*10) call abort()
end

4
gcc/testsuite/gfortran.dg/iso_c_binding_init_expr.f03
View file

@ -5,7 +5,7 @@ use iso_c_binding
implicit none
integer, target :: a
type t
type(c_ptr) :: ptr = c_loc(a) ! { dg-error "must be an intrinsic function" }
type(c_ptr) :: ptr = c_loc(a) ! { dg-error "Intrinsic function 'c_loc' at .1. is not permitted in an initialization expression" }
end type t
type(c_ptr) :: ptr2 = c_loc(a) ! { dg-error "must be an intrinsic function" }
type(c_ptr) :: ptr2 = c_loc(a) ! { dg-error "Intrinsic function 'c_loc' at .1. is not permitted in an initialization expression" }
end

23
gcc/testsuite/gfortran.dg/iso_c_binding_rename_3.f90 Normal file
View file

@ -0,0 +1,23 @@
! { dg-do compile }
!
! PR fortran/55343
!
! Contributed by Janus Weil
!
module my_mod
implicit none
type int_type
integer :: i
end type int_type
end module my_mod
program main
use iso_c_binding, only: C_void_ptr=>C_ptr, C_string_ptr=>C_ptr
use my_mod, only: i1_type=>int_type, i2_type=>int_type
implicit none
type(C_string_ptr) :: p_string
type(C_void_ptr) :: p_void
type (i1_type) :: i1
type (i2_type) :: i2
p_void = p_string
i1 = i2
end program main

6
gcc/testsuite/gfortran.dg/pr32601.f03
View file

@ -19,9 +19,9 @@ type(c_ptr) :: t
t = c_null_ptr
! Next two lines should be errors if -pedantic or -std=f2003
print *, c_null_ptr, t ! { dg-error "has PRIVATE components" }
print *, t ! { dg-error "has PRIVATE components" }
print *, c_null_ptr, t ! { dg-error "cannot have PRIVATE components" }
print *, t ! { dg-error "cannot have PRIVATE components" }
print *, c_loc(get_ptr()) ! { dg-error "has PRIVATE components" }
print *, c_loc(get_ptr()) ! { dg-error "cannot have PRIVATE components" }
end

4
gcc/testsuite/gfortran.dg/pr32601_1.f03
View file

@ -1,10 +1,12 @@
! { dg-do compile }
! { dg-options "" }
!
! PR fortran/32601
use, intrinsic :: iso_c_binding, only: c_loc, c_ptr
implicit none
! This was causing an ICE, but is an error because the argument to C_LOC
! needs to be a variable.
print *, c_loc(4) ! { dg-error "not a variable" }
print *, c_loc(4) ! { dg-error "shall have either the POINTER or the TARGET attribute" }
end

4
gcc/testsuite/gfortran.dg/storage_size_2.f08
View file

@ -14,10 +14,10 @@ integer(4) :: i1
integer(c_int) :: i2
type(t) :: x
print *,c_sizeof(i1) ! { dg-error "must be an interoperable data entity" }
print *,c_sizeof(i1)
print *,c_sizeof(i2)
print *,c_sizeof(x)
print *, c_sizeof(ran()) ! { dg-error "must be an interoperable data entity" }
print *, c_sizeof(ran())
print *,storage_size(1.0,4)
print *,storage_size(1.0,3.2) ! { dg-error "must be INTEGER" }

14
gcc/testsuite/gfortran.dg/transfer_resolve_2.f90 Normal file
View file

@ -0,0 +1,14 @@
! { dg-do compile }
!
! PR fortran/56079
!
! Contributed by Thomas Koenig
!
program gar_nichts
use ISO_C_BINDING
use ISO_C_BINDING, only: C_PTR
use ISO_C_BINDING, only: abc => C_PTR
use ISO_C_BINDING, only: xyz => C_PTR
type(xyz) nada
nada = transfer(C_NULL_PTR,nada)
end program gar_nichts

20
gcc/testsuite/gfortran.dg/transfer_resolve_3.f90 Normal file
View file

@ -0,0 +1,20 @@
! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/56079
!
use iso_c_binding
implicit none
type t
type(c_ptr) :: ptr = c_null_ptr
end type t
type(t), parameter :: para = t()
integer(c_intptr_t) :: intg
intg = transfer (para, intg)
intg = transfer (para%ptr, intg)
end
! { dg-final { scan-tree-dump-times "intg = 0;" 2 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

12
gcc/testsuite/gfortran.dg/transfer_resolve_4.f90 Normal file
View file

@ -0,0 +1,12 @@
! { dg-do compile }
!
! PR fortran/47034
!
! Contributed by James Van Buskirk
!
subroutine james
use iso_c_binding
type(C_PTR), parameter :: p1 = &
transfer(32512_C_INTPTR_T,C_NULL_PTR)
integer(C_INTPTR_T), parameter :: n1 = transfer(p1,0_C_INTPTR_T)
end