diff options
| author | burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4> | 2013-03-25 15:40:26 +0000 |
|---|---|---|
| committer | burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4> | 2013-03-25 15:40:26 +0000 |
| commit | 07f0c434a3df910e5e64acf6478687a682c01bba (patch) | |
| tree | 8a59184d212dad5695956782c588f54b5ed68b53 | |
| parent | 91cb50d26cc5e994e33f35ab064355ab59354b47 (diff) | |
| download | gcc-07f0c434a3df910e5e64acf6478687a682c01bba.tar.gz | |
2013-03-25 Tobias Burnus <burnus@net-b.de>
PR fortran/38536
PR fortran/38813
PR fortran/38894
PR fortran/39288
PR fortran/40963
PR fortran/45824
PR fortran/47023
PR fortran/47034
PR fortran/49023
PR fortran/50269
PR fortran/50612
PR fortran/52426
PR fortran/54263
PR fortran/55343
PR fortran/55444
PR fortran/55574
PR fortran/56079
PR fortran/56378
* check.c (gfc_var_strlen): Properly handle 0-sized string.
(gfc_check_c_sizeof): Use is_c_interoperable, add checks.
(is_c_interoperable, gfc_check_c_associated, gfc_check_c_f_pointer,
gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc): New
functions.
* expr.c (check_inquiry): Add c_sizeof, compiler_version and
compiler_options.
(gfc_check_pointer_assign): Refine function result check.
gfortran.h (gfc_isym_id): Add GFC_ISYM_C_ASSOCIATED,
GFC_ISYM_C_F_POINTER, GFC_ISYM_C_F_PROCPOINTER, GFC_ISYM_C_FUNLOC,
GFC_ISYM_C_LOC.
(iso_fortran_env_symbol, iso_c_binding_symbol): Handle
NAMED_SUBROUTINE.
(generate_isocbinding_symbol): Update prototype.
(get_iso_c_sym): Remove.
(gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New prototypes.
* intrinsic.c (gfc_intrinsic_subroutine_by_id): New function.
(gfc_intrinsic_sub_interface): Use it.
(add_functions, add_subroutines): Add missing C-binding intrinsics.
(gfc_intrinsic_func_interface): Add special case for c_loc.
gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New functions.
(gfc_intrinsic_func_interface, gfc_intrinsic_sub_interface): Use them.
* intrinsic.h (gfc_check_c_associated, gfc_check_c_f_pointer,
gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc,
gfc_resolve_c_loc, gfc_resolve_c_funloc): New prototypes.
* iresolve.c (gfc_resolve_c_loc, gfc_resolve_c_funloc): New
functions.
* iso-c-binding.def: Split PROCEDURE into NAMED_SUBROUTINE and
NAMED_FUNCTION.
* iso-fortran-env.def: Add NAMED_SUBROUTINE for completeness.
* module.c (create_intrinsic_function): Support subroutines and
derived-type results.
(use_iso_fortran_env_module): Update calls.
(import_iso_c_binding_module): Ditto; update calls to
generate_isocbinding_symbol.
* resolve.c (find_arglists): Skip for intrinsic symbols.
(gfc_resolve_intrinsic): Find intrinsic subs via id.
(is_scalar_expr_ptr, gfc_iso_c_func_interface,
set_name_and_label, gfc_iso_c_sub_interface): Remove.
(resolve_function, resolve_specific_s0): Remove calls to those.
(resolve_structure_cons): Fix handling.
* symbol.c (gen_special_c_interop_ptr): Update c_ptr/c_funptr
generation.
(gen_cptr_param, gen_fptr_param, gen_shape_param,
build_formal_args, get_iso_c_sym): Remove.
(std_for_isocbinding_symbol): Handle NAMED_SUBROUTINE.
(generate_isocbinding_symbol): Support hidden symbols and
using c_ptr/c_funptr symtrees for nullptr defs.
* target-memory.c (gfc_target_encode_expr): Fix handling
of c_ptr/c_funptr.
* trans-expr.c (conv_isocbinding_procedure): Remove.
(gfc_conv_procedure_call): Remove call to it.
(gfc_trans_subcomponent_assign, gfc_conv_expr): Update handling
of c_ptr/c_funptr.
* trans-intrinsic.c (conv_isocbinding_function,
conv_isocbinding_subroutine): New.
(gfc_conv_intrinsic_function, gfc_conv_intrinsic_subroutine):
Call them.
* trans-io.c (transfer_expr): Fix handling of c_ptr/c_funptr.
* trans-types.c (gfc_typenode_for_spec,
gfc_get_derived_type): Ditto.
(gfc_init_c_interop_kinds): Handle NAMED_SUBROUTINE.
2013-03-25 Tobias Burnus <burnus@net-b.de>
PR fortran/38536
PR fortran/38813
PR fortran/38894
PR fortran/39288
PR fortran/40963
PR fortran/45824
PR fortran/47023
PR fortran/47034
PR fortran/49023
PR fortran/50269
PR fortran/50612
PR fortran/52426
PR fortran/54263
PR fortran/55343
PR fortran/55444
PR fortran/55574
PR fortran/56079
PR fortran/56378
* gfortran.dg/c_assoc_2.f03: Update dg-error wording.
* gfortran.dg/c_f_pointer_shape_test.f90: Ditto.
* gfortran.dg/c_f_pointer_shape_tests_3.f03: Ditto.
* gfortran.dg/c_f_pointer_tests_5.f90: Ditto.
* gfortran.dg/c_funloc_tests_2.f03: Ditto.
* gfortran.dg/c_funloc_tests_5.f03: Ditto.
* gfortran.dg/c_funloc_tests_6.f90: Ditto.
* gfortran.dg/c_loc_tests_10.f03: Add -std=f2008.
* gfortran.dg/c_loc_tests_11.f03: Ditto, update dg-error.
* gfortran.dg/c_loc_tests_16.f90: Ditto.
* gfortran.dg/c_loc_tests_4.f03: Ditto.
* gfortran.dg/c_loc_tests_15.f90: Update dg-error wording.
* gfortran.dg/c_loc_tests_3.f03: Valid since F2003 TC5.
* gfortran.dg/c_loc_tests_8.f03: Ditto.
* gfortran.dg/c_ptr_tests_14.f90: Update scan-tree-dump-times.
* gfortran.dg/c_ptr_tests_15.f90: Ditto.
* gfortran.dg/c_sizeof_1.f90: Fix invalid code.
* gfortran.dg/iso_c_binding_init_expr.f03: Update dg-error wording.
* gfortran.dg/pr32601_1.f03: Ditto.
* gfortran.dg/storage_size_2.f08: Remove dg-error.
* gfortran.dg/blockdata_7.f90: New.
* gfortran.dg/c_assoc_4.f90: New.
* gfortran.dg/c_f_pointer_tests_6.f90: New.
* gfortran.dg/c_f_pointer_tests_7.f90: New.
* gfortran.dg/c_funloc_tests_8.f90: New.
* gfortran.dg/c_loc_test_17.f90: New.
* gfortran.dg/c_loc_test_18.f90: New.
* gfortran.dg/c_loc_test_19.f90: New.
* gfortran.dg/c_loc_test_20.f90: New.
* gfortran.dg/c_sizeof_5.f90: New.
* gfortran.dg/iso_c_binding_rename_3.f90: New.
* gfortran.dg/transfer_resolve_2.f90: New.
* gfortran.dg/transfer_resolve_3.f90: New.
* gfortran.dg/transfer_resolve_4.f90: New.
* gfortran.dg/pr32601.f03: Update dg-error.
* gfortran.dg/c_ptr_tests_13.f03: Update dg-error.
* gfortran.dg/c_ptr_tests_9.f03: Fix test case.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@197053 138bc75d-0d04-0410-961f-82ee72b054a4
56 files changed, 1629 insertions, 1517 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 00bbcd1a201..a14423cc94c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,86 @@ +2013-03-25 Tobias Burnus <burnus@net-b.de> + + PR fortran/38536 + PR fortran/38813 + PR fortran/38894 + PR fortran/39288 + PR fortran/40963 + PR fortran/45824 + PR fortran/47023 + PR fortran/47034 + PR fortran/49023 + PR fortran/50269 + PR fortran/50612 + PR fortran/52426 + PR fortran/54263 + PR fortran/55343 + PR fortran/55444 + PR fortran/55574 + PR fortran/56079 + PR fortran/56378 + * check.c (gfc_var_strlen): Properly handle 0-sized string. + (gfc_check_c_sizeof): Use is_c_interoperable, add checks. + (is_c_interoperable, gfc_check_c_associated, gfc_check_c_f_pointer, + gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc): New + functions. + * expr.c (check_inquiry): Add c_sizeof, compiler_version and + compiler_options. + (gfc_check_pointer_assign): Refine function result check. + gfortran.h (gfc_isym_id): Add GFC_ISYM_C_ASSOCIATED, + GFC_ISYM_C_F_POINTER, GFC_ISYM_C_F_PROCPOINTER, GFC_ISYM_C_FUNLOC, + GFC_ISYM_C_LOC. + (iso_fortran_env_symbol, iso_c_binding_symbol): Handle + NAMED_SUBROUTINE. + (generate_isocbinding_symbol): Update prototype. + (get_iso_c_sym): Remove. + (gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New prototypes. + * intrinsic.c (gfc_intrinsic_subroutine_by_id): New function. + (gfc_intrinsic_sub_interface): Use it. + (add_functions, add_subroutines): Add missing C-binding intrinsics. + (gfc_intrinsic_func_interface): Add special case for c_loc. + gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New functions. + (gfc_intrinsic_func_interface, gfc_intrinsic_sub_interface): Use them. + * intrinsic.h (gfc_check_c_associated, gfc_check_c_f_pointer, + gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc, + gfc_resolve_c_loc, gfc_resolve_c_funloc): New prototypes. + * iresolve.c (gfc_resolve_c_loc, gfc_resolve_c_funloc): New + functions. + * iso-c-binding.def: Split PROCEDURE into NAMED_SUBROUTINE and + NAMED_FUNCTION. + * iso-fortran-env.def: Add NAMED_SUBROUTINE for completeness. + * module.c (create_intrinsic_function): Support subroutines and + derived-type results. + (use_iso_fortran_env_module): Update calls. + (import_iso_c_binding_module): Ditto; update calls to + generate_isocbinding_symbol. + * resolve.c (find_arglists): Skip for intrinsic symbols. + (gfc_resolve_intrinsic): Find intrinsic subs via id. + (is_scalar_expr_ptr, gfc_iso_c_func_interface, + set_name_and_label, gfc_iso_c_sub_interface): Remove. + (resolve_function, resolve_specific_s0): Remove calls to those. + (resolve_structure_cons): Fix handling. + * symbol.c (gen_special_c_interop_ptr): Update c_ptr/c_funptr + generation. + (gen_cptr_param, gen_fptr_param, gen_shape_param, + build_formal_args, get_iso_c_sym): Remove. + (std_for_isocbinding_symbol): Handle NAMED_SUBROUTINE. + (generate_isocbinding_symbol): Support hidden symbols and + using c_ptr/c_funptr symtrees for nullptr defs. + * target-memory.c (gfc_target_encode_expr): Fix handling + of c_ptr/c_funptr. + * trans-expr.c (conv_isocbinding_procedure): Remove. + (gfc_conv_procedure_call): Remove call to it. + (gfc_trans_subcomponent_assign, gfc_conv_expr): Update handling + of c_ptr/c_funptr. + * trans-intrinsic.c (conv_isocbinding_function, + conv_isocbinding_subroutine): New. + (gfc_conv_intrinsic_function, gfc_conv_intrinsic_subroutine): + Call them. + * trans-io.c (transfer_expr): Fix handling of c_ptr/c_funptr. + * trans-types.c (gfc_typenode_for_spec, + gfc_get_derived_type): Ditto. + (gfc_init_c_interop_kinds): Handle NAMED_SUBROUTINE. + 2013-03-18 Tobias Burnus <burnus@net-b.de> * gfortran.h (gfc_option_t): Remove flag_whole_file. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 0e71b9506f8..0460bf2341d 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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; } diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 1b74a44ab74..8deb4ebf05d 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 76d27971f05..f28a99a78bf 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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); diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index c571533ef8f..358c33e02b7 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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; diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 5d502855269..0f9b50c8d1d 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -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 *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 5b2f8c7b44e..2b92b7c2bc6 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -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; diff --git a/gcc/fortran/iso-c-binding.def b/gcc/fortran/iso-c-binding.def index aaef80c5478..c36a4786083 100644 --- a/gcc/fortran/iso-c-binding.def +++ b/gcc/fortran/iso-c-binding.def @@ -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 diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def index dfd6364f101..13ddaa31603 100644 --- a/gcc/fortran/iso-fortran-env.def +++ b/gcc/fortran/iso-fortran-env.def @@ -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 diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 1b385558424..ee09291ec76 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -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: diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e9b6fb9be43..835b57f4996 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index ef4076df3fb..ec64231da8f 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -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; } diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index caad1b4368d..7633516664a 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -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."); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 2c3ff1fc3cd..06afc4f63e0 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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; } } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index a2bb2a78ee7..9b2cc19509e 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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; diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 9394810f01f..d60d15faf28 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -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; diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index cdac0dacc12..4f4c05840bc 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b8073921b28..7fef6065e97 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,61 @@ +2013-03-25 Tobias Burnus <burnus@net-b.de> + + PR fortran/38536 + PR fortran/38813 + PR fortran/38894 + PR fortran/39288 + PR fortran/40963 + PR fortran/45824 + PR fortran/47023 + PR fortran/47034 + PR fortran/49023 + PR fortran/50269 + PR fortran/50612 + PR fortran/52426 + PR fortran/54263 + PR fortran/55343 + PR fortran/55444 + PR fortran/55574 + PR fortran/56079 + PR fortran/56378 + * gfortran.dg/c_assoc_2.f03: Update dg-error wording. + * gfortran.dg/c_f_pointer_shape_test.f90: Ditto. + * gfortran.dg/c_f_pointer_shape_tests_3.f03: Ditto. + * gfortran.dg/c_f_pointer_tests_5.f90: Ditto. + * gfortran.dg/c_funloc_tests_2.f03: Ditto. + * gfortran.dg/c_funloc_tests_5.f03: Ditto. + * gfortran.dg/c_funloc_tests_6.f90: Ditto. + * gfortran.dg/c_loc_tests_10.f03: Add -std=f2008. + * gfortran.dg/c_loc_tests_11.f03: Ditto, update dg-error. + * gfortran.dg/c_loc_tests_16.f90: Ditto. + * gfortran.dg/c_loc_tests_4.f03: Ditto. + * gfortran.dg/c_loc_tests_15.f90: Update dg-error wording. + * gfortran.dg/c_loc_tests_3.f03: Valid since F2003 TC5. + * gfortran.dg/c_loc_tests_8.f03: Ditto. + * gfortran.dg/c_ptr_tests_14.f90: Update scan-tree-dump-times. + * gfortran.dg/c_ptr_tests_15.f90: Ditto. + * gfortran.dg/c_sizeof_1.f90: Fix invalid code. + * gfortran.dg/iso_c_binding_init_expr.f03: Update dg-error wording. + * gfortran.dg/pr32601_1.f03: Ditto. + * gfortran.dg/storage_size_2.f08: Remove dg-error. + * gfortran.dg/blockdata_7.f90: New. + * gfortran.dg/c_assoc_4.f90: New. + * gfortran.dg/c_f_pointer_tests_6.f90: New. + * gfortran.dg/c_f_pointer_tests_7.f90: New. + * gfortran.dg/c_funloc_tests_8.f90: New. + * gfortran.dg/c_loc_test_17.f90: New. + * gfortran.dg/c_loc_test_18.f90: New. + * gfortran.dg/c_loc_test_19.f90: New. + * gfortran.dg/c_loc_test_20.f90: New. + * gfortran.dg/c_sizeof_5.f90: New. + * gfortran.dg/iso_c_binding_rename_3.f90: New. + * gfortran.dg/transfer_resolve_2.f90: New. + * gfortran.dg/transfer_resolve_3.f90: New. + * gfortran.dg/transfer_resolve_4.f90: New. + * gfortran.dg/pr32601.f03: Update dg-error. + * gfortran.dg/c_ptr_tests_13.f03: Update dg-error. + * gfortran.dg/c_ptr_tests_9.f03: Fix test case. + 2013-03-25 Kyrylo Tkachov <kyrylo.tkachov@arm.com> * gcc.target/arm/vseleqdf.c: New test. diff --git a/gcc/testsuite/gfortran.dg/blockdata_7.f90 b/gcc/testsuite/gfortran.dg/blockdata_7.f90 new file mode 100644 index 00000000000..b7de9642cd5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/blockdata_7.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_assoc_2.f03 b/gcc/testsuite/gfortran.dg/c_assoc_2.f03 index 4b3b7963af9..275e88eadc3 100644 --- a/gcc/testsuite/gfortran.dg/c_assoc_2.f03 +++ b/gcc/testsuite/gfortran.dg/c_assoc_2.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_assoc_4.f90 b/gcc/testsuite/gfortran.dg/c_assoc_4.f90 new file mode 100644 index 00000000000..5421a363f10 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_assoc_4.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 index f27730a431d..9b130ad6e59 100644 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03 index 31fd9381064..632e4579ce8 100644 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03 +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_5.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_5.f90 index 05a3d8b8548..5194e40b1ea 100644 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_5.f90 +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_5.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_6.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_6.f90 new file mode 100644 index 00000000000..6dc439770d4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_6.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_7.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_7.f90 new file mode 100644 index 00000000000..8cabd18d138 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_7.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03 index d3ed265ea8c..4db7bcc5fc7 100644 --- a/gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03 +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 index f3fdb2b6f64..ae321a998dc 100644 --- a/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 @@ -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() diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 b/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 index 13ca9d91d9e..1a7f0362d16 100644 --- a/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_8.f90 b/gcc/testsuite/gfortran.dg/c_funloc_tests_8.f90 new file mode 100644 index 00000000000..1650a79e105 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_8.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_loc_test_17.f90 b/gcc/testsuite/gfortran.dg/c_loc_test_17.f90 new file mode 100644 index 00000000000..4c2a7d657ee --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_test_17.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_loc_test_18.f90 b/gcc/testsuite/gfortran.dg/c_loc_test_18.f90 new file mode 100644 index 00000000000..b8542002f59 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_test_18.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_loc_test_19.f90 b/gcc/testsuite/gfortran.dg/c_loc_test_19.f90 new file mode 100644 index 00000000000..a667eaf52de --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_test_19.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_loc_test_20.f90 b/gcc/testsuite/gfortran.dg/c_loc_test_20.f90 new file mode 100644 index 00000000000..4ff0ca1bac0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_test_20.f90 @@ -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 + diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_10.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_10.f03 index 867ba18cc6c..21cbe0be7ec 100644 --- a/gcc/testsuite/gfortran.dg/c_loc_tests_10.f03 +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_10.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_11.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_11.f03 index 197666d3091..b8e6d849e67 100644 --- a/gcc/testsuite/gfortran.dg/c_loc_tests_11.f03 +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_11.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_15.f90 b/gcc/testsuite/gfortran.dg/c_loc_tests_15.f90 index 63f8816379e..c8d58687050 100644 --- a/gcc/testsuite/gfortran.dg/c_loc_tests_15.f90 +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_15.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_16.f90 b/gcc/testsuite/gfortran.dg/c_loc_tests_16.f90 index 1c86a1f9c40..2c074e874f0 100644 --- a/gcc/testsuite/gfortran.dg/c_loc_tests_16.f90 +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_16.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_17.f90 b/gcc/testsuite/gfortran.dg/c_loc_tests_17.f90 new file mode 100644 index 00000000000..5e4eb8affab --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_17.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_3.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_3.f03 index 95eac4af380..0cd56a68464 100644 --- a/gcc/testsuite/gfortran.dg/c_loc_tests_3.f03 +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_3.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_4.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_4.f03 index 8453ec77272..1f28d3e0c0e 100644 --- a/gcc/testsuite/gfortran.dg/c_loc_tests_4.f03 +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_4.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_8.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_8.f03 index a094d690bdd..4a4e73ee7ce 100644 --- a/gcc/testsuite/gfortran.dg/c_loc_tests_8.f03 +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_8.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_13.f03 b/gcc/testsuite/gfortran.dg/c_ptr_tests_13.f03 index c7a603bcce6..020b057fe25 100644 --- a/gcc/testsuite/gfortran.dg/c_ptr_tests_13.f03 +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_13.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_14.f90 b/gcc/testsuite/gfortran.dg/c_ptr_tests_14.f90 index 946c4dd96ab..2bf4262898b 100644 --- a/gcc/testsuite/gfortran.dg/c_ptr_tests_14.f90 +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_14.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_15.f90 b/gcc/testsuite/gfortran.dg/c_ptr_tests_15.f90 index 9959d62715c..dec2e8e4ad9 100644 --- a/gcc/testsuite/gfortran.dg/c_ptr_tests_15.f90 +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_15.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03 b/gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03 index 8fff5473e5d..5a32553b8c5 100644 --- a/gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03 +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_sizeof_1.f90 b/gcc/testsuite/gfortran.dg/c_sizeof_1.f90 index e0ac06f940e..4a8385b8d8f 100644 --- a/gcc/testsuite/gfortran.dg/c_sizeof_1.f90 +++ b/gcc/testsuite/gfortran.dg/c_sizeof_1.f90 @@ -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) diff --git a/gcc/testsuite/gfortran.dg/c_sizeof_5.f90 b/gcc/testsuite/gfortran.dg/c_sizeof_5.f90 new file mode 100644 index 00000000000..127a24ab6a4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_sizeof_5.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/iso_c_binding_init_expr.f03 b/gcc/testsuite/gfortran.dg/iso_c_binding_init_expr.f03 index 0a0099628b3..45eaa5c2443 100644 --- a/gcc/testsuite/gfortran.dg/iso_c_binding_init_expr.f03 +++ b/gcc/testsuite/gfortran.dg/iso_c_binding_init_expr.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/iso_c_binding_rename_3.f90 b/gcc/testsuite/gfortran.dg/iso_c_binding_rename_3.f90 new file mode 100644 index 00000000000..bbe17cb8964 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iso_c_binding_rename_3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr32601.f03 b/gcc/testsuite/gfortran.dg/pr32601.f03 index 6fa275e0e52..a4048cc321c 100644 --- a/gcc/testsuite/gfortran.dg/pr32601.f03 +++ b/gcc/testsuite/gfortran.dg/pr32601.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr32601_1.f03 b/gcc/testsuite/gfortran.dg/pr32601_1.f03 index 3e9aa73842e..a297e1728ec 100644 --- a/gcc/testsuite/gfortran.dg/pr32601_1.f03 +++ b/gcc/testsuite/gfortran.dg/pr32601_1.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/storage_size_2.f08 b/gcc/testsuite/gfortran.dg/storage_size_2.f08 index 82913c88b14..ba8bd229cd8 100644 --- a/gcc/testsuite/gfortran.dg/storage_size_2.f08 +++ b/gcc/testsuite/gfortran.dg/storage_size_2.f08 @@ -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" } diff --git a/gcc/testsuite/gfortran.dg/transfer_resolve_2.f90 b/gcc/testsuite/gfortran.dg/transfer_resolve_2.f90 new file mode 100644 index 00000000000..b6c5ddd347f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_resolve_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/transfer_resolve_3.f90 b/gcc/testsuite/gfortran.dg/transfer_resolve_3.f90 new file mode 100644 index 00000000000..f3a58e27bee --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_resolve_3.f90 @@ -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" } } + diff --git a/gcc/testsuite/gfortran.dg/transfer_resolve_4.f90 b/gcc/testsuite/gfortran.dg/transfer_resolve_4.f90 new file mode 100644 index 00000000000..2dad63c7587 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_resolve_4.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR fortran/47034 +! +! Contributed by James Van Buskirk +! +subroutine james + use iso_c_binding + type(C_PTR), parameter :: p1 = & + transfer(32512_C_INTPTR_T,C_NULL_PTR) + integer(C_INTPTR_T), parameter :: n1 = transfer(p1,0_C_INTPTR_T) +end |