2013-03-22 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/49023
PR fortran/50269
PR fortran/50612
PR fortran/52426
PR fortran/54263
PR fortran/55343
PR fortran/55444
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.
* 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.
* 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.
* 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-22 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/49023
PR fortran/50269
PR fortran/50612
PR fortran/52426
PR fortran/54263
PR fortran/55343
PR fortran/55444
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
* gfortran.dg/c_assoc_4.f90
* gfortran.dg/c_f_pointer_tests_6.f90
* gfortran.dg/c_f_pointer_tests_7.f90
* gfortran.dg/c_funloc_tests_8.f90
* gfortran.dg/c_loc_test_17.f90
* gfortran.dg/c_loc_test_18.f90
* gfortran.dg/c_loc_test_19.f90
* gfortran.dg/c_loc_test_20.f90
* gfortran.dg/c_sizeof_5.f90
* gfortran.dg/iso_c_binding_rename_3.f90
* gfortran.dg/transfer_resolve_2.f90
gcc/fortran/check.c | 383 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
gcc/fortran/expr.c | 47 +++++++---
gcc/fortran/gfortran.h | 16 +++-
gcc/fortran/intrinsic.c | 67 +++++++++++++-
gcc/fortran/intrinsic.h | 7 ++
gcc/fortran/iresolve.c | 14 +++
gcc/fortran/iso-c-binding.def | 32 ++++---
gcc/fortran/iso-fortran-env.def | 5 +
gcc/fortran/module.c | 217 +++++++++++++++++++++++++++++++++++---------
gcc/fortran/resolve.c | 574 ++-----------------------------------------------------------------------------------------------------------------
gcc/fortran/symbol.c | 613 +++++++++++++++++++--------------------------------------------------------------------------------------------------------
gcc/fortran/target-memory.c | 3 +
gcc/fortran/trans-expr.c | 238 +-----------------------------------------------
gcc/fortran/trans-intrinsic.c | 214 +++++++++++++++++++++++++++++++++++++++++++
gcc/fortran/trans-io.c | 5 +-
gcc/fortran/trans-types.c | 17 ++--
16 files changed, 1035 insertions(+), 1417 deletions(-)
gcc/testsuite/gfortran.dg/blockdata_7.f90 | 16 ++++++++++++++++
gcc/testsuite/gfortran.dg/c_assoc_2.f03 | 8 ++++----
gcc/testsuite/gfortran.dg/c_assoc_4.f90 | 14 ++++++++++++++
gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 | 2 +-
gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03 | 4 ++--
gcc/testsuite/gfortran.dg/c_f_pointer_tests_5.f90 | 2 +-
gcc/testsuite/gfortran.dg/c_f_pointer_tests_6.f90 | 43 +++++++++++++++++++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/c_f_pointer_tests_7.f90 | 9 +++++++++
gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03 | 6 +++---
gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 | 4 ++--
gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 | 8 ++++----
gcc/testsuite/gfortran.dg/c_funloc_tests_8.f90 | 49 +++++++++++++++++++++++++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/c_loc_test_17.f90 | 27 +++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/c_loc_test_18.f90 | 21 +++++++++++++++++++++
gcc/testsuite/gfortran.dg/c_loc_test_19.f90 | 17 +++++++++++++++++
gcc/testsuite/gfortran.dg/c_loc_test_20.f90 | 34 ++++++++++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/c_loc_tests_10.f03 | 3 ++-
gcc/testsuite/gfortran.dg/c_loc_tests_11.f03 | 10 ++++++----
gcc/testsuite/gfortran.dg/c_loc_tests_15.f90 | 2 +-
gcc/testsuite/gfortran.dg/c_loc_tests_16.f90 | 10 +++++-----
gcc/testsuite/gfortran.dg/c_loc_tests_3.f03 | 2 +-
gcc/testsuite/gfortran.dg/c_loc_tests_4.f03 | 4 +++-
gcc/testsuite/gfortran.dg/c_loc_tests_8.f03 | 2 +-
gcc/testsuite/gfortran.dg/c_ptr_tests_14.f90 | 6 ++++--
gcc/testsuite/gfortran.dg/c_ptr_tests_15.f90 | 6 ++++--
gcc/testsuite/gfortran.dg/c_sizeof_1.f90 | 11 ++++++-----
gcc/testsuite/gfortran.dg/c_sizeof_5.f90 | 12 ++++++++++++
gcc/testsuite/gfortran.dg/iso_c_binding_init_expr.f03 | 4 ++--
gcc/testsuite/gfortran.dg/iso_c_binding_rename_3.f90 | 23 +++++++++++++++++++++++
gcc/testsuite/gfortran.dg/pr32601_1.f03 | 2 +-
gcc/testsuite/gfortran.dg/storage_size_2.f08 | 4 ++--
gcc/testsuite/gfortran.dg/transfer_resolve_2.f90 | 14 ++++++++++++++
32 files changed, 334 insertions(+), 45 deletions(-)
@@ -693,12 +693,15 @@ gfc_var_strlen (const gfc_expr *a)
{
long start_a, end_a;
+ if (!ra->u.ss.start || !ra->u.ss.end)
+ return -1;
+
if (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);
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)
return 1;
@@ -3621,17 +3624,389 @@ gfc_check_sizeof (gfc_expr *arg)
}
+/* Check whether an expression is interoperable. 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 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: 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 = "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->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_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->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->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;
}
@@ -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 != GFC_ISYM_COMPILER_OPTIONS
+ && e->symtree->n.sym->intmod_sym_id != GFC_ISYM_COMPILER_VERSION)
+ return MATCH_NO;
+
+ if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING
+ && e->symtree->n.sym->intmod_sym_id != GFC_ISYM_C_SIZEOF)
+ return MATCH_NO;
+ }
+ else
+ {
+ name = e->symtree->n.sym->name;
- functions = (gfc_option.warn_std & GFC_STD_F2003)
+ 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 = gfc_current_ns;
+
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ if (sym == gfc_current_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)
@@ -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,7 @@ 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);
match gfc_intrinsic_func_interface (gfc_expr *, int);
match gfc_intrinsic_sub_interface (gfc_code *, int);
@@ -811,6 +811,24 @@ find_sym (gfc_intrinsic_sym *start, int n, const char *name)
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)
{
gfc_intrinsic_sym *start = functions;
@@ -2652,9 +2670,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 +3093,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,
@@ -4105,12 +4158,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 +4245,11 @@ 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)
+ isym = gfc_intrinsic_subroutine_by_id ((gfc_isym_id)
+ c->symtree->n.sym->intmod_sym_id);
+ else
+ isym = gfc_find_subroutine (name);
if (isym == NULL)
return MATCH_NO;
@@ -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 *);
@@ -501,6 +501,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)
{
f->ts.type = BT_INTEGER;
@@ -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
@@ -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
@@ -5571,7 +5571,8 @@ 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)
+ const char *modname, intmod_id module,
+ bool subroutine, gfc_symbol *result_type)
{
gfc_intrinsic_sym *isym;
gfc_symtree *tmp_symtree;
@@ -5588,7 +5589,27 @@ 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)
+ {
+ isym = gfc_intrinsic_subroutine_by_id (id);
+ sym->attr.subroutine = 1;
+ }
+ else
+ {
+ isym = gfc_intrinsic_function_by_id (id);
+ sym->attr.function = 1;
+ if (result_type)
+ {
+ sym->ts.type = BT_DERIVED;
+ isym->ts.f90_type = BT_VOID;
+ sym->ts.u.derived = result_type;
+ sym->ts.is_c_interop = 1;
+ 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;
@@ -5614,6 +5635,8 @@ import_iso_c_binding_module (void)
const char *iso_c_module_name = "__iso_c_binding";
gfc_use_rename *u;
int i;
+ bool want_c_ptr = false, want_c_funptr = false;
+ gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
/* Look only in the current namespace. */
mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
@@ -5636,6 +5659,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 +5730,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 = "";
@@ -5695,20 +5767,60 @@ import_iso_c_binding_module (void)
{
#define NAMED_FUNCTION(a,b,c,d) \
case a: \
+ if (a == ISOCBINDING_LOC) \
+ 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, false, \
+ c_ptr->n.sym); \
+ else if (a == ISOCBINDING_FUNLOC) \
+ 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, false, \
+ c_funptr->n.sym); \
+ else \
+ 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, false, NULL); \
+ 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); \
+ 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:
- generate_isocbinding_symbol (iso_c_module_name,
- (iso_c_binding_symbol) i,
- u->local_name[0] ? u->local_name
- : u->use_name);
+ if (i == ISOCBINDING_NULL_PTR)
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i,
+ u->local_name[0]
+ ? u->local_name : u->use_name,
+ c_ptr, false);
+ else if (i == ISOCBINDING_NULL_FUNPTR)
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i,
+ u->local_name[0]
+ ? u->local_name : u->use_name,
+ c_funptr, false);
+ else
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i,
+ u->local_name[0]
+ ? u->local_name : u->use_name,
+ NULL, false);
}
}
@@ -5722,30 +5834,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 +5863,47 @@ import_iso_c_binding_module (void)
{
#define NAMED_FUNCTION(a,b,c,d) \
case a: \
+ if (a == ISOCBINDING_LOC) \
+ create_intrinsic_function (b, (gfc_isym_id) c, \
+ iso_c_module_name, \
+ INTMOD_ISO_C_BINDING, false, \
+ c_ptr->n.sym); \
+ else if (a == ISOCBINDING_FUNLOC) \
+ create_intrinsic_function (b, (gfc_isym_id) c, \
+ iso_c_module_name, \
+ INTMOD_ISO_C_BINDING, false, \
+ c_funptr->n.sym); \
+ else \
+ create_intrinsic_function (b, (gfc_isym_id) c, \
+ iso_c_module_name, \
+ INTMOD_ISO_C_BINDING, false, \
+ NULL); \
+ break;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+ case a: \
create_intrinsic_function (b, (gfc_isym_id) c, \
iso_c_module_name, \
- INTMOD_ISO_C_BINDING); \
+ 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:
- generate_isocbinding_symbol (iso_c_module_name,
- (iso_c_binding_symbol) i, NULL);
+ if (i == ISOCBINDING_NULL_PTR)
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i, NULL,
+ c_ptr, false);
+ else if (i == ISOCBINDING_NULL_FUNPTR)
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i, NULL,
+ c_funptr, false);
+ else
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i, NULL,
+ NULL, false);
}
}
}
@@ -5917,23 +6057,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 +6118,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 +6140,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 +6149,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);
+ INTMOD_ISO_FORTRAN_ENV, false,
+ NULL);
break;
default:
@@ -6054,7 +6184,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 +6200,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 +6207,14 @@ 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);
+ INTMOD_ISO_FORTRAN_ENV, false,
+ NULL);
break;
default:
@@ -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);
@@ -1562,12 +1562,14 @@ 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)
+ if (sym->intmod_sym_id && sym->attr.subroutine)
+ isym = gfc_intrinsic_subroutine_by_id ((gfc_isym_id) sym->intmod_sym_id);
+ else if (sym->intmod_sym_id)
isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_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 +1582,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 +2721,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 +2783,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 +2865,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 +3068,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 +3075,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)
@@ -3939,70 +3939,28 @@ 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);
@@ -4040,200 +3998,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, ¶m_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, ¶m_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, ¶m_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 +4078,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 +4092,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 +4112,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 +4152,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 +4215,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,57 +4251,53 @@ 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 ();
-
- /* 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;
-
- if (!tmp_sym->attr.generic
- && gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
- == FAILURE)
- return;
-
- if (!tmp_sym->attr.function
- && gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
- == FAILURE)
- return;
+ {
+ const char *hidden_name;
+ gfc_interface *intr, *head;
+
+ 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");
+
+ /* 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.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);
@@ -4592,9 +4308,10 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
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->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 +4334,10 @@ 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");
+ gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
+ "create component for c_address");
tmp_comp->ts.type = BT_INTEGER;
@@ -4641,157 +4353,20 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
/* 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;
}
@@ -316,6 +316,9 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
}
case BT_DERIVED:
+ if (source->ts.u.derived->ts.f90_type == BT_VOID)
+ return encode_integer (gfc_index_integer_kind, source->value.integer, buffer,
+ buffer_size);
return encode_derived (source, buffer, buffer_size);
default:
gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
@@ -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;
}
}
@@ -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;
@@ -2037,9 +2037,8 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
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;
@@ -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;
new file mode 100644
@@ -0,0 +1,16 @@
+! { dg-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
@@ -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
new file mode 100644
@@ -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
@@ -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
@@ -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
@@ -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
new file mode 100644
@@ -0,0 +1,43 @@
+! { dg-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
new file mode 100644
@@ -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
@@ -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
@@ -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()
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -0,0 +1,27 @@
+! { dg-do compile }
+!
+! 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
new file mode 100644
@@ -0,0 +1,21 @@
+! { dg-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
new file mode 100644
@@ -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
new file mode 100644
@@ -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
+
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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" } }
@@ -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,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)
new file mode 100644
@@ -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
@@ -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
new file mode 100644
@@ -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
@@ -5,6 +5,6 @@ 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
@@ -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" }
new file mode 100644
@@ -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
Dear all, initially, I only wanted to allow assumed-rank arrays with C_LOC, even if I played with the idea to cleanup the intrinsic handling of the ISO_C_Binding module for quite some time. But Mikael rejected a hacky version. The main change of this patch is to move all the special handling of the intrinsics from symbol.c to the normal intrinsics code in intrinsic.{c,h}, check.c, iresolve.c and trans-intrinsics.c. That also implied to do some larger changes to module.c. Additionally, I rewrote all the constraint checks from scratch, based on the Fortran 2003, 2008 and TS29113 standards - and fixed the fallout. Finally, I looked through the bugreports mentioning those intrinsics - and fixed some remaing issues (some were already fixed, either by this patch or since at least GCC 4.6). Build and regtested on x86-64-gnu-linux. OK for the trunk? Follow-up tasks: * Implement Fortran 2008's IS_CONTIGUOUS intrinsic, add a gfc_is_not_contiguous function (has various use: to simplify that intrinsic, for error checks in c_loc, to make copy-out unconditional etc.). Plus fixing some issues with gfc_is_simply_contiguous (e.g. BT_CLASS is unhandled, but there are more issues). See PR38536, gfortran.dg/c_loc_tests_16.f90 (w/o -std=f2008) and probably more PRs. * Implement compile-time simplification of (c_)sizeof; required for MPICH. See PR 46641, 36437, 56650 * Cleanup and bug fixes related to BIND(C) procedures, including some of the new TS29113 features and F2008. (Full support requires the new array descriptor) * Other C binding issues, e.g. having multiple interfaces for the same binding name or fixing binding-name issues with COMMON. And a bunch of other issues, including ICEs. * New array descriptor / Other TS29113 tasks (None of those rank top on my to-do list.) Tobias PS: What I like about the patch is that it reduces the number of code lines, brings Bind(C) code into line with the rest of gfortran and (hopefully) fixes some bugs, improves diagnostic and lifts some restrictions (new F2008/TS29113 features). gcc/fortran directory: 16 files changed, 1035 insertions(+), 1417 deletions(-)