2013-03-25 Tobias Burnus <burnus@net-b.de>
PR fortran/38536
PR fortran/38813
PR fortran/38894
PR fortran/39288
PR fortran/40963
PR fortran/45824
PR fortran/47023
PR fortran/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.
(gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New prototypes.
* intrinsic.c (gfc_intrinsic_subroutine_by_id): New function.
(gfc_intrinsic_sub_interface): Use it.
(add_functions, add_subroutines): Add missing C-binding intrinsics.
(gfc_intrinsic_func_interface): Add special case for c_loc.
gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New functions.
(gfc_intrinsic_func_interface, gfc_intrinsic_sub_interface): Use them.
* intrinsic.h (gfc_check_c_associated, gfc_check_c_f_pointer,
gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc,
gfc_resolve_c_loc, gfc_resolve_c_funloc): New prototypes.
* iresolve.c (gfc_resolve_c_loc, gfc_resolve_c_funloc): New
functions.
* iso-c-binding.def: Split PROCEDURE into NAMED_SUBROUTINE and
NAMED_FUNCTION.
* iso-fortran-env.def: Add NAMED_SUBROUTINE for completeness.
* module.c (create_intrinsic_function): Support subroutines and
derived-type results.
(use_iso_fortran_env_module): Update calls.
(import_iso_c_binding_module): Ditto; update calls to
generate_isocbinding_symbol.
* resolve.c (find_arglists): Skip for intrinsic symbols.
(gfc_resolve_intrinsic): Find intrinsic subs via id.
(is_scalar_expr_ptr, gfc_iso_c_func_interface,
set_name_and_label, gfc_iso_c_sub_interface): Remove.
(resolve_function, resolve_specific_s0): Remove calls to those.
(resolve_structure_cons): Fix handling.
* symbol.c (gen_special_c_interop_ptr): Update c_ptr/c_funptr
generation.
(gen_cptr_param, gen_fptr_param, gen_shape_param,
build_formal_args, get_iso_c_sym): Remove.
(std_for_isocbinding_symbol): Handle NAMED_SUBROUTINE.
(generate_isocbinding_symbol): Support hidden symbols and
using c_ptr/c_funptr symtrees for nullptr defs.
* target-memory.c (gfc_target_encode_expr): Fix handling
of c_ptr/c_funptr.
* trans-expr.c (conv_isocbinding_procedure): Remove.
(gfc_conv_procedure_call): Remove call to it.
(gfc_trans_subcomponent_assign, gfc_conv_expr): Update handling
of c_ptr/c_funptr.
* trans-intrinsic.c (conv_isocbinding_function,
conv_isocbinding_subroutine): New.
(gfc_conv_intrinsic_function, gfc_conv_intrinsic_subroutine):
Call them.
* trans-io.c (transfer_expr): Fix handling of c_ptr/c_funptr.
* trans-types.c (gfc_typenode_for_spec,
gfc_get_derived_type): Ditto.
(gfc_init_c_interop_kinds): Handle NAMED_SUBROUTINE.
2013-03-25 Tobias Burnus <burnus@net-b.de>
PR fortran/38536
PR fortran/38813
PR fortran/38894
PR fortran/39288
PR fortran/40963
PR fortran/45824
PR fortran/47023
PR fortran/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: New.
* gfortran.dg/c_assoc_4.f90: New.
* gfortran.dg/c_f_pointer_tests_6.f90: New.
* gfortran.dg/c_f_pointer_tests_7.f90: New.
* gfortran.dg/c_funloc_tests_8.f90: New.
* gfortran.dg/c_loc_test_17.f90: New.
* gfortran.dg/c_loc_test_18.f90: New.
* gfortran.dg/c_loc_test_19.f90: New.
* gfortran.dg/c_loc_test_20.f90: New.
* gfortran.dg/c_sizeof_5.f90: New.
* gfortran.dg/iso_c_binding_rename_3.f90: New.
* gfortran.dg/transfer_resolve_2.f90: New.
* gfortran.dg/transfer_resolve_3.f90: New.
* gfortran.dg/pr32601.f03: Update dg-error.
* gfortran.dg/c_ptr_tests_13.f03: Update dg-error.
* gfortran.dg/c_ptr_tests_9.f03: Fix test case.
gcc/fortran/check.c | 397 ++++++++++++++++++++++++-
gcc/fortran/expr.c | 47 ++-
gcc/fortran/gfortran.h | 19 +-
gcc/fortran/intrinsic.c | 107 ++++++-
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 | 206 +++++++++----
gcc/fortran/resolve.c | 612 ++-------------------------------------
gcc/fortran/symbol.c | 621 +++++++---------------------------------
gcc/fortran/target-memory.c | 11 +
gcc/fortran/trans-expr.c | 238 +--------------
gcc/fortran/trans-intrinsic.c | 214 ++++++++++++++
gcc/fortran/trans-io.c | 16 +-
gcc/fortran/trans-types.c | 17 +-
16 files changed, 1098 insertions(+), 1465 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 +++++++
.../gfortran.dg/c_f_pointer_shape_test.f90 | 2 +-
.../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 | 28 +++++++++++++
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_17.f90 | 14 +++++++
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_13.f03 | 4 +-
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_ptr_tests_9.f03 | 4 +-
gcc/testsuite/gfortran.dg/c_sizeof_1.f90 | 11 ++---
gcc/testsuite/gfortran.dg/c_sizeof_5.f90 | 12 ++++++
.../gfortran.dg/iso_c_binding_init_expr.f03 | 4 +-
.../gfortran.dg/iso_c_binding_rename_3.f90 | 23 ++++++++++
gcc/testsuite/gfortran.dg/pr32601.f03 | 6 +--
gcc/testsuite/gfortran.dg/pr32601_1.f03 | 4 +-
gcc/testsuite/gfortran.dg/storage_size_2.f08 | 4 +-
gcc/testsuite/gfortran.dg/transfer_resolve_2.f90 | 14 +++++++
gcc/testsuite/gfortran.dg/transfer_resolve_3.f90 | 20 +++++++++
37 files changed, 378 insertions(+), 52 deletions(-)
@@ -693,14 +693,19 @@ gfc_var_strlen (const gfc_expr *a)
{
long start_a, end_a;
- if (ra->u.ss.start->expr_type == EXPR_CONSTANT
+ if (!ra->u.ss.end)
+ return -1;
+
+ if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT)
&& ra->u.ss.end->expr_type == EXPR_CONSTANT)
{
- start_a = mpz_get_si (ra->u.ss.start->value.integer);
+ start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer)
+ : 1;
end_a = mpz_get_si (ra->u.ss.end->value.integer);
- return end_a - start_a + 1;
+ return (end_a < start_a) ? 0 : end_a - start_a + 1;
}
- else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
+ else if (ra->u.ss.start
+ && gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
return 1;
else
return -1;
@@ -3621,17 +3626,395 @@ gfc_check_sizeof (gfc_expr *arg)
}
+/* Check whether an expression is interoperable. When returning false,
+ msg is set to a string telling why the expression is not interoperable,
+ otherwise, it is set to NULL. The msg string can be used in diagnostics.
+ If all_len_okay is true, all length-type parameters (for character) are
+ allowed. Required for C_LOC (cf. Fortran 2003corr5 or Fortran 2008). */
+
+static bool
+is_c_interoperable (gfc_expr *expr, const char **msg, bool all_len_okay)
+{
+ *msg = NULL;
+
+ if (expr->ts.type == BT_CLASS)
+ {
+ *msg = "Expression is polymorphic";
+ return false;
+ }
+
+ if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c
+ && !expr->ts.u.derived->ts.is_iso_c)
+ {
+ *msg = "Expression is a noninteroperable derived type";
+ return false;
+ }
+
+ if (expr->ts.type == BT_PROCEDURE)
+ {
+ *msg = "Procedure unexpected as argument";
+ return false;
+ }
+
+ if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL)
+ {
+ int i;
+ for (i = 0; gfc_logical_kinds[i].kind; i++)
+ if (gfc_logical_kinds[i].kind == expr->ts.kind)
+ return true;
+ *msg = "Extension to use a non-C_Bool-kind LOGICAL";
+ return false;
+ }
+
+ if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER
+ && expr->ts.kind != 1)
+ {
+ *msg = "Extension to use a non-C_CHAR-kind CHARACTER";
+ return false;
+ }
+
+ if (expr->ts.type == BT_CHARACTER) {
+ if (expr->ts.deferred)
+ {
+ /* TS 29113 allows deferred-length strings as dummy arguments,
+ but it is not an interoperable type. */
+ *msg = "Expression shall not be a deferred-length string";
+ return false;
+ }
+
+ if (expr->ts.u.cl && expr->ts.u.cl->length
+ && gfc_simplify_expr (expr, 0) == FAILURE)
+ gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
+
+ if (!all_len_okay && expr->ts.u.cl
+ && (!expr->ts.u.cl->length
+ || expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
+ || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0))
+ {
+ *msg = "Type shall have a character length of 1";
+ return false;
+ }
+ }
+
+ /* Note: The following checks are about interoperatable variables, Fortran
+ 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
+ is allowed, e.g. assumed-shape arrays with TS 29113. */
+
+ if (gfc_is_coarray (expr))
+ {
+ *msg = "Coarrays are not interoperable";
+ return false;
+ }
+
+ if (expr->rank > 0 && expr->expr_type != EXPR_ARRAY)
+ {
+ gfc_array_ref *ar = gfc_find_array_ref (expr);
+ if (ar->type != AR_FULL)
+ {
+ *msg = "Only whole-arrays are interoperable";
+ return false;
+ }
+ if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE)
+ {
+ *msg = "Only explicit-size and assumed-size arrays are interoperable";
+ return false;
+ }
+ }
+
+ return true;
+}
+
+
gfc_try
gfc_check_c_sizeof (gfc_expr *arg)
{
- if (gfc_verify_c_interop (&arg->ts) != SUCCESS)
+ const char *msg;
+
+ if (is_c_interoperable (arg, &msg, false) != SUCCESS)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
- "interoperable data entity",
+ "interoperable data entity: %s",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &arg->where);
+ &arg->where, msg);
+ return FAILURE;
+ }
+
+ if (arg->rank && arg->expr_type == EXPR_VARIABLE
+ && arg->symtree->n.sym->as != NULL
+ && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
+ && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
+ "assumed-size array", gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic, &arg->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
+{
+ if (c_ptr_1->ts.type != BT_DERIVED
+ || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+ || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
+ && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
+ {
+ gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
+ "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
+ return FAILURE;
+ }
+
+ if (scalar_check (c_ptr_1, 0) == FAILURE)
+ return FAILURE;
+
+ if (c_ptr_2
+ && (c_ptr_2->ts.type != BT_DERIVED
+ || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+ || (c_ptr_1->ts.u.derived->intmod_sym_id
+ != c_ptr_2->ts.u.derived->intmod_sym_id)))
+ {
+ gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
+ "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
+ gfc_typename (&c_ptr_1->ts),
+ gfc_typename (&c_ptr_2->ts));
+ return FAILURE;
+ }
+
+ if (c_ptr_2 && scalar_check (c_ptr_2, 1) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
+{
+ symbol_attribute attr;
+ const char *msg;
+
+ if (cptr->ts.type != BT_DERIVED
+ || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+ || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
+ {
+ gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
+ "type TYPE(C_PTR)", &cptr->where);
+ return FAILURE;
+ }
+
+ if (scalar_check (cptr, 0) == FAILURE)
+ return FAILURE;
+
+ attr = gfc_expr_attr (fptr);
+
+ if (!attr.pointer)
+ {
+ gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
+ &fptr->where);
+ return FAILURE;
+ }
+
+ if (fptr->ts.type == BT_CLASS)
+ {
+ gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
+ &fptr->where);
+ return FAILURE;
+ }
+
+ if (gfc_is_coindexed (fptr))
+ {
+ gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
+ "coindexed", &fptr->where);
+ return FAILURE;
+ }
+
+ if (fptr->rank == 0 && shape)
+ {
+ gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
+ "FPTR", &fptr->where);
+ return FAILURE;
+ }
+ else if (fptr->rank && !shape)
+ {
+ gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
+ "FPTR at %L", &fptr->where);
+ return FAILURE;
+ }
+
+ if (shape && rank_check (shape, 2, 1) == FAILURE)
+ return FAILURE;
+
+ if (shape && type_check (shape, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (shape)
+ {
+ mpz_t size;
+
+ if (gfc_array_size (shape, &size) == SUCCESS
+ && mpz_cmp_ui (size, fptr->rank) != 0)
+ {
+ mpz_clear (size);
+ gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
+ "size as the RANK of FPTR", &shape->where);
+ return FAILURE;
+ }
+ mpz_clear (size);
+ }
+
+ if (fptr->ts.type == BT_CLASS)
+ {
+ gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
+ return FAILURE;
+ }
+
+ if (!is_c_interoperable (fptr, &msg, false) && fptr->rank)
+ return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable array FPTR "
+ "at %L to C_F_POINTER: %s", &fptr->where, msg);
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
+{
+ symbol_attribute attr;
+
+ if (cptr->ts.type != BT_DERIVED
+ || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+ || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)
+ {
+ gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
+ "type TYPE(C_FUNPTR)", &cptr->where);
+ return FAILURE;
+ }
+
+ if (scalar_check (cptr, 0) == FAILURE)
+ return FAILURE;
+
+ attr = gfc_expr_attr (fptr);
+
+ if (!attr.proc_pointer)
+ {
+ gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
+ "pointer", &fptr->where);
+ return FAILURE;
+ }
+
+ if (gfc_is_coindexed (fptr))
+ {
+ gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
+ "coindexed", &fptr->where);
+ return FAILURE;
+ }
+
+ if (!attr.is_bind_c)
+ return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable procedure "
+ "pointer at %L to C_F_PROCPOINTER", &fptr->where);
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_c_funloc (gfc_expr *x)
+{
+ symbol_attribute attr;
+
+ if (gfc_is_coindexed (x))
+ {
+ gfc_error ("Argument X at %L to C_FUNLOC shall not be "
+ "coindexed", &x->where);
return FAILURE;
}
+
+ attr = gfc_expr_attr (x);
+
+ if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE
+ && x->symtree->n.sym == x->symtree->n.sym->result)
+ {
+ gfc_namespace *ns = gfc_current_ns;
+
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ if (x->symtree->n.sym == ns->proc_name)
+ {
+ gfc_error ("Function result '%s' at %L is invalid as X argument "
+ "to C_FUNLOC", x->symtree->n.sym->name, &x->where);
+ return FAILURE;
+ }
+ }
+
+ if (attr.flavor != FL_PROCEDURE)
+ {
+ gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
+ "or a procedure pointer", &x->where);
+ return FAILURE;
+ }
+
+ if (!attr.is_bind_c)
+ return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable procedure "
+ "at %L to C_FUNLOC", &x->where);
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_c_loc (gfc_expr *x)
+{
+ symbol_attribute attr;
+ const char *msg;
+
+ if (gfc_is_coindexed (x))
+ {
+ gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where);
+ return FAILURE;
+ }
+
+ if (x->ts.type == BT_CLASS)
+ {
+ gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
+ &x->where);
+ return FAILURE;
+ }
+
+ attr = gfc_expr_attr (x);
+
+ if (!attr.pointer
+ && (x->expr_type != EXPR_VARIABLE || !attr.target
+ || attr.flavor == FL_PARAMETER))
+ {
+ gfc_error ("Argument X at %L to C_LOC shall have either "
+ "the POINTER or the TARGET attribute", &x->where);
+ return FAILURE;
+ }
+
+ if (x->ts.type == BT_CHARACTER
+ && gfc_var_strlen (x) == 0)
+ {
+ gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
+ "string", &x->where);
+ return FAILURE;
+ }
+
+ if (!is_c_interoperable (x, &msg, true))
+ {
+ if (x->ts.type == BT_CLASS)
+ {
+ gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
+ &x->where);
+ return FAILURE;
+ }
+
+ if (x->rank
+ && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable array at %L as"
+ " argument to C_LOC: %s", &x->where, msg) == FAILURE)
+ return FAILURE;
+ }
+
return SUCCESS;
}
@@ -2256,7 +2256,7 @@ check_inquiry (gfc_expr *e, int not_restricted)
"new_line", NULL
};
- int i;
+ int i = 0;
gfc_actual_arglist *ap;
if (!e->value.function.isym
@@ -2267,17 +2267,31 @@ check_inquiry (gfc_expr *e, int not_restricted)
if (e->symtree == NULL)
return MATCH_NO;
- name = e->symtree->n.sym->name;
+ if (e->symtree->n.sym->from_intmod)
+ {
+ if (e->symtree->n.sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
+ && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
+ return MATCH_NO;
+
+ if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING
+ && e->symtree->n.sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
+ return MATCH_NO;
+ }
+ else
+ {
+ name = e->symtree->n.sym->name;
- functions = (gfc_option.warn_std & GFC_STD_F2003)
+ functions = (gfc_option.warn_std & GFC_STD_F2003)
? inquiry_func_f2003 : inquiry_func_f95;
- for (i = 0; functions[i]; i++)
- if (strcmp (functions[i], name) == 0)
- break;
+ for (i = 0; functions[i]; i++)
+ if (strcmp (functions[i], name) == 0)
+ break;
- if (functions[i] == NULL)
- return MATCH_ERROR;
+ if (functions[i] == NULL)
+ return MATCH_ERROR;
+ }
/* At this point we have an inquiry function with a variable argument. The
type of the variable might be undefined, but we need it now, because the
@@ -3429,13 +3443,18 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
attr = gfc_expr_attr (rvalue);
}
/* Check for result of embracing function. */
- if (sym == gfc_current_ns->proc_name
- && sym->attr.function && sym->result == sym)
+ if (sym->attr.function && sym->result == sym)
{
- gfc_error ("Function result '%s' is invalid as proc-target "
- "in procedure pointer assignment at %L",
- sym->name, &rvalue->where);
- return FAILURE;
+ gfc_namespace *ns;
+
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ if (sym == ns->proc_name)
+ {
+ gfc_error ("Function result '%s' is invalid as proc-target "
+ "in procedure pointer assignment at %L",
+ sym->name, &rvalue->where);
+ return FAILURE;
+ }
}
}
if (attr.abstract)
@@ -343,6 +343,11 @@ enum gfc_isym_id
GFC_ISYM_CPU_TIME,
GFC_ISYM_CSHIFT,
GFC_ISYM_CTIME,
+ GFC_ISYM_C_ASSOCIATED,
+ GFC_ISYM_C_F_POINTER,
+ GFC_ISYM_C_F_PROCPOINTER,
+ GFC_ISYM_C_FUNLOC,
+ GFC_ISYM_C_LOC,
GFC_ISYM_C_SIZEOF,
GFC_ISYM_DATE_AND_TIME,
GFC_ISYM_DBLE,
@@ -610,6 +615,7 @@ gfc_reverse;
#define NAMED_INTCST(a,b,c,d) a,
#define NAMED_KINDARRAY(a,b,c,d) a,
#define NAMED_FUNCTION(a,b,c,d) a,
+#define NAMED_SUBROUTINE(a,b,c,d) a,
#define NAMED_DERIVED_TYPE(a,b,c,d) a,
typedef enum
{
@@ -621,6 +627,7 @@ iso_fortran_env_symbol;
#undef NAMED_INTCST
#undef NAMED_KINDARRAY
#undef NAMED_FUNCTION
+#undef NAMED_SUBROUTINE
#undef NAMED_DERIVED_TYPE
#define NAMED_INTCST(a,b,c,d) a,
@@ -630,8 +637,8 @@ iso_fortran_env_symbol;
#define NAMED_CHARKNDCST(a,b,c) a,
#define NAMED_CHARCST(a,b,c) a,
#define DERIVED_TYPE(a,b,c) a,
-#define PROCEDURE(a,b) a,
#define NAMED_FUNCTION(a,b,c,d) a,
+#define NAMED_SUBROUTINE(a,b,c,d) a,
typedef enum
{
ISOCBINDING_INVALID = -1,
@@ -647,8 +654,8 @@ iso_c_binding_symbol;
#undef NAMED_CHARKNDCST
#undef NAMED_CHARCST
#undef DERIVED_TYPE
-#undef PROCEDURE
#undef NAMED_FUNCTION
+#undef NAMED_SUBROUTINE
typedef enum
{
@@ -2635,8 +2642,8 @@ gfc_try gfc_verify_c_interop_param (gfc_symbol *);
gfc_try verify_bind_c_sym (gfc_symbol *, gfc_typespec *, int, gfc_common_head *);
gfc_try verify_bind_c_derived_type (gfc_symbol *);
gfc_try verify_com_block_vars_c_interop (gfc_common_head *);
-void generate_isocbinding_symbol (const char *, iso_c_binding_symbol, const char *);
-gfc_symbol *get_iso_c_sym (gfc_symbol *, char *, const char *, int);
+gfc_symtree *generate_isocbinding_symbol (const char *, iso_c_binding_symbol,
+ const char *, gfc_symtree *, bool);
int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **, bool);
int gfc_get_ha_symbol (const char *, gfc_symbol **);
int gfc_get_ha_sym_tree (const char *, gfc_symtree **);
@@ -2707,6 +2714,10 @@ int gfc_intrinsic_actual_ok (const char *, const bool);
gfc_intrinsic_sym *gfc_find_function (const char *);
gfc_intrinsic_sym *gfc_find_subroutine (const char *);
gfc_intrinsic_sym *gfc_intrinsic_function_by_id (gfc_isym_id);
+gfc_intrinsic_sym *gfc_intrinsic_subroutine_by_id (gfc_isym_id);
+gfc_isym_id gfc_isym_id_by_intmod (intmod_id, int);
+gfc_isym_id gfc_isym_id_by_intmod_sym (gfc_symbol *);
+
match gfc_intrinsic_func_interface (gfc_expr *, int);
match gfc_intrinsic_sub_interface (gfc_code *, int);
@@ -810,6 +810,57 @@ find_sym (gfc_intrinsic_sym *start, int n, const char *name)
}
+gfc_isym_id
+gfc_isym_id_by_intmod (intmod_id from_intmod, int intmod_sym_id)
+{
+ if (from_intmod == INTMOD_ISO_C_BINDING)
+ return (gfc_isym_id) c_interop_kinds_table[intmod_sym_id].value;
+ else if (from_intmod == INTMOD_ISO_FORTRAN_ENV)
+ switch (intmod_sym_id)
+ {
+#define NAMED_SUBROUTINE(a,b,c,d) \
+ case a: \
+ return (gfc_isym_id) c;
+#define NAMED_FUNCTION(a,b,c,d) \
+ case a: \
+ return (gfc_isym_id) c;
+#include "iso-fortran-env.def"
+ default:
+ gcc_unreachable ();
+ }
+ else
+ {
+ gcc_unreachable ();
+ }
+ return (gfc_isym_id) 0;
+}
+
+
+gfc_isym_id
+gfc_isym_id_by_intmod_sym (gfc_symbol *sym)
+{
+ return gfc_isym_id_by_intmod (sym->from_intmod, sym->intmod_sym_id);
+}
+
+
+gfc_intrinsic_sym *
+gfc_intrinsic_subroutine_by_id (gfc_isym_id id)
+{
+ gfc_intrinsic_sym *start = subroutines;
+ int n = nsub;
+
+ while (true)
+ {
+ gcc_assert (n > 0);
+ if (id == start->id)
+ return start;
+
+ start++;
+ n--;
+ }
+}
+
+
gfc_intrinsic_sym *
gfc_intrinsic_function_by_id (gfc_isym_id id)
{
@@ -2652,9 +2703,28 @@ add_functions (void)
make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
- /* C_SIZEOF is part of ISO_C_BINDING. */
+ /* The following functions are part of ISO_C_BINDING. */
+ add_sym_2 ("c_associated", GFC_ISYM_C_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO,
+ BT_LOGICAL, dl, GFC_STD_F2003, gfc_check_c_associated, NULL, NULL,
+ "C_PTR_1", BT_VOID, 0, REQUIRED,
+ "C_PTR_2", BT_VOID, 0, OPTIONAL);
+ make_from_module();
+
+ add_sym_1 ("c_loc", GFC_ISYM_C_LOC, CLASS_INQUIRY, ACTUAL_NO,
+ BT_VOID, 0, GFC_STD_F2003,
+ gfc_check_c_loc, NULL, gfc_resolve_c_loc,
+ x, BT_UNKNOWN, 0, REQUIRED);
+ make_from_module();
+
+ add_sym_1 ("c_funloc", GFC_ISYM_C_FUNLOC, CLASS_INQUIRY, ACTUAL_NO,
+ BT_VOID, 0, GFC_STD_F2003,
+ gfc_check_c_funloc, NULL, gfc_resolve_c_funloc,
+ x, BT_UNKNOWN, 0, REQUIRED);
+ make_from_module();
+
add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
- BT_INTEGER, ii, GFC_STD_F2008, gfc_check_c_sizeof, NULL, NULL,
+ BT_INTEGER, gfc_index_integer_kind, GFC_STD_F2008,
+ gfc_check_c_sizeof, NULL, NULL,
x, BT_UNKNOWN, 0, REQUIRED);
make_from_module();
@@ -3056,6 +3126,22 @@ add_subroutines (void)
pt, BT_INTEGER, di, OPTIONAL, INTENT_IN,
gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+ /* The following subroutines are part of ISO_C_BINDING. */
+
+ add_sym_3s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0,
+ GFC_STD_F2003, gfc_check_c_f_pointer, NULL, NULL,
+ "cptr", BT_VOID, 0, REQUIRED, INTENT_IN,
+ "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT,
+ "shape", BT_INTEGER, di, OPTIONAL, INTENT_IN);
+ make_from_module();
+
+ add_sym_2s ("c_f_procpointer", GFC_ISYM_C_F_PROCPOINTER, CLASS_IMPURE,
+ BT_UNKNOWN, 0, GFC_STD_F2003, gfc_check_c_f_procpointer,
+ NULL, NULL,
+ "cptr", BT_VOID, 0, REQUIRED, INTENT_IN,
+ "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
+ make_from_module();
+
/* More G77 compatibility garbage. */
add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
@@ -4078,8 +4164,8 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
if (expr->symtree->n.sym->intmod_sym_id)
{
- int id = expr->symtree->n.sym->intmod_sym_id;
- isym = specific = gfc_intrinsic_function_by_id ((gfc_isym_id) id);
+ gfc_isym_id id = gfc_isym_id_by_intmod_sym (expr->symtree->n.sym);
+ isym = specific = gfc_intrinsic_function_by_id (id);
}
else
isym = specific = gfc_find_function (name);
@@ -4105,12 +4191,12 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
gfc_current_intrinsic_where = &expr->where;
- /* Bypass the generic list for min and max. */
+ /* Bypass the generic list for min, max and ISO_C_Binding's c_loc. */
if (isym->check.f1m == gfc_check_min_max)
{
init_arglist (isym);
- if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
+ if (isym->check.f1m (expr->value.function.actual) == SUCCESS)
goto got_specific;
if (!error_flag)
@@ -4192,7 +4278,14 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
name = c->symtree->n.sym->name;
- isym = gfc_find_subroutine (name);
+ if (c->symtree->n.sym->intmod_sym_id)
+ {
+ gfc_isym_id id;
+ id = gfc_isym_id_by_intmod_sym (c->symtree->n.sym);
+ isym = gfc_intrinsic_subroutine_by_id (id);
+ }
+ else
+ isym = gfc_find_subroutine (name);
if (isym == NULL)
return MATCH_NO;
@@ -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
@@ -5570,8 +5570,9 @@ gfc_dump_module (const char *name, int dump_flag)
static void
-create_intrinsic_function (const char *name, gfc_isym_id id,
- const char *modname, intmod_id module)
+create_intrinsic_function (const char *name, int id,
+ const char *modname, intmod_id module,
+ bool subroutine, gfc_symbol *result_type)
{
gfc_intrinsic_sym *isym;
gfc_symtree *tmp_symtree;
@@ -5588,7 +5589,30 @@ create_intrinsic_function (const char *name, gfc_isym_id id,
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
sym = tmp_symtree->n.sym;
- isym = gfc_intrinsic_function_by_id (id);
+ if (subroutine)
+ {
+ gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
+ isym = gfc_intrinsic_subroutine_by_id (isym_id);
+ sym->attr.subroutine = 1;
+ }
+ else
+ {
+ gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
+ isym = gfc_intrinsic_function_by_id (isym_id);
+
+ sym->attr.function = 1;
+ if (result_type)
+ {
+ sym->ts.type = BT_DERIVED;
+ sym->ts.u.derived = result_type;
+ sym->ts.is_c_interop = 1;
+ isym->ts.f90_type = BT_VOID;
+ isym->ts.type = BT_DERIVED;
+ isym->ts.f90_type = BT_VOID;
+ isym->ts.u.derived = result_type;
+ isym->ts.is_c_interop = 1;
+ }
+ }
gcc_assert (isym);
sym->attr.flavor = FL_PROCEDURE;
@@ -5609,11 +5633,13 @@ create_intrinsic_function (const char *name, gfc_isym_id id,
static void
import_iso_c_binding_module (void)
{
- gfc_symbol *mod_sym = NULL;
- gfc_symtree *mod_symtree = NULL;
+ gfc_symbol *mod_sym = NULL, *return_type;
+ gfc_symtree *mod_symtree = NULL, *tmp_symtree;
+ gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
const char *iso_c_module_name = "__iso_c_binding";
gfc_use_rename *u;
int i;
+ bool want_c_ptr = false, want_c_funptr = false;
/* Look only in the current namespace. */
mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
@@ -5636,6 +5662,57 @@ import_iso_c_binding_module (void)
mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
}
+ /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
+ check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
+ need C_(FUN)PTR. */
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name,
+ u->use_name) == 0)
+ want_c_ptr = true;
+ else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name,
+ u->use_name) == 0)
+ want_c_ptr = true;
+ else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name,
+ u->use_name) == 0)
+ want_c_funptr = true;
+ else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name,
+ u->use_name) == 0)
+ want_c_funptr = true;
+ else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
+ u->use_name) == 0)
+ {
+ c_ptr = generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol)
+ ISOCBINDING_PTR,
+ u->local_name[0] ? u->local_name
+ : u->use_name,
+ NULL, false);
+ }
+ else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
+ u->use_name) == 0)
+ {
+ c_funptr
+ = generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol)
+ ISOCBINDING_FUNPTR,
+ u->local_name[0] ? u->local_name
+ : u->use_name,
+ NULL, false);
+ }
+ }
+
+ if ((want_c_ptr || !only_flag) && !c_ptr)
+ c_ptr = generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol)
+ ISOCBINDING_PTR,
+ NULL, NULL, only_flag);
+ if ((want_c_funptr || !only_flag) && !c_funptr)
+ c_funptr = generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol)
+ ISOCBINDING_FUNPTR,
+ NULL, NULL, only_flag);
+
/* Generate the symbols for the named constants representing
the kinds for intrinsic data types. */
for (i = 0; i < ISOCBINDING_NUMBER; i++)
@@ -5656,29 +5733,27 @@ import_iso_c_binding_module (void)
not_in_std = (gfc_option.allow_std & d) == 0; \
name = b; \
break;
-#include "iso-c-binding.def"
-#undef NAMED_FUNCTION
+#define NAMED_SUBROUTINE(a,b,c,d) \
+ case a: \
+ not_in_std = (gfc_option.allow_std & d) == 0; \
+ name = b; \
+ break;
#define NAMED_INTCST(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
name = b; \
break;
-#include "iso-c-binding.def"
-#undef NAMED_INTCST
#define NAMED_REALCST(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
name = b; \
break;
-#include "iso-c-binding.def"
-#undef NAMED_REALCST
#define NAMED_CMPXCST(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
name = b; \
break;
#include "iso-c-binding.def"
-#undef NAMED_CMPXCST
default:
not_in_std = false;
name = "";
@@ -5695,20 +5770,43 @@ import_iso_c_binding_module (void)
{
#define NAMED_FUNCTION(a,b,c,d) \
case a: \
+ if (a == ISOCBINDING_LOC) \
+ return_type = c_ptr->n.sym; \
+ else if (a == ISOCBINDING_FUNLOC) \
+ return_type = c_funptr->n.sym; \
+ else \
+ return_type = NULL; \
+ create_intrinsic_function (u->local_name[0] \
+ ? u->local_name : u->use_name, \
+ a, iso_c_module_name, \
+ INTMOD_ISO_C_BINDING, false, \
+ return_type); \
+ break;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+ case a: \
create_intrinsic_function (u->local_name[0] ? u->local_name \
: u->use_name, \
- (gfc_isym_id) c, \
- iso_c_module_name, \
- INTMOD_ISO_C_BINDING); \
+ a, iso_c_module_name, \
+ INTMOD_ISO_C_BINDING, true, NULL); \
break;
#include "iso-c-binding.def"
-#undef NAMED_FUNCTION
+ case ISOCBINDING_PTR:
+ case ISOCBINDING_FUNPTR:
+ /* Already handled above. */
+ break;
default:
+ if (i == ISOCBINDING_NULL_PTR)
+ tmp_symtree = c_ptr;
+ else if (i == ISOCBINDING_NULL_FUNPTR)
+ tmp_symtree = c_funptr;
+ else
+ tmp_symtree = NULL;
generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol) i,
- u->local_name[0] ? u->local_name
- : u->use_name);
+ u->local_name[0]
+ ? u->local_name : u->use_name,
+ tmp_symtree, false);
}
}
@@ -5722,30 +5820,27 @@ import_iso_c_binding_module (void)
if ((gfc_option.allow_std & d) == 0) \
continue; \
break;
-#include "iso-c-binding.def"
-#undef NAMED_FUNCTION
-
+#define NAMED_SUBROUTINE(a,b,c,d) \
+ case a: \
+ if ((gfc_option.allow_std & d) == 0) \
+ continue; \
+ break;
#define NAMED_INTCST(a,b,c,d) \
case a: \
if ((gfc_option.allow_std & d) == 0) \
continue; \
break;
-#include "iso-c-binding.def"
-#undef NAMED_INTCST
#define NAMED_REALCST(a,b,c,d) \
case a: \
if ((gfc_option.allow_std & d) == 0) \
continue; \
break;
-#include "iso-c-binding.def"
-#undef NAMED_REALCST
#define NAMED_CMPXCST(a,b,c,d) \
case a: \
if ((gfc_option.allow_std & d) == 0) \
continue; \
break;
#include "iso-c-binding.def"
-#undef NAMED_CMPXCST
default:
; /* Not GFC_STD_* versioned. */
}
@@ -5754,16 +5849,37 @@ import_iso_c_binding_module (void)
{
#define NAMED_FUNCTION(a,b,c,d) \
case a: \
- create_intrinsic_function (b, (gfc_isym_id) c, \
- iso_c_module_name, \
- INTMOD_ISO_C_BINDING); \
+ if (a == ISOCBINDING_LOC) \
+ return_type = c_ptr->n.sym; \
+ else if (a == ISOCBINDING_FUNLOC) \
+ return_type = c_funptr->n.sym; \
+ else \
+ return_type = NULL; \
+ create_intrinsic_function (b, a, iso_c_module_name, \
+ INTMOD_ISO_C_BINDING, false, \
+ return_type); \
+ break;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+ case a: \
+ create_intrinsic_function (b, a, iso_c_module_name, \
+ INTMOD_ISO_C_BINDING, true, NULL); \
break;
#include "iso-c-binding.def"
-#undef NAMED_FUNCTION
+ case ISOCBINDING_PTR:
+ case ISOCBINDING_FUNPTR:
+ /* Already handled above. */
+ break;
default:
+ if (i == ISOCBINDING_NULL_PTR)
+ tmp_symtree = c_ptr;
+ else if (i == ISOCBINDING_NULL_FUNPTR)
+ tmp_symtree = c_funptr;
+ else
+ tmp_symtree = NULL;
generate_isocbinding_symbol (iso_c_module_name,
- (iso_c_binding_symbol) i, NULL);
+ (iso_c_binding_symbol) i, NULL,
+ tmp_symtree, false);
}
}
}
@@ -5917,23 +6033,16 @@ use_iso_fortran_env_module (void)
intmod_sym symbol[] = {
#define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
-#include "iso-fortran-env.def"
-#undef NAMED_INTCST
#define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
-#include "iso-fortran-env.def"
-#undef NAMED_KINDARRAY
#define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
-#include "iso-fortran-env.def"
-#undef NAMED_DERIVED_TYPE
#define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
+#define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
#include "iso-fortran-env.def"
-#undef NAMED_FUNCTION
{ ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
i = 0;
#define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
#include "iso-fortran-env.def"
-#undef NAMED_INTCST
/* Generate the symbol for the module itself. */
mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
@@ -5985,7 +6094,6 @@ use_iso_fortran_env_module (void)
#define NAMED_INTCST(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
-#undef NAMED_INTCST
create_int_parameter (u->local_name[0] ? u->local_name
: u->use_name,
symbol[i].value, mod,
@@ -6008,7 +6116,6 @@ use_iso_fortran_env_module (void)
symbol[i].id); \
break;
#include "iso-fortran-env.def"
-#undef NAMED_KINDARRAY
#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
case a:
@@ -6018,16 +6125,15 @@ use_iso_fortran_env_module (void)
mod, INTMOD_ISO_FORTRAN_ENV,
symbol[i].id);
break;
-#undef NAMED_DERIVED_TYPE
#define NAMED_FUNCTION(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
-#undef NAMED_FUNCTION
create_intrinsic_function (u->local_name[0] ? u->local_name
: u->use_name,
- (gfc_isym_id) symbol[i].value, mod,
- INTMOD_ISO_FORTRAN_ENV);
+ symbol[i].id, mod,
+ INTMOD_ISO_FORTRAN_ENV, false,
+ NULL);
break;
default:
@@ -6054,7 +6160,6 @@ use_iso_fortran_env_module (void)
#define NAMED_INTCST(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
-#undef NAMED_INTCST
create_int_parameter (symbol[i].name, symbol[i].value, mod,
INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
break;
@@ -6071,7 +6176,6 @@ use_iso_fortran_env_module (void)
INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
break;
#include "iso-fortran-env.def"
-#undef NAMED_KINDARRAY
#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
case a:
@@ -6079,15 +6183,13 @@ use_iso_fortran_env_module (void)
create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
symbol[i].id);
break;
-#undef NAMED_DERIVED_TYPE
#define NAMED_FUNCTION(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
-#undef NAMED_FUNCTION
- create_intrinsic_function (symbol[i].name,
- (gfc_isym_id) symbol[i].value, mod,
- INTMOD_ISO_FORTRAN_ENV);
+ create_intrinsic_function (symbol[i].name, symbol[i].id, mod,
+ INTMOD_ISO_FORTRAN_ENV, false,
+ NULL);
break;
default:
@@ -520,7 +520,7 @@ static void
find_arglists (gfc_symbol *sym)
{
if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
- || sym->attr.flavor == FL_DERIVED)
+ || sym->attr.flavor == FL_DERIVED || sym->attr.intrinsic)
return;
resolve_formal_arglist (sym);
@@ -1038,23 +1038,6 @@ resolve_structure_cons (gfc_expr *expr, int init)
cons = gfc_constructor_first (expr->value.constructor);
- /* See if the user is trying to invoke a structure constructor for one of
- the iso_c_binding derived types. */
- if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
- && expr->ts.u.derived->ts.is_iso_c && cons
- && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
- {
- gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
- expr->ts.u.derived->name, &(expr->where));
- return FAILURE;
- }
-
- /* Return if structure constructor is c_null_(fun)prt. */
- if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
- && expr->ts.u.derived->ts.is_iso_c && cons
- && cons->expr && cons->expr->expr_type == EXPR_NULL)
- return SUCCESS;
-
/* A constructor may have references if it is the result of substituting a
parameter variable. In this case we just pull out the component we
want. */
@@ -1180,7 +1163,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
if (cons->expr->expr_type == EXPR_NULL
&& !(comp->attr.pointer || comp->attr.allocatable
- || comp->attr.proc_pointer
+ || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
|| (comp->ts.type == BT_CLASS
&& (CLASS_DATA (comp)->attr.class_pointer
|| CLASS_DATA (comp)->attr.allocatable))))
@@ -1562,12 +1545,20 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
gfc_find_subroutine directly to check whether it is a function or
subroutine. */
- if (sym->intmod_sym_id)
- isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
+ if (sym->intmod_sym_id && sym->attr.subroutine)
+ {
+ gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
+ isym = gfc_intrinsic_subroutine_by_id (id);
+ }
+ else if (sym->intmod_sym_id)
+ {
+ gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
+ isym = gfc_intrinsic_function_by_id (id);
+ }
else if (!sym->attr.subroutine)
isym = gfc_find_function (sym->name);
- if (isym)
+ if (isym && !sym->attr.subroutine)
{
if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
&& !sym->attr.implicit_type)
@@ -1580,7 +1571,7 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
sym->ts = isym->ts;
}
- else if ((isym = gfc_find_subroutine (sym->name)))
+ else if (isym || (isym = gfc_find_subroutine (sym->name)))
{
if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
{
@@ -2719,366 +2710,6 @@ pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
}
-static gfc_try
-is_scalar_expr_ptr (gfc_expr *expr)
-{
- gfc_try retval = SUCCESS;
- gfc_ref *ref;
- int start;
- int end;
-
- /* See if we have a gfc_ref, which means we have a substring, array
- reference, or a component. */
- if (expr->ref != NULL)
- {
- ref = expr->ref;
- while (ref->next != NULL)
- ref = ref->next;
-
- switch (ref->type)
- {
- case REF_SUBSTRING:
- if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
- || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
- retval = FAILURE;
- break;
-
- case REF_ARRAY:
- if (ref->u.ar.type == AR_ELEMENT)
- retval = SUCCESS;
- else if (ref->u.ar.type == AR_FULL)
- {
- /* The user can give a full array if the array is of size 1. */
- if (ref->u.ar.as != NULL
- && ref->u.ar.as->rank == 1
- && ref->u.ar.as->type == AS_EXPLICIT
- && ref->u.ar.as->lower[0] != NULL
- && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
- && ref->u.ar.as->upper[0] != NULL
- && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
- {
- /* If we have a character string, we need to check if
- its length is one. */
- if (expr->ts.type == BT_CHARACTER)
- {
- if (expr->ts.u.cl == NULL
- || expr->ts.u.cl->length == NULL
- || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
- != 0)
- retval = FAILURE;
- }
- else
- {
- /* We have constant lower and upper bounds. If the
- difference between is 1, it can be considered a
- scalar.
- FIXME: Use gfc_dep_compare_expr instead. */
- start = (int) mpz_get_si
- (ref->u.ar.as->lower[0]->value.integer);
- end = (int) mpz_get_si
- (ref->u.ar.as->upper[0]->value.integer);
- if (end - start + 1 != 1)
- retval = FAILURE;
- }
- }
- else
- retval = FAILURE;
- }
- else
- retval = FAILURE;
- break;
- default:
- retval = SUCCESS;
- break;
- }
- }
- else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
- {
- /* Character string. Make sure it's of length 1. */
- if (expr->ts.u.cl == NULL
- || expr->ts.u.cl->length == NULL
- || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
- retval = FAILURE;
- }
- else if (expr->rank != 0)
- retval = FAILURE;
-
- return retval;
-}
-
-
-/* Match one of the iso_c_binding functions (c_associated or c_loc)
- and, in the case of c_associated, set the binding label based on
- the arguments. */
-
-static gfc_try
-gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
- gfc_symbol **new_sym)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- int optional_arg = 0;
- gfc_try retval = SUCCESS;
- gfc_symbol *args_sym;
- gfc_typespec *arg_ts;
- symbol_attribute arg_attr;
-
- if (args->expr->expr_type == EXPR_CONSTANT
- || args->expr->expr_type == EXPR_OP
- || args->expr->expr_type == EXPR_NULL)
- {
- gfc_error ("Argument to '%s' at %L is not a variable",
- sym->name, &(args->expr->where));
- return FAILURE;
- }
-
- args_sym = args->expr->symtree->n.sym;
-
- /* The typespec for the actual arg should be that stored in the expr
- and not necessarily that of the expr symbol (args_sym), because
- the actual expression could be a part-ref of the expr symbol. */
- arg_ts = &(args->expr->ts);
- arg_attr = gfc_expr_attr (args->expr);
-
- if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
- {
- /* If the user gave two args then they are providing something for
- the optional arg (the second cptr). Therefore, set the name and
- binding label to the c_associated for two cptrs. Otherwise,
- set c_associated to expect one cptr. */
- if (args->next)
- {
- /* two args. */
- sprintf (name, "%s_2", sym->name);
- optional_arg = 1;
- }
- else
- {
- /* one arg. */
- sprintf (name, "%s_1", sym->name);
- optional_arg = 0;
- }
-
- /* Get a new symbol for the version of c_associated that
- will get called. */
- *new_sym = get_iso_c_sym (sym, name, NULL, optional_arg);
- }
- else if (sym->intmod_sym_id == ISOCBINDING_LOC
- || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
- {
- sprintf (name, "%s", sym->name);
-
- /* Error check the call. */
- if (args->next != NULL)
- {
- gfc_error_now ("More actual than formal arguments in '%s' "
- "call at %L", name, &(args->expr->where));
- retval = FAILURE;
- }
- else if (sym->intmod_sym_id == ISOCBINDING_LOC)
- {
- gfc_ref *ref;
- bool seen_section;
-
- /* Make sure we have either the target or pointer attribute. */
- if (!arg_attr.target && !arg_attr.pointer)
- {
- gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
- "a TARGET or an associated pointer",
- args_sym->name,
- sym->name, &(args->expr->where));
- retval = FAILURE;
- }
-
- if (gfc_is_coindexed (args->expr))
- {
- gfc_error_now ("Coindexed argument not permitted"
- " in '%s' call at %L", name,
- &(args->expr->where));
- retval = FAILURE;
- }
-
- /* Follow references to make sure there are no array
- sections. */
- seen_section = false;
-
- for (ref=args->expr->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_ARRAY)
- {
- if (ref->u.ar.type == AR_SECTION)
- seen_section = true;
-
- if (ref->u.ar.type != AR_ELEMENT)
- {
- gfc_ref *r;
- for (r = ref->next; r; r=r->next)
- if (r->type == REF_COMPONENT)
- {
- gfc_error_now ("Array section not permitted"
- " in '%s' call at %L", name,
- &(args->expr->where));
- retval = FAILURE;
- break;
- }
- }
- }
- }
-
- if (seen_section && retval == SUCCESS)
- gfc_warning ("Array section in '%s' call at %L", name,
- &(args->expr->where));
-
- /* See if we have interoperable type and type param. */
- if (gfc_verify_c_interop (arg_ts) == SUCCESS
- || gfc_check_any_c_kind (arg_ts) == SUCCESS)
- {
- if (args_sym->attr.target == 1)
- {
- /* Case 1a, section 15.1.2.5, J3/04-007: variable that
- has the target attribute and is interoperable. */
- /* Case 1b, section 15.1.2.5, J3/04-007: allocated
- allocatable variable that has the TARGET attribute and
- is not an array of zero size. */
- if (args_sym->attr.allocatable == 1)
- {
- if (args_sym->attr.dimension != 0
- && (args_sym->as && args_sym->as->rank == 0))
- {
- gfc_error_now ("Allocatable variable '%s' used as a "
- "parameter to '%s' at %L must not be "
- "an array of zero size",
- args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
- }
- else
- {
- /* A non-allocatable target variable with C
- interoperable type and type parameters must be
- interoperable. */
- if (args_sym && args_sym->attr.dimension)
- {
- if (args_sym->as->type == AS_ASSUMED_SHAPE)
- {
- gfc_error ("Assumed-shape array '%s' at %L "
- "cannot be an argument to the "
- "procedure '%s' because "
- "it is not C interoperable",
- args_sym->name,
- &(args->expr->where), sym->name);
- retval = FAILURE;
- }
- else if (args_sym->as->type == AS_DEFERRED)
- {
- gfc_error ("Deferred-shape array '%s' at %L "
- "cannot be an argument to the "
- "procedure '%s' because "
- "it is not C interoperable",
- args_sym->name,
- &(args->expr->where), sym->name);
- retval = FAILURE;
- }
- }
-
- /* Make sure it's not a character string. Arrays of
- any type should be ok if the variable is of a C
- interoperable type. */
- if (arg_ts->type == BT_CHARACTER)
- if (arg_ts->u.cl != NULL
- && (arg_ts->u.cl->length == NULL
- || arg_ts->u.cl->length->expr_type
- != EXPR_CONSTANT
- || mpz_cmp_si
- (arg_ts->u.cl->length->value.integer, 1)
- != 0)
- && is_scalar_expr_ptr (args->expr) != SUCCESS)
- {
- gfc_error_now ("CHARACTER argument '%s' to '%s' "
- "at %L must have a length of 1",
- args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
- }
- }
- else if (arg_attr.pointer
- && is_scalar_expr_ptr (args->expr) != SUCCESS)
- {
- /* Case 1c, section 15.1.2.5, J3/04-007: an associated
- scalar pointer. */
- gfc_error_now ("Argument '%s' to '%s' at %L must be an "
- "associated scalar POINTER", args_sym->name,
- sym->name, &(args->expr->where));
- retval = FAILURE;
- }
- }
- else
- {
- /* The parameter is not required to be C interoperable. If it
- is not C interoperable, it must be a nonpolymorphic scalar
- with no length type parameters. It still must have either
- the pointer or target attribute, and it can be
- allocatable (but must be allocated when c_loc is called). */
- if (args->expr->rank != 0
- && is_scalar_expr_ptr (args->expr) != SUCCESS)
- {
- gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
- "scalar", args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
- else if (arg_ts->type == BT_CHARACTER
- && is_scalar_expr_ptr (args->expr) != SUCCESS)
- {
- gfc_error_now ("CHARACTER argument '%s' to '%s' at "
- "%L must have a length of 1",
- args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
- else if (arg_ts->type == BT_CLASS)
- {
- gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
- "polymorphic", args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
- }
- }
- else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
- {
- if (args_sym->attr.flavor != FL_PROCEDURE)
- {
- /* TODO: Update this error message to allow for procedure
- pointers once they are implemented. */
- gfc_error_now ("Argument '%s' to '%s' at %L must be a "
- "procedure",
- args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
- else if (args_sym->attr.is_bind_c != 1
- && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
- "argument '%s' to '%s' at %L",
- args_sym->name, sym->name,
- &(args->expr->where)) == FAILURE)
- retval = FAILURE;
- }
-
- /* for c_loc/c_funloc, the new symbol is the same as the old one */
- *new_sym = sym;
- }
- else
- {
- gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
- "iso_c_binding function: '%s'!\n", sym->name);
- }
-
- return retval;
-}
-
-
/* Resolve a function call, which means resolving the arguments, then figuring
out which entity the name refers to. */
@@ -3141,19 +2772,6 @@ resolve_function (gfc_expr *expr)
inquiry_argument = false;
- /* Need to setup the call to the correct c_associated, depending on
- the number of cptrs to user gives to compare. */
- if (sym && sym->attr.is_iso_c == 1)
- {
- if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
- == FAILURE)
- return FAILURE;
-
- /* Get the symtree for the new symbol (resolved func).
- the old one will be freed later, when it's no longer used. */
- gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
- }
-
/* Resume assumed_size checking. */
need_full_assumed_size--;
@@ -3236,6 +2854,7 @@ resolve_function (gfc_expr *expr)
&& GENERIC_ID != GFC_ISYM_LBOUND
&& GENERIC_ID != GFC_ISYM_LEN
&& GENERIC_ID != GFC_ISYM_LOC
+ && GENERIC_ID != GFC_ISYM_C_LOC
&& GENERIC_ID != GFC_ISYM_PRESENT)
{
/* Array intrinsics must also have the last upper bound of an
@@ -3438,190 +3057,6 @@ generic:
}
-/* Set the name and binding label of the subroutine symbol in the call
- expression represented by 'c' to include the type and kind of the
- second parameter. This function is for resolving the appropriate
- version of c_f_pointer() and c_f_procpointer(). For example, a
- call to c_f_pointer() for a default integer pointer could have a
- name of c_f_pointer_i4. If no second arg exists, which is an error
- for these two functions, it defaults to the generic symbol's name
- and binding label. */
-
-static void
-set_name_and_label (gfc_code *c, gfc_symbol *sym,
- char *name, const char **binding_label)
-{
- gfc_expr *arg = NULL;
- char type;
- int kind;
-
- /* The second arg of c_f_pointer and c_f_procpointer determines
- the type and kind for the procedure name. */
- arg = c->ext.actual->next->expr;
-
- if (arg != NULL)
- {
- /* Set up the name to have the given symbol's name,
- plus the type and kind. */
- /* a derived type is marked with the type letter 'u' */
- if (arg->ts.type == BT_DERIVED)
- {
- type = 'd';
- kind = 0; /* set the kind as 0 for now */
- }
- else
- {
- type = gfc_type_letter (arg->ts.type);
- kind = arg->ts.kind;
- }
-
- if (arg->ts.type == BT_CHARACTER)
- /* Kind info for character strings not needed. */
- kind = 0;
-
- sprintf (name, "%s_%c%d", sym->name, type, kind);
- /* Set up the binding label as the given symbol's label plus
- the type and kind. */
- *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
- kind);
- }
- else
- {
- /* If the second arg is missing, set the name and label as
- was, cause it should at least be found, and the missing
- arg error will be caught by compare_parameters(). */
- sprintf (name, "%s", sym->name);
- *binding_label = sym->binding_label;
- }
-
- return;
-}
-
-
-/* Resolve a generic version of the iso_c_binding procedure given
- (sym) to the specific one based on the type and kind of the
- argument(s). Currently, this function resolves c_f_pointer() and
- c_f_procpointer based on the type and kind of the second argument
- (FPTR). Other iso_c_binding procedures aren't specially handled.
- Upon successfully exiting, c->resolved_sym will hold the resolved
- symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
- otherwise. */
-
-match
-gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
-{
- gfc_symbol *new_sym;
- /* this is fine, since we know the names won't use the max */
- char name[GFC_MAX_SYMBOL_LEN + 1];
- const char* binding_label;
- /* default to success; will override if find error */
- match m = MATCH_YES;
-
- /* Make sure the actual arguments are in the necessary order (based on the
- formal args) before resolving. */
- if (gfc_procedure_use (sym, &c->ext.actual, &(c->loc)) == FAILURE)
- {
- c->resolved_sym = sym;
- return MATCH_ERROR;
- }
-
- if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
- (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
- {
- set_name_and_label (c, sym, name, &binding_label);
-
- if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
- {
- if (c->ext.actual != NULL && c->ext.actual->next != NULL)
- {
- gfc_actual_arglist *arg1 = c->ext.actual;
- gfc_actual_arglist *arg2 = c->ext.actual->next;
- gfc_actual_arglist *arg3 = c->ext.actual->next->next;
-
- /* Check first argument (CPTR). */
- if (arg1->expr->ts.type != BT_DERIVED
- || arg1->expr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
- {
- gfc_error ("Argument CPTR to C_F_POINTER at %L shall have "
- "the type C_PTR", &arg1->expr->where);
- m = MATCH_ERROR;
- }
-
- /* Check second argument (FPTR). */
- if (arg2->expr->ts.type == BT_CLASS)
- {
- gfc_error ("Argument FPTR to C_F_POINTER at %L must not be "
- "polymorphic", &arg2->expr->where);
- m = MATCH_ERROR;
- }
-
- /* Make sure we got a third arg (SHAPE) if the second arg has
- non-zero rank. We must also check that the type and rank are
- correct since we short-circuit this check in
- gfc_procedure_use() (called above to sort actual args). */
- if (arg2->expr->rank != 0)
- {
- if (arg3 == NULL || arg3->expr == NULL)
- {
- m = MATCH_ERROR;
- gfc_error ("Missing SHAPE argument for call to %s at %L",
- sym->name, &c->loc);
- }
- else if (arg3->expr->ts.type != BT_INTEGER
- || arg3->expr->rank != 1)
- {
- m = MATCH_ERROR;
- gfc_error ("SHAPE argument for call to %s at %L must be "
- "a rank 1 INTEGER array", sym->name, &c->loc);
- }
- }
- }
- }
- else /* ISOCBINDING_F_PROCPOINTER. */
- {
- if (c->ext.actual
- && (c->ext.actual->expr->ts.type != BT_DERIVED
- || c->ext.actual->expr->ts.u.derived->intmod_sym_id
- != ISOCBINDING_FUNPTR))
- {
- gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type "
- "C_FUNPTR", &c->ext.actual->expr->where);
- m = MATCH_ERROR;
- }
- if (c->ext.actual && c->ext.actual->next
- && !gfc_expr_attr (c->ext.actual->next->expr).is_bind_c
- && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
- "procedure-pointer at %L to C_F_FUNPOINTER",
- &c->ext.actual->next->expr->where)
- == FAILURE)
- m = MATCH_ERROR;
- }
-
- if (m != MATCH_ERROR)
- {
- /* the 1 means to add the optional arg to formal list */
- new_sym = get_iso_c_sym (sym, name, binding_label, 1);
-
- /* for error reporting, say it's declared where the original was */
- new_sym->declared_at = sym->declared_at;
- }
- }
- else
- {
- /* no differences for c_loc or c_funloc */
- new_sym = sym;
- }
-
- /* set the resolved symbol */
- if (m != MATCH_ERROR)
- c->resolved_sym = new_sym;
- else
- c->resolved_sym = sym;
-
- return m;
-}
-
-
/* Resolve a subroutine call known to be specific. */
static match
@@ -3629,12 +3064,6 @@ resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
{
match m;
- if(sym->attr.is_iso_c)
- {
- m = gfc_iso_c_sub_interface (c,sym);
- return m;
- }
-
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
{
if (sym->attr.dummy)
@@ -8767,7 +8196,16 @@ resolve_transfer (gfc_code *code)
return;
}
- if (derived_inaccessible (ts->u.derived))
+ /* C_PTR and C_FUNPTR have private components which means they can not
+ be printed. However, if -std=gnu and not -pedantic, allow
+ the component to be printed to help debugging. */
+ if (ts->u.derived->ts.f90_type == BT_VOID)
+ {
+ if (gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L cannot "
+ "have PRIVATE components", &code->loc) == FAILURE)
+ return;
+ }
+ else if (derived_inaccessible (ts->u.derived))
{
gfc_error ("Data transfer element at %L cannot have "
"PRIVATE components",&code->loc);
@@ -3939,75 +3939,32 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
static gfc_try
-gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
- const char *module_name)
+gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree)
{
- gfc_symtree *tmp_symtree;
- gfc_symbol *tmp_sym;
gfc_constructor *c;
- tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
-
- if (tmp_symtree != NULL)
- tmp_sym = tmp_symtree->n.sym;
- else
- {
- tmp_sym = NULL;
- gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
- "create symbol for %s", ptr_name);
- }
+ gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym);
+ dt_symtree->n.sym->attr.referenced = 1;
- tmp_sym->ts.is_c_interop = 1;
tmp_sym->attr.is_c_interop = 1;
+ tmp_sym->attr.is_bind_c = 1;
+ tmp_sym->ts.is_c_interop = 1;
tmp_sym->ts.is_iso_c = 1;
tmp_sym->ts.type = BT_DERIVED;
+ tmp_sym->ts.f90_type = BT_VOID;
tmp_sym->attr.flavor = FL_PARAMETER;
-
- /* The c_ptr and c_funptr derived types will provide the
- definition for c_null_ptr and c_null_funptr, respectively. */
- if (ptr_id == ISOCBINDING_NULL_PTR)
- tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
- else
- tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
- if (tmp_sym->ts.u.derived == NULL)
- {
- /* This can occur if the user forgot to declare c_ptr or
- c_funptr and they're trying to use one of the procedures
- that has arg(s) of the missing type. In this case, a
- regular version of the thing should have been put in the
- current ns. */
-
- generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
- ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
- (const char *) (ptr_id == ISOCBINDING_NULL_PTR
- ? "c_ptr"
- : "c_funptr"));
- tmp_sym->ts.u.derived =
- get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
- ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
- }
-
- /* Module name is some mangled version of iso_c_binding. */
- tmp_sym->module = gfc_get_string (module_name);
-
- /* Say it's from the iso_c_binding module. */
- tmp_sym->attr.is_iso_c = 1;
-
- tmp_sym->attr.use_assoc = 1;
- tmp_sym->attr.is_bind_c = 1;
- /* Since we never generate a call to this symbol, don't set the
- binding_label. */
+ tmp_sym->ts.u.derived = dt_symtree->n.sym;
/* Set the c_address field of c_null_ptr and c_null_funptr to
the value of NULL. */
tmp_sym->value = gfc_get_expr ();
tmp_sym->value->expr_type = EXPR_STRUCTURE;
tmp_sym->value->ts.type = BT_DERIVED;
+ tmp_sym->value->ts.f90_type = BT_VOID;
tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
c = gfc_constructor_first (tmp_sym->value->value.constructor);
- c->expr = gfc_get_expr ();
- c->expr->expr_type = EXPR_NULL;
+ c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
c->expr->ts.is_iso_c = 1;
return SUCCESS;
@@ -4040,200 +3997,6 @@ add_formal_arg (gfc_formal_arglist **head,
}
-/* Generates a symbol representing the CPTR argument to an
- iso_c_binding procedure. Also, create a gfc_formal_arglist for the
- CPTR and add it to the provided argument list. */
-
-static void
-gen_cptr_param (gfc_formal_arglist **head,
- gfc_formal_arglist **tail,
- const char *module_name,
- gfc_namespace *ns, const char *c_ptr_name,
- int iso_c_sym_id)
-{
- gfc_symbol *param_sym = NULL;
- gfc_symbol *c_ptr_sym = NULL;
- gfc_symtree *param_symtree = NULL;
- gfc_formal_arglist *formal_arg = NULL;
- const char *c_ptr_in;
- const char *c_ptr_type = NULL;
-
- if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
- c_ptr_type = "c_funptr";
- else
- c_ptr_type = "c_ptr";
-
- if(c_ptr_name == NULL)
- c_ptr_in = "gfc_cptr__";
- else
- c_ptr_in = c_ptr_name;
- gfc_get_sym_tree (c_ptr_in, ns, ¶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 +4077,6 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
}
-/* Builds the parameter list for the iso_c_binding procedure
- c_f_pointer or c_f_procpointer. The old_sym typically refers to a
- generic version of either the c_f_pointer or c_f_procpointer
- functions. The new_proc_sym represents a "resolved" version of the
- symbol. The functions are resolved to match the types of their
- parameters; for example, c_f_pointer(cptr, fptr) would resolve to
- something similar to c_f_pointer_i4 if the type of data object fptr
- pointed to was a default integer. The actual name of the resolved
- procedure symbol is further mangled with the module name, etc., but
- the idea holds true. */
-
-static void
-build_formal_args (gfc_symbol *new_proc_sym,
- gfc_symbol *old_sym, int add_optional_arg)
-{
- gfc_formal_arglist *head = NULL, *tail = NULL;
- gfc_namespace *parent_ns = NULL;
-
- parent_ns = gfc_current_ns;
- /* Create a new namespace, which will be the formal ns (namespace
- of the formal args). */
- gfc_current_ns = gfc_get_namespace(parent_ns, 0);
- gfc_current_ns->proc_name = new_proc_sym;
-
- /* Generate the params. */
- if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
- {
- gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "cptr", old_sym->intmod_sym_id);
- gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "fptr", 1);
- }
- else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
- {
- gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "cptr", old_sym->intmod_sym_id);
- gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "fptr", 0);
- /* If we're dealing with c_f_pointer, it has an optional third arg. */
- gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
- gfc_current_ns, "shape");
-
- }
- else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
- {
- /* c_associated has one required arg and one optional; both
- are c_ptrs. */
- gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
- if (add_optional_arg)
- {
- gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
- /* The last param is optional so mark it as such. */
- tail->sym->attr.optional = 1;
- }
- }
-
- /* Add the interface (store formal args to new_proc_sym). */
- add_proc_interface (new_proc_sym, IFSRC_DECL, head);
-
- /* Set up the formal_ns pointer to the one created for the
- new procedure so it'll get cleaned up during gfc_free_symbol(). */
- new_proc_sym->formal_ns = gfc_current_ns;
-
- gfc_current_ns = parent_ns;
-}
-
static int
std_for_isocbinding_symbol (int id)
{
@@ -4396,8 +4091,12 @@ std_for_isocbinding_symbol (int id)
#define NAMED_FUNCTION(a,b,c,d) \
case a:\
return d;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+ case a:\
+ return d;
#include "iso-c-binding.def"
#undef NAMED_FUNCTION
+#undef NAMED_SUBROUTINE
default:
return GFC_STD_F2003;
@@ -4412,23 +4111,29 @@ std_for_isocbinding_symbol (int id)
reported. If the user does not give an 'only' clause, all
iso_c_binding symbols are generated. If a list of specific kinds
is given, it must have a NULL in the first empty spot to mark the
- end of the list. */
+ end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
+ point to the symtree for c_(fun)ptr. */
-
-void
+gfc_symtree *
generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
- const char *local_name)
+ const char *local_name, gfc_symtree *dt_symtree,
+ bool hidden)
{
- const char *const name = (local_name && local_name[0]) ? local_name
- : c_interop_kinds_table[s].name;
- gfc_symtree *tmp_symtree = NULL;
+ const char *const name = (local_name && local_name[0])
+ ? local_name : c_interop_kinds_table[s].name;
+ gfc_symtree *tmp_symtree;
gfc_symbol *tmp_sym = NULL;
int index;
if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
- return;
+ return NULL;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (hidden
+ && (!tmp_symtree || !tmp_symtree->n.sym
+ || tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING
+ || tmp_symtree->n.sym->intmod_sym_id != s))
+ tmp_symtree = NULL;
/* Already exists in this scope so don't re-add it. */
if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
@@ -4446,21 +4151,40 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
gfc_derived_types = dt_list;
}
- return;
+ return tmp_symtree;
}
/* Create the sym tree in the current ns. */
- gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
- if (tmp_symtree)
- tmp_sym = tmp_symtree->n.sym;
+ if (hidden)
+ {
+ tmp_symtree = gfc_get_unique_symtree (gfc_current_ns);
+ tmp_sym = gfc_new_symbol (name, gfc_current_ns);
+
+ /* Add to the list of tentative symbols. */
+ latest_undo_chgset->syms.safe_push (tmp_sym);
+ tmp_sym->old_symbol = NULL;
+ tmp_sym->mark = 1;
+ tmp_sym->gfc_new = 1;
+
+ tmp_symtree->n.sym = tmp_sym;
+ tmp_sym->refs++;
+ }
else
- gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
- "create symbol");
+ {
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+ gcc_assert (tmp_symtree);
+ tmp_sym = tmp_symtree->n.sym;
+ }
/* Say what module this symbol belongs to. */
tmp_sym->module = gfc_get_string (mod_name);
tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
tmp_sym->intmod_sym_id = s;
+ tmp_sym->attr.is_iso_c = 1;
+ tmp_sym->attr.use_assoc = 1;
+
+ gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR
+ || s == ISOCBINDING_NULL_PTR);
switch (s)
{
@@ -4490,11 +4214,6 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
/* Tell what f90 type this c interop kind is valid. */
tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
- /* Say it's from the iso_c_binding module. */
- tmp_sym->attr.is_iso_c = 1;
-
- /* Make it use associated. */
- tmp_sym->attr.use_assoc = 1;
break;
@@ -4531,70 +4250,69 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
/* Tell what f90 type this c interop kind is valid. */
tmp_sym->ts.f90_type = BT_CHARACTER;
- /* Say it's from the iso_c_binding module. */
- tmp_sym->attr.is_iso_c = 1;
-
- /* Make it use associated. */
- tmp_sym->attr.use_assoc = 1;
break;
case ISOCBINDING_PTR:
case ISOCBINDING_FUNPTR:
{
- gfc_interface *intr, *head;
gfc_symbol *dt_sym;
- const char *hidden_name;
gfc_dt_list **dt_list_ptr = NULL;
gfc_component *tmp_comp = NULL;
- char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
-
- hidden_name = gfc_get_string ("%c%s",
- (char) TOUPPER ((unsigned char) tmp_sym->name[0]),
- &tmp_sym->name[1]);
/* Generate real derived type. */
- tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
- hidden_name);
-
- if (tmp_symtree != NULL)
- gcc_unreachable ();
- gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
- if (tmp_symtree)
- dt_sym = tmp_symtree->n.sym;
+ if (hidden)
+ dt_sym = tmp_sym;
else
- gcc_unreachable ();
-
- /* 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);
dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
dt_sym->intmod_sym_id = s;
+ dt_sym->attr.use_assoc = 1;
/* Initialize an integer constant expression node. */
dt_sym->attr.flavor = FL_DERIVED;
dt_sym->ts.is_c_interop = 1;
dt_sym->attr.is_c_interop = 1;
- dt_sym->attr.is_iso_c = 1;
+ dt_sym->attr.private_comp = 1;
+ dt_sym->component_access = ACCESS_PRIVATE;
dt_sym->ts.is_iso_c = 1;
dt_sym->ts.type = BT_DERIVED;
+ dt_sym->ts.f90_type = BT_VOID;
/* A derived type must have the bind attribute to be
interoperable (J3/04-007, Section 15.2.3), even though
@@ -4617,15 +4335,9 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
(*dt_list_ptr)->derived = dt_sym;
(*dt_list_ptr)->next = NULL;
- /* Set up the component of the derived type, which will be
- an integer with kind equal to c_ptr_size. Mangle the name of
- the field for the c_address to prevent the curious user from
- trying to access it from Fortran. */
- sprintf (comp_name, "__%s_%s", dt_sym->name, "c_address");
- gfc_add_component (dt_sym, comp_name, &tmp_comp);
+ gfc_add_component (dt_sym, "c_address", &tmp_comp);
if (tmp_comp == NULL)
- gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
- "create component for c_address");
+ gcc_unreachable ();
tmp_comp->ts.type = BT_INTEGER;
@@ -4635,163 +4347,24 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
/* The kinds for c_ptr and c_funptr are the same. */
index = get_c_kind ("c_ptr", c_interop_kinds_table);
tmp_comp->ts.kind = c_interop_kinds_table[index].value;
-
- tmp_comp->attr.pointer = 0;
- tmp_comp->attr.dimension = 0;
+ tmp_comp->attr.access = ACCESS_PRIVATE;
/* Mark the component as C interoperable. */
tmp_comp->ts.is_c_interop = 1;
-
- /* Make it use associated (iso_c_binding module). */
- dt_sym->attr.use_assoc = 1;
}
break;
case ISOCBINDING_NULL_PTR:
case ISOCBINDING_NULL_FUNPTR:
- gen_special_c_interop_ptr (s, name, mod_name);
+ gen_special_c_interop_ptr (tmp_sym, dt_symtree);
break;
- case ISOCBINDING_F_POINTER:
- case ISOCBINDING_ASSOCIATED:
- case ISOCBINDING_LOC:
- case ISOCBINDING_FUNLOC:
- case ISOCBINDING_F_PROCPOINTER:
-
- tmp_sym->attr.proc = PROC_MODULE;
-
- /* Use the procedure's name as it is in the iso_c_binding module for
- setting the binding label in case the user renamed the symbol. */
- tmp_sym->binding_label =
- gfc_get_string ("%s_%s", mod_name,
- c_interop_kinds_table[s].name);
- tmp_sym->attr.is_iso_c = 1;
- if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
- tmp_sym->attr.subroutine = 1;
- else
- {
- /* TODO! This needs to be finished more for the expr of the
- function or something!
- This may not need to be here, because trying to do c_loc
- as an external. */
- if (s == ISOCBINDING_ASSOCIATED)
- {
- tmp_sym->attr.function = 1;
- tmp_sym->ts.type = BT_LOGICAL;
- tmp_sym->ts.kind = gfc_default_logical_kind;
- tmp_sym->result = tmp_sym;
- }
- else
- {
- /* Here, we're taking the simple approach. We're defining
- c_loc as an external identifier so the compiler will put
- what we expect on the stack for the address we want the
- C address of. */
- tmp_sym->ts.type = BT_DERIVED;
- if (s == ISOCBINDING_LOC)
- tmp_sym->ts.u.derived =
- get_iso_c_binding_dt (ISOCBINDING_PTR);
- else
- tmp_sym->ts.u.derived =
- get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
-
- if (tmp_sym->ts.u.derived == NULL)
- {
- /* Create the necessary derived type so we can continue
- processing the file. */
- generate_isocbinding_symbol
- (mod_name, s == ISOCBINDING_FUNLOC
- ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
- (const char *)(s == ISOCBINDING_FUNLOC
- ? "c_funptr" : "c_ptr"));
- tmp_sym->ts.u.derived =
- get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
- ? ISOCBINDING_FUNPTR
- : ISOCBINDING_PTR);
- }
-
- /* The function result is itself (no result clause). */
- tmp_sym->result = tmp_sym;
- tmp_sym->attr.external = 1;
- tmp_sym->attr.use_assoc = 0;
- tmp_sym->attr.pure = 1;
- tmp_sym->attr.if_source = IFSRC_UNKNOWN;
- tmp_sym->attr.proc = PROC_UNKNOWN;
- }
- }
-
- tmp_sym->attr.flavor = FL_PROCEDURE;
- tmp_sym->attr.contained = 0;
-
- /* Try using this builder routine, with the new and old symbols
- both being the generic iso_c proc sym being created. This
- will create the formal args (and the new namespace for them).
- Don't build an arg list for c_loc because we're going to treat
- c_loc as an external procedure. */
- if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
- /* The 1 says to add any optional args, if applicable. */
- build_formal_args (tmp_sym, tmp_sym, 1);
-
- /* Set this after setting up the symbol, to prevent error messages. */
- tmp_sym->attr.use_assoc = 1;
-
- /* This symbol will not be referenced directly. It will be
- resolved to the implementation for the given f90 kind. */
- tmp_sym->attr.referenced = 0;
-
- break;
-
default:
gcc_unreachable ();
}
gfc_commit_symbol (tmp_sym);
-}
-
-
-/* Creates a new symbol based off of an old iso_c symbol, with a new
- binding label. This function can be used to create a new,
- resolved, version of a procedure symbol for c_f_pointer or
- c_f_procpointer that is based on the generic symbols. A new
- parameter list is created for the new symbol using
- build_formal_args(). The add_optional_flag specifies whether the
- to add the optional SHAPE argument. The new symbol is
- returned. */
-
-gfc_symbol *
-get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
- const char *new_binding_label, int add_optional_arg)
-{
- gfc_symtree *new_symtree = NULL;
-
- /* See if we have a symbol by that name already available, looking
- through any parent namespaces. */
- gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
- if (new_symtree != NULL)
- /* Return the existing symbol. */
- return new_symtree->n.sym;
-
- /* Create the symtree/symbol, with attempted host association. */
- gfc_get_ha_sym_tree (new_name, &new_symtree);
- if (new_symtree == NULL)
- gfc_internal_error ("get_iso_c_sym(): Unable to create "
- "symtree for '%s'", new_name);
-
- /* Now fill in the fields of the resolved symbol with the old sym. */
- new_symtree->n.sym->binding_label = new_binding_label;
- new_symtree->n.sym->attr = old_sym->attr;
- new_symtree->n.sym->ts = old_sym->ts;
- new_symtree->n.sym->module = gfc_get_string (old_sym->module);
- new_symtree->n.sym->from_intmod = old_sym->from_intmod;
- new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
- if (old_sym->attr.function)
- new_symtree->n.sym->result = new_symtree->n.sym;
- /* Build the formal arg list. */
- build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
-
- gfc_commit_symbol (new_symtree->n.sym);
-
- return new_symtree->n.sym;
+ return tmp_symtree;
}
@@ -316,6 +316,17 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
}
case BT_DERIVED:
+ if (source->ts.u.derived->ts.f90_type == BT_VOID)
+ {
+ gfc_constructor *c;
+ gcc_assert (source->expr_type == EXPR_STRUCTURE);
+ c = gfc_constructor_first (source->value.constructor);
+ gcc_assert (c->expr->expr_type == EXPR_CONSTANT
+ && c->expr->ts.type == BT_INTEGER);
+ return encode_integer (gfc_index_integer_kind, c->expr->value.integer,
+ buffer, buffer_size);
+ }
+
return encode_derived (source, buffer, buffer_size);
default:
gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
@@ -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;
@@ -2026,20 +2026,8 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
&& ts->u.derived != NULL
&& (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
{
- /* C_PTR and C_FUNPTR have private components which means they can not
- be printed. However, if -std=gnu and not -pedantic, allow
- the component to be printed to help debugging. */
- if (gfc_notification_std (GFC_STD_GNU) != SILENT)
- {
- gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
- ts->u.derived->name, code != NULL ? &(code->loc) :
- &gfc_current_locus);
- return;
- }
-
- ts->type = ts->u.derived->ts.type;
- ts->kind = ts->u.derived->ts.kind;
- ts->f90_type = ts->u.derived->ts.f90_type;
+ ts->type = BT_INTEGER;
+ ts->kind = gfc_index_integer_kind;
}
kind = ts->kind;
@@ -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-do compile }
+!
+! PR fortran/55444
+!
+! Contributed by Henrik Holst
+!
+ BLOCKDATA
+! USE ISO_C_BINDING, ONLY: C_INT, C_FLOAT ! WORKS
+ USE :: ISO_C_BINDING ! FAILS
+ INTEGER(C_INT) X
+ REAL(C_FLOAT) Y
+ COMMON /FOO/ X,Y
+ BIND(C,NAME='fortranStuff') /FOO/
+ DATA X /1/
+ DATA Y /2.0/
+ END BLOCKDATA
@@ -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-do compile }
+!
+! PR fortran/38894
+!
+!
+
+subroutine test2
+use iso_c_binding
+type(c_funptr) :: fun
+type(c_ptr) :: fptr
+procedure(), pointer :: bar
+integer, pointer :: bari
+call c_f_procpointer(fptr,bar) ! { dg-error "Argument CPTR at .1. to C_F_PROCPOINTER shall have the type TYPE.C_FUNPTR." }
+call c_f_pointer(fun,bari) ! { dg-error "Argument CPTR at .1. to C_F_POINTER shall have the type TYPE.C_PTR." }
+fun = fptr ! { dg-error "Can't convert TYPE.c_ptr. to TYPE.c_funptr." }
+end
+
+subroutine test()
+use iso_c_binding, c_ptr2 => c_ptr
+type(c_ptr2) :: fun
+procedure(), pointer :: bar
+integer, pointer :: foo
+call c_f_procpointer(fun,bar) ! { dg-error "Argument CPTR at .1. to C_F_PROCPOINTER shall have the type TYPE.C_FUNPTR." }
+call c_f_pointer(fun,foo) ! OK
+end
+
+module rename
+ use, intrinsic :: iso_c_binding, only: my_c_ptr_0 => c_ptr
+end module rename
+
+program p
+ use, intrinsic :: iso_c_binding, my_c_ptr => c_ptr
+ type(my_c_ptr) :: my_ptr
+ print *,c_associated(my_ptr)
+contains
+ subroutine sub()
+ use rename ! (***)
+ type(my_c_ptr_0) :: my_ptr2
+ type(c_funptr) :: myfun
+ print *,c_associated(my_ptr,my_ptr2)
+ print *,c_associated(my_ptr,myfun) ! { dg-error "Argument C_PTR_2 at .1. to C_ASSOCIATED shall have the same type as C_PTR_1: TYPE.c_ptr. instead of TYPE.c_funptr." }
+ end subroutine
+end
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,28 @@
+! { dg-do compile }
+! { dg-options "" }
+!
+! PR fortran/56378
+! PR fortran/52426
+!
+! Contributed by David Sagan & Joost VandeVondele
+!
+
+module t
+ use, intrinsic :: iso_c_binding
+ interface fvec2vec
+ module procedure int_fvec2vec
+ end interface
+contains
+ function int_fvec2vec (f_vec, n) result (c_vec)
+ integer f_vec(:)
+ integer(c_int), target :: c_vec(n)
+ end function int_fvec2vec
+ subroutine lat_to_c (Fp, C) bind(c)
+ integer, allocatable :: ic(:)
+ call lat_to_c2 (c_loc(fvec2vec(ic, n1_ic))) ! { dg-error "Argument X at .1. to C_LOC shall have either the POINTER or the TARGET attribute" }
+ end subroutine lat_to_c
+end module
+
+use iso_c_binding
+print *, c_loc([1]) ! { dg-error "Argument X at .1. to C_LOC shall have either the POINTER or the TARGET attribute" }
+end
new file mode 100644
@@ -0,0 +1,21 @@
+! { dg-do compile }
+!
+! PR fortran/39288
+!
+! From IR F03/0129, cf.
+! Fortran 2003, Technical Corrigendum 5
+!
+! Was invalid before.
+
+ SUBROUTINE S(A,I,K)
+ USE ISO_C_BINDING
+ CHARACTER(*),TARGET :: A
+ CHARACTER(:),ALLOCATABLE,TARGET :: B
+ TYPE(C_PTR) P1,P2,P3,P4,P5
+ P1 = C_LOC(A(1:1)) ! *1
+ P2 = C_LOC(A(I:I)) ! *2
+ P3 = C_LOC(A(1:)) ! *3
+ P4 = C_LOC(A(I:K)) ! *4
+ ALLOCATE(CHARACTER(1)::B)
+ P5 = C_LOC(B) ! *5
+ END SUBROUTINE
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
new file mode 100644
@@ -0,0 +1,14 @@
+! { dg-do compile }
+!
+! PR fortran/55574
+! The following code used to be accepted because C_LOC pulls in C_PTR
+! implicitly.
+!
+! Contributed by Valery Weber <valeryweber@hotmail.com>
+!
+program aaaa
+ use iso_c_binding, only : c_loc
+ integer, target :: i
+ type(C_PTR) :: f_ptr ! { dg-error "being used before it is defined" }
+ f_ptr=c_loc(i) ! { dg-error "Can't convert" }
+end program aaaa
@@ -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
@@ -10,6 +10,6 @@ program main
integer(C_INTPTR_T) p
type(C_PTR) cptr
p = 0
- cptr = C_PTR(p+1) ! { dg-error "Components of structure constructor" }
- cptr = C_PTR(1) ! { dg-error "Components of structure constructor" }
+ cptr = C_PTR(p+1) ! { dg-error "is a PRIVATE component of 'c_ptr'" }
+ cptr = C_PTR(1) ! { dg-error "is a PRIVATE component of 'c_ptr'" }
end program main
@@ -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" } }
@@ -16,9 +16,9 @@ contains
type(myF90Derived), pointer :: my_f90_type_ptr
my_f90_type%my_c_ptr = c_null_ptr
- print *, 'my_f90_type is: ', my_f90_type
+ print *, 'my_f90_type is: ', my_f90_type%my_c_ptr
my_f90_type_ptr => my_f90_type
- print *, 'my_f90_type_ptr is: ', my_f90_type_ptr
+ print *, 'my_f90_type_ptr is: ', my_f90_type_ptr%my_c_ptr
end subroutine sub0
end module c_ptr_tests_9
@@ -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
@@ -19,9 +19,9 @@ type(c_ptr) :: t
t = c_null_ptr
! Next two lines should be errors if -pedantic or -std=f2003
-print *, c_null_ptr, t ! { dg-error "has PRIVATE components" }
-print *, t ! { dg-error "has PRIVATE components" }
+print *, c_null_ptr, t ! { dg-error "cannot have PRIVATE components" }
+print *, t ! { dg-error "cannot have PRIVATE components" }
-print *, c_loc(get_ptr()) ! { dg-error "has PRIVATE components" }
+print *, c_loc(get_ptr()) ! { dg-error "cannot have PRIVATE components" }
end
@@ -1,10 +1,12 @@
! { dg-do compile }
+! { dg-options "" }
+!
! PR fortran/32601
use, intrinsic :: iso_c_binding, only: c_loc, c_ptr
implicit none
! This was causing an ICE, but is an error because the argument to C_LOC
! needs to be a variable.
-print *, c_loc(4) ! { dg-error "not a variable" }
+print *, c_loc(4) ! { dg-error "shall have either the POINTER or the TARGET attribute" }
end
@@ -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
new file mode 100644
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/56079
+!
+use iso_c_binding
+implicit none
+type t
+ type(c_ptr) :: ptr = c_null_ptr
+end type t
+
+type(t), parameter :: para = t()
+integer(c_intptr_t) :: intg
+intg = transfer (para, intg)
+intg = transfer (para%ptr, intg)
+end
+
+! { dg-final { scan-tree-dump-times "intg = 0;" 2 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
+