diff options
| author | kargl <kargl@138bc75d-0d04-0410-961f-82ee72b054a4> | 2007-07-02 02:47:21 +0000 |
|---|---|---|
| committer | kargl <kargl@138bc75d-0d04-0410-961f-82ee72b054a4> | 2007-07-02 02:47:21 +0000 |
| commit | c5d33754e3b885a5a2f323bedaa29371f44748b3 (patch) | |
| tree | ac4b8eff52a0e3e3d04868300cc36392b6ca3faa /gcc | |
| parent | af1ff7da323f7dda32e4b0e7bda1d43fa4654252 (diff) | |
| download | gcc-c5d33754e3b885a5a2f323bedaa29371f44748b3.tar.gz | |
2007-07-01 Christopher D. Rickett <crickett@lanl.gov>
* interface.c (gfc_compare_derived_types): Special case for comparing
derived types across namespaces.
(gfc_compare_types): Deal with BT_VOID.
(compare_parameter): Use BT_VOID to accept ISO C Binding pointers.
* trans-expr.c (gfc_conv_function_call): Remove setting parm_kind
to SCALAR
(gfc_conv_initializer): Deal with ISO C Binding NULL_PTR and
NULL_FUNPTR.
(gfc_conv_expr): Convert expressions for ISO C Binding derived types.
* symbol.c (gfc_set_default_type): BIND(C) variables should not be
implicitly declared.
(check_conflict): Add BIND(C) and check for conflicts.
(gfc_add_explicit_interface): Whitespace.
(gfc_add_is_bind_c): New function.
(gfc_copy_attr): Use it.
(gfc_new_symbol): Initialize ISO C Binding objects.
(get_iso_c_binding_dt): New function.
(verify_bind_c_derived_type): Ditto.
(gen_special_c_interop_ptr): Ditto.
(add_formal_arg): Ditto.
(gen_cptr_param): Ditto.
(gen_fptr_param): Ditto.
(gen_shape_param): Ditto.
(add_proc_interface): Ditto.
(build_formal_args): Ditto.
(generate_isocbinding_symbol): Ditto.
(get_iso_c_sym): Ditto.
* decl.c (num_idents_on_line, has_name_equals): New variables.
(verify_c_interop_param): New function.
(build_sym): Finish binding labels and deal with COMMON blocks.
(add_init_expr_to_sym): Check if the initialized expression is
an iso_c_binding named constants
(variable_decl): Set ISO C Binding type_spec components.
(gfc_match_kind_spec): Check match for C interoperable kind.
(match_char_spec): Fix comment. Chnage gfc_match_small_int
to gfc_match_small_int_expr. Check for C interoperable kind.
(match_type_spec): Clear the current binding label.
(match_attr_spec): Add DECL_IS_BIND_C. If BIND(C) is found, use it
to set attributes.
(set_binding_label): New function.
(set_com_block_bind_c): Ditto.
(verify_c_interop): Ditto.
(verify_com_block_vars_c_interop): Ditto.
(verify_bind_c_sym): Ditto.
(set_verify_bind_c_sym): Ditto.
(set_verify_bind_c_com_block): Ditto.
(get_bind_c_idents): Ditto.
(gfc_match_bind_c_stmt): Ditto.
(gfc_match_data_decl): Use num_idents_on_line.
(match_result): Deal with right paren in BIND(C).
(gfc_match_suffix): New function.
(gfc_match_function_decl): Use it. Code is re-arranged to deal with
ISO C Binding result clauses.
(gfc_match_subroutine): Deal with BIND(C).
(gfc_match_bind_c): New function.
(gfc_get_type_attr_spec): New function. Code is re-arranged in and
taken from gfc_match_derived_decl.
(gfc_match_derived_decl): Add check for BIND(C).
* trans-common.c: Forward declare gfc_get_common.
(gfc_sym_mangled_common_id): Change arg from 'const char *name' to
'gfc_common_head *com'. Check for ISO C Binding of the common block.
(build_common_decl): 'com->name' to 'com in SET_DECL_ASSEMBLER_NAME.
* gfortran.h: Add GFC_MAX_BINDING_LABEL_LEN
(bt): Add BT_VOID
(sym_flavor): Add FL_VOID.
(iso_fortran_env_symbol, iso_c_binding_symbol, intmod_id): New enum
(CInteropKind_t): New struct.
(c_interop_kinds_table): Use it. Declare an array of structs.
(symbol_attribute): Add is_bind_c, is_c_interop, and is_iso_c
bitfields.
(gfc_typespec): Add is_c_interop; is_iso_c, and f90_type members.
(gfc_symbol): Add from_intmod, intmod_sym_id, binding_label, and
common_block members.
(gfc_common_head): Add binding_label and is_bind_c members.
(gfc_gsymbol): Add sym_name, mod_name, and binding_label members.
Add prototypes for get_c_kind, gfc_validate_c_kind,
gfc_check_any_c_kind, gfc_add_is_bind_c, gfc_add_value,
verify_c_interop, verify_c_interop_param, verify_bind_c_sym,
verify_bind_c_derived_type, verify_com_block_vars_c_interop,
generate_isocbinding_symbol, get_iso_c_sym, gfc_iso_c_sub_interface
* iso-c-binding.def: New file. This file contains the definitions
of the types provided by the Fortran 2003 ISO_C_BINDING intrinsic
module.
* trans-const.c (gfc_conv_constant_to_tree): Deal with C_NULL_PTR
or C_NULL_FUNPTR expressions.
* expr.c (gfc_copy_expr): Add BT_VOID case. For BT_CHARACTER, the
ISO C Binding requires a minimum string length of 1 for '\0'.
* module.c (intmod_sym): New struct.
(pointer_info): Add binding_label member.
(write_atom): Set len to 0 for NULL pointers. Check for NULL p and *p.
(ab_attribute): Add AB_IS_BIND_C, AB_IS_C_INTEROP and AB_IS_ISO_C.
(attr_bits): Add "IS_BIND_C", "IS_C_INTEROP", and "IS_ISO_C".
(mio_symbol_attribute): Deal with ISO C Binding attributes.
(bt_types): Add "VOID".
(mio_typespec): Deal with ISO C Binding components.
(mio_namespace_ref): Add intmod variable.
(mio_symbol): Check for symbols from an intrinsic module.
(load_commons): Check for BIND(C) common block.
(read_module): Read binding_label and use it.
(write_common): Add label. Write BIND(C) info.
(write_blank_common): Blank commons are not BIND(C). Explicitly
set is_bind_c=0.
(write_symbol): Deal with binding_label.
(sort_iso_c_rename_list): New function.
(import_iso_c_binding_module): Ditto.
(create_int_parameter): Add to args.
(use_iso_fortran_env_module): Adjust to deal with iso_c_binding
intrinsic module.
* trans-types.c (c_interop_kinds_table): new array of structs.
(gfc_validate_c_kind): New function.
(gfc_check_any_c_kind): Ditto.
(get_real_kind_from_node): Ditto.
(get_int_kind_from_node): Ditto.
(get_int_kind_from_width): Ditto.
(get_int_kind_from_minimal_width): Ditto.
(init_c_interop_kinds): Ditto.
(gfc_init_kinds): call init_c_interop_kinds.
(gfc_typenode_for_spec): Adjust for BT_VOID and ISO C Binding pointers.
Adjust handling of BT_DERIVED.
(gfc_sym_type): Whitespace.
(gfc_get_derived_type): Account for iso_c_binding derived types
* resolve.c (is_scalar_expr_ptr): New function.
(gfc_iso_c_func_interface): Ditto.
(resolve_function): Use gfc_iso_c_func_interface.
(set_name_and_label): New function.
(gfc_iso_c_sub_interface): Ditto.
(resolve_specific_s0): Use gfc_iso_c_sub_interface.
(resolve_bind_c_comms): New function.
(resolve_bind_c_derived_types): Ditto.
(gfc_verify_binding_labels): Ditto.
(resolve_fl_procedure): Check for ISO C interoperability.
(resolve_symbol): Check C interoperability.
(resolve_types): Walk the namespace. Check COMMON blocks.
* trans-decl.c (gfc_sym_mangled_identifier): Prevent the mangling
of identifiers that have an assigned binding label.
(gfc_sym_mangled_function_id): Use the binding label rather than
the mangled name.
(gfc_finish_var_decl): Put variables that are BIND(C) into a common
segment of the object file, because this is what C would do.
(gfc_create_module_variable): Conver to proper types
(set_tree_decl_type_code): New function.
(generate_local_decl): Check dummy variables and derived types for
ISO C Binding attributes.
* match.c (gfc_match_small_int_expr): New function.
(gfc_match_name_C): Ditto.
(match_common_name): Deal with ISO C Binding in COMMON blocks
* trans-io.c (transfer_expr): Deal with C_NULL_PTR or C_NULL_FUNPTR
expressions
* match.h: Add prototypes for gfc_match_small_int_expr,
gfc_match_name_C, match_common_name, set_com_block_bind_c,
set_binding_label, set_verify_bind_c_sym,
set_verify_bind_c_com_block, get_bind_c_idents,
gfc_match_bind_c_stmt, gfc_match_suffix, gfc_match_bind_c,
gfc_get_type_attr_spec
* parse.c (decode_statement): Use gfc_match_bind_c_stmt
(parse_derived): Init *derived_sym = NULL, and gfc_current_block
later for valiadation.
* primary.c (got_delim): Set ISO C Binding components of ts.
(match_logical_constant): Ditto.
(match_complex_constant): Ditto.
(match_complex_constant): Ditto.
(gfc_match_rvalue): Check for existence of at least one arg for
C_LOC, C_FUNLOC, and C_ASSOCIATED.
* misc.c (gfc_clear_ts): Clear ISO C Bindoing components in ts.
(get_c_kind): New function.
2007-07-01 Christopher D. Rickett <crickett@lanl.gov>
* Makefile.in: Add support for iso_c_generated_procs.c and
iso_c_binding.c.
* Makefile.am: Ditto.
* intrinsics/iso_c_generated_procs.c: New file containing helper
functions.
* intrinsics/iso_c_binding.c: Ditto.
* intrinsics/iso_c_binding.h: New file
* gfortran.map: Include the __iso_c_binding_c_* functions.
* libgfortran.h: define GFC_NUM_RANK_BITS.
2007-06-23 Christopher D. Rickett <crickett@lanl.gov>
* bind_c_array_params.f03: New files for Fortran 2003 ISO C Binding.
* bind_c_coms.f90: Ditto.
* bind_c_coms_driver.c: Ditto.
* bind_c_dts.f90: Ditto.
* bind_c_dts_2.f03: Ditto.
* bind_c_dts_2_driver.c: Ditto.
* bind_c_dts_3.f03: Ditto.
* bind_c_dts_4.f03: Ditto.
* bind_c_dts_driver.c: Ditto.
* bind_c_implicit_vars.f03: Ditto.
* bind_c_procs.f03: Ditto.
* bind_c_usage_2.f03: Ditto.
* bind_c_usage_3.f03: Ditto.
* bind_c_usage_5.f03: Ditto.
* bind_c_usage_6.f03: Ditto.
* bind_c_usage_7.f03: Ditto.
* bind_c_vars.f90: Ditto.
* bind_c_vars_driver.c: Ditto.
* binding_c_table_15_1.f03: Ditto.
* binding_label_tests.f03: Ditto.
* binding_label_tests_10.f03: Ditto.
* binding_label_tests_10_main.f03: Ditto.
* binding_label_tests_11.f03: Ditto.
* binding_label_tests_11_main.f03: Ditto.
* binding_label_tests_12.f03: Ditto.
* binding_label_tests_13.f03: Ditto.
* binding_label_tests_13_main.f03: Ditto.
* binding_label_tests_14.f03: Ditto.
* binding_label_tests_2.f03: Ditto.
* binding_label_tests_3.f03: Ditto.
* binding_label_tests_4.f03: Ditto.
* binding_label_tests_5.f03: Ditto.
* binding_label_tests_6.f03: Ditto.
* binding_label_tests_7.f03: Ditto.
* binding_label_tests_8.f03: Ditto.
* binding_label_tests_9.f03: Ditto.
* c_assoc.f90: Ditto.
* c_assoc_2.f03: Ditto.
* c_f_pointer_shape_test.f90: Ditto.
* c_f_pointer_tests.f90: Ditto.
* c_f_tests_driver.c: Ditto.
* c_funloc_tests.f03: Ditto.
* c_funloc_tests_2.f03: Ditto.
* c_funloc_tests_3.f03: Ditto.
* c_funloc_tests_3_funcs.c: Ditto.
* c_kind_params.f90: Ditto.
* c_kind_tests_2.f03: Ditto.
* c_kinds.c: Ditto.
* c_loc_driver.c: Ditto.
* c_loc_test.f90: Ditto.
* c_loc_tests_2.f03: Ditto.
* c_loc_tests_2_funcs.c: Ditto.
* c_loc_tests_3.f03: Ditto.
* c_loc_tests_4.f03: Ditto.
* c_loc_tests_5.f03: Ditto.
* c_loc_tests_6.f03: Ditto.
* c_loc_tests_7.f03: Ditto.
* c_loc_tests_8.f03: Ditto.
* c_ptr_tests.f03: Ditto.
* c_ptr_tests_10.f03: Ditto.
* c_ptr_tests_5.f03: Ditto.
* c_ptr_tests_7.f03: Ditto.
* c_ptr_tests_7_driver.c: Ditto.
* c_ptr_tests_8.f03: Ditto.
* c_ptr_tests_8_funcs.c: Ditto.
* c_ptr_tests_9.f03: Ditto.
* c_ptr_tests_driver.c: Ditto.
* c_size_t_driver.c: Ditto.
* c_size_t_test.f03: Ditto.
* com_block_driver.f90: Ditto.
* global_vars_c_init.f90: Ditto.
* global_vars_c_init_driver.c: Ditto.
* global_vars_f90_init.f90: Ditto.
* global_vars_f90_init_driver.c: Ditto.
* interop_params.f03: Ditto.
* iso_c_binding_only.f03: Ditto.
* iso_c_binding_rename_1.f03: Ditto.
* iso_c_binding_rename_1_driver.c: Ditto.
* iso_c_binding_rename_2.f03: Ditto.
* iso_c_binding_rename_2_driver.c: Ditto.
* kind_tests_2.f03: Ditto.
* kind_tests_3.f03: Ditto.
* module_md5_1.f90: Ditto.
* only_clause_main.c: Ditto.
* print_c_kinds.f90: Ditto.
* test_bind_c_parens.f03: Ditto.
* test_c_assoc.c: Ditto.
* test_com_block.f90: Ditto.
* test_common_binding_labels.f03: Ditto.
* test_common_binding_labels_2.f03: Ditto.
* test_common_binding_labels_2_main.f03: Ditto.
* test_common_binding_labels_3.f03: Ditto.
* test_common_binding_labels_3_main.f03: Ditto.
* test_only_clause.f90: Ditto.
* use_iso_c_binding.f90: Ditto.
* value_5.f90: Ditto.
* value_test.f90: Ditto.
* value_tests_f03.f90: Ditto.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@126185 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
119 files changed, 6945 insertions, 134 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d0fe5d71455..02060eef179 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,171 @@ +2007-07-01 Christopher D. Rickett <crickett@lanl.gov> + + * interface.c (gfc_compare_derived_types): Special case for comparing + derived types across namespaces. + (gfc_compare_types): Deal with BT_VOID. + (compare_parameter): Use BT_VOID to accept ISO C Binding pointers. + * trans-expr.c (gfc_conv_function_call): Remove setting parm_kind + to SCALAR + (gfc_conv_initializer): Deal with ISO C Binding NULL_PTR and + NULL_FUNPTR. + (gfc_conv_expr): Convert expressions for ISO C Binding derived types. + * symbol.c (gfc_set_default_type): BIND(C) variables should not be + implicitly declared. + (check_conflict): Add BIND(C) and check for conflicts. + (gfc_add_explicit_interface): Whitespace. + (gfc_add_is_bind_c): New function. + (gfc_copy_attr): Use it. + (gfc_new_symbol): Initialize ISO C Binding objects. + (get_iso_c_binding_dt): New function. + (verify_bind_c_derived_type): Ditto. + (gen_special_c_interop_ptr): Ditto. + (add_formal_arg): Ditto. + (gen_cptr_param): Ditto. + (gen_fptr_param): Ditto. + (gen_shape_param): Ditto. + (add_proc_interface): Ditto. + (build_formal_args): Ditto. + (generate_isocbinding_symbol): Ditto. + (get_iso_c_sym): Ditto. + * decl.c (num_idents_on_line, has_name_equals): New variables. + (verify_c_interop_param): New function. + (build_sym): Finish binding labels and deal with COMMON blocks. + (add_init_expr_to_sym): Check if the initialized expression is + an iso_c_binding named constants + (variable_decl): Set ISO C Binding type_spec components. + (gfc_match_kind_spec): Check match for C interoperable kind. + (match_char_spec): Fix comment. Chnage gfc_match_small_int + to gfc_match_small_int_expr. Check for C interoperable kind. + (match_type_spec): Clear the current binding label. + (match_attr_spec): Add DECL_IS_BIND_C. If BIND(C) is found, use it + to set attributes. + (set_binding_label): New function. + (set_com_block_bind_c): Ditto. + (verify_c_interop): Ditto. + (verify_com_block_vars_c_interop): Ditto. + (verify_bind_c_sym): Ditto. + (set_verify_bind_c_sym): Ditto. + (set_verify_bind_c_com_block): Ditto. + (get_bind_c_idents): Ditto. + (gfc_match_bind_c_stmt): Ditto. + (gfc_match_data_decl): Use num_idents_on_line. + (match_result): Deal with right paren in BIND(C). + (gfc_match_suffix): New function. + (gfc_match_function_decl): Use it. Code is re-arranged to deal with + ISO C Binding result clauses. + (gfc_match_subroutine): Deal with BIND(C). + (gfc_match_bind_c): New function. + (gfc_get_type_attr_spec): New function. Code is re-arranged in and + taken from gfc_match_derived_decl. + (gfc_match_derived_decl): Add check for BIND(C). + * trans-common.c: Forward declare gfc_get_common. + (gfc_sym_mangled_common_id): Change arg from 'const char *name' to + 'gfc_common_head *com'. Check for ISO C Binding of the common block. + (build_common_decl): 'com->name' to 'com in SET_DECL_ASSEMBLER_NAME. + * gfortran.h: Add GFC_MAX_BINDING_LABEL_LEN + (bt): Add BT_VOID + (sym_flavor): Add FL_VOID. + (iso_fortran_env_symbol, iso_c_binding_symbol, intmod_id): New enum + (CInteropKind_t): New struct. + (c_interop_kinds_table): Use it. Declare an array of structs. + (symbol_attribute): Add is_bind_c, is_c_interop, and is_iso_c + bitfields. + (gfc_typespec): Add is_c_interop; is_iso_c, and f90_type members. + (gfc_symbol): Add from_intmod, intmod_sym_id, binding_label, and + common_block members. + (gfc_common_head): Add binding_label and is_bind_c members. + (gfc_gsymbol): Add sym_name, mod_name, and binding_label members. + Add prototypes for get_c_kind, gfc_validate_c_kind, + gfc_check_any_c_kind, gfc_add_is_bind_c, gfc_add_value, + verify_c_interop, verify_c_interop_param, verify_bind_c_sym, + verify_bind_c_derived_type, verify_com_block_vars_c_interop, + generate_isocbinding_symbol, get_iso_c_sym, gfc_iso_c_sub_interface + * iso-c-binding.def: New file. This file contains the definitions + of the types provided by the Fortran 2003 ISO_C_BINDING intrinsic + module. + * trans-const.c (gfc_conv_constant_to_tree): Deal with C_NULL_PTR + or C_NULL_FUNPTR expressions. + * expr.c (gfc_copy_expr): Add BT_VOID case. For BT_CHARACTER, the + ISO C Binding requires a minimum string length of 1 for '\0'. + * module.c (intmod_sym): New struct. + (pointer_info): Add binding_label member. + (write_atom): Set len to 0 for NULL pointers. Check for NULL p and *p. + (ab_attribute): Add AB_IS_BIND_C, AB_IS_C_INTEROP and AB_IS_ISO_C. + (attr_bits): Add "IS_BIND_C", "IS_C_INTEROP", and "IS_ISO_C". + (mio_symbol_attribute): Deal with ISO C Binding attributes. + (bt_types): Add "VOID". + (mio_typespec): Deal with ISO C Binding components. + (mio_namespace_ref): Add intmod variable. + (mio_symbol): Check for symbols from an intrinsic module. + (load_commons): Check for BIND(C) common block. + (read_module): Read binding_label and use it. + (write_common): Add label. Write BIND(C) info. + (write_blank_common): Blank commons are not BIND(C). Explicitly + set is_bind_c=0. + (write_symbol): Deal with binding_label. + (sort_iso_c_rename_list): New function. + (import_iso_c_binding_module): Ditto. + (create_int_parameter): Add to args. + (use_iso_fortran_env_module): Adjust to deal with iso_c_binding + intrinsic module. + * trans-types.c (c_interop_kinds_table): new array of structs. + (gfc_validate_c_kind): New function. + (gfc_check_any_c_kind): Ditto. + (get_real_kind_from_node): Ditto. + (get_int_kind_from_node): Ditto. + (get_int_kind_from_width): Ditto. + (get_int_kind_from_minimal_width): Ditto. + (init_c_interop_kinds): Ditto. + (gfc_init_kinds): call init_c_interop_kinds. + (gfc_typenode_for_spec): Adjust for BT_VOID and ISO C Binding pointers. + Adjust handling of BT_DERIVED. + (gfc_sym_type): Whitespace. + (gfc_get_derived_type): Account for iso_c_binding derived types + * resolve.c (is_scalar_expr_ptr): New function. + (gfc_iso_c_func_interface): Ditto. + (resolve_function): Use gfc_iso_c_func_interface. + (set_name_and_label): New function. + (gfc_iso_c_sub_interface): Ditto. + (resolve_specific_s0): Use gfc_iso_c_sub_interface. + (resolve_bind_c_comms): New function. + (resolve_bind_c_derived_types): Ditto. + (gfc_verify_binding_labels): Ditto. + (resolve_fl_procedure): Check for ISO C interoperability. + (resolve_symbol): Check C interoperability. + (resolve_types): Walk the namespace. Check COMMON blocks. + * trans-decl.c (gfc_sym_mangled_identifier): Prevent the mangling + of identifiers that have an assigned binding label. + (gfc_sym_mangled_function_id): Use the binding label rather than + the mangled name. + (gfc_finish_var_decl): Put variables that are BIND(C) into a common + segment of the object file, because this is what C would do. + (gfc_create_module_variable): Conver to proper types + (set_tree_decl_type_code): New function. + (generate_local_decl): Check dummy variables and derived types for + ISO C Binding attributes. + * match.c (gfc_match_small_int_expr): New function. + (gfc_match_name_C): Ditto. + (match_common_name): Deal with ISO C Binding in COMMON blocks + * trans-io.c (transfer_expr): Deal with C_NULL_PTR or C_NULL_FUNPTR + expressions + * match.h: Add prototypes for gfc_match_small_int_expr, + gfc_match_name_C, match_common_name, set_com_block_bind_c, + set_binding_label, set_verify_bind_c_sym, + set_verify_bind_c_com_block, get_bind_c_idents, + gfc_match_bind_c_stmt, gfc_match_suffix, gfc_match_bind_c, + gfc_get_type_attr_spec + * parse.c (decode_statement): Use gfc_match_bind_c_stmt + (parse_derived): Init *derived_sym = NULL, and gfc_current_block + later for valiadation. + * primary.c (got_delim): Set ISO C Binding components of ts. + (match_logical_constant): Ditto. + (match_complex_constant): Ditto. + (match_complex_constant): Ditto. + (gfc_match_rvalue): Check for existence of at least one arg for + C_LOC, C_FUNLOC, and C_ASSOCIATED. + * misc.c (gfc_clear_ts): Clear ISO C Bindoing components in ts. + (get_c_kind): New function. + 2007-07-01 Janne Blomqvist <jb@gcc.gnu.org> PR fortran/32239 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 2568a50c7b3..24f1a3d1b59 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -42,6 +42,15 @@ static symbol_attribute current_attr; static gfc_array_spec *current_as; static int colon_seen; +/* The current binding label (if any). */ +static char curr_binding_label[GFC_MAX_BINDING_LABEL_LEN + 1]; +/* Need to know how many identifiers are on the current data declaration + line in case we're given the BIND(C) attribute with a NAME= specifier. */ +static int num_idents_on_line; +/* Need to know if a NAME= specifier was found during gfc_match_bind_c so we + can supply a name if the curr_binding_label is nil and NAME= was not. */ +static int has_name_equals = 0; + /* Initializer of the previous enumerator. */ static gfc_expr *last_initializer; @@ -750,8 +759,147 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) } -/* Function called by variable_decl() that adds a name to the symbol - table. */ +/* Verify that the given symbol representing a parameter is C + interoperable, by checking to see if it was marked as such after + its declaration. If the given symbol is not interoperable, a + warning is reported, thus removing the need to return the status to + the calling function. The standard does not require the user use + one of the iso_c_binding named constants to declare an + interoperable parameter, but we can't be sure if the param is C + interop or not if the user doesn't. For example, integer(4) may be + legal Fortran, but doesn't have meaning in C. It may interop with + a number of the C types, which causes a problem because the + compiler can't know which one. This code is almost certainly not + portable, and the user will get what they deserve if the C type + across platforms isn't always interoperable with integer(4). If + the user had used something like integer(c_int) or integer(c_long), + the compiler could have automatically handled the varying sizes + across platforms. */ + +try +verify_c_interop_param (gfc_symbol *sym) +{ + int is_c_interop = 0; + try retval = SUCCESS; + + /* We check implicitly typed variables in symbol.c:gfc_set_default_type(). + Don't repeat the checks here. */ + if (sym->attr.implicit_type) + return SUCCESS; + + /* For subroutines or functions that are passed to a BIND(C) procedure, + they're interoperable if they're BIND(C) and their params are all + interoperable. */ + if (sym->attr.flavor == FL_PROCEDURE) + { + if (sym->attr.is_bind_c == 0) + { + gfc_error_now ("Procedure '%s' at %L must have the BIND(C) " + "attribute to be C interoperable", sym->name, + &(sym->declared_at)); + + return FAILURE; + } + else + { + if (sym->attr.is_c_interop == 1) + /* We've already checked this procedure; don't check it again. */ + return SUCCESS; + else + return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, + sym->common_block); + } + } + + /* See if we've stored a reference to a procedure that owns sym. */ + if (sym->ns != NULL && sym->ns->proc_name != NULL) + { + if (sym->ns->proc_name->attr.is_bind_c == 1) + { + is_c_interop = + (verify_c_interop (&(sym->ts), sym->name, &(sym->declared_at)) + == SUCCESS ? 1 : 0); + + if (is_c_interop != 1) + { + /* Make personalized messages to give better feedback. */ + if (sym->ts.type == BT_DERIVED) + gfc_error ("Type '%s' at %L is a parameter to the BIND(C) " + " procedure '%s' but is not C interoperable " + "because derived type '%s' is not C interoperable", + sym->name, &(sym->declared_at), + sym->ns->proc_name->name, + sym->ts.derived->name); + else + gfc_warning ("Variable '%s' at %L is a parameter to the " + "BIND(C) procedure '%s' but may not be C " + "interoperable", + sym->name, &(sym->declared_at), + sym->ns->proc_name->name); + } + + /* We have to make sure that any param to a bind(c) routine does + not have the allocatable, pointer, or optional attributes, + according to J3/04-007, section 5.1. */ + if (sym->attr.allocatable == 1) + { + gfc_error ("Variable '%s' at %L cannot have the " + "ALLOCATABLE attribute because procedure '%s'" + " is BIND(C)", sym->name, &(sym->declared_at), + sym->ns->proc_name->name); + retval = FAILURE; + } + + if (sym->attr.pointer == 1) + { + gfc_error ("Variable '%s' at %L cannot have the " + "POINTER attribute because procedure '%s'" + " is BIND(C)", sym->name, &(sym->declared_at), + sym->ns->proc_name->name); + retval = FAILURE; + } + + if (sym->attr.optional == 1) + { + gfc_error ("Variable '%s' at %L cannot have the " + "OPTIONAL attribute because procedure '%s'" + " is BIND(C)", sym->name, &(sym->declared_at), + sym->ns->proc_name->name); + retval = FAILURE; + } + + /* Make sure that if it has the dimension attribute, that it is + either assumed size or explicit shape. */ + if (sym->as != NULL) + { + if (sym->as->type == AS_ASSUMED_SHAPE) + { + gfc_error ("Assumed-shape array '%s' at %L cannot be an " + "argument to the procedure '%s' at %L because " + "the procedure is BIND(C)", sym->name, + &(sym->declared_at), sym->ns->proc_name->name, + &(sym->ns->proc_name->declared_at)); + retval = FAILURE; + } + + if (sym->as->type == AS_DEFERRED) + { + gfc_error ("Deferred-shape array '%s' at %L cannot be an " + "argument to the procedure '%s' at %L because " + "the procedure is BIND(C)", sym->name, + &(sym->declared_at), sym->ns->proc_name->name, + &(sym->ns->proc_name->declared_at)); + retval = FAILURE; + } + } + } + } + + return retval; +} + + +/* Function called by variable_decl() that adds a name to the symbol table. */ static try build_sym (const char *name, gfc_charlen *cl, @@ -786,6 +934,40 @@ build_sym (const char *name, gfc_charlen *cl, if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE) return FAILURE; + /* Finish any work that may need to be done for the binding label, + if it's a bind(c). The bind(c) attr is found before the symbol + is made, and before the symbol name (for data decls), so the + current_ts is holding the binding label, or nothing if the + name= attr wasn't given. Therefore, test here if we're dealing + with a bind(c) and make sure the binding label is set correctly. */ + if (sym->attr.is_bind_c == 1) + { + if (sym->binding_label[0] == '\0') + { + /* Here, we're not checking the numIdents (the last param). + This could be an error we're letting slip through! */ + if (set_binding_label (sym->binding_label, sym->name, 1) == FAILURE) + return FAILURE; + } + } + + /* See if we know we're in a common block, and if it's a bind(c) + common then we need to make sure we're an interoperable type. */ + if (sym->attr.in_common == 1) + { + /* Test the common block object. */ + if (sym->common_block != NULL && sym->common_block->is_bind_c == 1 + && sym->ts.is_c_interop != 1) + { + gfc_error_now ("Variable '%s' in common block '%s' at %C " + "must be declared with a C interoperable " + "kind since common block '%s' is BIND(C)", + sym->name, sym->common_block->name, + sym->common_block->name); + gfc_clear_error (); + } + } + sym->attr.implied_index = 0; return SUCCESS; @@ -987,6 +1169,26 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) } } + /* Need to check if the expression we initialized this + to was one of the iso_c_binding named constants. If so, + and we're a parameter (constant), let it be iso_c. + For example: + integer(c_int), parameter :: my_int = c_int + integer(my_int) :: my_int_2 + If we mark my_int as iso_c (since we can see it's value + is equal to one of the named constants), then my_int_2 + will be considered C interoperable. */ + if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED) + { + sym->ts.is_iso_c |= init->ts.is_iso_c; + sym->ts.is_c_interop |= init->ts.is_c_interop; + /* attr bits needed for module files. */ + sym->attr.is_iso_c |= init->ts.is_iso_c; + sym->attr.is_c_interop |= init->ts.is_c_interop; + if (init->ts.is_iso_c) + sym->ts.f90_type = init->ts.f90_type; + } + /* Add initializer. Make sure we keep the ranks sane. */ if (sym->attr.dimension && init->rank == 0) { @@ -1253,6 +1455,8 @@ variable_decl (int elem) sym->ts.kind = current_ts.kind; sym->ts.cl = cl; sym->ts.derived = current_ts.derived; + sym->ts.is_c_interop = current_ts.is_c_interop; + sym->ts.is_iso_c = current_ts.is_iso_c; m = MATCH_YES; /* Check to see if we have an array specification. */ @@ -1536,25 +1740,41 @@ gfc_match_kind_spec (gfc_typespec *ts) goto no_match; } + /* Before throwing away the expression, let's see if we had a + C interoperable kind (and store the fact). */ + if (e->ts.is_c_interop == 1) + { + /* Mark this as c interoperable if being declared with one + of the named constants from iso_c_binding. */ + ts->is_c_interop = e->ts.is_iso_c; + ts->f90_type = e->ts.f90_type; + } + gfc_free_expr (e); e = NULL; + /* Ignore errors to this point, if we've gotten here. This means + we ignore the m=MATCH_ERROR from above. */ if (gfc_validate_kind (ts->type, ts->kind, true) < 0) { gfc_error ("Kind %d not supported for type %s at %C", ts->kind, gfc_basic_typename (ts->type)); - m = MATCH_ERROR; - goto no_match; } - - if (gfc_match_char (')') != MATCH_YES) + else if (gfc_match_char (')') != MATCH_YES) { gfc_error ("Missing right parenthesis at %C"); - goto no_match; + m = MATCH_ERROR; } + else + /* All tests passed. */ + m = MATCH_YES; - return MATCH_YES; + if(m == MATCH_ERROR) + gfc_current_locus = where; + + /* Return what we know from the test(s). */ + return m; no_match: gfc_free_expr (e); @@ -1573,7 +1793,7 @@ match_char_spec (gfc_typespec *ts) gfc_charlen *cl; gfc_expr *len; match m; - + gfc_expr *kind_expr = NULL; kind = gfc_default_character_kind; len = NULL; seen_length = 0; @@ -1593,14 +1813,15 @@ match_char_spec (gfc_typespec *ts) m = gfc_match_char ('('); if (m != MATCH_YES) { - m = MATCH_YES; /* character without length is a single char */ + m = MATCH_YES; /* Character without length is a single char. */ goto done; } - /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */ + /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */ if (gfc_match (" kind =") == MATCH_YES) { - m = gfc_match_small_int (&kind); + m = gfc_match_small_int_expr(&kind, &kind_expr); + if (m == MATCH_ERROR) goto done; if (m == MATCH_NO) @@ -1635,7 +1856,7 @@ match_char_spec (gfc_typespec *ts) if (gfc_match (" , kind =") != MATCH_YES) goto syntax; - gfc_match_small_int (&kind); + gfc_match_small_int_expr(&kind, &kind_expr); if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0) { @@ -1661,9 +1882,9 @@ match_char_spec (gfc_typespec *ts) if (gfc_match_char (',') != MATCH_YES) goto syntax; - gfc_match (" kind ="); /* Gobble optional text */ + gfc_match (" kind ="); /* Gobble optional text. */ - m = gfc_match_small_int (&kind); + m = gfc_match_small_int_expr(&kind, &kind_expr); if (m == MATCH_ERROR) goto done; if (m == MATCH_NO) @@ -1698,6 +1919,7 @@ done: if (m != MATCH_YES) { gfc_free_expr (len); + gfc_free_expr (kind_expr); return m; } @@ -1714,6 +1936,29 @@ done: ts->cl = cl; ts->kind = kind; + /* We have to know if it was a c interoperable kind so we can + do accurate type checking of bind(c) procs, etc. */ + if (kind_expr != NULL) + { + /* Mark this as c interoperable if being declared with one + of the named constants from iso_c_binding. */ + ts->is_c_interop = kind_expr->ts.is_iso_c; + gfc_free_expr (kind_expr); + } + else if (len != NULL) + { + /* Here, we might have parsed something such as: + character(c_char) + In this case, the parsing code above grabs the c_char when + looking for the length (line 1690, roughly). it's the last + testcase for parsing the kind params of a character variable. + However, it's not actually the length. this seems like it + could be an error. + To see if the user used a C interop kind, test the expr + of the so called length, and see if it's C interoperable. */ + ts->is_c_interop = len->ts.is_iso_c; + } + return MATCH_YES; } @@ -1736,6 +1981,9 @@ match_type_spec (gfc_typespec *ts, int implicit_flag) gfc_clear_ts (ts); + /* Clear the current binding label, in case one is given. */ + curr_binding_label[0] = '\0'; + if (gfc_match (" byte") == MATCH_YES) { if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C") @@ -2193,7 +2441,7 @@ match_attr_spec (void) DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL, DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE, - DECL_COLON, DECL_NONE, + DECL_IS_BIND_C, DECL_COLON, DECL_NONE, GFC_DECL_END /* Sentinel */ } decl_types; @@ -2229,6 +2477,7 @@ match_attr_spec (void) const char *attr; match m; try t; + char peek_char; gfc_clear_attr (¤t_attr); start = gfc_current_locus; @@ -2243,6 +2492,27 @@ match_attr_spec (void) for (;;) { d = (decl_types) gfc_match_strings (decls); + + if (d == DECL_NONE) + { + /* See if we can find the bind(c) since all else failed. + We need to skip over any whitespace and stop on the ','. */ + gfc_gobble_whitespace (); + peek_char = gfc_peek_char (); + if (peek_char == ',') + { + /* Chomp the comma. */ + peek_char = gfc_next_char (); + /* Try and match the bind(c). */ + if (gfc_match_bind_c (NULL) == MATCH_YES) + d = DECL_IS_BIND_C; + else + { + return MATCH_ERROR; + } + } + } + if (d == DECL_NONE || d == DECL_COLON) break; @@ -2324,9 +2594,12 @@ match_attr_spec (void) case DECL_TARGET: attr = "TARGET"; break; - case DECL_VALUE: - attr = "VALUE"; - break; + case DECL_IS_BIND_C: + attr = "IS_BIND_C"; + break; + case DECL_VALUE: + attr = "VALUE"; + break; case DECL_VOLATILE: attr = "VOLATILE"; break; @@ -2476,6 +2749,10 @@ match_attr_spec (void) t = gfc_add_target (¤t_attr, &seen_at[d]); break; + case DECL_IS_BIND_C: + t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0); + break; + case DECL_VALUE: if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute " "at %C") @@ -2516,6 +2793,389 @@ cleanup: } +/* Set the binding label, dest_label, either with the binding label + stored in the given gfc_typespec, ts, or if none was provided, it + will be the symbol name in all lower case, as required by the draft + (J3/04-007, section 15.4.1). If a binding label was given and + there is more than one argument (num_idents), it is an error. */ + +try +set_binding_label (char *dest_label, const char *sym_name, int num_idents) +{ + if (curr_binding_label[0] != '\0') + { + if (num_idents > 1 || num_idents_on_line > 1) + { + gfc_error ("Multiple identifiers provided with " + "single NAME= specifier at %C"); + return FAILURE; + } + + /* Binding label given; store in temp holder til have sym. */ + strncpy (dest_label, curr_binding_label, + strlen (curr_binding_label) + 1); + } + else + { + /* No binding label given, and the NAME= specifier did not exist, + which means there was no NAME="". */ + if (sym_name != NULL && has_name_equals == 0) + strncpy (dest_label, sym_name, strlen (sym_name) + 1); + } + + return SUCCESS; +} + + +/* Set the status of the given common block as being BIND(C) or not, + depending on the given parameter, is_bind_c. */ + +void +set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c) +{ + com_block->is_bind_c = is_bind_c; + return; +} + + +/* Verify that the given gfc_typespec is for a C interoperable type. */ + +try +verify_c_interop (gfc_typespec *ts, const char *name, locus *where) +{ + try t; + + /* Make sure the kind used is appropriate for the type. + The f90_type is unknown if an integer constant was + used (e.g., real(4), bind(c) :: myFloat). */ + if (ts->f90_type != BT_UNKNOWN) + { + t = gfc_validate_c_kind (ts); + if (t != SUCCESS) + { + /* Print an error, but continue parsing line. */ + gfc_error_now ("C kind parameter is for type %s but " + "symbol '%s' at %L is of type %s", + gfc_basic_typename (ts->f90_type), + name, where, + gfc_basic_typename (ts->type)); + } + } + + /* Make sure the kind is C interoperable. This does not care about the + possible error above. */ + if (ts->type == BT_DERIVED && ts->derived != NULL) + return (ts->derived->ts.is_c_interop ? SUCCESS : FAILURE); + else if (ts->is_c_interop != 1) + return FAILURE; + + return SUCCESS; +} + + +/* Verify that the variables of a given common block, which has been + defined with the attribute specifier bind(c), to be of a C + interoperable type. Errors will be reported here, if + encountered. */ + +try +verify_com_block_vars_c_interop (gfc_common_head *com_block) +{ + gfc_symbol *curr_sym = NULL; + try retval = SUCCESS; + + curr_sym = com_block->head; + + /* Make sure we have at least one symbol. */ + if (curr_sym == NULL) + return retval; + + /* Here we know we have a symbol, so we'll execute this loop + at least once. */ + do + { + /* The second to last param, 1, says this is in a common block. */ + retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block); + curr_sym = curr_sym->common_next; + } while (curr_sym != NULL); + + return retval; +} + + +/* Verify that a given BIND(C) symbol is C interoperable. If it is not, + an appropriate error message is reported. */ + +try +verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, + int is_in_common, gfc_common_head *com_block) +{ + try retval = SUCCESS; + + /* Here, we know we have the bind(c) attribute, so if we have + enough type info, then verify that it's a C interop kind. + The info could be in the symbol already, or possibly still in + the given ts (current_ts), so look in both. */ + if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN) + { + if (verify_c_interop (&(tmp_sym->ts), tmp_sym->name, + &(tmp_sym->declared_at)) != SUCCESS) + { + /* See if we're dealing with a sym in a common block or not. */ + if (is_in_common == 1) + { + gfc_warning ("Variable '%s' in common block '%s' at %L " + "may not be a C interoperable " + "kind though common block '%s' is BIND(C)", + tmp_sym->name, com_block->name, + &(tmp_sym->declared_at), com_block->name); + } + else + { + if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED) + gfc_error ("Type declaration '%s' at %L is not C " + "interoperable but it is BIND(C)", + tmp_sym->name, &(tmp_sym->declared_at)); + else + gfc_warning ("Variable '%s' at %L " + "may not be a C interoperable " + "kind but it is bind(c)", + tmp_sym->name, &(tmp_sym->declared_at)); + } + } + + /* Variables declared w/in a common block can't be bind(c) + since there's no way for C to see these variables, so there's + semantically no reason for the attribute. */ + if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1) + { + gfc_error ("Variable '%s' in common block '%s' at " + "%L cannot be declared with BIND(C) " + "since it is not a global", + tmp_sym->name, com_block->name, + &(tmp_sym->declared_at)); + retval = FAILURE; + } + + /* Scalar variables that are bind(c) can not have the pointer + or allocatable attributes. */ + if (tmp_sym->attr.is_bind_c == 1) + { + if (tmp_sym->attr.pointer == 1) + { + gfc_error ("Variable '%s' at %L cannot have both the " + "POINTER and BIND(C) attributes", + tmp_sym->name, &(tmp_sym->declared_at)); + retval = FAILURE; + } + + if (tmp_sym->attr.allocatable == 1) + { + gfc_error ("Variable '%s' at %L cannot have both the " + "ALLOCATABLE and BIND(C) attributes", + tmp_sym->name, &(tmp_sym->declared_at)); + retval = FAILURE; + } + + /* If it is a BIND(C) function, make sure the return value is a + scalar value. The previous tests in this function made sure + the type is interoperable. */ + if (tmp_sym->attr.function == 1 && tmp_sym->as != NULL) + gfc_error ("Return type of BIND(C) function '%s' at %L cannot " + "be an array", tmp_sym->name, &(tmp_sym->declared_at)); + + /* BIND(C) functions can not return a character string. */ + if (tmp_sym->attr.function == 1 && tmp_sym->ts.type == BT_CHARACTER) + if (tmp_sym->ts.cl == NULL || tmp_sym->ts.cl->length == NULL + || tmp_sym->ts.cl->length->expr_type != EXPR_CONSTANT + || mpz_cmp_si (tmp_sym->ts.cl->length->value.integer, 1) != 0) + gfc_error ("Return type of BIND(C) function '%s' at %L cannot " + "be a character string", tmp_sym->name, + &(tmp_sym->declared_at)); + } + } + + /* See if the symbol has been marked as private. If it has, make sure + there is no binding label and warn the user if there is one. */ + if (tmp_sym->attr.access == ACCESS_PRIVATE + && tmp_sym->binding_label[0] != '\0') + /* Use gfc_warning_now because we won't say that the symbol fails + just because of this. */ + gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been " + "given the binding label '%s'", tmp_sym->name, + &(tmp_sym->declared_at), tmp_sym->binding_label); + + return retval; +} + + +/* Set the appropriate fields for a symbol that's been declared as + BIND(C) (the is_bind_c flag and the binding label), and verify that + the type is C interoperable. Errors are reported by the functions + used to set/test these fields. */ + +try +set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents) +{ + try retval = SUCCESS; + + /* TODO: Do we need to make sure the vars aren't marked private? */ + + /* Set the is_bind_c bit in symbol_attribute. */ + gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0); + + if (set_binding_label (tmp_sym->binding_label, tmp_sym->name, + num_idents) != SUCCESS) + return FAILURE; + + return retval; +} + + +/* Set the fields marking the given common block as BIND(C), including + a binding label, and report any errors encountered. */ + +try +set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents) +{ + try retval = SUCCESS; + + /* destLabel, common name, typespec (which may have binding label). */ + if (set_binding_label (com_block->binding_label, com_block->name, num_idents) + != SUCCESS) + return FAILURE; + + /* Set the given common block (com_block) to being bind(c) (1). */ + set_com_block_bind_c (com_block, 1); + + return retval; +} + + +/* Retrieve the list of one or more identifiers that the given bind(c) + attribute applies to. */ + +try +get_bind_c_idents (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + int num_idents = 0; + gfc_symbol *tmp_sym = NULL; + match found_id; + gfc_common_head *com_block = NULL; + + if (gfc_match_name (name) == MATCH_YES) + { + found_id = MATCH_YES; + gfc_get_ha_symbol (name, &tmp_sym); + } + else if (match_common_name (name) == MATCH_YES) + { + found_id = MATCH_YES; + com_block = gfc_get_common (name, 0); + } + else + { + gfc_error ("Need either entity or common block name for " + "attribute specification statement at %C"); + return FAILURE; + } + + /* Save the current identifier and look for more. */ + do + { + /* Increment the number of identifiers found for this spec stmt. */ + num_idents++; + + /* Make sure we have a sym or com block, and verify that it can + be bind(c). Set the appropriate field(s) and look for more + identifiers. */ + if (tmp_sym != NULL || com_block != NULL) + { + if (tmp_sym != NULL) + { + if (set_verify_bind_c_sym (tmp_sym, num_idents) + != SUCCESS) + return FAILURE; + } + else + { + if (set_verify_bind_c_com_block(com_block, num_idents) + != SUCCESS) + return FAILURE; + } + + /* Look to see if we have another identifier. */ + tmp_sym = NULL; + if (gfc_match_eos () == MATCH_YES) + found_id = MATCH_NO; + else if (gfc_match_char (',') != MATCH_YES) + found_id = MATCH_NO; + else if (gfc_match_name (name) == MATCH_YES) + { + found_id = MATCH_YES; + gfc_get_ha_symbol (name, &tmp_sym); + } + else if (match_common_name (name) == MATCH_YES) + { + found_id = MATCH_YES; + com_block = gfc_get_common (name, 0); + } + else + { + gfc_error ("Missing entity or common block name for " + "attribute specification statement at %C"); + return FAILURE; + } + } + else + { + gfc_internal_error ("Missing symbol"); + } + } while (found_id == MATCH_YES); + + /* if we get here we were successful */ + return SUCCESS; +} + + +/* Try and match a BIND(C) attribute specification statement. */ + +match +gfc_match_bind_c_stmt (void) +{ + match found_match = MATCH_NO; + gfc_typespec *ts; + + ts = ¤t_ts; + + /* This may not be necessary. */ + gfc_clear_ts (ts); + /* Clear the temporary binding label holder. */ + curr_binding_label[0] = '\0'; + + /* Look for the bind(c). */ + found_match = gfc_match_bind_c (NULL); + + if (found_match == MATCH_YES) + { + /* Look for the :: now, but it is not required. */ + gfc_match (" :: "); + + /* Get the identifier(s) that needs to be updated. This may need to + change to hand the flag(s) for the attr specified so all identifiers + found can have all appropriate parts updated (assuming that the same + spec stmt can have multiple attrs, such as both bind(c) and + allocatable...). */ + if (get_bind_c_idents () != SUCCESS) + /* Error message should have printed already. */ + return MATCH_ERROR; + } + + return found_match; +} + + /* Match a data declaration statement. */ match @@ -2525,6 +3185,8 @@ gfc_match_data_decl (void) match m; int elem; + num_idents_on_line = 0; + m = match_type_spec (¤t_ts, 0); if (m != MATCH_YES) return m; @@ -2584,6 +3246,7 @@ ok: elem = 1; for (;;) { + num_idents_on_line++; m = variable_decl (elem++); if (m == MATCH_ERROR) goto cleanup; @@ -2814,9 +3477,11 @@ match_result (gfc_symbol *function, gfc_symbol **result) if (m != MATCH_YES) return m; - if (gfc_match (" )%t") != MATCH_YES) + /* Get the right paren, and that's it because there could be the + bind(c) attribute after the result clause. */ + if (gfc_match_char(')') != MATCH_YES) { - gfc_error ("Unexpected junk following RESULT variable at %C"); + /* TODO: should report the missing right paren here. */ return MATCH_ERROR; } @@ -2839,6 +3504,79 @@ match_result (gfc_symbol *function, gfc_symbol **result) } +/* Match a function suffix, which could be a combination of a result + clause and BIND(C), either one, or neither. The draft does not + require them to come in a specific order. */ + +match +gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result) +{ + match is_bind_c; /* Found bind(c). */ + match is_result; /* Found result clause. */ + match found_match; /* Status of whether we've found a good match. */ + int peek_char; /* Character we're going to peek at. */ + + /* Initialize to having found nothing. */ + found_match = MATCH_NO; + is_bind_c = MATCH_NO; + is_result = MATCH_NO; + + /* Get the next char to narrow between result and bind(c). */ + gfc_gobble_whitespace (); + peek_char = gfc_peek_char (); + + switch (peek_char) + { + case 'r': + /* Look for result clause. */ + is_result = match_result (sym, result); + if (is_result == MATCH_YES) + { + /* Now see if there is a bind(c) after it. */ + is_bind_c = gfc_match_bind_c (sym); + /* We've found the result clause and possibly bind(c). */ + found_match = MATCH_YES; + } + else + /* This should only be MATCH_ERROR. */ + found_match = is_result; + break; + case 'b': + /* Look for bind(c) first. */ + is_bind_c = gfc_match_bind_c (sym); + if (is_bind_c == MATCH_YES) + { + /* Now see if a result clause followed it. */ + is_result = match_result (sym, result); + found_match = MATCH_YES; + } + else + { + /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */ + found_match = MATCH_ERROR; + } + break; + default: + gfc_error ("Unexpected junk after function declaration at %C"); + found_match = MATCH_ERROR; + break; + } + + if (is_result == MATCH_ERROR || is_bind_c == MATCH_ERROR) + { + gfc_error ("Error in function suffix at %C"); + return MATCH_ERROR; + } + + if (is_bind_c == MATCH_YES) + if (gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1) + == FAILURE) + return MATCH_ERROR; + + return found_match; +} + + /* Match a function declaration. */ match @@ -2848,6 +3586,8 @@ gfc_match_function_decl (void) gfc_symbol *sym, *result; locus old_loc; match m; + match suffix_match; + match found_match; /* Status returned by match func. */ if (gfc_current_state () != COMP_NONE && gfc_current_state () != COMP_INTERFACE @@ -2887,50 +3627,74 @@ gfc_match_function_decl (void) result = NULL; - if (gfc_match_eos () != MATCH_YES) - { - /* See if a result variable is present. */ - m = match_result (sym, &result); - if (m == MATCH_NO) - gfc_error ("Unexpected junk after function declaration at %C"); - - if (m != MATCH_YES) - { - m = MATCH_ERROR; - goto cleanup; - } + /* According to the draft, the bind(c) and result clause can + come in either order after the formal_arg_list (i.e., either + can be first, both can exist together or by themselves or neither + one). Therefore, the match_result can't match the end of the + string, and check for the bind(c) or result clause in either order. */ + found_match = gfc_match_eos (); + + /* Make sure that it isn't already declared as BIND(C). If it is, it + must have been marked BIND(C) with a BIND(C) attribute and that is + not allowed for procedures. */ + if (sym->attr.is_bind_c == 1) + { + sym->attr.is_bind_c = 0; + if (sym->old_symbol != NULL) + gfc_error_now ("BIND(C) attribute at %L can only be used for " + "variables or common blocks", + &(sym->old_symbol->declared_at)); + else + gfc_error_now ("BIND(C) attribute at %L can only be used for " + "variables or common blocks", &gfc_current_locus); } - /* Make changes to the symbol. */ - m = MATCH_ERROR; - - if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE) - goto cleanup; - - if (gfc_missing_attr (&sym->attr, NULL) == FAILURE - || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE) - goto cleanup; - - if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN - && !sym->attr.implicit_type) + if (found_match != MATCH_YES) { - gfc_error ("Function '%s' at %C already has a type of %s", name, - gfc_basic_typename (sym->ts.type)); - goto cleanup; + /* If we haven't found the end-of-statement, look for a suffix. */ + suffix_match = gfc_match_suffix (sym, &result); + if (suffix_match == MATCH_YES) + /* Need to get the eos now. */ + found_match = gfc_match_eos (); + else + found_match = suffix_match; } - if (result == NULL) - { - sym->ts = current_ts; - sym->result = sym; - } + if(found_match != MATCH_YES) + m = MATCH_ERROR; else { - result->ts = current_ts; - sym->result = result; - } + /* Make changes to the symbol. */ + m = MATCH_ERROR; + + if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE) + goto cleanup; + + if (gfc_missing_attr (&sym->attr, NULL) == FAILURE + || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE) + goto cleanup; - return MATCH_YES; + if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN + && !sym->attr.implicit_type) + { + gfc_error ("Function '%s' at %C already has a type of %s", name, + gfc_basic_typename (sym->ts.type)); + goto cleanup; + } + + if (result == NULL) + { + sym->ts = current_ts; + sym->result = sym; + } + else + { + result->ts = current_ts; + sym->result = result; + } + + return MATCH_YES; + } cleanup: gfc_current_locus = old_loc; @@ -3165,6 +3929,8 @@ gfc_match_subroutine (void) char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_symbol *sym; match m; + match is_bind_c; + char peek_char; if (gfc_current_state () != COMP_NONE && gfc_current_state () != COMP_INTERFACE @@ -3183,12 +3949,56 @@ gfc_match_subroutine (void) return MATCH_ERROR; gfc_new_block = sym; + /* Check what next non-whitespace character is so we can tell if there + where the required parens if we have a BIND(C). */ + gfc_gobble_whitespace (); + peek_char = gfc_peek_char (); + if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES) return MATCH_ERROR; + /* Make sure that it isn't already declared as BIND(C). If it is, it + must have been marked BIND(C) with a BIND(C) attribute and that is + not allowed for procedures. */ + if (sym->attr.is_bind_c == 1) + { + sym->attr.is_bind_c = 0; + if (sym->old_symbol != NULL) + gfc_error_now ("BIND(C) attribute at %L can only be used for " + "variables or common blocks", + &(sym->old_symbol->declared_at)); + else + gfc_error_now ("BIND(C) attribute at %L can only be used for " + "variables or common blocks", &gfc_current_locus); + } + + /* Here, we are just checking if it has the bind(c) attribute, and if + so, then we need to make sure it's all correct. If it doesn't, + we still need to continue matching the rest of the subroutine line. */ + is_bind_c = gfc_match_bind_c (sym); + if (is_bind_c == MATCH_ERROR) + { + /* There was an attempt at the bind(c), but it was wrong. An + error message should have been printed w/in the gfc_match_bind_c + so here we'll just return the MATCH_ERROR. */ + return MATCH_ERROR; + } + + if (is_bind_c == MATCH_YES) + { + if (peek_char != '(') + { + gfc_error ("Missing required parentheses before BIND(C) at %C"); + return MATCH_ERROR; + } + if (gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1) + == FAILURE) + return MATCH_ERROR; + } + if (gfc_match_eos () != MATCH_YES) { gfc_syntax_error (ST_SUBROUTINE); @@ -3202,6 +4012,130 @@ gfc_match_subroutine (void) } +/* Match a BIND(C) specifier, with the optional 'name=' specifier if + given, and set the binding label in either the given symbol (if not + NULL), or in the current_ts. The symbol may be NULL becuase we may + encounter the BIND(C) before the declaration itself. Return + MATCH_NO if what we're looking at isn't a BIND(C) specifier, + MATCH_ERROR if it is a BIND(C) clause but an error was encountered, + or MATCH_YES if the specifier was correct and the binding label and + bind(c) fields were set correctly for the given symbol or the + current_ts. */ + +match +gfc_match_bind_c (gfc_symbol *sym) +{ + /* binding label, if exists */ + char binding_label[GFC_MAX_SYMBOL_LEN + 1]; + match double_quote; + match single_quote; + int has_name_equals = 0; + + /* Initialize the flag that specifies whether we encountered a NAME= + specifier or not. */ + has_name_equals = 0; + + /* Init the first char to nil so we can catch if we don't have + the label (name attr) or the symbol name yet. */ + binding_label[0] = '\0'; + + /* This much we have to be able to match, in this order, if + there is a bind(c) label. */ + if (gfc_match (" bind ( c ") != MATCH_YES) + return MATCH_NO; + + /* Now see if there is a binding label, or if we've reached the + end of the bind(c) attribute without one. */ + if (gfc_match_char (',') == MATCH_YES) + { + if (gfc_match (" name = ") != MATCH_YES) + { + gfc_error ("Syntax error in NAME= specifier for binding label " + "at %C"); + /* should give an error message here */ + return MATCH_ERROR; + } + + has_name_equals = 1; + + /* Get the opening quote. */ + double_quote = MATCH_YES; + single_quote = MATCH_YES; + double_quote = gfc_match_char ('"'); + if (double_quote != MATCH_YES) + single_quote = gfc_match_char ('\''); + if (double_quote != MATCH_YES && single_quote != MATCH_YES) + { + gfc_error ("Syntax error in NAME= specifier for binding label " + "at %C"); + return MATCH_ERROR; + } + + /* Grab the binding label, using functions that will not lower + case the names automatically. */ + if (gfc_match_name_C (binding_label) != MATCH_YES) + return MATCH_ERROR; + + /* Get the closing quotation. */ + if (double_quote == MATCH_YES) + { + if (gfc_match_char ('"') != MATCH_YES) + { + gfc_error ("Missing closing quote '\"' for binding label at %C"); + /* User started string with '"' so looked to match it. */ + return MATCH_ERROR; + } + } + else + { + if (gfc_match_char ('\'') != MATCH_YES) + { + gfc_error ("Missing closing quote '\'' for binding label at %C"); + /* User started string with "'" char. */ + return MATCH_ERROR; + } + } + } + + /* Get the required right paren. */ + if (gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Missing closing paren for binding label at %C"); + return MATCH_ERROR; + } + + /* Save the binding label to the symbol. If sym is null, we're + probably matching the typespec attributes of a declaration and + haven't gotten the name yet, and therefore, no symbol yet. */ + if (binding_label[0] != '\0') + { + if (sym != NULL) + { + strncpy (sym->binding_label, binding_label, + strlen (binding_label)+1); + } + else + strncpy (curr_binding_label, binding_label, + strlen (binding_label) + 1); + } + else + { + /* No binding label, but if symbol isn't null, we + can set the label for it here. */ + /* TODO: If the name= was given and no binding label (name=""), we simply + will let fortran mangle the symbol name as it usually would. + However, this could still let C call it if the user looked up the + symbol in the object file. Should the name set during mangling in + trans-decl.c be marked with characters that are invalid for C to + prevent this? */ + if (sym != NULL && sym->name != NULL && has_name_equals == 0) + strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1); + } + + return MATCH_YES; +} + + /* Return nonzero if we're currently compiling a contained procedure. */ static int @@ -4385,24 +5319,16 @@ syntax: } -/* Match the beginning of a derived type declaration. If a type name - was the result of a function, then it is possible to have a symbol - already to be known as a derived type yet have no components. */ +/* Match the optional attribute specifiers for a type declaration. + Return MATCH_ERROR if an error is encountered in one of the handled + attributes (public, private, bind(c)), MATCH_NO if what's found is + not a handled attribute, and MATCH_YES otherwise. TODO: More error + checking on attribute conflicts needs to be done. */ match -gfc_match_derived_decl (void) +gfc_get_type_attr_spec (symbol_attribute *attr) { - char name[GFC_MAX_SYMBOL_LEN + 1]; - symbol_attribute attr; - gfc_symbol *sym; - match m; - - if (gfc_current_state () == COMP_DERIVED) - return MATCH_NO; - - gfc_clear_attr (&attr); - -loop: + /* See if the derived type is marked as private. */ if (gfc_match (" , private") == MATCH_YES) { if (gfc_current_state () != COMP_MODULE) @@ -4412,12 +5338,10 @@ loop: return MATCH_ERROR; } - if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE) + if (gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE) return MATCH_ERROR; - goto loop; } - - if (gfc_match (" , public") == MATCH_YES) + else if (gfc_match (" , public") == MATCH_YES) { if (gfc_current_state () != COMP_MODULE) { @@ -4426,10 +5350,52 @@ loop: return MATCH_ERROR; } - if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE) + if (gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE) return MATCH_ERROR; - goto loop; } + else if(gfc_match(" , bind ( c )") == MATCH_YES) + { + /* If the type is defined to be bind(c) it then needs to make + sure that all fields are interoperable. This will + need to be a semantic check on the finished derived type. + See 15.2.3 (lines 9-12) of F2003 draft. */ + if (gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0) != SUCCESS) + return MATCH_ERROR; + + /* TODO: attr conflicts need to be checked, probably in symbol.c. */ + } + else + return MATCH_NO; + + /* If we get here, something matched. */ + return MATCH_YES; +} + + +/* Match the beginning of a derived type declaration. If a type name + was the result of a function, then it is possible to have a symbol + already to be known as a derived type yet have no components. */ + +match +gfc_match_derived_decl (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + symbol_attribute attr; + gfc_symbol *sym; + match m; + match is_type_attr_spec = MATCH_NO; + + if (gfc_current_state () == COMP_DERIVED) + return MATCH_NO; + + gfc_clear_attr (&attr); + + do + { + is_type_attr_spec = gfc_get_type_attr_spec (&attr); + if (is_type_attr_spec == MATCH_ERROR) + return MATCH_ERROR; + } while (is_type_attr_spec == MATCH_YES); if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN) { @@ -4488,6 +5454,10 @@ loop: && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE) return MATCH_ERROR; + /* See if the derived type was labeled as bind(c). */ + if (attr.is_bind_c != 0) + sym->attr.is_bind_c = attr.is_bind_c; + gfc_new_block = sym; return MATCH_YES; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index d3f0ddf5cce..0ca7dbfcae2 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -449,19 +449,32 @@ gfc_copy_expr (gfc_expr *p) s = gfc_getmem (p->value.character.length + 1); q->value.character.string = s; - memcpy (s, p->value.character.string, p->value.character.length + 1); + /* This is the case for the C_NULL_CHAR named constant. */ + if (p->value.character.length == 0 + && (p->ts.is_c_interop || p->ts.is_iso_c)) + { + *s = '\0'; + /* Need to set the length to 1 to make sure the NUL + terminator is copied. */ + q->value.character.length = 1; + } + else + memcpy (s, p->value.character.string, + p->value.character.length + 1); } break; case BT_HOLLERITH: case BT_LOGICAL: case BT_DERIVED: - break; /* Already done */ + break; /* Already done. */ case BT_PROCEDURE: + case BT_VOID: + /* Should never be reached. */ case BT_UNKNOWN: gfc_internal_error ("gfc_copy_expr(): Bad expr node"); - /* Not reached */ + /* Not reached. */ } break; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 9a653ce29ac..8419118e2fe 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -56,6 +56,8 @@ char *alloca (); /* Major control parameters. */ #define GFC_MAX_SYMBOL_LEN 63 /* Must be at least 63 for F2003. */ +#define GFC_MAX_BINDING_LABEL_LEN 126 /* (2 * GFC_MAX_SYMBOL_LEN) */ +#define GFC_MAX_LINE 132 /* Characters beyond this are not seen. */ #define GFC_MAX_DIMENSIONS 7 /* Maximum dimensions in an array. */ #define GFC_LETTERS 26 /* Number of letters in the alphabet. */ @@ -155,9 +157,12 @@ typedef enum { FORM_FREE, FORM_FIXED, FORM_UNKNOWN } gfc_source_form; +/* Basic types. BT_VOID is used by ISO C BInding so funcs like c_f_pointer + can take any arg with the pointer attribute as a param. */ typedef enum { BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX, - BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE, BT_HOLLERITH + BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE, BT_HOLLERITH, + BT_VOID } bt; @@ -261,7 +266,8 @@ interface_type; typedef enum sym_flavor { FL_UNKNOWN = 0, FL_PROGRAM, FL_BLOCK_DATA, FL_MODULE, FL_VARIABLE, - FL_PARAMETER, FL_LABEL, FL_PROCEDURE, FL_DERIVED, FL_NAMELIST + FL_PARAMETER, FL_LABEL, FL_PROCEDURE, FL_DERIVED, FL_NAMELIST, + FL_VOID } sym_flavor; @@ -553,6 +559,62 @@ ioerror_codes; /* Used for keeping things in balanced binary trees. */ #define BBT_HEADER(self) int priority; struct self *left, *right +#define NAMED_INTCST(a,b,c) a, +typedef enum +{ + ISOFORTRANENV_INVALID = -1, +#include "iso-fortran-env.def" + ISOFORTRANENV_LAST, ISOFORTRANENV_NUMBER = ISOFORTRANENV_LAST +} +iso_fortran_env_symbol; +#undef NAMED_INTCST + +#define NAMED_INTCST(a,b,c) a, +#define NAMED_REALCST(a,b,c) a, +#define NAMED_CMPXCST(a,b,c) a, +#define NAMED_LOGCST(a,b,c) a, +#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, +typedef enum +{ + ISOCBINDING_INVALID = -1, +#include "iso-c-binding.def" + ISOCBINDING_LAST, + ISOCBINDING_NUMBER = ISOCBINDING_LAST +} +iso_c_binding_symbol; +#undef NAMED_INTCST +#undef NAMED_REALCST +#undef NAMED_CMPXCST +#undef NAMED_LOGCST +#undef NAMED_CHARKNDCST +#undef NAMED_CHARCST +#undef DERIVED_TYPE +#undef PROCEDURE + +typedef enum +{ + INTMOD_NONE = 0, INTMOD_ISO_FORTRAN_ENV, INTMOD_ISO_C_BINDING +} +intmod_id; + +typedef struct +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + int value; /* Used for both integer and character values. */ + bt f90_type; +} +CInteropKind_t; + +/* Array of structs, where the structs represent the C interop kinds. + The list will be implemented based on a hash of the kind name since + these could be accessed multiple times. + Declared in trans-types.c as a global, since it's in that file + that the list is initialized. */ +extern CInteropKind_t c_interop_kinds_table[]; + /* Symbol attribute structure. */ typedef struct { @@ -572,6 +634,14 @@ typedef struct unsigned implicit_type:1; /* Type defined via implicit rules. */ unsigned untyped:1; /* No implicit type could be found. */ + unsigned is_bind_c:1; /* say if is bound to C */ + + /* These flags are both in the typespec and attribute. The attribute + list is what gets read from/written to a module file. The typespec + is created from a decl being processed. */ + unsigned is_c_interop:1; /* It's c interoperable. */ + unsigned is_iso_c:1; /* Symbol is from iso_c_binding. */ + /* Function/subroutine attributes */ unsigned sequence:1, elemental:1, pure:1, recursive:1; unsigned unmaskable:1, masked:1, contained:1, mod_proc:1; @@ -714,6 +784,9 @@ typedef struct int kind; struct gfc_symbol *derived; gfc_charlen *cl; /* For character types only. */ + int is_c_interop; + int is_iso_c; + bt f90_type; } gfc_typespec; @@ -964,18 +1037,33 @@ typedef struct gfc_symbol struct gfc_namespace *ns; /* namespace containing this symbol */ tree backend_decl; + + /* Identity of the intrinsic module the symbol comes from, or + INTMOD_NONE if it's not imported from a intrinsic module. */ + intmod_id from_intmod; + /* Identity of the symbol from intrinsic modules, from enums maintained + separately by each intrinsic module. Used together with from_intmod, + it uniquely identifies a symbol from an intrinsic module. */ + int intmod_sym_id; + + /* This may be repetitive, since the typespec now has a binding + label field. */ + char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1]; + /* Store a reference to the common_block, if this symbol is in one. */ + struct gfc_common_head *common_block; } gfc_symbol; /* This structure is used to keep track of symbols in common blocks. */ - typedef struct gfc_common_head { locus where; char use_assoc, saved, threadprivate; char name[GFC_MAX_SYMBOL_LEN + 1]; struct gfc_symbol *head; + char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1]; + int is_bind_c; } gfc_common_head; @@ -1115,6 +1203,9 @@ typedef struct gfc_gsymbol BBT_HEADER(gfc_gsymbol); const char *name; + const char *sym_name; + const char *mod_name; + const char *binding_label; enum { GSYM_UNKNOWN=1, GSYM_PROGRAM, GSYM_FUNCTION, GSYM_SUBROUTINE, GSYM_MODULE, GSYM_COMMON, GSYM_BLOCK_DATA } type; @@ -1865,6 +1956,8 @@ void gfc_init_2 (void); void gfc_done_1 (void); void gfc_done_2 (void); +int get_c_kind (const char *, CInteropKind_t *); + /* options.c */ unsigned int gfc_init_options (unsigned int, const char **); int gfc_handle_option (size_t, const char *, int); @@ -1921,6 +2014,8 @@ gfc_expr *gfc_enum_initializer (gfc_expr *, locus); arith gfc_check_integer_range (mpz_t p, int kind); /* trans-types.c */ +try gfc_validate_c_kind (gfc_typespec *); +try gfc_check_any_c_kind (gfc_typespec *); int gfc_validate_kind (bt, int, bool); extern int gfc_index_integer_kind; extern int gfc_default_integer_kind; @@ -1980,10 +2075,11 @@ try gfc_add_pure (symbol_attribute *, locus *); try gfc_add_recursive (symbol_attribute *, locus *); try gfc_add_function (symbol_attribute *, const char *, locus *); try gfc_add_subroutine (symbol_attribute *, const char *, locus *); -try gfc_add_value (symbol_attribute *, const char *, locus *); try gfc_add_volatile (symbol_attribute *, const char *, locus *); try gfc_add_access (symbol_attribute *, gfc_access, const char *, locus *); +try gfc_add_is_bind_c(symbol_attribute *, const char *, locus *, int); +try gfc_add_value (symbol_attribute *, const char *, locus *); try gfc_add_flavor (symbol_attribute *, sym_flavor, const char *, locus *); try gfc_add_entry (symbol_attribute *, const char *, locus *); try gfc_add_procedure (symbol_attribute *, procedure_type, @@ -2017,6 +2113,13 @@ gfc_symbol *gfc_new_symbol (const char *, gfc_namespace *); int gfc_find_symbol (const char *, gfc_namespace *, int, gfc_symbol **); int gfc_find_sym_tree (const char *, gfc_namespace *, int, gfc_symtree **); int gfc_get_symbol (const char *, gfc_namespace *, gfc_symbol **); +try verify_c_interop (gfc_typespec *, const char *name, locus *where); +try verify_c_interop_param (gfc_symbol *); +try verify_bind_c_sym (gfc_symbol *, gfc_typespec *, int, gfc_common_head *); +try verify_bind_c_derived_type (gfc_symbol *); +try verify_com_block_vars_c_interop (gfc_common_head *); +void generate_isocbinding_symbol (const char *, iso_c_binding_symbol, char *); +gfc_symbol *get_iso_c_sym (gfc_symbol *, char *, char *, int); int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **); int gfc_get_ha_symbol (const char *, gfc_symbol **); int gfc_get_ha_sym_tree (const char *, gfc_symtree **); @@ -2143,6 +2246,8 @@ try gfc_resolve_iterator (gfc_iterator *, bool); try gfc_resolve_index (gfc_expr *, int); try gfc_resolve_dim_arg (gfc_expr *); int gfc_is_formal_arg (void); +match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *); + /* array.c */ void gfc_free_array_spec (gfc_array_spec *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index da8696b81da..69ab3269d87 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -334,8 +334,8 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) /* Special case for comparing derived types across namespaces. If the true names and module names are the same and the module name is nonnull, then they are equal. */ - if (strcmp (derived1->name, derived2->name) == 0 - && derived1 != NULL && derived2 != NULL + if (derived1 != NULL && derived2 != NULL + && strcmp (derived1->name, derived2->name) == 0 && derived1->module != NULL && derived2->module != NULL && strcmp (derived1->module, derived2->module) == 0) return 1; @@ -400,6 +400,13 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) int gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) { + /* See if one of the typespecs is a BT_VOID, which is what is being used + to allow the funcs like c_f_pointer to accept any pointer type. + TODO: Possibly should narrow this to just the one typespec coming in + that is for the formal arg, but oh well. */ + if (ts1->type == BT_VOID || ts2->type == BT_VOID) + return 1; + if (ts1->type != ts2->type) return 0; if (ts1->type != BT_DERIVED) @@ -1184,6 +1191,18 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, { gfc_ref *ref; + /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding + procs c_f_pointer or c_f_procpointer, and we need to accept most + pointers the user could give us. This should allow that. */ + if (formal->ts.type == BT_VOID) + return 1; + + if (formal->ts.type == BT_DERIVED + && formal->ts.derived && formal->ts.derived->ts.is_iso_c + && actual->ts.type == BT_DERIVED + && actual->ts.derived && actual->ts.derived->ts.is_iso_c) + return 1; + if (actual->ts.type == BT_PROCEDURE) { if (formal->attr.flavor != FL_PROCEDURE) diff --git a/gcc/fortran/iso-c-binding.def b/gcc/fortran/iso-c-binding.def new file mode 100644 index 00000000000..664c43a398c --- /dev/null +++ b/gcc/fortran/iso-c-binding.def @@ -0,0 +1,158 @@ +/* Copyright (C) 2006 Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 2, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING. If not, write to the Free +Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. */ + +/* This file contains the definition of the types provided by the + Fortran 2003 ISO_C_BINDING intrinsic module. */ + +#ifndef NAMED_INTCST +# define NAMED_INTCST(a,b,c) +#endif + +#ifndef NAMED_REALCST +# define NAMED_REALCST(a,b,c) +#endif + +#ifndef NAMED_CMPXCST +# define NAMED_CMPXCST(a,b,c) +#endif + +#ifndef NAMED_LOGCST +# define NAMED_LOGCST(a,b,c) +#endif + +#ifndef NAMED_CHARKNDCST +# define NAMED_CHARKNDCST(a,b,c) +#endif + +/* The arguments to NAMED_*CST are: + -- an internal name + -- the symbol name in the module, as seen by Fortran code + -- the value it has, for use in trans-types.c */ + +NAMED_INTCST (ISOCBINDING_INT, "c_int", gfc_c_int_kind) +NAMED_INTCST (ISOCBINDING_SHORT, "c_short", \ + get_int_kind_from_node (short_integer_type_node)) +NAMED_INTCST (ISOCBINDING_LONG, "c_long", \ + get_int_kind_from_node (long_integer_type_node)) +NAMED_INTCST (ISOCBINDING_LONG_LONG, "c_long_long", \ + get_int_kind_from_node (long_long_integer_type_node)) + +NAMED_INTCST (ISOCBINDING_INTMAX_T, "c_intmax_t", \ + get_int_kind_from_node (intmax_type_node)) +NAMED_INTCST (ISOCBINDING_INTPTR_T, "c_intptr_t", \ + get_int_kind_from_node (ptr_type_node)) +NAMED_INTCST (ISOCBINDING_SIZE_T, "c_size_t", \ + gfc_index_integer_kind) +NAMED_INTCST (ISOCBINDING_SIGNED_CHAR, "c_signed_char", \ + get_int_kind_from_node (signed_char_type_node)) + +NAMED_INTCST (ISOCBINDING_INT8_T, "c_int8_t", get_int_kind_from_width (8)) +NAMED_INTCST (ISOCBINDING_INT16_T, "c_int16_t", get_int_kind_from_width (16)) +NAMED_INTCST (ISOCBINDING_INT32_T, "c_int32_t", get_int_kind_from_width (32)) +NAMED_INTCST (ISOCBINDING_INT64_T, "c_int64_t", get_int_kind_from_width (64)) + +NAMED_INTCST (ISOCBINDING_INT_LEAST8_T, "c_int_least8_t", \ + get_int_kind_from_minimal_width (8)) +NAMED_INTCST (ISOCBINDING_INT_LEAST16_T, "c_int_least16_t", \ + get_int_kind_from_minimal_width (16)) +NAMED_INTCST (ISOCBINDING_INT_LEAST32_T, "c_int_least32_t", \ + get_int_kind_from_minimal_width (32)) +NAMED_INTCST (ISOCBINDING_INT_LEAST64_T, "c_int_least64_t", \ + get_int_kind_from_minimal_width (64)) + +/* TODO: Implement c_int_fast*_t. Depends on PR 448. */ +NAMED_INTCST (ISOCBINDING_INT_FAST8_T, "c_int_fast8_t", -2) +NAMED_INTCST (ISOCBINDING_INT_FAST16_T, "c_int_fast16_t", -2) +NAMED_INTCST (ISOCBINDING_INT_FAST32_T, "c_int_fast32_t", -2) +NAMED_INTCST (ISOCBINDING_INT_FAST64_T, "c_int_fast64_t", -2) + +NAMED_REALCST (ISOCBINDING_FLOAT, "c_float", \ + get_real_kind_from_node (float_type_node)) +NAMED_REALCST (ISOCBINDING_DOUBLE, "c_double", \ + get_real_kind_from_node (double_type_node)) +NAMED_REALCST (ISOCBINDING_LONG_DOUBLE, "c_long_double", \ + get_real_kind_from_node (long_double_type_node)) +NAMED_CMPXCST (ISOCBINDING_FLOAT_COMPLEX, "c_float_complex", \ + get_real_kind_from_node (float_type_node)) +NAMED_CMPXCST (ISOCBINDING_DOUBLE_COMPLEX, "c_double_complex", \ + get_real_kind_from_node (double_type_node)) +NAMED_CMPXCST (ISOCBINDING_LONG_DOUBLE_COMPLEX, "c_long_double_complex", \ + get_real_kind_from_node (long_double_type_node)) + +NAMED_LOGCST (ISOCBINDING_BOOL, "c_bool", \ + get_int_kind_from_width (BOOL_TYPE_SIZE)) + +NAMED_CHARKNDCST (ISOCBINDING_CHAR, "c_char", gfc_default_character_kind) + +#ifndef NAMED_CHARCST +# define NAMED_CHARCST(a,b,c) +#endif + +/* Use langhooks to deal with host to target translations. */ +NAMED_CHARCST (ISOCBINDING_NULL_CHAR, "c_null_char", \ + lang_hooks.to_target_charset ('\0')) +NAMED_CHARCST (ISOCBINDING_ALERT, "c_alert", \ + lang_hooks.to_target_charset ('\a')) +NAMED_CHARCST (ISOCBINDING_BACKSPACE, "c_backspace", \ + lang_hooks.to_target_charset ('\b')) +NAMED_CHARCST (ISOCBINDING_FORM_FEED, "c_form_feed", \ + lang_hooks.to_target_charset ('\f')) +NAMED_CHARCST (ISOCBINDING_NEW_LINE, "c_new_line", \ + lang_hooks.to_target_charset ('\n')) +NAMED_CHARCST (ISOCBINDING_CARRIAGE_RETURN, "c_carriage_return", \ + lang_hooks.to_target_charset ('\r')) +NAMED_CHARCST (ISOCBINDING_HORIZONTAL_TAB, "c_horizontal_tab", \ + lang_hooks.to_target_charset ('\t')) +NAMED_CHARCST (ISOCBINDING_VERTICAL_TAB, "c_vertical_tab", \ + lang_hooks.to_target_charset ('\v')) + +#ifndef DERIVED_TYPE +# define DERIVED_TYPE(a,b,c) +#endif + +DERIVED_TYPE (ISOCBINDING_PTR, "c_ptr", \ + get_int_kind_from_node (ptr_type_node)) +DERIVED_TYPE (ISOCBINDING_NULL_PTR, "c_null_ptr", \ + get_int_kind_from_node (ptr_type_node)) +DERIVED_TYPE (ISOCBINDING_FUNPTR, "c_funptr", \ + get_int_kind_from_node (ptr_type_node)) +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") + +/* Insert c_f_procpointer, though unsupported for now. */ +PROCEDURE (ISOCBINDING_F_PROCPOINTER, "c_f_procpointer") + +#undef NAMED_INTCST +#undef NAMED_REALCST +#undef NAMED_CMPXCST +#undef NAMED_LOGCST +#undef NAMED_CHARCST +#undef NAMED_CHARKNDCST +#undef DERIVED_TYPE +#undef PROCEDURE diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index ee376f5640e..8db0b63b249 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -270,6 +270,38 @@ gfc_match_small_int (int *value) } +/* This function is the same as the gfc_match_small_int, except that + we're keeping the pointer to the expr. This function could just be + removed and the previously mentioned one modified, though all calls + to it would have to be modified then (and there were a number of + them). Return MATCH_ERROR if fail to extract the int; otherwise, + return the result of gfc_match_expr(). The expr (if any) that was + matched is returned in the parameter expr. */ + +match +gfc_match_small_int_expr (int *value, gfc_expr **expr) +{ + const char *p; + match m; + int i; + + m = gfc_match_expr (expr); + if (m != MATCH_YES) + return m; + + p = gfc_extract_int (*expr, &i); + + if (p != NULL) + { + gfc_error (p); + m = MATCH_ERROR; + } + + *value = i; + return m; +} + + /* Matches a statement label. Uses gfc_match_small_literal_int() to do most of the work. */ @@ -476,6 +508,99 @@ gfc_match_name (char *buffer) } +/* Match a valid name for C, which is almost the same as for Fortran, + except that you can start with an underscore, etc.. It could have + been done by modifying the gfc_match_name, but this way other + things C allows can be added, such as no limits on the length. + Right now, the length is limited to the same thing as Fortran.. + Also, by rewriting it, we use the gfc_next_char_C() to prevent the + input characters from being automatically lower cased, since C is + case sensitive. The parameter, buffer, is used to return the name + that is matched. Return MATCH_ERROR if the name is too long + (though this is a self-imposed limit), MATCH_NO if what we're + seeing isn't a name, and MATCH_YES if we successfully match a C + name. */ + +match +gfc_match_name_C (char *buffer) +{ + locus old_loc; + int i = 0; + int c; + + old_loc = gfc_current_locus; + gfc_gobble_whitespace (); + + /* Get the next char (first possible char of name) and see if + it's valid for C (either a letter or an underscore). */ + c = gfc_next_char_literal (1); + + /* If the user put nothing expect spaces between the quotes, it is valid + and simply means there is no name= specifier and the name is the fortran + symbol name, all lowercase. */ + if (c == '"' || c == '\'') + { + buffer[0] = '\0'; + gfc_current_locus = old_loc; + return MATCH_YES; + } + + if (!ISALPHA (c) && c != '_') + { + gfc_error ("Invalid C name in NAME= specifier at %C"); + return MATCH_ERROR; + } + + /* Continue to read valid variable name characters. */ + do + { + buffer[i++] = c; + + /* C does not define a maximum length of variable names, to my + knowledge, but the compiler typically places a limit on them. + For now, i'll use the same as the fortran limit for simplicity, + but this may need to be changed to a dynamic buffer that can + be realloc'ed here if necessary, or more likely, a larger + upper-bound set. */ + if (i > gfc_option.max_identifier_length) + { + gfc_error ("Name at %C is too long"); + return MATCH_ERROR; + } + + old_loc = gfc_current_locus; + + /* Get next char; param means we're in a string. */ + c = gfc_next_char_literal (1); + } while (ISALNUM (c) || c == '_'); + + buffer[i] = '\0'; + gfc_current_locus = old_loc; + + /* See if we stopped because of whitespace. */ + if (c == ' ') + { + gfc_gobble_whitespace (); + c = gfc_peek_char (); + if (c != '"' && c != '\'') + { + gfc_error ("Embedded space in NAME= specifier at %C"); + return MATCH_ERROR; + } + } + + /* If we stopped because we had an invalid character for a C name, report + that to the user by returning MATCH_NO. */ + if (c != '"' && c != '\'') + { + gfc_error ("Invalid C name in NAME= specifier at %C"); + return MATCH_ERROR; + } + + return MATCH_YES; +} + + /* Match a symbol on the input. Modifies the pointer to the symbol pointer if successful. */ @@ -2306,8 +2431,7 @@ gfc_get_common (const char *name, int from_module) /* Match a common block name. */ -static match -match_common_name (char *name) +match match_common_name (char *name) { match m; @@ -2415,6 +2539,35 @@ gfc_match_common (void) if (m == MATCH_NO) goto syntax; + /* Store a ref to the common block for error checking. */ + sym->common_block = t; + + /* See if we know the current common block is bind(c), and if + so, then see if we can check if the symbol is (which it'll + need to be). This can happen if the bind(c) attr stmt was + applied to the common block, and the variable(s) already + defined, before declaring the common block. */ + if (t->is_bind_c == 1) + { + if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1) + { + /* If we find an error, just print it and continue, + cause it's just semantic, and we can see if there + are more errors. */ + gfc_error_now ("Variable '%s' at %L in common block '%s' " + "at %C must be declared with a C " + "interoperable kind since common block " + "'%s' is bind(c)", + sym->name, &(sym->declared_at), t->name, + t->name); + } + + if (sym->attr.is_bind_c == 1) + gfc_error_now ("Variable '%s' in common block " + "'%s' at %C can not be bind(c) since " + "it is not global", sym->name, t->name); + } + if (sym->attr.in_common) { gfc_error ("Symbol '%s' at %C is already in a COMMON block", diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 8a309c5f2dd..8bcc5b14b92 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -46,8 +46,10 @@ match gfc_match_small_literal_int (int *, int *); match gfc_match_st_label (gfc_st_label **); match gfc_match_label (void); match gfc_match_small_int (int *); +match gfc_match_small_int_expr (int *, gfc_expr **); int gfc_match_strings (mstring *); match gfc_match_name (char *); +match gfc_match_name_C (char *buffer); match gfc_match_symbol (gfc_symbol **, int); match gfc_match_sym_tree (gfc_symtree **, int); match gfc_match_intrinsic_op (gfc_intrinsic_op *); @@ -76,6 +78,15 @@ match gfc_match_nullify (void); match gfc_match_deallocate (void); match gfc_match_return (void); match gfc_match_call (void); + +/* We want to use this function to check for a common-block-name + that can exist in a bind statement, so removed the "static" + declaration of the function in match.c. + + TODO: should probably rename this now that it'll be globally seen to + gfc_match_common_name. */ +match match_common_name (char *name); + match gfc_match_common (void); match gfc_match_block_data (void); match gfc_match_namelist (void); @@ -153,7 +164,21 @@ match gfc_match_target (void); match gfc_match_value (void); match gfc_match_volatile (void); -/* primary.c */ +/* decl.c. */ + +/* Fortran 2003 c interop. + TODO: some of these should be moved to another file rather than decl.c */ +void set_com_block_bind_c (gfc_common_head *, int); +try set_binding_label (char *, const char *, int); +try set_verify_bind_c_sym (gfc_symbol *, int); +try set_verify_bind_c_com_block (gfc_common_head *, int); +try get_bind_c_idents (void); +match gfc_match_bind_c_stmt (void); +match gfc_match_suffix (gfc_symbol *, gfc_symbol **); +match gfc_match_bind_c (gfc_symbol *); +match gfc_get_type_attr_spec (symbol_attribute *); + +/* primary.c. */ match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **); match gfc_match_variable (gfc_expr **, int); match gfc_match_equiv_variable (gfc_expr **); diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c index f1fdbf52e3d..bf0eca88664 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -78,6 +78,12 @@ gfc_clear_ts (gfc_typespec *ts) ts->kind = 0; ts->derived = NULL; ts->cl = NULL; + /* flag that says if the type is C interoperable */ + ts->is_c_interop = 0; + /* says what f90 type the C kind interops with */ + ts->f90_type = BT_UNKNOWN; + /* flag that says whether it's from iso_c_binding or not */ + ts->is_iso_c = 0; } @@ -285,3 +291,18 @@ gfc_done_2 (void) gfc_module_done_2 (); } + +/* Returns the index into the table of C interoperable kinds where the + kind with the given name (c_kind_name) was found. */ + +int +get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[]) +{ + int index = 0; + + for (index = 0; index < ISOCBINDING_LAST; index++) + if (strcmp (kinds_table[index].name, c_kind_name) == 0) + return index; + + return ISOCBINDING_INVALID; +} diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 14d26d9e432..665f6a11088 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -86,6 +86,15 @@ typedef struct } module_locus; +/* Structure for list of symbols of intrinsic modules. */ +typedef struct +{ + int id; + const char *name; + int value; +} +intmod_sym; + typedef enum { @@ -132,6 +141,7 @@ typedef struct pointer_info module_locus where; fixup_t *stfixup; gfc_symtree *symtree; + char binding_label[GFC_MAX_SYMBOL_LEN + 1]; } rsym; @@ -1333,6 +1343,9 @@ write_atom (atom_type atom, const void *v) } + if(p == NULL || *p == '\0') + len = 0; + else len = strlen (p); if (atom != ATOM_RPAREN) @@ -1350,7 +1363,7 @@ write_atom (atom_type atom, const void *v) if (atom == ATOM_STRING) write_char ('\''); - while (*p) + while (p != NULL && *p) { if (atom == ATOM_STRING && *p == '\'') write_char ('\''); @@ -1503,7 +1516,8 @@ typedef enum AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP, - AB_VALUE, AB_VOLATILE, AB_PROTECTED + AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_IS_BIND_C, AB_IS_C_INTEROP, + AB_IS_ISO_C } ab_attribute; @@ -1516,7 +1530,6 @@ static const mstring attr_bits[] = minit ("OPTIONAL", AB_OPTIONAL), minit ("POINTER", AB_POINTER), minit ("SAVE", AB_SAVE), - minit ("VALUE", AB_VALUE), minit ("VOLATILE", AB_VOLATILE), minit ("TARGET", AB_TARGET), minit ("THREADPRIVATE", AB_THREADPRIVATE), @@ -1535,11 +1548,16 @@ static const mstring attr_bits[] = minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT), minit ("CRAY_POINTER", AB_CRAY_POINTER), minit ("CRAY_POINTEE", AB_CRAY_POINTEE), + minit ("IS_BIND_C", AB_IS_BIND_C), + minit ("IS_C_INTEROP", AB_IS_C_INTEROP), + minit ("IS_ISO_C", AB_IS_ISO_C), + minit ("VALUE", AB_VALUE), minit ("ALLOC_COMP", AB_ALLOC_COMP), minit ("PROTECTED", AB_PROTECTED), minit (NULL, -1) }; + /* Specialization of mio_name. */ DECL_MIO_NAME (ab_attribute) DECL_MIO_NAME (ar_type) @@ -1633,6 +1651,12 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits); if (attr->cray_pointee) MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits); + if (attr->is_bind_c) + MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits); + if (attr->is_c_interop) + MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits); + if (attr->is_iso_c) + MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits); if (attr->alloc_comp) MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits); @@ -1732,6 +1756,15 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_CRAY_POINTEE: attr->cray_pointee = 1; break; + case AB_IS_BIND_C: + attr->is_bind_c = 1; + break; + case AB_IS_C_INTEROP: + attr->is_c_interop = 1; + break; + case AB_IS_ISO_C: + attr->is_iso_c = 1; + break; case AB_ALLOC_COMP: attr->alloc_comp = 1; break; @@ -1750,6 +1783,7 @@ static const mstring bt_types[] = { minit ("DERIVED", BT_DERIVED), minit ("PROCEDURE", BT_PROCEDURE), minit ("UNKNOWN", BT_UNKNOWN), + minit ("VOID", BT_VOID), minit (NULL, -1) }; @@ -1820,6 +1854,18 @@ mio_typespec (gfc_typespec *ts) else mio_symbol_ref (&ts->derived); + /* Add info for C interop and is_iso_c. */ + mio_integer (&ts->is_c_interop); + mio_integer (&ts->is_iso_c); + + /* If the typespec is for an identifier either from iso_c_binding, or + a constant that was initialized to an identifier from it, use the + f90_type. Otherwise, use the ts->type, since it shouldn't matter. */ + if (ts->is_iso_c) + ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types); + else + ts->f90_type = MIO_NAME (bt) (ts->type, bt_types); + if (ts->type != BT_CHARACTER) { /* ts->cl is only valid for BT_CHARACTER. */ @@ -2951,6 +2997,8 @@ mio_namespace_ref (gfc_namespace **nsp) static void mio_symbol (gfc_symbol *sym) { + int intmod = INTMOD_NONE; + gfc_formal_arglist *formal; mio_lparen (); @@ -3006,6 +3054,23 @@ mio_symbol (gfc_symbol *sym) = MIO_NAME (gfc_access) (sym->component_access, access_types); mio_namelist (sym); + + /* Add the fields that say whether this is from an intrinsic module, + and if so, what symbol it is within the module. */ +/* mio_integer (&(sym->from_intmod)); */ + if (iomode == IO_OUTPUT) + { + intmod = sym->from_intmod; + mio_integer (&intmod); + } + else + { + mio_integer (&intmod); + sym->from_intmod = intmod; + } + + mio_integer (&(sym->intmod_sym_id)); + mio_rparen (); } @@ -3179,6 +3244,11 @@ load_commons (void) p->threadprivate = 1; p->use_assoc = 1; + /* Get whether this was a bind(c) common or not. */ + mio_integer (&p->is_bind_c); + /* Get the binding label. */ + mio_internal_string (p->binding_label); + mio_rparen (); } @@ -3415,7 +3485,9 @@ read_module (void) mio_internal_string (info->u.rsym.true_name); mio_internal_string (info->u.rsym.module); + mio_internal_string (info->u.rsym.binding_label); + require_atom (ATOM_INTEGER); info->u.rsym.ns = atom_int; @@ -3525,6 +3597,11 @@ read_module (void) gfc_current_ns); sym = info->u.rsym.sym; sym->module = gfc_get_string (info->u.rsym.module); + + /* TODO: hmm, can we test this? Do we know it will be + initialized to zeros? */ + if (info->u.rsym.binding_label[0] != '\0') + strcpy (sym->binding_label, info->u.rsym.binding_label); } st->n.sym = sym; @@ -3648,7 +3725,8 @@ write_common (gfc_symtree *st) gfc_common_head *p; const char * name; int flags; - + const char *label; + if (st == NULL) return; @@ -3668,16 +3746,35 @@ write_common (gfc_symtree *st) if (p->threadprivate) flags |= 2; mio_integer (&flags); + /* Write out whether the common block is bind(c) or not. */ + mio_integer (&(p->is_bind_c)); + + /* Write out the binding label, or the com name if no label given. */ + if (p->is_bind_c) + { + label = p->binding_label; + mio_pool_string (&label); + } + else + { + label = p->name; + mio_pool_string (&label); + } + mio_rparen (); } -/* Write the blank common block to the module */ + +/* Write the blank common block to the module. */ static void write_blank_common (void) { const char * name = BLANK_COMMON_NAME; int saved; + /* TODO: Blank commons are not bind(c). The F2003 standard probably says + this, but it hasn't been checked. Just making it so for now. */ + int is_bind_c = 0; if (gfc_current_ns->blank_common.head == NULL) return; @@ -3690,6 +3787,13 @@ write_blank_common (void) saved = gfc_current_ns->blank_common.saved; mio_integer (&saved); + /* Write out whether the common block is bind(c) or not. */ + mio_integer (&is_bind_c); + + /* Write out the binding label, which is BLANK_COMMON_NAME, though + it doesn't matter because the label isn't used. */ + mio_pool_string (&name); + mio_rparen (); } @@ -3726,6 +3830,7 @@ write_equiv (void) static void write_symbol (int n, gfc_symbol *sym) { + const char *label; if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL) gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name); @@ -3734,6 +3839,14 @@ write_symbol (int n, gfc_symbol *sym) mio_pool_string (&sym->name); mio_pool_string (&sym->module); + if (sym->attr.is_bind_c || sym->attr.is_iso_c) + { + label = sym->binding_label; + mio_pool_string (&label); + } + else + mio_pool_string (&sym->name); + mio_pointer_ref (&sym->ns); mio_symbol (sym); @@ -3777,8 +3890,6 @@ write_symbol0 (gfc_symtree *st) write_symbol (p->integer, sym); p->u.wsym.state = WRITTEN; - - return; } @@ -4080,9 +4191,145 @@ gfc_dump_module (const char *name, int dump_flag) } +static void +sort_iso_c_rename_list (void) +{ + gfc_use_rename *tmp_list = NULL; + gfc_use_rename *curr; + gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL}; + int c_kind; + int i; + + for (curr = gfc_rename_list; curr; curr = curr->next) + { + c_kind = get_c_kind (curr->use_name, c_interop_kinds_table); + if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST) + { + gfc_error ("Symbol '%s' referenced at %L does not exist in " + "intrinsic module ISO_C_BINDING.", curr->use_name, + &curr->where); + } + else + /* Put it in the list. */ + kinds_used[c_kind] = curr; + } + + /* Make a new (sorted) rename list. */ + i = 0; + while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL) + i++; + + if (i < ISOCBINDING_NUMBER) + { + tmp_list = kinds_used[i]; + + i++; + curr = tmp_list; + for (; i < ISOCBINDING_NUMBER; i++) + if (kinds_used[i] != NULL) + { + curr->next = kinds_used[i]; + curr = curr->next; + curr->next = NULL; + } + } + + gfc_rename_list = tmp_list; +} + + +/* Import the instrinsic ISO_C_BINDING module, generating symbols in + the current namespace for all named constants, pointer types, and + procedures in the module unless the only clause was used or a rename + list was provided. */ + +static void +import_iso_c_binding_module (void) +{ + gfc_symbol *mod_sym = NULL; + gfc_symtree *mod_symtree = NULL; + const char *iso_c_module_name = "__iso_c_binding"; + gfc_use_rename *u; + int i; + char *local_name; + + /* Look only in the current namespace. */ + mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name); + + if (mod_symtree == NULL) + { + /* symtree doesn't already exist in current namespace. */ + gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree); + + if (mod_symtree != NULL) + mod_sym = mod_symtree->n.sym; + else + gfc_internal_error ("import_iso_c_binding_module(): Unable to " + "create symbol for %s", iso_c_module_name); + + mod_sym->attr.flavor = FL_MODULE; + mod_sym->attr.intrinsic = 1; + mod_sym->module = gfc_get_string (iso_c_module_name); + mod_sym->from_intmod = INTMOD_ISO_C_BINDING; + } + + /* Generate the symbols for the named constants representing + the kinds for intrinsic data types. */ + if (only_flag) + { + /* Sort the rename list because there are dependencies between types + and procedures (e.g., c_loc needs c_ptr). */ + sort_iso_c_rename_list (); + + for (u = gfc_rename_list; u; u = u->next) + { + i = get_c_kind (u->use_name, c_interop_kinds_table); + + if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST) + { + gfc_error ("Symbol '%s' referenced at %L does not exist in " + "intrinsic module ISO_C_BINDING.", u->use_name, + &u->where); + continue; + } + + generate_isocbinding_symbol (iso_c_module_name, i, u->local_name); + } + } + else + { + for (i = 0; i < ISOCBINDING_NUMBER; i++) + { + local_name = NULL; + for (u = gfc_rename_list; u; u = u->next) + { + if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0) + { + local_name = u->local_name; + u->found = 1; + break; + } + } + generate_isocbinding_symbol (iso_c_module_name, i, local_name); + } + + for (u = gfc_rename_list; u; u = u->next) + { + if (u->found) + continue; + + gfc_error ("Symbol '%s' referenced at %L not found in intrinsic " + "module ISO_C_BINDING", u->use_name, &u->where); + } + } +} + + /* Add an integer named constant from a given module. */ + static void -create_int_parameter (const char *name, int value, const char *modname) +create_int_parameter (const char *name, int value, const char *modname, + intmod_id module, int id) { gfc_symtree *tmp_symtree; gfc_symbol *sym; @@ -4105,6 +4352,8 @@ create_int_parameter (const char *name, int value, const char *modname) sym->ts.kind = gfc_default_integer_kind; sym->value = gfc_int_expr (value); sym->attr.use_assoc = 1; + sym->from_intmod = module; + sym->intmod_sym_id = id; } @@ -4120,14 +4369,14 @@ use_iso_fortran_env_module (void) gfc_symtree *mod_symtree; int i; - mstring symbol[] = { -#define NAMED_INTCST(a,b,c) minit(b,0), + intmod_sym symbol[] = { +#define NAMED_INTCST(a,b,c) { a, b, 0 }, #include "iso-fortran-env.def" #undef NAMED_INTCST - minit (NULL, -1234) }; + { ISOFORTRANENV_INVALID, NULL, -1234 } }; i = 0; -#define NAMED_INTCST(a,b,c) symbol[i++].tag = c; +#define NAMED_INTCST(a,b,c) symbol[i++].value = c; #include "iso-fortran-env.def" #undef NAMED_INTCST @@ -4142,6 +4391,7 @@ use_iso_fortran_env_module (void) mod_sym->attr.flavor = FL_MODULE; mod_sym->attr.intrinsic = 1; mod_sym->module = gfc_get_string (mod); + mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV; } else if (!mod_symtree->n.sym->attr.intrinsic) @@ -4152,11 +4402,11 @@ use_iso_fortran_env_module (void) if (only_flag) for (u = gfc_rename_list; u; u = u->next) { - for (i = 0; symbol[i].string; i++) - if (strcmp (symbol[i].string, u->use_name) == 0) + for (i = 0; symbol[i].name; i++) + if (strcmp (symbol[i].name, u->use_name) == 0) break; - if (symbol[i].string == NULL) + if (symbol[i].name == NULL) { gfc_error ("Symbol '%s' referenced at %L does not exist in " "intrinsic module ISO_FORTRAN_ENV", u->use_name, @@ -4165,7 +4415,7 @@ use_iso_fortran_env_module (void) } if ((gfc_option.flag_default_integer || gfc_option.flag_default_real) - && strcmp (symbol[i].string, "numeric_storage_size") == 0) + && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE) gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant " "from intrinsic module ISO_FORTRAN_ENV at %L is " "incompatible with option %s", &u->where, @@ -4173,17 +4423,18 @@ use_iso_fortran_env_module (void) ? "-fdefault-integer-8" : "-fdefault-real-8"); create_int_parameter (u->local_name[0] ? u->local_name - : symbol[i].string, - symbol[i].tag, mod); + : symbol[i].name, + symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV, + symbol[i].id); } else { - for (i = 0; symbol[i].string; i++) + for (i = 0; symbol[i].name; i++) { local_name = NULL; for (u = gfc_rename_list; u; u = u->next) { - if (strcmp (symbol[i].string, u->use_name) == 0) + if (strcmp (symbol[i].name, u->use_name) == 0) { local_name = u->local_name; u->found = 1; @@ -4192,15 +4443,16 @@ use_iso_fortran_env_module (void) } if ((gfc_option.flag_default_integer || gfc_option.flag_default_real) - && strcmp (symbol[i].string, "numeric_storage_size") == 0) + && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE) gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant " "from intrinsic module ISO_FORTRAN_ENV at %C is " "incompatible with option %s", gfc_option.flag_default_integer ? "-fdefault-integer-8" : "-fdefault-real-8"); - create_int_parameter (local_name ? local_name : symbol[i].string, - symbol[i].tag, mod); + create_int_parameter (local_name ? local_name : symbol[i].name, + symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV, + symbol[i].id); } for (u = gfc_rename_list; u; u = u->next) @@ -4248,11 +4500,19 @@ gfc_use_module (void) return; } + if (strcmp (module_name, "iso_c_binding") == 0 + && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: " + "ISO_C_BINDING module at %C") != FAILURE) + { + import_iso_c_binding_module(); + return; + } + module_fp = gfc_open_intrinsic_module (filename); if (module_fp == NULL && specified_int) - gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C", - module_name); + gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C", + module_name); } if (module_fp == NULL) diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 0daac0c1b89..f1f9028605a 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -181,6 +181,7 @@ decode_statement (void) case 'b': match ("backspace", gfc_match_backspace, ST_BACKSPACE); match ("block data", gfc_match_block_data, ST_BLOCK_DATA); + match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL); break; case 'c': @@ -1510,6 +1511,7 @@ parse_derived (void) int compiling_type, seen_private, seen_sequence, seen_component, error_flag; gfc_statement st; gfc_state_data s; + gfc_symbol *derived_sym = NULL; gfc_symbol *sym; gfc_component *c; @@ -1608,6 +1610,11 @@ parse_derived (void) } } + /* need to verify that all fields of the derived type are + * interoperable with C if the type is declared to be bind(c) + */ + derived_sym = gfc_current_block(); + /* Look for allocatable components. */ sym = gfc_current_block (); for (c = sym->components; c; c = c->next) diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 14253f6f1bd..0e3b6c0a139 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -941,6 +941,8 @@ got_delim: e->ref = NULL; e->ts.type = BT_CHARACTER; e->ts.kind = kind; + e->ts.is_c_interop = 0; + e->ts.is_iso_c = 0; e->where = start_locus; e->value.character.string = p = gfc_getmem (length + 1); @@ -1012,6 +1014,8 @@ match_logical_constant (gfc_expr **result) e->value.logical = i; e->ts.type = BT_LOGICAL; e->ts.kind = kind; + e->ts.is_c_interop = 0; + e->ts.is_iso_c = 0; e->where = gfc_current_locus; *result = e; @@ -1196,6 +1200,8 @@ match_complex_constant (gfc_expr **result) } target.type = BT_REAL; target.kind = kind; + target.is_c_interop = 0; + target.is_iso_c = 0; if (real->ts.type != BT_REAL || kind != real->ts.kind) gfc_convert_type (real, &target, 2); @@ -2190,6 +2196,25 @@ gfc_match_rvalue (gfc_expr **result) break; } + /* Check here for the existence of at least one argument for the + iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The + argument(s) given will be checked in gfc_iso_c_func_interface, + during resolution of the function call. */ + if (sym->attr.is_iso_c == 1 + && (sym->from_intmod == INTMOD_ISO_C_BINDING + && (sym->intmod_sym_id == ISOCBINDING_LOC + || sym->intmod_sym_id == ISOCBINDING_FUNLOC + || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED))) + { + /* make sure we were given a param */ + if (actual_arglist == NULL) + { + gfc_error ("Missing argument to '%s' at %C", sym->name); + m = MATCH_ERROR; + break; + } + } + if (sym->result == NULL) sym->result = sym; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 43711cd126d..fde5043403c 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1540,6 +1540,284 @@ pure_function (gfc_expr *e, const char **name) } +static try +is_scalar_expr_ptr (gfc_expr *expr) +{ + 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.length != NULL + && ref->u.ss.length->length != NULL + && ref->u.ss.start + && ref->u.ss.start->expr_type == EXPR_CONSTANT + && ref->u.ss.end + && ref->u.ss.end->expr_type == EXPR_CONSTANT) + { + start = (int) mpz_get_si (ref->u.ss.start->value.integer); + end = (int) mpz_get_si (ref->u.ss.end->value.integer); + if (end - start + 1 != 1) + retval = FAILURE; + } + else + 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.cl == NULL + || expr->ts.cl->length == NULL + || mpz_cmp_si (expr->ts.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. */ + 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.cl == NULL + || expr->ts.cl->length == NULL + || mpz_cmp_si (expr->ts.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 try +gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, + gfc_symbol **new_sym) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1]; + int optional_arg = 0; + try retval = SUCCESS; + gfc_symbol *args_sym; + + args_sym = args->expr->symtree->n.sym; + + 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); + sprintf (binding_label, "%s_2", sym->binding_label); + optional_arg = 1; + } + else + { + /* one arg. */ + sprintf (name, "%s_1", sym->name); + sprintf (binding_label, "%s_1", sym->binding_label); + 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, binding_label, optional_arg); + } + else if (sym->intmod_sym_id == ISOCBINDING_LOC + || sym->intmod_sym_id == ISOCBINDING_FUNLOC) + { + sprintf (name, "%s", sym->name); + sprintf (binding_label, "%s", sym->binding_label); + + /* 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) + { + /* Make sure we have either the target or pointer attribute. */ + if (!(args->expr->symtree->n.sym->attr.target) + && !(args->expr->symtree->n.sym->attr.pointer)) + { + gfc_error_now ("Parameter '%s' to '%s' at %L must be either " + "a TARGET or an associated pointer", + args->expr->symtree->n.sym->name, + sym->name, &(args->expr->where)); + retval = FAILURE; + } + + /* See if we have interoperable type and type param. */ + if (verify_c_interop (&(args->expr->symtree->n.sym->ts), + args->expr->symtree->n.sym->name, + &(args->expr->where)) == SUCCESS + || gfc_check_any_c_kind (&(args_sym->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 + { + /* 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 (args_sym->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 (args_sym->attr.pointer == 1 + && 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_sym->attr.dimension != 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 (args_sym->ts.type == BT_CHARACTER + && args_sym->ts.cl != NULL) + { + gfc_error_now ("CHARACTER parameter '%s' to '%s' at %L " + "cannot have a length type parameter", + args_sym->name, sym->name, + &(args->expr->where)); + retval = FAILURE; + } + } + } + else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC) + { + if (args->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE) + { + /* TODO: Update this error message to allow for procedure + pointers once they are implemented. */ + gfc_error_now ("Parameter '%s' to '%s' at %L must be a " + "procedure", + args->expr->symtree->n.sym->name, sym->name, + &(args->expr->where)); + retval = FAILURE; + } + else if (args->expr->symtree->n.sym->attr.is_c_interop != 1) + { + gfc_error_now ("Parameter '%s' to '%s' at %L must be C " + "interoperable", + args->expr->symtree->n.sym->name, sym->name, + &(args->expr->where)); + 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. */ /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed @@ -1583,7 +1861,20 @@ resolve_function (gfc_expr *expr) if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE) return FAILURE; - /* Resume assumed_size checking. */ + /* 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--; if (sym && sym->ts.type == BT_CHARACTER @@ -1850,6 +2141,164 @@ 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, 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; + } + 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. */ + sprintf (binding_label, "%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); + sprintf (binding_label, "%s", 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]; + char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1]; + /* default to success; will override if find error */ + match m = MATCH_YES; + gfc_symbol *tmp_sym; + + 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) + { + /* Make sure we got a third arg. The type/rank of it will + be checked later if it's there (gfc_procedure_use()). */ + if (c->ext.actual->next->expr->rank != 0 && + c->ext.actual->next->next == NULL) + { + m = MATCH_ERROR; + gfc_error ("Missing SHAPE parameter for call to %s " + "at %L", sym->name, &(c->loc)); + } + /* Make sure the param is a POINTER. No need to make sure + it does not have INTENT(IN) since it is a POINTER. */ + tmp_sym = c->ext.actual->next->expr->symtree->n.sym; + if (tmp_sym != NULL && tmp_sym->attr.pointer != 1) + { + gfc_error ("Argument '%s' to '%s' at %L " + "must have the POINTER attribute", + tmp_sym->name, sym->name, &(c->loc)); + 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 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) + { + /* TODO: Figure out if this is even reacable; this part of the + conditional may not be necessary. */ + int num_args = 0; + if (c->ext.actual->next == NULL) + { + /* The user did not give two args, so resolve to the version + of c_associated expecting one arg. */ + num_args = 1; + /* get rid of the second arg */ + /* TODO!! Should free up the memory here! */ + sym->formal->next = NULL; + } + else + { + num_args = 2; + } + + new_sym = sym; + sprintf (name, "%s_%d", sym->name, num_args); + sprintf (binding_label, "%s_%d", sym->binding_label, num_args); + sym->name = gfc_get_string (name); + strcpy (sym->binding_label, binding_label); + } + else + { + /* no differences for c_loc or c_funloc */ + new_sym = sym; + } + + /* set the resolved symbol */ + if (m != MATCH_ERROR) + { + gfc_procedure_use (new_sym, &c->ext.actual, &c->loc); + c->resolved_sym = new_sym; + } + else + c->resolved_sym = sym; + + return m; +} + + /* Resolve a subroutine call known to be specific. */ static match @@ -1857,6 +2306,12 @@ 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) @@ -5498,6 +5953,206 @@ resolve_values (gfc_symbol *sym) } +/* Verify the binding labels for common blocks that are BIND(C). The label + for a BIND(C) common block must be identical in all scoping units in which + the common block is declared. Further, the binding label can not collide + with any other global entity in the program. */ + +static void +resolve_bind_c_comms (gfc_symtree *comm_block_tree) +{ + if (comm_block_tree->n.common->is_bind_c == 1) + { + gfc_gsymbol *binding_label_gsym; + gfc_gsymbol *comm_name_gsym; + + /* See if a global symbol exists by the common block's name. It may + be NULL if the common block is use-associated. */ + comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root, + comm_block_tree->n.common->name); + if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON) + gfc_error ("Binding label '%s' for common block '%s' at %L collides " + "with the global entity '%s' at %L", + comm_block_tree->n.common->binding_label, + comm_block_tree->n.common->name, + &(comm_block_tree->n.common->where), + comm_name_gsym->name, &(comm_name_gsym->where)); + else if (comm_name_gsym != NULL + && strcmp (comm_name_gsym->name, + comm_block_tree->n.common->name) == 0) + { + /* TODO: Need to make sure the fields of gfc_gsymbol are initialized + as expected. */ + if (comm_name_gsym->binding_label == NULL) + /* No binding label for common block stored yet; save this one. */ + comm_name_gsym->binding_label = + comm_block_tree->n.common->binding_label; + else + if (strcmp (comm_name_gsym->binding_label, + comm_block_tree->n.common->binding_label) != 0) + { + /* Common block names match but binding labels do not. */ + gfc_error ("Binding label '%s' for common block '%s' at %L " + "does not match the binding label '%s' for common " + "block '%s' at %L", + comm_block_tree->n.common->binding_label, + comm_block_tree->n.common->name, + &(comm_block_tree->n.common->where), + comm_name_gsym->binding_label, + comm_name_gsym->name, + &(comm_name_gsym->where)); + return; + } + } + + /* There is no binding label (NAME="") so we have nothing further to + check and nothing to add as a global symbol for the label. */ + if (comm_block_tree->n.common->binding_label[0] == '\0' ) + return; + + binding_label_gsym = + gfc_find_gsymbol (gfc_gsym_root, + comm_block_tree->n.common->binding_label); + if (binding_label_gsym == NULL) + { + /* Need to make a global symbol for the binding label to prevent + it from colliding with another. */ + binding_label_gsym = + gfc_get_gsymbol (comm_block_tree->n.common->binding_label); + binding_label_gsym->sym_name = comm_block_tree->n.common->name; + binding_label_gsym->type = GSYM_COMMON; + } + else + { + /* If comm_name_gsym is NULL, the name common block is use + associated and the name could be colliding. */ + if (binding_label_gsym->type != GSYM_COMMON) + gfc_error ("Binding label '%s' for common block '%s' at %L " + "collides with the global entity '%s' at %L", + comm_block_tree->n.common->binding_label, + comm_block_tree->n.common->name, + &(comm_block_tree->n.common->where), + binding_label_gsym->name, + &(binding_label_gsym->where)); + else if (comm_name_gsym != NULL + && (strcmp (binding_label_gsym->name, + comm_name_gsym->binding_label) != 0) + && (strcmp (binding_label_gsym->sym_name, + comm_name_gsym->name) != 0)) + gfc_error ("Binding label '%s' for common block '%s' at %L " + "collides with global entity '%s' at %L", + binding_label_gsym->name, binding_label_gsym->sym_name, + &(comm_block_tree->n.common->where), + comm_name_gsym->name, &(comm_name_gsym->where)); + } + } + + return; +} + + +/* Verify any BIND(C) derived types in the namespace so we can report errors + for them once, rather than for each variable declared of that type. */ + +static void +resolve_bind_c_derived_types (gfc_symbol *derived_sym) +{ + if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED + && derived_sym->attr.is_bind_c == 1) + verify_bind_c_derived_type (derived_sym); + + return; +} + + +/* Verify that any binding labels used in a given namespace do not collide + with the names or binding labels of any global symbols. */ + +static void +gfc_verify_binding_labels (gfc_symbol *sym) +{ + int has_error = 0; + + if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0 + && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0') + { + gfc_gsymbol *bind_c_sym; + + bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label); + if (bind_c_sym != NULL + && strcmp (bind_c_sym->name, sym->binding_label) == 0) + { + if (sym->attr.if_source == IFSRC_DECL + && (bind_c_sym->type != GSYM_SUBROUTINE + && bind_c_sym->type != GSYM_FUNCTION) + && ((sym->attr.contained == 1 + && strcmp (bind_c_sym->sym_name, sym->name) != 0) + || (sym->attr.use_assoc == 1 + && (strcmp (bind_c_sym->mod_name, sym->module) != 0)))) + { + /* Make sure global procedures don't collide with anything. */ + gfc_error ("Binding label '%s' at %L collides with the global " + "entity '%s' at %L", sym->binding_label, + &(sym->declared_at), bind_c_sym->name, + &(bind_c_sym->where)); + has_error = 1; + } + else if (sym->attr.contained == 0 + && (sym->attr.if_source == IFSRC_IFBODY + && sym->attr.flavor == FL_PROCEDURE) + && (bind_c_sym->sym_name != NULL + && strcmp (bind_c_sym->sym_name, sym->name) != 0)) + { + /* Make sure procedures in interface bodies don't collide. */ + gfc_error ("Binding label '%s' in interface body at %L collides " + "with the global entity '%s' at %L", + sym->binding_label, + &(sym->declared_at), bind_c_sym->name, + &(bind_c_sym->where)); + has_error = 1; + } + else if (sym->attr.contained == 0 + && (sym->attr.if_source == IFSRC_UNKNOWN)) + if ((sym->attr.use_assoc + && (strcmp (bind_c_sym->mod_name, sym->module) != 0)) + || sym->attr.use_assoc == 0) + { + gfc_error ("Binding label '%s' at %L collides with global " + "entity '%s' at %L", sym->binding_label, + &(sym->declared_at), bind_c_sym->name, + &(bind_c_sym->where)); + has_error = 1; + } + + if (has_error != 0) + /* Clear the binding label to prevent checking multiple times. */ + sym->binding_label[0] = '\0'; + } + else if (bind_c_sym == NULL) + { + bind_c_sym = gfc_get_gsymbol (sym->binding_label); + bind_c_sym->where = sym->declared_at; + bind_c_sym->sym_name = sym->name; + + if (sym->attr.use_assoc == 1) + bind_c_sym->mod_name = sym->module; + else + if (sym->ns->proc_name != NULL) + bind_c_sym->mod_name = sym->ns->proc_name->name; + + if (sym->attr.contained == 0) + { + if (sym->attr.subroutine) + bind_c_sym->type = GSYM_SUBROUTINE; + else if (sym->attr.function) + bind_c_sym->type = GSYM_FUNCTION; + } + } + } + return; +} + + /* Resolve an index expression. */ static try @@ -6013,6 +6668,45 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) "'%s' at %L is obsolescent in fortran 95", sym->name, &sym->declared_at); } + + if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1) + { + gfc_formal_arglist *curr_arg; + + if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, + sym->common_block) == FAILURE) + { + /* Clear these to prevent looking at them again if there was an + error. */ + sym->attr.is_bind_c = 0; + sym->attr.is_c_interop = 0; + sym->ts.is_c_interop = 0; + } + else + { + /* So far, no errors have been found. */ + sym->attr.is_c_interop = 1; + sym->ts.is_c_interop = 1; + } + + curr_arg = sym->formal; + while (curr_arg != NULL) + { + /* Skip implicitly typed dummy args here. */ + if (curr_arg->sym->attr.implicit_type == 0 + && verify_c_interop_param (curr_arg->sym) == FAILURE) + { + /* If something is found to fail, mark the symbol for the + procedure as not being BIND(C) to try and prevent multiple + errors being reported. */ + sym->attr.is_c_interop = 0; + sym->ts.is_c_interop = 0; + sym->attr.is_bind_c = 0; + } + curr_arg = curr_arg->next; + } + } + return SUCCESS; } @@ -6381,6 +7075,76 @@ resolve_symbol (gfc_symbol *sym) sym->name, &sym->declared_at); return; } + + if (sym->ts.is_c_interop + && mpz_cmp_si (cl->length->value.integer, 1) != 0) + { + gfc_error ("C interoperable character dummy variable '%s' at %L " + "with VALUE attribute must have length one", + sym->name, &sym->declared_at); + return; + } + } + + /* If the symbol is marked as bind(c), verify it's type and kind. Do not + do this for something that was implicitly typed because that is handled + in gfc_set_default_type. Handle dummy arguments and procedure + definitions separately. Also, anything that is use associated is not + handled here but instead is handled in the module it is declared in. + Finally, derived type definitions are allowed to be BIND(C) since that + only implies that they're interoperable, and they are checked fully for + interoperability when a variable is declared of that type. */ + if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 && + sym->attr.use_assoc == 0 && sym->attr.dummy == 0 && + sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED) + { + try t = SUCCESS; + + /* First, make sure the variable is declared at the + module-level scope (J3/04-007, Section 15.3). */ + if (sym->ns->proc_name->attr.flavor != FL_MODULE && + sym->attr.in_common == 0) + { + gfc_error ("Variable '%s' at %L cannot be BIND(C) because it " + "is neither a COMMON block nor declared at the " + "module level scope", sym->name, &(sym->declared_at)); + t = FAILURE; + } + else if (sym->common_head != NULL) + { + t = verify_com_block_vars_c_interop (sym->common_head); + } + else + { + /* If type() declaration, we need to verify that the components + of the given type are all C interoperable, etc. */ + if (sym->ts.type == BT_DERIVED && + sym->ts.derived->attr.is_c_interop != 1) + { + /* Make sure the user marked the derived type as BIND(C). If + not, call the verify routine. This could print an error + for the derived type more than once if multiple variables + of that type are declared. */ + if (sym->ts.derived->attr.is_bind_c != 1) + verify_bind_c_derived_type (sym->ts.derived); + t = FAILURE; + } + + /* Verify the variable itself as C interoperable if it + is BIND(C). It is not possible for this to succeed if + the verify_bind_c_derived_type failed, so don't have to handle + any error returned by verify_bind_c_derived_type. */ + t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, + sym->common_block); + } + + if (t == FAILURE) + { + /* clear the is_bind_c flag to prevent reporting errors more than + once if something failed. */ + sym->attr.is_bind_c = 0; + return; + } } /* If a derived type symbol has reached this point, without its @@ -7428,6 +8192,8 @@ resolve_types (gfc_namespace *ns) resolve_contained_functions (ns); + gfc_traverse_ns (ns, resolve_bind_c_derived_types); + for (cl = ns->cl_list; cl; cl = cl->next) resolve_charlen (cl); @@ -7460,6 +8226,11 @@ resolve_types (gfc_namespace *ns) iter_stack = NULL; gfc_traverse_ns (ns, gfc_formalize_init_value); + gfc_traverse_ns (ns, gfc_verify_binding_labels); + + if (ns->common_root != NULL) + gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms); + for (eq = ns->equiv; eq; eq = eq->next) resolve_equivalence (eq); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index e1b27dc0fb7..867c6ef8026 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -27,6 +27,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA #include "gfortran.h" #include "parse.h" + /* Strings for all symbol attributes. We use these for dumping the parse tree, in error messages, and also when reading and writing modules. */ @@ -249,6 +250,32 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns) sym->ts = *ts; sym->attr.implicit_type = 1; + if (sym->attr.is_bind_c == 1) + { + /* BIND(C) variables should not be implicitly declared. */ + gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may " + "not be C interoperable", sym->name, &sym->declared_at); + sym->ts.f90_type = sym->ts.type; + } + + if (sym->attr.dummy != 0) + { + if (sym->ns->proc_name != NULL + && (sym->ns->proc_name->attr.subroutine != 0 + || sym->ns->proc_name->attr.function != 0) + && sym->ns->proc_name->attr.is_bind_c != 0) + { + /* Dummy args to a BIND(C) routine may not be interoperable if + they are implicitly typed. */ + gfc_warning_now ("Implicity declared variable '%s' at %L may not " + "be C interoperable but it is a dummy argument to " + "the BIND(C) procedure '%s' at %L", sym->name, + &(sym->declared_at), sym->ns->proc_name->name, + &(sym->ns->proc_name->declared_at)); + sym->ts.f90_type = sym->ts.type; + } + } + return SUCCESS; } @@ -319,7 +346,8 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE", *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER", *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", - *volatile_ = "VOLATILE", *protected = "PROTECTED"; + *volatile_ = "VOLATILE", *protected = "PROTECTED", + *is_bind_c = "BIND(C)"; static const char *threadprivate = "THREADPRIVATE"; const char *a1, *a2; @@ -370,7 +398,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (dummy, save); conf (dummy, threadprivate); conf (pointer, target); - conf (pointer, external); conf (pointer, intrinsic); conf (pointer, elemental); conf (allocatable, elemental); @@ -418,6 +445,17 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (function, subroutine); + if (!function && !subroutine) + conf (is_bind_c, dummy); + + conf (is_bind_c, cray_pointer); + conf (is_bind_c, cray_pointee); + conf (is_bind_c, allocatable); + + /* Need to also get volatile attr, according to 5.1 of F2003 draft. + Parameter conflict caught below. Also, value cannot be specified + for a dummy procedure. */ + /* Cray pointer/pointee conflicts. */ conf (cray_pointer, cray_pointee); conf (cray_pointer, dimension); @@ -449,10 +487,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (data, allocatable); conf (data, use_assoc); - conf (protected, intrinsic) - conf (protected, external) - conf (protected, in_common) - conf (value, pointer) conf (value, allocatable) conf (value, subroutine) @@ -469,6 +503,10 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) goto conflict; } + conf (protected, intrinsic) + conf (protected, external) + conf (protected, in_common) + conf (volatile_, intrinsic) conf (volatile_, external) @@ -596,6 +634,8 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (value); conf2 (volatile_); conf2 (threadprivate); + /* TODO: hmm, double check this. */ + conf2 (value); break; default: @@ -1269,9 +1309,35 @@ gfc_add_access (symbol_attribute *attr, gfc_access access, } +/* Set the is_bind_c field for the given symbol_attribute. */ + +try +gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where, + int is_proc_lang_bind_spec) +{ + + if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE) + gfc_error_now ("BIND(C) attribute at %L can only be used for " + "variables or common blocks", where); + else if (attr->is_bind_c) + gfc_error_now ("Duplicate BIND attribute specified at %L", where); + else + attr->is_bind_c = 1; + + if (where == NULL) + where = &gfc_current_locus; + + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where) + == FAILURE) + return FAILURE; + + return check_conflict (attr, name, where); +} + + try -gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source, - gfc_formal_arglist * formal, locus * where) +gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source, + gfc_formal_arglist * formal, locus *where) { if (check_used (&sym->attr, sym->name, where)) @@ -1363,9 +1429,10 @@ gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED, where we are called from, so we ignore some bits. */ try -gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) +gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) { - + int is_proc_lang_bind_spec; + if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE) goto fail; @@ -1437,6 +1504,17 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE) goto fail; + is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0); + if (src->is_bind_c + && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec) + != SUCCESS) + return FAILURE; + + if (src->is_c_interop) + dest->is_c_interop = 1; + if (src->is_iso_c) + dest->is_iso_c = 1; + if (src->external && gfc_add_external (dest, where) == FAILURE) goto fail; if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE) @@ -2087,6 +2165,16 @@ gfc_new_symbol (const char *name, gfc_namespace *ns) gfc_internal_error ("new_symbol(): Symbol name too long"); p->name = gfc_get_string (name); + + /* Make sure flags for symbol being C bound are clear initially. */ + p->attr.is_bind_c = 0; + p->attr.is_iso_c = 0; + /* Make sure the binding label field has a Nul char to start. */ + p->binding_label[0] = '\0'; + + /* Clear the ptrs we may need. */ + p->common_block = NULL; + return p; } @@ -2872,3 +2960,859 @@ gfc_get_gsymbol (const char *name) return s; } + + +static gfc_symbol * +get_iso_c_binding_dt (int sym_id) +{ + gfc_dt_list *dt_list; + + dt_list = gfc_derived_types; + + /* Loop through the derived types in the name list, searching for + the desired symbol from iso_c_binding. Search the parent namespaces + if necessary and requested to (parent_flag). */ + while (dt_list != NULL) + { + if (dt_list->derived->from_intmod != INTMOD_NONE + && dt_list->derived->intmod_sym_id == sym_id) + return dt_list->derived; + + dt_list = dt_list->next; + } + + return NULL; +} + + +/* Verifies that the given derived type symbol, derived_sym, is interoperable + with C. This is necessary for any derived type that is BIND(C) and for + derived types that are parameters to functions that are BIND(C). All + fields of the derived type are required to be interoperable, and are tested + for such. If an error occurs, the errors are reported here, allowing for + multiple errors to be handled for a single derived type. */ + +try +verify_bind_c_derived_type (gfc_symbol *derived_sym) +{ + gfc_component *curr_comp = NULL; + try is_c_interop = FAILURE; + try retval = SUCCESS; + + if (derived_sym == NULL) + gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is " + "unexpectedly NULL"); + + /* If we've already looked at this derived symbol, do not look at it again + so we don't repeat warnings/errors. */ + if (derived_sym->ts.is_c_interop) + return SUCCESS; + + /* The derived type must have the BIND attribute to be interoperable + J3/04-007, Section 15.2.3. */ + if (derived_sym->attr.is_bind_c != 1) + { + derived_sym->ts.is_c_interop = 0; + gfc_error_now ("Derived type '%s' declared at %L must have the BIND " + "attribute to be C interoperable", derived_sym->name, + &(derived_sym->declared_at)); + retval = FAILURE; + } + + curr_comp = derived_sym->components; + + /* TODO: is this really an error? */ + if (curr_comp == NULL) + { + gfc_error ("Derived type '%s' at %L is empty", + derived_sym->name, &(derived_sym->declared_at)); + return FAILURE; + } + + /* Initialize the derived type as being C interoperable. + If we find an error in the components, this will be set false. */ + derived_sym->ts.is_c_interop = 1; + + /* Loop through the list of components to verify that the kind of + each is a C interoperable type. */ + do + { + /* The components cannot be pointers (fortran sense). + J3/04-007, Section 15.2.3, C1505. */ + if (curr_comp->pointer != 0) + { + gfc_error ("Component '%s' at %L cannot have the " + "POINTER attribute because it is a member " + "of the BIND(C) derived type '%s' at %L", + curr_comp->name, &(curr_comp->loc), + derived_sym->name, &(derived_sym->declared_at)); + retval = FAILURE; + } + + /* The components cannot be allocatable. + J3/04-007, Section 15.2.3, C1505. */ + if (curr_comp->allocatable != 0) + { + gfc_error ("Component '%s' at %L cannot have the " + "ALLOCATABLE attribute because it is a member " + "of the BIND(C) derived type '%s' at %L", + curr_comp->name, &(curr_comp->loc), + derived_sym->name, &(derived_sym->declared_at)); + retval = FAILURE; + } + + /* BIND(C) derived types must have interoperable components. */ + if (curr_comp->ts.type == BT_DERIVED + && curr_comp->ts.derived->ts.is_iso_c != 1 + && curr_comp->ts.derived != derived_sym) + { + /* This should be allowed; the draft says a derived-type can not + have type parameters if it is has the BIND attribute. Type + parameters seem to be for making parameterized derived types. + There's no need to verify the type if it is c_ptr/c_funptr. */ + retval = verify_bind_c_derived_type (curr_comp->ts.derived); + } + else + { + /* Grab the typespec for the given component and test the kind. */ + is_c_interop = verify_c_interop (&(curr_comp->ts), curr_comp->name, + &(curr_comp->loc)); + + if (is_c_interop != SUCCESS) + { + /* Report warning and continue since not fatal. The + draft does specify a constraint that requires all fields + to interoperate, but if the user says real(4), etc., it + may interoperate with *something* in C, but the compiler + most likely won't know exactly what. Further, it may not + interoperate with the same data type(s) in C if the user + recompiles with different flags (e.g., -m32 and -m64 on + x86_64 and using integer(4) to claim interop with a + C_LONG). */ + if (derived_sym->attr.is_bind_c == 1) + /* If the derived type is bind(c), all fields must be + interop. */ + gfc_warning ("Component '%s' in derived type '%s' at %L " + "may not be C interoperable, even though " + "derived type '%s' is BIND(C)", + curr_comp->name, derived_sym->name, + &(curr_comp->loc), derived_sym->name); + else + /* If derived type is param to bind(c) routine, or to one + of the iso_c_binding procs, it must be interoperable, so + all fields must interop too. */ + gfc_warning ("Component '%s' in derived type '%s' at %L " + "may not be C interoperable", + curr_comp->name, derived_sym->name, + &(curr_comp->loc)); + } + } + + curr_comp = curr_comp->next; + } while (curr_comp != NULL); + + + /* Make sure we don't have conflicts with the attributes. */ + if (derived_sym->attr.access == ACCESS_PRIVATE) + { + gfc_error ("Derived type '%s' at %L cannot be declared with both " + "PRIVATE and BIND(C) attributes", derived_sym->name, + &(derived_sym->declared_at)); + retval = FAILURE; + } + + if (derived_sym->attr.sequence != 0) + { + gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE " + "attribute because it is BIND(C)", derived_sym->name, + &(derived_sym->declared_at)); + retval = FAILURE; + } + + /* Mark the derived type as not being C interoperable if we found an + error. If there were only warnings, proceed with the assumption + it's interoperable. */ + if (retval == FAILURE) + derived_sym->ts.is_c_interop = 0; + + return retval; +} + + +/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */ + +static try +gen_special_c_interop_ptr (int ptr_id, const char *ptr_name, + const char *module_name) +{ + gfc_symtree *tmp_symtree; + gfc_symbol *tmp_sym; + + 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); + } + + /* Set up the symbol's important fields. Save attr required so we can + initialize the ptr to NULL. */ + tmp_sym->attr.save = 1; + tmp_sym->ts.is_c_interop = 1; + tmp_sym->attr.is_c_interop = 1; + tmp_sym->ts.is_iso_c = 1; + tmp_sym->ts.type = BT_DERIVED; + + /* 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.derived = get_iso_c_binding_dt (ISOCBINDING_PTR); + else + tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR); + if (tmp_sym->ts.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, + (char *) (ptr_id == ISOCBINDING_NULL_PTR + ? "_gfortran_iso_c_binding_c_ptr" + : "_gfortran_iso_c_binding_c_funptr")); + + tmp_sym->ts.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; + /* Set the binding_label. */ + sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name); + + /* 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.derived = tmp_sym->ts.derived; + tmp_sym->value->value.constructor = gfc_get_constructor (); + /* This line will initialize the c_null_ptr/c_null_funptr + c_address field to NULL. */ + tmp_sym->value->value.constructor->expr = gfc_int_expr (0); + /* Must declare c_null_ptr and c_null_funptr as having the + PARAMETER attribute so they can be used in init expressions. */ + tmp_sym->attr.flavor = FL_PARAMETER; + + return SUCCESS; +} + + +/* Add a formal argument, gfc_formal_arglist, to the + end of the given list of arguments. Set the reference to the + provided symbol, param_sym, in the argument. */ + +static void +add_formal_arg (gfc_formal_arglist **head, + gfc_formal_arglist **tail, + gfc_formal_arglist *formal_arg, + gfc_symbol *param_sym) +{ + /* Put in list, either as first arg or at the tail (curr arg). */ + if (*head == NULL) + *head = *tail = formal_arg; + else + { + (*tail)->next = formal_arg; + (*tail) = formal_arg; + } + + (*tail)->sym = param_sym; + (*tail)->next = NULL; + + return; +} + + +/* 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) +{ + 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 = "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); + 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, no matter what it's name is (user renamed). */ + 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. */ + gfc_error_now ("Type 'C_PTR' required for ISO_C_BINDING function at %C"); + generate_isocbinding_symbol (module_name, ISOCBINDING_PTR, + (char *) "_gfortran_iso_c_binding_c_ptr"); + + gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym)); + } + + param_sym->ts.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); +} + + +/* 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) +{ + 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); + 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++; + 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); +} + + +/* 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__"; + int i; + + if (shape_param_name != NULL) + shape_param = shape_param_name; + + gfc_get_sym_tree (shape_param, ns, ¶m_symtree); + 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. */ + param_sym->ts.type = BT_INTEGER; + param_sym->ts.kind = gfc_default_integer_kind; + param_sym->as = gfc_get_array_spec (); + + /* Clear out the dimension info for the array. */ + for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + { + param_sym->as->lower[i] = NULL; + param_sym->as->upper[i] = NULL; + } + param_sym->as->rank = 1; + param_sym->as->lower[0] = gfc_int_expr (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); +} + +/* Add a procedure interface to the given symbol (i.e., store a + reference to the list of formal arguments). */ + +static void +add_proc_interface (gfc_symbol *sym, ifsrc source, + gfc_formal_arglist *formal) +{ + + sym->formal = formal; + sym->attr.if_source = source; +} + + +/* 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_POINTER) || + (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)) + { + gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module, + gfc_current_ns, "cptr"); + gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module, + gfc_current_ns, "fptr"); + + /* If we're dealing with c_f_pointer, it has an optional third arg. */ + if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) + { + 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"); + if (add_optional_arg) + { + gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module, + gfc_current_ns, "c_ptr_2"); + /* 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; +} + + +/* Generate the given set of C interoperable kind objects, or all + interoperable kinds. This function will only be given kind objects + for valid iso_c_binding defined types because this is verified when + the 'use' statement is parsed. If the user gives an 'only' clause, + the specific kinds are looked up; if they don't exist, an error is + 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. */ + + +void +generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, + char *local_name) +{ + char *name = (local_name && local_name[0]) ? local_name + : c_interop_kinds_table[s].name; + gfc_symtree *tmp_symtree = NULL; + gfc_symbol *tmp_sym = NULL; + gfc_dt_list **dt_list_ptr = NULL; + gfc_component *tmp_comp = NULL; + char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1]; + int index; + + tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); + + /* Already exists in this scope so don't re-add it. + TODO: we should probably check that it's really the same symbol. */ + if (tmp_symtree != NULL) + return; + + /* Create the sym tree in the current ns. */ + gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree); + if (tmp_symtree) + tmp_sym = tmp_symtree->n.sym; + else + gfc_internal_error ("generate_isocbinding_symbol(): Unable to " + "create symbol"); + + /* 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; + + switch (s) + { + +#define NAMED_INTCST(a,b,c) case a : +#define NAMED_REALCST(a,b,c) case a : +#define NAMED_CMPXCST(a,b,c) case a : +#define NAMED_LOGCST(a,b,c) case a : +#define NAMED_CHARKNDCST(a,b,c) case a : +#include "iso-c-binding.def" + + tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value); + + /* Initialize an integer constant expression node. */ + tmp_sym->attr.flavor = FL_PARAMETER; + tmp_sym->ts.type = BT_INTEGER; + tmp_sym->ts.kind = gfc_default_integer_kind; + + /* Mark this type as a C interoperable one. */ + tmp_sym->ts.is_c_interop = 1; + tmp_sym->ts.is_iso_c = 1; + tmp_sym->value->ts.is_c_interop = 1; + tmp_sym->value->ts.is_iso_c = 1; + tmp_sym->attr.is_c_interop = 1; + + /* 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; + + +#define NAMED_CHARCST(a,b,c) case a : +#include "iso-c-binding.def" + + /* Initialize an integer constant expression node for the + length of the character. */ + tmp_sym->value = gfc_get_expr (); + tmp_sym->value->expr_type = EXPR_CONSTANT; + tmp_sym->value->ts.type = BT_CHARACTER; + tmp_sym->value->ts.kind = gfc_default_character_kind; + tmp_sym->value->where = gfc_current_locus; + tmp_sym->value->ts.is_c_interop = 1; + tmp_sym->value->ts.is_iso_c = 1; + tmp_sym->value->value.character.length = 1; + tmp_sym->value->value.character.string = gfc_getmem (2); + tmp_sym->value->value.character.string[0] + = (char) c_interop_kinds_table[s].value; + tmp_sym->value->value.character.string[1] = '\0'; + + /* May not need this in both attr and ts, but do need in + attr for writing module file. */ + tmp_sym->attr.is_c_interop = 1; + + tmp_sym->attr.flavor = FL_PARAMETER; + tmp_sym->ts.type = BT_CHARACTER; + + /* Need to set it to the C_CHAR kind. */ + tmp_sym->ts.kind = gfc_default_character_kind; + + /* Mark this type as a C interoperable one. */ + tmp_sym->ts.is_c_interop = 1; + tmp_sym->ts.is_iso_c = 1; + + /* 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: + + /* Initialize an integer constant expression node. */ + tmp_sym->attr.flavor = FL_DERIVED; + tmp_sym->ts.is_c_interop = 1; + tmp_sym->attr.is_c_interop = 1; + tmp_sym->attr.is_iso_c = 1; + tmp_sym->ts.is_iso_c = 1; + tmp_sym->ts.type = BT_DERIVED; + + /* A derived type must have the bind attribute to be + interoperable (J3/04-007, Section 15.2.3), even though + the binding label is not used. */ + tmp_sym->attr.is_bind_c = 1; + + tmp_sym->attr.referenced = 1; + + tmp_sym->ts.derived = tmp_sym; + + /* Add the symbol created for the derived type to the current ns. */ + dt_list_ptr = &(gfc_derived_types); + while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL) + dt_list_ptr = &((*dt_list_ptr)->next); + + /* There is already at least one derived type in the list, so append + the one we're currently building for c_ptr or c_funptr. */ + if (*dt_list_ptr != NULL) + dt_list_ptr = &((*dt_list_ptr)->next); + (*dt_list_ptr) = gfc_get_dt_list (); + (*dt_list_ptr)->derived = tmp_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", tmp_sym->name, "c_address"); + gfc_add_component (tmp_sym, comp_name, &tmp_comp); + if (tmp_comp == NULL) + gfc_internal_error ("generate_isocbinding_symbol(): Unable to " + "create component for c_address"); + + tmp_comp->ts.type = BT_INTEGER; + + /* Set this because the module will need to read/write this field. */ + tmp_comp->ts.f90_type = BT_INTEGER; + + /* 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->pointer = 0; + tmp_comp->dimension = 0; + + /* Mark the component as C interoperable. */ + tmp_comp->ts.is_c_interop = 1; + + /* Make it use associated (iso_c_binding module). */ + tmp_sym->attr.use_assoc = 1; + break; + + case ISOCBINDING_NULL_PTR: + case ISOCBINDING_NULL_FUNPTR: + gen_special_c_interop_ptr (s, name, mod_name); + 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. */ + sprintf (tmp_sym->binding_label, "%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.derived = + get_iso_c_binding_dt (ISOCBINDING_PTR); + else + tmp_sym->ts.derived = + get_iso_c_binding_dt (ISOCBINDING_FUNPTR); + + if (tmp_sym->ts.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_FUNPTR, + (char *)(s == ISOCBINDING_FUNLOC + ? "_gfortran_iso_c_binding_c_funptr" + : "_gfortran_iso_c_binding_c_ptr")); + tmp_sym->ts.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.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 (); + } +} + + +/* 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, + 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. */ + strcpy (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); + /* 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; +} + diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index 78cb7be3e8e..7b862c7f88c 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -109,6 +109,12 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA #include "target-memory.h" +/* TODO: This is defined in match.h, and probably shouldn't be here also, + but we need it for now at least and don't want to include the whole + match.h. */ +gfc_common_head *gfc_get_common (const char *, int); + + /* Holds a single variable in an equivalence set. */ typedef struct segment_info { @@ -217,13 +223,37 @@ add_segments (segment_info *list, segment_info *v) return list; } + /* Construct mangled common block name from symbol name. */ +/* We need the bind(c) flag to tell us how/if we should mangle the symbol + name. There are few calls to this function, so few places that this + would need to be added. At the moment, there is only one call, in + build_common_decl(). We can't attempt to look up the common block + because we may be building it for the first time and therefore, it won't + be in the common_root. We also need the binding label, if it's bind(c). + Therefore, send in the pointer to the common block, so whatever info we + have so far can be used. All of the necessary info should be available + in the gfc_common_head by now, so it should be accurate to test the + isBindC flag and use the binding label given if it is bind(c). + + We may NOT know yet if it's bind(c) or not, but we can try at least. + Will have to figure out what to do later if it's labeled bind(c) + after this is called. */ + static tree -gfc_sym_mangled_common_id (const char *name) +gfc_sym_mangled_common_id (gfc_common_head *com) { int has_underscore; char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; + char name[GFC_MAX_SYMBOL_LEN + 1]; + + /* Get the name out of the common block pointer. */ + strcpy (name, com->name); + + /* If we're suppose to do a bind(c). */ + if (com->is_bind_c == 1 && com->binding_label[0] != '\0') + return get_identifier (com->binding_label); if (strcmp (name, BLANK_COMMON_NAME) == 0) return get_identifier (name); @@ -381,7 +411,7 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) if (decl == NULL_TREE) { decl = build_decl (VAR_DECL, get_identifier (com->name), union_type); - SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com->name)); + SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com)); TREE_PUBLIC (decl) = 1; TREE_STATIC (decl) = 1; DECL_ALIGN (decl) = BIGGEST_ALIGNMENT; diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c index 24aa809be5a..7aaed0bd29e 100644 --- a/gcc/fortran/trans-const.c +++ b/gcc/fortran/trans-const.c @@ -280,6 +280,20 @@ gfc_conv_constant_to_tree (gfc_expr * expr) void gfc_conv_constant (gfc_se * se, gfc_expr * expr) { + /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR. If + so, they expr_type will not yet be an EXPR_CONSTANT. We need to make + it so here. */ + if (expr->ts.type == BT_DERIVED && expr->ts.derived + && expr->ts.derived->attr.is_iso_c) + { + if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR + || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR) + { + /* Create a new EXPR_CONSTANT expression for our local uses. */ + expr = gfc_int_expr (0); + } + } + gcc_assert (expr->expr_type == EXPR_CONSTANT); if (se->ss != NULL) diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index e1379bad827..1a949826cf1 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -292,6 +292,12 @@ gfc_sym_mangled_identifier (gfc_symbol * sym) { char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; + /* Prevent the mangling of identifiers that have an assigned + binding label (mainly those that are bind(c)). */ + if (sym->attr.is_bind_c == 1 + && sym->binding_label[0] != '\0') + return get_identifier(sym->binding_label); + if (sym->module == NULL) return gfc_sym_identifier (sym); else @@ -310,6 +316,14 @@ gfc_sym_mangled_function_id (gfc_symbol * sym) int has_underscore; char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; + /* It may be possible to simply use the binding label if it's + provided, and remove the other checks. Then we could use it + for other things if we wished. */ + if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) && + sym->binding_label[0] != '\0') + /* use the binding label rather than the mangled name */ + return get_identifier (sym->binding_label); + if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL || (sym->module != NULL && (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY))) @@ -473,6 +487,21 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) if (sym->attr.cray_pointee) return; + if(sym->attr.is_bind_c == 1) + { + /* We need to put variables that are bind(c) into the common + segment of the object file, because this is what C would do. + gfortran would typically put them in either the BSS or + initialized data segments, and only mark them as common if + they were part of common blocks. However, if they are not put + into common space, then C cannot initialize global fortran + variables that it interoperates with and the draft says that + either Fortran or C should be able to initialize it (but not + both, of course.) (J3/04-007, section 15.3). */ + TREE_PUBLIC(decl) = 1; + DECL_COMMON(decl) = 1; + } + /* If a variable is USE associated, it's always external. */ if (sym->attr.use_assoc) { @@ -2718,6 +2747,12 @@ gfc_create_module_variable (gfc_symbol * sym) if (sym->attr.entry) return; + /* Make sure we convert the types of the derived types from iso_c_binding + into (void *). */ + if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c + && sym->ts.type == BT_DERIVED) + sym->backend_decl = gfc_typenode_for_spec (&(sym->ts)); + /* Only output variables and array valued parameters. */ if (sym->attr.flavor != FL_VARIABLE && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0)) @@ -2804,6 +2839,41 @@ gfc_generate_contained_functions (gfc_namespace * parent) } +/* Set up the tree type for the given symbol to allow the dummy + variable (parameter) to be passed by-value. To do this, the main + idea is to simply remove the extra layer added by Fortran + automatically (the POINTER_TYPE node). This pointer type node + would normally just contain the real type underneath, but we remove + it here and later we change the way the argument is converted for a + function call (trans-expr.c:gfc_conv_function_call). This is the + approach the C compiler takes (or it appears to be this way). When + the middle-end is given the typed node rather than the POINTER_TYPE + node, it knows to pass the value. */ + +static void +set_tree_decl_type_code (gfc_symbol *sym) +{ + /* This should not happen. during the gfc_sym_type function, + when the backend_decl is being built for a dummy arg, if the arg + is pass-by-value then no reference type is wrapped around the + true type (e.g., REAL_TYPE). */ + if (TREE_CODE (TREE_TYPE (sym->backend_decl)) == POINTER_TYPE || + TREE_CODE (TREE_TYPE (sym->backend_decl)) == REFERENCE_TYPE) + TREE_TYPE (sym->backend_decl) = gfc_typenode_for_spec (&sym->ts); + DECL_BY_REFERENCE (sym->backend_decl) = 0; + + /* the tree can't be addressable if it's pass-by-value..? x*/ +/* TREE_TYPE(sym->backend_decl)->common.addressable_flag = 0; */ + + DECL_ARG_TYPE (sym->backend_decl) = TREE_TYPE (sym->backend_decl); + + DECL_MODE (sym->backend_decl) = + TYPE_MODE (TREE_TYPE (sym->backend_decl)); + + return; +} + + /* Drill down through expressions for the array specification bounds and character length calling generate_local_decl for all those variables that have not already been declared. */ @@ -2952,6 +3022,21 @@ generate_local_decl (gfc_symbol * sym) gfc_get_symbol_decl (sym); } } + + if (sym->attr.dummy == 1) + { + /* The sym->backend_decl can be NULL if this is one of the + intrinsic types, such as the symbol of type c_ptr for the + c_f_pointer function, so don't set up the tree code for it. */ + if (sym->attr.value == 1 && sym->backend_decl != NULL) + set_tree_decl_type_code (sym); + } + + /* Make sure we convert the types of the derived types from iso_c_binding + into (void *). */ + if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c + && sym->ts.type == BT_DERIVED) + sym->backend_decl = gfc_typenode_for_spec (&(sym->ts)); } static void diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index d70e4d53888..c9cee1cad34 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2127,8 +2127,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, argss = gfc_walk_expr (e); if (argss == gfc_ss_terminator) - { - parm_kind = SCALAR; + { if (fsym && fsym->attr.value) { gfc_conv_expr (&parmse, e); @@ -2778,6 +2777,12 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, if (!(expr || pointer)) return NULL_TREE; + if (expr != NULL && expr->ts.type == BT_DERIVED + && expr->ts.is_iso_c && expr->ts.derived + && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR + || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)) + expr = gfc_int_expr (0); + if (array) { /* Arrays need special handling. */ @@ -3166,6 +3171,31 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) return; } + /* We need to convert the expressions for the iso_c_binding derived types. + C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to + 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.derived + && expr->ts.derived->attr.is_iso_c) + { + if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR + || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR) + { + /* Set expr_type to EXPR_NULL, which will result in + null_pointer_node being used below. */ + expr->expr_type = EXPR_NULL; + } + else + { + /* 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.derived->ts.type; + expr->ts.f90_type = expr->ts.derived->ts.f90_type; + expr->ts.kind = expr->ts.derived->ts.kind; + } + } + switch (expr->expr_type) { case EXPR_OP: diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index a1a057042d8..00d0ebdfb5b 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -1810,6 +1810,17 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr) gfc_component *c; int kind; + /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if + the user says something like: print *, 'c_null_ptr: ', c_null_ptr + We need to translate the expression to a constant if it's either + C_NULL_PTR or C_NULL_FUNPTR. */ + if (ts->type == BT_DERIVED && ts->is_iso_c == 1 && ts->derived != NULL) + { + ts->type = ts->derived->ts.type; + ts->kind = ts->derived->ts.kind; + ts->f90_type = ts->derived->ts.f90_type; + } + kind = ts->kind; function = NULL; arg2 = NULL; diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 897b4ca18d8..dace23a5bde 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -27,6 +27,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA #include "system.h" #include "coretypes.h" #include "tree.h" +#include "langhooks.h" #include "tm.h" #include "target.h" #include "ggc.h" @@ -48,6 +49,9 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA #error If you really need >99 dimensions, continue the sequence above... #endif +/* array of structs so we don't have to worry about xmalloc or free */ +CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER]; + static tree gfc_get_derived_type (gfc_symbol * derived); tree gfc_array_index_type; @@ -105,6 +109,150 @@ int gfc_charlen_int_kind; int gfc_numeric_storage_size; int gfc_character_storage_size; + +/* Validate that the f90_type of the given gfc_typespec is valid for + the type it represents. The f90_type represents the Fortran types + this C kind can be used with. For example, c_int has a f90_type of + BT_INTEGER and c_float has a f90_type of BT_REAL. Returns FAILURE + if a mismatch occurs between ts->f90_type and ts->type; SUCCESS if + they match. */ + +try +gfc_validate_c_kind (gfc_typespec *ts) +{ + return ((ts->type == ts->f90_type) ? SUCCESS : FAILURE); +} + + +try +gfc_check_any_c_kind (gfc_typespec *ts) +{ + int i; + + for (i = 0; i < ISOCBINDING_NUMBER; i++) + { + /* Check for any C interoperable kind for the given type/kind in ts. + This can be used after verify_c_interop to make sure that the + Fortran kind being used exists in at least some form for C. */ + if (c_interop_kinds_table[i].f90_type == ts->type && + c_interop_kinds_table[i].value == ts->kind) + return SUCCESS; + } + + return FAILURE; +} + + +static int +get_real_kind_from_node (tree type) +{ + int i; + + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type)) + return gfc_real_kinds[i].kind; + + return -4; +} + +static int +get_int_kind_from_node (tree type) +{ + int i; + + if (!type) + return -2; + + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type)) + return gfc_integer_kinds[i].kind; + + return -1; +} + +static int +get_int_kind_from_width (int size) +{ + int i; + + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + if (gfc_integer_kinds[i].bit_size == size) + return gfc_integer_kinds[i].kind; + + return -2; +} + +static int +get_int_kind_from_minimal_width (int size) +{ + int i; + + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + if (gfc_integer_kinds[i].bit_size >= size) + return gfc_integer_kinds[i].kind; + + return -2; +} + + +/* Generate the CInteropKind_t objects for the C interoperable + kinds. */ + +static +void init_c_interop_kinds (void) +{ + int i; + tree intmax_type_node = INT_TYPE_SIZE == LONG_LONG_TYPE_SIZE ? + integer_type_node : + (LONG_TYPE_SIZE == LONG_LONG_TYPE_SIZE ? + long_integer_type_node : + long_long_integer_type_node); + + /* init all pointers in the list to NULL */ + for (i = 0; i < ISOCBINDING_NUMBER; i++) + { + /* Initialize the name and value fields. */ + c_interop_kinds_table[i].name[0] = '\0'; + c_interop_kinds_table[i].value = -100; + c_interop_kinds_table[i].f90_type = BT_UNKNOWN; + } + +#define NAMED_INTCST(a,b,c) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_INTEGER; \ + c_interop_kinds_table[a].value = c; +#define NAMED_REALCST(a,b,c) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_REAL; \ + c_interop_kinds_table[a].value = c; +#define NAMED_CMPXCST(a,b,c) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_COMPLEX; \ + c_interop_kinds_table[a].value = c; +#define NAMED_LOGCST(a,b,c) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_LOGICAL; \ + c_interop_kinds_table[a].value = c; +#define NAMED_CHARKNDCST(a,b,c) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_CHARACTER; \ + c_interop_kinds_table[a].value = c; +#define NAMED_CHARCST(a,b,c) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_CHARACTER; \ + c_interop_kinds_table[a].value = c; +#define DERIVED_TYPE(a,b,c) \ + 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) \ + 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" +} + + /* Query the target to determine which machine modes are available for computation. Choose KIND numbers for them. */ @@ -308,6 +456,9 @@ gfc_init_kinds (void) gfc_index_integer_kind = POINTER_SIZE / 8; /* Pick a kind the same size as the C "int" type. */ gfc_c_int_kind = INT_TYPE_SIZE / 8; + + /* initialize the C interoperable kinds */ + init_c_interop_kinds(); } /* Make sure that a valid kind is present. Returns an index into the @@ -687,7 +838,13 @@ gfc_typenode_for_spec (gfc_typespec * spec) gcc_unreachable (); case BT_INTEGER: - basetype = gfc_get_int_type (spec->kind); + /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol + has been resolved. This is done so we can convert C_PTR and + C_FUNPTR to simple variables that get translated to (void *). */ + if (spec->f90_type == BT_VOID) + basetype = ptr_type_node; + else + basetype = gfc_get_int_type (spec->kind); break; case BT_REAL: @@ -708,8 +865,23 @@ gfc_typenode_for_spec (gfc_typespec * spec) case BT_DERIVED: basetype = gfc_get_derived_type (spec->derived); - break; + /* If we're dealing with either C_PTR or C_FUNPTR, we modified the + 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->derived->attr.is_iso_c) + { + spec->type = spec->derived->ts.type; + spec->kind = spec->derived->ts.kind; + spec->f90_type = spec->derived->ts.f90_type; + } + break; + case BT_VOID: + /* This is for the second arg to c_f_pointer and c_f_procpointer + of the iso_c_binding module, to accept any ptr type. */ + basetype = ptr_type_node; + break; default: gcc_unreachable (); } @@ -1358,8 +1530,10 @@ gfc_sym_type (gfc_symbol * sym) } } else + { type = gfc_build_array_type (type, sym->as); } + } else { if (sym->attr.allocatable || sym->attr.pointer) @@ -1468,12 +1642,25 @@ copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to) static tree gfc_get_derived_type (gfc_symbol * derived) { - tree typenode, field, field_type, fieldlist; + tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL; gfc_component *c; gfc_dt_list *dt; gcc_assert (derived && derived->attr.flavor == FL_DERIVED); + /* See if it's one of the iso_c_binding derived types. */ + if (derived->attr.is_iso_c == 1) + { + derived->backend_decl = ptr_type_node; + derived->ts.kind = gfc_index_integer_kind; + derived->ts.type = BT_INTEGER; + /* Set the f90_type to BT_VOID as a way to recognize something of type + BT_INTEGER that needs to fit a void * for the purpose of the + iso_c_binding derived types. */ + derived->ts.f90_type = BT_VOID; + return derived->backend_decl; + } + /* derived->backend_decl != 0 means we saw it before, but its components' backend_decl may have not been built. */ if (derived->backend_decl) @@ -1506,6 +1693,16 @@ gfc_get_derived_type (gfc_symbol * derived) if (!c->pointer || c->ts.derived->backend_decl == NULL) c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived); + + if (c->ts.derived && c->ts.derived->attr.is_iso_c) + { + /* Need to copy the modified ts from the derived type. The + typespec was modified because C_PTR/C_FUNPTR are translated + into (void *) from derived types. */ + c->ts.type = c->ts.derived->ts.type; + c->ts.kind = c->ts.derived->ts.kind; + c->ts.f90_type = c->ts.derived->ts.f90_type; + } } if (TYPE_FIELDS (derived->backend_decl)) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6c58ee5cbf4..c08ccd90d3d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,104 @@ +2007-07-01 Christopher D. Rickett <crickett@lanl.gov> + + * bind_c_array_params.f03: New files for Fortran 2003 ISO C Binding. + * bind_c_coms.f90: Ditto. + * bind_c_coms_driver.c: Ditto. + * bind_c_dts.f90: Ditto. + * bind_c_dts_2.f03: Ditto. + * bind_c_dts_2_driver.c: Ditto. + * bind_c_dts_3.f03: Ditto. + * bind_c_dts_4.f03: Ditto. + * bind_c_dts_driver.c: Ditto. + * bind_c_implicit_vars.f03: Ditto. + * bind_c_procs.f03: Ditto. + * bind_c_usage_2.f03: Ditto. + * bind_c_usage_3.f03: Ditto. + * bind_c_usage_5.f03: Ditto. + * bind_c_usage_6.f03: Ditto. + * bind_c_usage_7.f03: Ditto. + * bind_c_vars.f90: Ditto. + * bind_c_vars_driver.c: Ditto. + * binding_c_table_15_1.f03: Ditto. + * binding_label_tests.f03: Ditto. + * binding_label_tests_10.f03: Ditto. + * binding_label_tests_10_main.f03: Ditto. + * binding_label_tests_11.f03: Ditto. + * binding_label_tests_11_main.f03: Ditto. + * binding_label_tests_12.f03: Ditto. + * binding_label_tests_13.f03: Ditto. + * binding_label_tests_13_main.f03: Ditto. + * binding_label_tests_14.f03: Ditto. + * binding_label_tests_2.f03: Ditto. + * binding_label_tests_3.f03: Ditto. + * binding_label_tests_4.f03: Ditto. + * binding_label_tests_5.f03: Ditto. + * binding_label_tests_6.f03: Ditto. + * binding_label_tests_7.f03: Ditto. + * binding_label_tests_8.f03: Ditto. + * binding_label_tests_9.f03: Ditto. + * c_assoc.f90: Ditto. + * c_assoc_2.f03: Ditto. + * c_f_pointer_shape_test.f90: Ditto. + * c_f_pointer_tests.f90: Ditto. + * c_f_tests_driver.c: Ditto. + * c_funloc_tests.f03: Ditto. + * c_funloc_tests_2.f03: Ditto. + * c_funloc_tests_3.f03: Ditto. + * c_funloc_tests_3_funcs.c: Ditto. + * c_kind_params.f90: Ditto. + * c_kind_tests_2.f03: Ditto. + * c_kinds.c: Ditto. + * c_loc_driver.c: Ditto. + * c_loc_test.f90: Ditto. + * c_loc_tests_2.f03: Ditto. + * c_loc_tests_2_funcs.c: Ditto. + * c_loc_tests_3.f03: Ditto. + * c_loc_tests_4.f03: Ditto. + * c_loc_tests_5.f03: Ditto. + * c_loc_tests_6.f03: Ditto. + * c_loc_tests_7.f03: Ditto. + * c_loc_tests_8.f03: Ditto. + * c_ptr_tests.f03: Ditto. + * c_ptr_tests_10.f03: Ditto. + * c_ptr_tests_5.f03: Ditto. + * c_ptr_tests_7.f03: Ditto. + * c_ptr_tests_7_driver.c: Ditto. + * c_ptr_tests_8.f03: Ditto. + * c_ptr_tests_8_funcs.c: Ditto. + * c_ptr_tests_9.f03: Ditto. + * c_ptr_tests_driver.c: Ditto. + * c_size_t_driver.c: Ditto. + * c_size_t_test.f03: Ditto. + * com_block_driver.f90: Ditto. + * global_vars_c_init.f90: Ditto. + * global_vars_c_init_driver.c: Ditto. + * global_vars_f90_init.f90: Ditto. + * global_vars_f90_init_driver.c: Ditto. + * interop_params.f03: Ditto. + * iso_c_binding_only.f03: Ditto. + * iso_c_binding_rename_1.f03: Ditto. + * iso_c_binding_rename_1_driver.c: Ditto. + * iso_c_binding_rename_2.f03: Ditto. + * iso_c_binding_rename_2_driver.c: Ditto. + * kind_tests_2.f03: Ditto. + * kind_tests_3.f03: Ditto. + * module_md5_1.f90: Ditto. + * only_clause_main.c: Ditto. + * print_c_kinds.f90: Ditto. + * test_bind_c_parens.f03: Ditto. + * test_c_assoc.c: Ditto. + * test_com_block.f90: Ditto. + * test_common_binding_labels.f03: Ditto. + * test_common_binding_labels_2.f03: Ditto. + * test_common_binding_labels_2_main.f03: Ditto. + * test_common_binding_labels_3.f03: Ditto. + * test_common_binding_labels_3_main.f03: Ditto. + * test_only_clause.f90: Ditto. + * use_iso_c_binding.f90: Ditto. + * value_5.f90: Ditto. + * value_test.f90: Ditto. + * value_tests_f03.f90: Ditto. + 2007-07-01 Daniel Jacobowitz <dan@codesourcery.com> * gcc.dg/tls/opt-14.c: New. diff --git a/gcc/testsuite/gfortran.dg/bind_c_array_params.f03 b/gcc/testsuite/gfortran.dg/bind_c_array_params.f03 new file mode 100644 index 00000000000..6590db1d1d6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_array_params.f03 @@ -0,0 +1,14 @@ +! { dg-do compile } +module bind_c_array_params +use, intrinsic :: iso_c_binding +implicit none + +contains + subroutine sub0(assumed_array) bind(c) ! { dg-error "cannot be an argument" } + integer(c_int), dimension(:) :: assumed_array + end subroutine sub0 + + subroutine sub1(deferred_array) bind(c) ! { dg-error "cannot" } + integer(c_int), pointer :: deferred_array(:) + end subroutine sub1 +end module bind_c_array_params diff --git a/gcc/testsuite/gfortran.dg/bind_c_coms.f90 b/gcc/testsuite/gfortran.dg/bind_c_coms.f90 new file mode 100644 index 00000000000..e88d56d182c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_coms.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! { dg-additional-sources bind_c_coms_driver.c } +! { dg-options "-w" } +! the -w option is to prevent the warning about long long ints +module bind_c_coms + use, intrinsic :: iso_c_binding + implicit none + + common /COM/ R, S + real(c_double) :: r + real(c_double) :: t + real(c_double) :: s + bind(c) :: /COM/, /SINGLE/, /MYCOM/ + common /SINGLE/ T + common /MYCOM/ LONG_INTS + integer(c_long) :: LONG_INTS + common /MYCOM2/ LONG_LONG_INTS + integer(c_long_long) :: long_long_ints + bind(c) :: /mycom2/ + + common /com2/ i, j + integer(c_int) :: i, j + bind(c, name="f03_com2") /com2/ + + common /com3/ m, n + integer(c_int) :: m, n + bind(c, name="") /com3/ + +contains + subroutine test_coms() bind(c) + r = r + .1d0; + s = s + .1d0; + t = t + .1d0; + long_ints = long_ints + 1 + long_long_ints = long_long_ints + 1 + i = i + 1 + j = j + 1 + + m = 1 + n = 1 + end subroutine test_coms +end module bind_c_coms + +module bind_c_coms_2 + use, intrinsic :: iso_c_binding, only: c_int + common /com3/ m, n + integer(c_int) :: m, n + bind(c, name="") /com3/ +end module bind_c_coms_2 + +! { dg-final { cleanup-modules "bind_c_coms bind_c_coms_2" } } diff --git a/gcc/testsuite/gfortran.dg/bind_c_coms_driver.c b/gcc/testsuite/gfortran.dg/bind_c_coms_driver.c new file mode 100644 index 00000000000..c83f22d836f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_coms_driver.c @@ -0,0 +1,42 @@ +double fabs(double); + +void test_coms(void); + +extern void abort(void); + +struct {double r, s; } com; /* refers to the common block "com" */ +double single; /* refers to the common block "single" */ +long int mycom; /* refers to the common block "MYCOM" */ +long long int mycom2; /* refers to the common block "MYCOM2" */ +struct {int i, j; } f03_com2; /* refers to the common block "com2" */ + +int main(int argc, char **argv) +{ + com.r = 1.0; + com.s = 2.0; + single = 1.0; + mycom = 1; + mycom2 = 2; + f03_com2.i = 1; + f03_com2.j = 2; + + /* change the common block variables in F90 */ + test_coms(); + + if(fabs(com.r - 1.1) > 0.00000000) + abort(); + if(fabs(com.s - 2.1) > 0.00000000) + abort(); + if(fabs(single - 1.1) > 0.00000000) + abort(); + if(mycom != 2) + abort(); + if(mycom2 != 3) + abort(); + if(f03_com2.i != 2) + abort(); + if(f03_com2.j != 3) + abort(); + + return 0; +}/* end main() */ diff --git a/gcc/testsuite/gfortran.dg/bind_c_dts.f90 b/gcc/testsuite/gfortran.dg/bind_c_dts.f90 new file mode 100644 index 00000000000..f78630ba560 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_dts.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! { dg-additional-sources bind_c_dts_driver.c } +module bind_c_dts + use, intrinsic :: iso_c_binding + implicit none + + type, bind(c) :: MYFTYPE_1 + integer(c_int) :: i, j + real(c_float) :: s + end type MYFTYPE_1 + + TYPE, BIND(C) :: particle + REAL(C_DOUBLE) :: x,vx + REAL(C_DOUBLE) :: y,vy + REAL(C_DOUBLE) :: z,vz + REAL(C_DOUBLE) :: m + END TYPE particle + + type(myftype_1), bind(c, name="myDerived") :: myDerived + +contains + subroutine types_test(my_particles, num_particles) bind(c) + integer(c_int), value :: num_particles + type(particle), dimension(num_particles) :: my_particles + integer :: i + + ! going to set the particle in the middle of the list + i = num_particles / 2; + my_particles(i)%x = my_particles(i)%x + .2d0 + my_particles(i)%vx = my_particles(i)%vx + .2d0 + my_particles(i)%y = my_particles(i)%y + .2d0 + my_particles(i)%vy = my_particles(i)%vy + .2d0 + my_particles(i)%z = my_particles(i)%z + .2d0 + my_particles(i)%vz = my_particles(i)%vz + .2d0 + my_particles(i)%m = my_particles(i)%m + .2d0 + + myDerived%i = myDerived%i + 1 + myDerived%j = myDerived%j + 1 + myDerived%s = myDerived%s + 1.0; + end subroutine types_test +end module bind_c_dts diff --git a/gcc/testsuite/gfortran.dg/bind_c_dts_2.f03 b/gcc/testsuite/gfortran.dg/bind_c_dts_2.f03 new file mode 100644 index 00000000000..4e5e61b4ee8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_dts_2.f03 @@ -0,0 +1,61 @@ +! { dg-do run } +! { dg-additional-sources bind_c_dts_2_driver.c } +module bind_c_dts_2 +use, intrinsic :: iso_c_binding +implicit none + +type, bind(c) :: my_c_type_0 + integer(c_int) :: i + type(c_ptr) :: nested_c_address + integer(c_int) :: array(3) +end type my_c_type_0 + +type, bind(c) :: my_c_type_1 + type(my_c_type_0) :: my_nested_type + type(c_ptr) :: c_address + integer(c_int) :: j +end type my_c_type_1 + +contains + subroutine sub0(my_type, expected_i, expected_nested_c_address, & + expected_array_1, expected_array_2, expected_array_3, & + expected_c_address, expected_j) bind(c) + type(my_c_type_1) :: my_type + integer(c_int), value :: expected_i + type(c_ptr), value :: expected_nested_c_address + integer(c_int), value :: expected_array_1 + integer(c_int), value :: expected_array_2 + integer(c_int), value :: expected_array_3 + type(c_ptr), value :: expected_c_address + integer(c_int), value :: expected_j + + if (my_type%my_nested_type%i .ne. expected_i) then + call abort () + end if + + if (.not. c_associated(my_type%my_nested_type%nested_c_address, & + expected_nested_c_address)) then + call abort () + end if + + if (my_type%my_nested_type%array(1) .ne. expected_array_1) then + call abort () + end if + + if (my_type%my_nested_type%array(2) .ne. expected_array_2) then + call abort () + end if + + if (my_type%my_nested_type%array(3) .ne. expected_array_3) then + call abort () + end if + + if (.not. c_associated(my_type%c_address, expected_c_address)) then + call abort () + end if + + if (my_type%j .ne. expected_j) then + call abort () + end if + end subroutine sub0 +end module bind_c_dts_2 diff --git a/gcc/testsuite/gfortran.dg/bind_c_dts_2_driver.c b/gcc/testsuite/gfortran.dg/bind_c_dts_2_driver.c new file mode 100644 index 00000000000..53d26794e3f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_dts_2_driver.c @@ -0,0 +1,37 @@ +typedef struct c_type_0 +{ + int i; + int *ptr; + int array[3]; +}c_type_0_t; + +typedef struct c_type_1 +{ + c_type_0_t nested_type; + int *ptr; + int j; +}c_type_1_t; + +void sub0(c_type_1_t *c_type, int expected_i, int *expected_nested_ptr, + int array_0, int array_1, int array_2, + int *expected_ptr, int expected_j); + +int main(int argc, char **argv) +{ + c_type_1_t c_type; + + c_type.nested_type.i = 10; + c_type.nested_type.ptr = &(c_type.nested_type.i); + c_type.nested_type.array[0] = 1; + c_type.nested_type.array[1] = 2; + c_type.nested_type.array[2] = 3; + c_type.ptr = &(c_type.j); + c_type.j = 11; + + sub0(&c_type, c_type.nested_type.i, c_type.nested_type.ptr, + c_type.nested_type.array[0], + c_type.nested_type.array[1], c_type.nested_type.array[2], + c_type.ptr, c_type.j); + + return 0; +} diff --git a/gcc/testsuite/gfortran.dg/bind_c_dts_3.f03 b/gcc/testsuite/gfortran.dg/bind_c_dts_3.f03 new file mode 100644 index 00000000000..6c6da9f5785 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_dts_3.f03 @@ -0,0 +1,39 @@ +! { dg-do compile } +module bind_c_dts_3 +use, intrinsic :: iso_c_binding +implicit none + +TYPE, bind(c) :: t + integer(c_int) :: i +end type t + +type :: my_c_type_0 ! { dg-error "must have the BIND attribute" } + integer(c_int) :: i +end type my_c_type_0 + +type, bind(c) :: my_c_type_1 ! { dg-error "BIND.C. derived type" } + type(my_c_type_0) :: my_nested_type + type(c_ptr) :: c_address + integer(c_int), pointer :: j ! { dg-error "cannot have the POINTER" } +end type my_c_type_1 + +type, bind(c) :: t2 ! { dg-error "BIND.C. derived type" } + type (t2), pointer :: next ! { dg-error "cannot have the POINTER" } +end type t2 + +type, bind(c):: t3 ! { dg-error "BIND.C. derived type" } + type(t), allocatable :: c(:) ! { dg-error "cannot have the ALLOCATABLE" } +end type t3 + +contains + subroutine sub0(my_type, expected_value) bind(c) ! { dg-error "is not C interoperable" } + type(my_c_type_1) :: my_type + integer(c_int), value :: expected_value + + if (my_type%my_nested_type%i .ne. expected_value) then + call abort () + end if + end subroutine sub0 +end module bind_c_dts_3 + +! { dg-final { cleanup-modules "bind_c_dts_3" } } diff --git a/gcc/testsuite/gfortran.dg/bind_c_dts_4.f03 b/gcc/testsuite/gfortran.dg/bind_c_dts_4.f03 new file mode 100644 index 00000000000..b2eb5694f1c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_dts_4.f03 @@ -0,0 +1,10 @@ +! { dg-do compile } +module test +use iso_c_binding, only: c_int + type, bind(c) :: foo + integer :: p ! { dg-warning "may not be C interoperable" } + end type + type(foo), bind(c) :: cp +end module test + +! { dg-final { cleanup-modules "test" } } diff --git a/gcc/testsuite/gfortran.dg/bind_c_dts_driver.c b/gcc/testsuite/gfortran.dg/bind_c_dts_driver.c new file mode 100644 index 00000000000..bf076ce4a40 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_dts_driver.c @@ -0,0 +1,66 @@ +double fabs (double); + +/* interops with myftype_1 */ +typedef struct { + int m, n; + float r; +} myctype_t; + +/* interops with particle in f90 */ +typedef struct particle +{ + double x; /* x position */ + double vx; /* velocity in x direction */ + double y; /* y position */ + double vy; /* velocity in y direction */ + double z; /* z position */ + double vz; /* velocity in z direction */ + double m; /* mass */ +}particle_t; + +extern void abort(void); +void types_test(particle_t *my_particles, int num_particles); +/* declared in the fortran module bind_c_dts */ +extern myctype_t myDerived; + +int main(int argc, char **argv) +{ + particle_t my_particles[100]; + + /* the fortran code will modify the middle particle */ + my_particles[49].x = 1.0; + my_particles[49].vx = 1.0; + my_particles[49].y = 1.0; + my_particles[49].vy = 1.0; + my_particles[49].z = 1.0; + my_particles[49].vz = 1.0; + my_particles[49].m = 1.0; + + myDerived.m = 1; + myDerived.n = 2; + myDerived.r = 3.0; + + types_test(&(my_particles[0]), 100); + + if(fabs(my_particles[49].x - 1.2) > 0.00000000) + abort(); + if(fabs(my_particles[49].vx - 1.2) > 0.00000000) + abort(); + if(fabs(my_particles[49].y - 1.2) > 0.00000000) + abort(); + if(fabs(my_particles[49].vy - 1.2) > 0.00000000) + abort(); + if(fabs(my_particles[49].z - 1.2) > 0.00000000) + abort(); + if(fabs(my_particles[49].vz - 1.2) > 0.00000000) + abort(); + if(fabs(my_particles[49].m - 1.2) > 0.00000000) + abort(); + if(myDerived.m != 2) + abort(); + if(myDerived.n != 3) + abort(); + if(fabs(myDerived.r - 4.0) > 0.00000000) + abort(); + return 0; +}/* end main() */ diff --git a/gcc/testsuite/gfortran.dg/bind_c_implicit_vars.f03 b/gcc/testsuite/gfortran.dg/bind_c_implicit_vars.f03 new file mode 100644 index 00000000000..ff284ce3346 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_implicit_vars.f03 @@ -0,0 +1,10 @@ +! { dg-do compile } +module bind_c_implicit_vars + +bind(c) :: j ! { dg-warning "may not be C interoperable" } + +contains + subroutine sub0(i) bind(c) ! { dg-warning "may not be C interoperable" } + i = 0 + end subroutine sub0 +end module bind_c_implicit_vars diff --git a/gcc/testsuite/gfortran.dg/bind_c_procs.f03 b/gcc/testsuite/gfortran.dg/bind_c_procs.f03 new file mode 100644 index 00000000000..718042bafcb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_procs.f03 @@ -0,0 +1,39 @@ +! { dg-do compile } +module bind_c_procs + use, intrinsic :: iso_c_binding, only: c_int + + interface + ! warning for my_param possibly not being C interoperable + subroutine my_c_sub(my_param) bind(c) ! { dg-warning "may not be C interoperable" } + integer, value :: my_param + end subroutine my_c_sub + + ! warning for my_c_func possibly not being a C interoperable kind + ! warning for my_param possibly not being C interoperable + ! error message truncated to provide an expression that both warnings + ! should match. + function my_c_func(my_param) bind(c) ! { dg-warning "may not be" } + integer, value :: my_param + integer :: my_c_func + end function my_c_func + end interface + +contains + ! warning for my_param possibly not being C interoperable + subroutine my_f03_sub(my_param) bind(c) ! { dg-warning "may not be" } + integer, value :: my_param + end subroutine my_f03_sub + + ! warning for my_f03_func possibly not being a C interoperable kind + ! warning for my_param possibly not being C interoperable + ! error message truncated to provide an expression that both warnings + ! should match. + function my_f03_func(my_param) bind(c) ! { dg-warning "may not be" } + integer, value :: my_param + integer :: my_f03_func + my_f03_func = 1 + end function my_f03_func + +end module bind_c_procs + +! { dg-final { cleanup-modules "bind_c_procs" } } diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_2.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_2.f03 new file mode 100644 index 00000000000..e76215e7f2b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_usage_2.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +use, intrinsic :: iso_c_binding +type, bind(c) :: mytype + integer(c_int) :: j +end type mytype + +type(mytype), bind(c) :: mytype_var ! { dg-error "cannot be BIND.C." } + +integer(c_int), bind(c) :: i ! { dg-error "cannot be declared with BIND.C." } +integer(c_int), bind(c), dimension(10) :: my_array ! { dg-error "cannot be BIND.C." } + +common /COM/ i +bind(c) :: /com/ + +end diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_3.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_3.f03 new file mode 100644 index 00000000000..47f9d9a9218 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_usage_3.f03 @@ -0,0 +1,19 @@ +! { dg-do compile } +module test + use, intrinsic :: iso_c_binding + + type, bind(c) :: my_c_type ! { dg-error "BIND.C. derived type" } + integer(c_int), pointer :: ptr ! { dg-error "cannot have the POINTER attribute" } + end type my_c_type + + type, bind(c) :: my_type ! { dg-error "BIND.C. derived type" } + integer(c_int), allocatable :: ptr(:) ! { dg-error "cannot have the ALLOCATABLE attribute" } + end type my_type + + type foo ! { dg-error "must have the BIND attribute" } + integer(c_int) :: p + end type foo + + type(foo), bind(c) :: cp ! { dg-error "is not C interoperable" } + real(c_double), pointer,bind(c) :: p ! { dg-error "cannot have both the POINTER and BIND.C." } +end module test diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_5.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_5.f03 new file mode 100644 index 00000000000..95afa010fb1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_usage_5.f03 @@ -0,0 +1,8 @@ +! { dg-do compile } +module bind_c_usage_5 +use, intrinsic :: iso_c_binding + +bind(c) c3, c4 +integer(c_int), bind(c) :: c3 ! { dg-error "Duplicate BIND attribute" } +integer(c_int) :: c4 +end module bind_c_usage_5 diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_6.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_6.f03 new file mode 100644 index 00000000000..924dd40bc69 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_usage_6.f03 @@ -0,0 +1,48 @@ +! { dg-do compile } +module x + use iso_c_binding + bind(c) :: test, sub1 ! { dg-error "only be used for variables or common blocks" } + bind(c) :: sub2 ! { dg-error "only be used for variables or common blocks" } +contains + function foo() bind(c,name="xx") + integer(c_int),bind(c,name="xy") :: foo ! { dg-error "only be used for variables or common blocks" } + ! NAG f95: "BIND(C) for non-variable FOO" + ! g95: "Duplicate BIND attribute specified" + ! gfortran: Accepted + foo = 5_c_int + end function foo + + function test() + integer(c_int) :: test + bind(c,name="kk") :: test ! { dg-error "only be used for variables or common blocks" } + ! NAG f95: "BIND(C) for non-variable TEST" + ! gfortran, g95: Accepted + test = 5_c_int + end function test + + function bar() bind(c) + integer(c_int) :: bar + bind(c,name="zx") :: bar ! { dg-error "only be used for variables or common blocks" } + bar = 5_c_int + end function bar + + subroutine sub0() bind(c) + bind(c) :: sub0 ! { dg-error "only be used for variables or common blocks" } + end subroutine sub0 + + subroutine sub1(i) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int), value :: i + end subroutine sub1 + + subroutine sub2(i) + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int), value :: i + end subroutine sub2 + + subroutine sub3(i) + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int), value :: i + bind(c) :: sub3 ! { dg-error "only be used for variables or common blocks" } + end subroutine sub3 +end module x diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_7.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_7.f03 new file mode 100644 index 00000000000..845aab95322 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_usage_7.f03 @@ -0,0 +1,16 @@ +! { dg-do compile } +module x + use iso_c_binding + implicit none +contains + function bar() bind(c) ! { dg-error "cannot be an array" } + integer(c_int) :: bar(5) + end function bar + + function my_string_func() bind(c) ! { dg-error "cannot be a character string" } + character(kind=c_char, len=10) :: my_string_func + my_string_func = 'my_string' // C_NULL_CHAR + end function my_string_func +end module x + +! { dg-final { cleanup-modules "x" } } diff --git a/gcc/testsuite/gfortran.dg/bind_c_vars.f90 b/gcc/testsuite/gfortran.dg/bind_c_vars.f90 new file mode 100644 index 00000000000..4f4a0cfd795 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_vars.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-additional-sources bind_c_vars_driver.c } +module bind_c_vars + use, intrinsic :: iso_c_binding + implicit none + + integer(c_int), bind(c) :: myF90Int + real(c_float), bind(c, name="myF90Real") :: f90_real + integer(c_int) :: c2 + integer(c_int) :: c3 + integer(c_int) :: c4 + bind(c, name="myVariable") :: c2 + bind(c) c3, c4 + + integer(c_int), bind(c, name="myF90Array3D") :: A(18, 3:7, 10) + integer(c_int), bind(c, name="myF90Array2D") :: B(3, 2) + +contains + + subroutine changeF90Globals() bind(c, name='changeF90Globals') + implicit none + ! should make it 2 + myF90Int = myF90Int + 1 + ! should make it 3.0 + f90_real = f90_real * 3.0; + ! should make it 4 + c2 = c2 * 2; + ! should make it 6 + c3 = c3 + 3; + ! should make it 2 + c4 = c4 / 2; + ! should make it 2 + A(5, 6, 3) = A(5, 6, 3) + 1 + ! should make it 3 + B(3, 2) = B(3, 2) + 1 + end subroutine changeF90Globals + +end module bind_c_vars diff --git a/gcc/testsuite/gfortran.dg/bind_c_vars_driver.c b/gcc/testsuite/gfortran.dg/bind_c_vars_driver.c new file mode 100644 index 00000000000..2af800a15c2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_vars_driver.c @@ -0,0 +1,46 @@ +double fabs (double); + +/* defined in fortran module bind_c_vars */ +void changeF90Globals(void); + +extern void abort(void); + +/* module level scope in bind_c_vars */ +extern int myf90int; /* myf90int in bind_c_vars */ +float myF90Real; /* f90_real in bind_c_vars */ +int myF90Array3D[10][5][18]; /* A in bind_c_vars */ +int myF90Array2D[2][3]; /* B in bind_c_vars */ +int myVariable; /* c2 in bind_c_vars */ +int c3; /* c3 in bind_c_vars */ +int c4; /* c4 in bind_c_vars */ + +int main(int argc, char **argv) +{ + myf90int = 1; + myF90Real = 1.0; + myVariable = 2; + c3 = 3; + c4 = 4; + myF90Array3D[2][3][4] = 1; + myF90Array2D[1][2] = 2; + + /* will change the global vars initialized above */ + changeF90Globals(); + + if(myf90int != 2) + abort(); + if(fabs(myF90Real-3.0) > 0.00000000) + abort(); + if(myVariable != 4) + abort(); + if(c3 != 6) + abort(); + if(c4 != 2) + abort(); + if(myF90Array3D[2][3][4] != 2) + abort(); + if(myF90Array2D[1][2] != 3) + abort(); + + return 0; +}/* end main() */ diff --git a/gcc/testsuite/gfortran.dg/binding_c_table_15_1.f03 b/gcc/testsuite/gfortran.dg/binding_c_table_15_1.f03 new file mode 100644 index 00000000000..a5573092d85 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_c_table_15_1.f03 @@ -0,0 +1,14 @@ +! { dg-do run } +! Test the named constants in Table 15.1. +program a + use, intrinsic :: iso_c_binding + implicit none + if (C_NULL_CHAR /= CHAR(0) ) call abort + if (C_ALERT /= ACHAR(7) ) call abort + if (C_BACKSPACE /= ACHAR(8) ) call abort + if (C_FORM_FEED /= ACHAR(12)) call abort + if (C_NEW_LINE /= ACHAR(10)) call abort + if (C_CARRIAGE_RETURN /= ACHAR(13)) call abort + if (C_HORIZONTAL_TAB /= ACHAR(9) ) call abort + if (C_VERTICAL_TAB /= ACHAR(11)) call abort +end program a diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests.f03 new file mode 100644 index 00000000000..34986501e29 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests.f03 @@ -0,0 +1,77 @@ +! { dg-do compile } +module binding_label_tests + use, intrinsic :: iso_c_binding + implicit none + + contains + + subroutine c_sub() BIND(c, name = "C_Sub") + print *, 'hello from c_sub' + end subroutine c_sub + + integer(c_int) function c_func() bind(C, name="__C_funC") + print *, 'hello from c_func' + c_func = 1 + end function c_func + + real(c_float) function f90_func() + print *, 'hello from f90_func' + f90_func = 1.0 + end function f90_func + + real(c_float) function c_real_func() bind(c) + print *, 'hello from c_real_func' + c_real_func = 1.5 + end function c_real_func + + integer function f90_func_0() result ( f90_func_0_result ) + print *, 'hello from f90_func_0' + f90_func_0_result = 0 + end function f90_func_0 + + integer(c_int) function f90_func_1() result ( f90_func_1_result ) bind(c, name="__F90_Func_1__") + print *, 'hello from f90_func_1' + f90_func_1_result = 1 + end function f90_func_1 + + integer(c_int) function f90_func_3() result ( f90_func_3_result ) bind(c) + print *, 'hello from f90_func_3' + f90_func_3_result = 3 + end function f90_func_3 + + integer(c_int) function F90_func_2() bind(c) result ( f90_func_2_result ) + print *, 'hello from f90_func_2' + f90_func_2_result = 2 + end function f90_func_2 + + integer(c_int) function F90_func_4() bind(c, name="F90_func_4") result ( f90_func_4_result ) + print *, 'hello from f90_func_4' + f90_func_4_result = 4 + end function f90_func_4 + + integer(c_int) function F90_func_5() bind(c, name="F90_func_5") result ( f90_func_5_result ) + print *, 'hello from f90_func_5' + f90_func_5_result = 5 + end function f90_func_5 + + subroutine c_sub_2() bind(c, name='c_sub_2') + print *, 'hello from c_sub_2' + end subroutine c_sub_2 + + subroutine c_sub_3() BIND(c, name = " C_Sub_3 ") + print *, 'hello from c_sub_3' + end subroutine c_sub_3 + + subroutine c_sub_5() BIND(c, name = "C_Sub_5 ") + print *, 'hello from c_sub_5' + end subroutine c_sub_5 + + ! nothing between the quotes except spaces, so name="". + ! the name will get set to the regularly mangled version of the name. + ! perhaps it should be marked with some characters that are invalid for + ! C names so C can not call it? + subroutine sub4() BIND(c, name = " ") + end subroutine sub4 +end module binding_label_tests + +! { dg-final { cleanup-modules "binding_label_tests" } } diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_10.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_10.f03 new file mode 100644 index 00000000000..99c9c527624 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_10.f03 @@ -0,0 +1,10 @@ +! { dg-do compile } +! This file must be compiled BEFORE binding_label_tests_10_main.f03, which it +! should be because dejagnu will sort the files. +module binding_label_tests_10 + use iso_c_binding + implicit none + integer(c_int), bind(c,name="c_one") :: one +end module binding_label_tests_10 + +! Do not use dg-final to cleanup-modules diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_10_main.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_10_main.f03 new file mode 100644 index 00000000000..aa24a6ac1d6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_10_main.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +! This file must be compiled AFTER binding_label_tests_10.f03, which it +! should be because dejagnu will sort the files. +module binding_label_tests_10_main + use iso_c_binding + implicit none + integer(c_int), bind(c,name="c_one") :: one ! { dg-error "collides" } +end module binding_label_tests_10_main + +program main + use binding_label_tests_10 ! { dg-error "collides" } + use binding_label_tests_10_main +end program main + +! { dg-final { cleanup-modules "binding_label_tests_10_main binding_label_tests_10" } } diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_11.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_11.f03 new file mode 100644 index 00000000000..5e889a7886e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_11.f03 @@ -0,0 +1,14 @@ +! { dg-do compile } +! This file must be compiled BEFORE binding_label_tests_11_main.f03, which it +! should be because dejagnu will sort the files. +module binding_label_tests_11 + use iso_c_binding, only: c_int + implicit none +contains + function one() bind(c, name="c_one") + integer(c_int) one + one = 1 + end function one +end module binding_label_tests_11 + +! Do not use dg-final to cleanup-modules diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_11_main.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_11_main.f03 new file mode 100644 index 00000000000..53eac7cf546 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_11_main.f03 @@ -0,0 +1,19 @@ +! { dg-do compile } +! This file must be compiled AFTER binding_label_tests_11.f03, which it +! should be because dejagnu will sort the files. +module binding_label_tests_11_main + use iso_c_binding, only: c_int + implicit none +contains + function one() bind(c, name="c_one") ! { dg-error "collides" } + integer(c_int) one + one = 1 + end function one +end module binding_label_tests_11_main + +program main + use binding_label_tests_11 ! { dg-error "collides" } + use binding_label_tests_11_main +end program main + +! { dg-final { cleanup-modules "binding_label_tests_11_main binding_label_tests_11" } } diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_12.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_12.f03 new file mode 100644 index 00000000000..0a000668115 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_12.f03 @@ -0,0 +1,24 @@ +! { dg-do run } +! This verifies that the compiler will correctly accpet the name="", write out +! an empty string for the binding label to the module file, and then read it +! back in. Also, during gfc_verify_binding_labels, the name="" will prevent +! any verification (since there is no label to verify). +module one +contains + subroutine foo() bind(c) + end subroutine foo +end module one + +module two +contains + ! This procedure is only used accessed in C + ! as procedural pointer + subroutine foo() bind(c, name="") + end subroutine foo +end module two + +use one, only: foo_one => foo +use two, only: foo_two => foo +end + +! { dg-final { cleanup-modules "one two" } } diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_13.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_13.f03 new file mode 100644 index 00000000000..786945d3af7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_13.f03 @@ -0,0 +1,8 @@ +! { dg-do compile } +! This file must be compiled BEFORE binding_label_tests_13_main.f03, which it +! should be because dejagnu will sort the files. +module binding_label_tests_13 + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int) :: c3 + bind(c) c3 +end module binding_label_tests_13 diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_13_main.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_13_main.f03 new file mode 100644 index 00000000000..1addc9c495c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_13_main.f03 @@ -0,0 +1,16 @@ +! { dg-do compile } +! This file must be compiled AFTER binding_label_tests_13.f03, which it +! should be because dejagnu will sort the files. The module file +! binding_label_tests_13.mod can not be removed until after this test is done. +module binding_label_tests_13_main + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int) :: c3 ! { dg-error "collides" } + bind(c) c3 + +contains + subroutine c_sub() BIND(c, name = "C_Sub") + use binding_label_tests_13 ! { dg-error "collides" } + end subroutine c_sub +end module binding_label_tests_13_main +! { dg-final { cleanup-modules "binding_label_tests_13 binding_label_tests_13_main" } } + diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_14.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_14.f03 new file mode 100644 index 00000000000..041237bbee5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_14.f03 @@ -0,0 +1,12 @@ +! { dg-do run } +subroutine display() bind(c) + implicit none +end subroutine display + +program main + implicit none + interface + subroutine display() bind(c) + end subroutine display + end interface +end program main diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_2.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_2.f03 new file mode 100644 index 00000000000..bf9da112ab4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_2.f03 @@ -0,0 +1,35 @@ +! { dg-do compile } +module binding_label_tests_2 + +contains + ! this is just here so at least one of the subroutines will be accepted so + ! gfortran doesn't give an Extension warning when using -pedantic-errors + subroutine ok() + end subroutine ok + + subroutine sub0() bind(c, name=" 1") ! { dg-error "Invalid C name" } + end subroutine sub0 ! { dg-error "Expecting END MODULE" } + + subroutine sub1() bind(c, name="$") ! { dg-error "Invalid C name" } + end subroutine sub1 ! { dg-error "Expecting END MODULE" } + + subroutine sub2() bind(c, name="abc$") ! { dg-error "Invalid C name" } + end subroutine sub2 ! { dg-error "Expecting END MODULE" } + + subroutine sub3() bind(c, name="abc d") ! { dg-error "Embedded space" } + end subroutine sub3 ! { dg-error "Expecting END MODULE" } + + subroutine sub5() BIND(C, name=" myvar 2 ") ! { dg-error "Embedded space" } + end subroutine sub5 ! { dg-error "Expecting END MODULE" } + + subroutine sub6() bind(c, name=" ) ! { dg-error "Invalid C name" } + end subroutine sub6 ! { dg-error "Expecting END MODULE" } + + subroutine sub7() bind(c, name=) ! { dg-error "Syntax error" } + end subroutine sub7 ! { dg-error "Expecting END MODULE" } + + subroutine sub8() bind(c, name) ! { dg-error "Syntax error" } + end subroutine sub8 ! { dg-error "Expecting END MODULE" } +end module binding_label_tests_2 + +! { dg-final { cleanup-modules "binding_label_tests_2" } } diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_3.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_3.f03 new file mode 100644 index 00000000000..6e124470251 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_3.f03 @@ -0,0 +1,30 @@ +! { dg-do compile } +program main +use iso_c_binding + interface + subroutine p1(f, a1, a2, a3, a4) bind(c, name='printf') ! { dg-error "collides" } + import :: c_ptr, c_int, c_double + type(c_ptr), value :: f + integer(c_int), value :: a1, a3 + real(c_double), value :: a2, a4 + end subroutine p1 + + subroutine p2(f, a1, a2, a3, a4) bind(c, name='printf') ! { dg-error "collides" } + import :: c_ptr, c_int, c_double + type(c_ptr), value :: f + real(c_double), value :: a1, a3 + integer(c_int), value :: a2, a4 + end subroutine p2 + end interface + + type(c_ptr) :: f_ptr + character(len=20), target :: format + + f_ptr = c_loc(format(1:1)) + + format = 'Hello %d %f %d %f\n' // char(0) + call p1(f_ptr, 10, 1.23d0, 20, 2.46d0) + + format = 'World %f %d %f %d\n' // char(0) + call p2(f_ptr, 1.23d0, 10, 2.46d0, 20) +end program main diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_4.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_4.f03 new file mode 100644 index 00000000000..5a0767d8785 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_4.f03 @@ -0,0 +1,24 @@ +! { dg-do compile } +module A + use, intrinsic :: iso_c_binding +contains + subroutine pA() bind(c, name='printf') ! { dg-error "collides" } + print *, 'hello from pA' + end subroutine pA +end module A + +module B + use, intrinsic :: iso_c_binding + +contains + subroutine pB() bind(c, name='printf') ! { dg-error "collides" } + print *, 'hello from pB' + end subroutine pB +end module B + +module C +use A +use B ! { dg-error "Can't open module file" } +end module C + + diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_5.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_5.f03 new file mode 100644 index 00000000000..c8aa4e86218 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_5.f03 @@ -0,0 +1,12 @@ +! { dg-do compile } +module binding_label_tests_5 + use, intrinsic :: iso_c_binding + + interface + subroutine sub0() bind(c, name='c_sub') ! { dg-error "collides" } + end subroutine sub0 + + subroutine sub1() bind(c, name='c_sub') ! { dg-error "collides" } + end subroutine sub1 + end interface +end module binding_label_tests_5 diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_6.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_6.f03 new file mode 100644 index 00000000000..0784de12e29 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_6.f03 @@ -0,0 +1,6 @@ +! { dg-do compile } +module binding_label_tests_6 + use, intrinsic :: iso_c_binding + integer(c_int), bind(c, name='my_int') :: my_f90_int_1 ! { dg-error "collides" } + integer(c_int), bind(c, name='my_int') :: my_f90_int_2 ! { dg-error "collides" } +end module binding_label_tests_6 diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_7.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_7.f03 new file mode 100644 index 00000000000..1234bb53538 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_7.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +module A + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int), bind(c, name='my_c_print') :: my_int ! { dg-error "collides" } +end module A + +program main +use A +interface + subroutine my_c_print() bind(c) ! { dg-error "collides" } + end subroutine my_c_print +end interface + +call my_c_print() +end program main diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_8.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_8.f03 new file mode 100644 index 00000000000..c49ee625458 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_8.f03 @@ -0,0 +1,9 @@ +! { dg-do compile } +module binding_label_tests_8 + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int), bind(c, name='my_f90_sub') :: my_c_int ! { dg-error "collides" } + +contains + subroutine my_f90_sub() bind(c) ! { dg-error "collides" } + end subroutine my_f90_sub +end module binding_label_tests_8 diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_9.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_9.f03 new file mode 100644 index 00000000000..0f50a08b7e0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_9.f03 @@ -0,0 +1,23 @@ +! { dg-do compile } +module x + use iso_c_binding + implicit none + private :: bar ! { dg-warning "PRIVATE but has been given the binding label" } + private :: my_private_sub + private :: my_private_sub_2 ! { dg-warning "PRIVATE but has been given the binding label" } + public :: my_public_sub +contains + subroutine bar() bind(c,name="foo") + end subroutine bar + + subroutine my_private_sub() bind(c, name="") + end subroutine my_private_sub + + subroutine my_private_sub_2() bind(c) + end subroutine my_private_sub_2 + + subroutine my_public_sub() bind(c, name="my_sub") + end subroutine my_public_sub +end module x + +! { dg-final { cleanup-modules "x" } } diff --git a/gcc/testsuite/gfortran.dg/c_assoc.f90 b/gcc/testsuite/gfortran.dg/c_assoc.f90 new file mode 100644 index 00000000000..9b2af24f984 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_assoc.f90 @@ -0,0 +1,68 @@ +! { dg-do run } +! { dg-additional-sources test_c_assoc.c } +module c_assoc + use, intrinsic :: iso_c_binding + implicit none + +contains + + function test_c_assoc_0(my_c_ptr) bind(c) + use, intrinsic :: iso_c_binding, only: c_ptr, c_int, c_associated + integer(c_int) :: test_c_assoc_0 + type(c_ptr), value :: my_c_ptr + + if(c_associated(my_c_ptr)) then + test_c_assoc_0 = 1 + else + test_c_assoc_0 = 0 + endif + end function test_c_assoc_0 + + function test_c_assoc_1(my_c_ptr_1, my_c_ptr_2) bind(c) + use, intrinsic :: iso_c_binding, only: c_ptr, c_int, c_associated + integer(c_int) :: test_c_assoc_1 + type(c_ptr), value :: my_c_ptr_1 + type(c_ptr), value :: my_c_ptr_2 + + if(c_associated(my_c_ptr_1, my_c_ptr_2)) then + test_c_assoc_1 = 1 + else + test_c_assoc_1 = 0 + endif + end function test_c_assoc_1 + + function test_c_assoc_2(my_c_ptr_1, my_c_ptr_2, num_ptrs) bind(c) + integer(c_int) :: test_c_assoc_2 + type(c_ptr), value :: my_c_ptr_1 + type(c_ptr), value :: my_c_ptr_2 + integer(c_int), value :: num_ptrs + + if(num_ptrs .eq. 1) then + if(c_associated(my_c_ptr_1)) then + test_c_assoc_2 = 1 + else + test_c_assoc_2 = 0 + endif + else + if(c_associated(my_c_ptr_1, my_c_ptr_2)) then + test_c_assoc_2 = 1 + else + test_c_assoc_2 = 0 + endif + endif + end function test_c_assoc_2 + + subroutine verify_assoc(my_c_ptr_1, my_c_ptr_2) bind(c) + type(c_ptr), value :: my_c_ptr_1 + type(c_ptr), value :: my_c_ptr_2 + + if(.not. c_associated(my_c_ptr_1)) then + call abort() + else if(.not. c_associated(my_c_ptr_2)) then + call abort() + else if(.not. c_associated(my_c_ptr_1, my_c_ptr_2)) then + call abort() + endif + end subroutine verify_assoc + +end module c_assoc diff --git a/gcc/testsuite/gfortran.dg/c_assoc_2.f03 b/gcc/testsuite/gfortran.dg/c_assoc_2.f03 new file mode 100644 index 00000000000..9bb2f1b6abc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_assoc_2.f03 @@ -0,0 +1,36 @@ +! { dg-do compile } +module c_assoc_2 + use, intrinsic :: iso_c_binding, only: c_ptr, c_associated + +contains + subroutine sub0(my_c_ptr) bind(c) + type(c_ptr), value :: my_c_ptr + type(c_ptr), pointer :: my_c_ptr_2 + integer :: my_integer + + if(.not. c_associated(my_c_ptr)) then + call abort() + end if + + if(.not. c_associated(my_c_ptr, my_c_ptr)) then + 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" } + call abort() + end if + + if(.not. c_associated()) then ! { dg-error "Missing argument" } + call abort() + end if ! { dg-error "Expecting END SUBROUTINE" } + + if(.not. c_associated(my_c_ptr_2)) then + call abort() + end if + + if(.not. c_associated(my_integer)) then ! { dg-error "Type/rank mismatch" } + call abort() + end if + end subroutine sub0 + +end module c_assoc_2 diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 new file mode 100644 index 00000000000..c6204bdac7f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! verify that the compiler catches the error in the call to c_f_pointer +! because it is missing the required SHAPE parameter. the SHAPE parameter +! is optional, in general, but must exist if given a fortran pointer +! to a non-zero rank object. --Rickett, 09.26.06 +module c_f_pointer_shape_test +contains + subroutine test_0(myAssumedArray, cPtr) + use, intrinsic :: iso_c_binding + integer, dimension(*) :: myAssumedArray + integer, dimension(:), pointer :: myArrayPtr + integer, dimension(1:2), target :: myArray + type(c_ptr), value :: cPtr + + myArrayPtr => myArray + call c_f_pointer(cPtr, myArrayPtr) ! { dg-error "Missing SHAPE parameter" } + end subroutine test_0 +end module c_f_pointer_shape_test + diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests.f90 new file mode 100644 index 00000000000..1e4dbc0201f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests.f90 @@ -0,0 +1,68 @@ +! { dg-do run } +! { dg-additional-sources c_f_tests_driver.c } +module c_f_pointer_tests + use, intrinsic :: iso_c_binding + + type myF90Derived + integer(c_int) :: cInt + real(c_double) :: cDouble + real(c_float) :: cFloat + integer(c_short) :: cShort + type(c_funptr) :: myFunPtr + end type myF90Derived + + type dummyDerived + integer(c_int) :: myInt + end type dummyDerived + + contains + + subroutine testDerivedPtrs(myCDerived, derivedArray, arrayLen, & + derived2DArray, dim1, dim2) & + bind(c, name="testDerivedPtrs") + implicit none + type(c_ptr), value :: myCDerived + type(c_ptr), value :: derivedArray + integer(c_int), value :: arrayLen + type(c_ptr), value :: derived2DArray + integer(c_int), value :: dim1 + integer(c_int), value :: dim2 + type(myF90Derived), pointer :: myF90Type + type(myF90Derived), dimension(:), pointer :: myF90DerivedArray + type(myF90Derived), dimension(:,:), pointer :: derivedArray2D + ! one dimensional array coming in (derivedArray) + integer(c_int), dimension(1:1) :: shapeArray + integer(c_int), dimension(1:2) :: shapeArray2 + type(myF90Derived), dimension(1:10), target :: tmpArray + + call c_f_pointer(myCDerived, myF90Type) + ! make sure numbers are ok. initialized in c_f_tests_driver.c + if(myF90Type%cInt .ne. 1) then + call abort() + endif + if(myF90Type%cDouble .ne. 2.0d0) then + call abort() + endif + if(myF90Type%cFloat .ne. 3.0) then + call abort() + endif + if(myF90Type%cShort .ne. 4) then + call abort() + endif + + shapeArray(1) = arrayLen + call c_f_pointer(derivedArray, myF90DerivedArray, shapeArray) + + ! upper bound of each dim is arrayLen2 + shapeArray2(1) = dim1 + shapeArray2(2) = dim2 + call c_f_pointer(derived2DArray, derivedArray2D, shapeArray2) + ! make sure the last element is ok + if((derivedArray2D(dim1, dim2)%cInt .ne. 4) .or. & + (derivedArray2D(dim1, dim2)%cDouble .ne. 4.0d0) .or. & + (derivedArray2D(dim1, dim2)%cFloat .ne. 4.0) .or. & + (derivedArray2D(dim1, dim2)%cShort .ne. 4)) then + call abort() + endif + end subroutine testDerivedPtrs +end module c_f_pointer_tests diff --git a/gcc/testsuite/gfortran.dg/c_f_tests_driver.c b/gcc/testsuite/gfortran.dg/c_f_tests_driver.c new file mode 100644 index 00000000000..5079cf79900 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_tests_driver.c @@ -0,0 +1,66 @@ +extern void abort(void); + +typedef struct myCDerived +{ + int cInt; + double cDouble; + float cFloat; + short cShort; + void *ptr; +}myCDerived_t; + +#define DERIVED_ARRAY_LEN 10 +#define ARRAY_LEN_2 3 +#define DIM1 2 +#define DIM2 3 + +void testDerivedPtrs(myCDerived_t *cDerivedPtr, + myCDerived_t *derivedArray, int arrayLen, + myCDerived_t *derived2d, int dim1, int dim2); + +int main(int argc, char **argv) +{ + myCDerived_t cDerived; + myCDerived_t derivedArray[DERIVED_ARRAY_LEN]; + myCDerived_t derived2DArray[DIM1][DIM2]; + int i = 0; + int j = 0; + + cDerived.cInt = 1; + cDerived.cDouble = 2.0; + cDerived.cFloat = 3.0; + cDerived.cShort = 4; +/* cDerived.ptr = NULL; */ + /* nullify the ptr */ + cDerived.ptr = 0; + + for(i = 0; i < DERIVED_ARRAY_LEN; i++) + { + derivedArray[i].cInt = (i+1) * 1; + derivedArray[i].cDouble = (i+1) * 1.0; /* 2.0; */ + derivedArray[i].cFloat = (i+1) * 1.0; /* 3.0; */ + derivedArray[i].cShort = (i+1) * 1; /* 4; */ +/* derivedArray[i].ptr = NULL; */ + derivedArray[i].ptr = 0; + } + + for(i = 0; i < DIM1; i++) + { + for(j = 0; j < DIM2; j++) + { + derived2DArray[i][j].cInt = ((i*DIM1) * 1) + j; + derived2DArray[i][j].cDouble = ((i*DIM1) * 1.0) + j; + derived2DArray[i][j].cFloat = ((i*DIM1) * 1.0) + j; + derived2DArray[i][j].cShort = ((i*DIM1) * 1) + j; +/* derived2DArray[i][j].ptr = NULL; */ + derived2DArray[i][j].ptr = 0; + } + } + + /* send in the transpose size (dim2 is dim1, dim1 is dim2) */ + testDerivedPtrs(&cDerived, derivedArray, DERIVED_ARRAY_LEN, + derived2DArray[0], DIM2, DIM1); + + return 0; +}/* end main() */ + diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests.f03 new file mode 100644 index 00000000000..c34ef2b6f49 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests.f03 @@ -0,0 +1,21 @@ +! { dg-do run } +! This test case simply checks that c_funloc exists, accepts arguments of +! flavor FL_PROCEDURE, and returns the type c_funptr +module c_funloc_tests + use, intrinsic :: iso_c_binding, only: c_funptr, c_funloc + +contains + subroutine sub0() bind(c) + type(c_funptr) :: my_c_funptr + + my_c_funptr = c_funloc(sub0) + end subroutine sub0 +end module c_funloc_tests + +program driver + use c_funloc_tests + + call sub0() +end program driver + +! { dg-final { cleanup-modules "c_funloc_tests" } } diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03 new file mode 100644 index 00000000000..afaf29fc896 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03 @@ -0,0 +1,16 @@ +! { dg-do compile } +module c_funloc_tests_2 + use, intrinsic :: iso_c_binding, only: c_funptr, c_funloc + implicit none + +contains + subroutine sub0() bind(c) + type(c_funptr) :: my_c_funptr + integer :: my_local_variable + + my_c_funptr = c_funloc() ! { dg-error "Missing argument" } + 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" } + end subroutine sub0 +end module c_funloc_tests_2 diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_3.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests_3.f03 new file mode 100644 index 00000000000..2d23efb243a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_3.f03 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-additional-sources c_funloc_tests_3_funcs.c } +! This testcase tests c_funloc and c_funptr from iso_c_binding. It uses +! functions defined in c_funloc_tests_3_funcs.c. +module c_funloc_tests_3 + implicit none +contains + function ffunc(j) bind(c) + use iso_c_binding, only: c_funptr, c_int + integer(c_int) :: ffunc + integer(c_int), value :: j + ffunc = -17*j + end function ffunc +end module c_funloc_tests_3 +program main + use iso_c_binding, only: c_funptr, c_funloc + use c_funloc_tests_3, only: ffunc + implicit none + interface + function returnFunc() bind(c,name="returnFunc") + use iso_c_binding, only: c_funptr + type(c_funptr) :: returnFunc + end function returnFunc + subroutine callFunc(func,pass,compare) bind(c,name="callFunc") + use iso_c_binding, only: c_funptr, c_int + type(c_funptr), value :: func + integer(c_int), value :: pass,compare + end subroutine callFunc + end interface + type(c_funptr) :: p + p = returnFunc() + call callFunc(p, 13,3*13) + p = c_funloc(ffunc) + call callFunc(p, 21,-17*21) +end program main +! { dg-final { cleanup-modules "c_funloc_tests_3" } } diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_3_funcs.c b/gcc/testsuite/gfortran.dg/c_funloc_tests_3_funcs.c new file mode 100644 index 00000000000..994da0a505d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_3_funcs.c @@ -0,0 +1,25 @@ +/* These functions support the test case c_funloc_tests_3. */ +#include <stdlib.h> +#include <stdio.h> + +int printIntC(int i) +{ + return 3*i; +} + +int (*returnFunc(void))(int) +{ + return &printIntC; +} + +void callFunc(int(*func)(int), int pass, int compare) +{ + int result = (*func)(pass); + if(result != compare) + { + printf("FAILED: Got %d, expected %d\n", result, compare); + abort(); + } + else + printf("SUCCESS: Got %d, expected %d\n", result, compare); +} diff --git a/gcc/testsuite/gfortran.dg/c_kind_params.f90 b/gcc/testsuite/gfortran.dg/c_kind_params.f90 new file mode 100644 index 00000000000..a7e577a9e17 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_kind_params.f90 @@ -0,0 +1,76 @@ +! { dg-do run } +! { dg-additional-sources c_kinds.c } +! { dg-options "-w -std=c99" } +! the -w option is needed to make f951 not report a warning for +! the -std=c99 option that the C file needs. +! +! Note: int_fast*_t currently not supported, cf. PR 448. +module c_kind_params + use, intrinsic :: iso_c_binding + implicit none + +contains + subroutine param_test(my_short, my_int, my_long, my_long_long, & + my_int8_t, my_int_least8_t, my_int16_t, & + my_int_least16_t, my_int32_t, my_int_least32_t, & + my_int64_t, my_int_least64_t, & + my_intmax_t, my_intptr_t, my_float, my_double, my_long_double, & + my_char, my_bool) bind(c) + integer(c_short), value :: my_short + integer(c_int), value :: my_int + integer(c_long), value :: my_long + integer(c_long_long), value :: my_long_long + integer(c_int8_t), value :: my_int8_t + integer(c_int_least8_t), value :: my_int_least8_t +! integer(c_int_fast8_t), value :: my_int_fast8_t + integer(c_int16_t), value :: my_int16_t + integer(c_int_least16_t), value :: my_int_least16_t +! integer(c_int_fast16_t), value :: my_int_fast16_t + integer(c_int32_t), value :: my_int32_t + integer(c_int_least32_t), value :: my_int_least32_t +! integer(c_int_fast32_t), value :: my_int_fast32_t + integer(c_int64_t), value :: my_int64_t + integer(c_int_least64_t), value :: my_int_least64_t +! integer(c_int_fast64_t), value :: my_int_fast64_t + integer(c_intmax_t), value :: my_intmax_t + integer(c_intptr_t), value :: my_intptr_t + real(c_float), value :: my_float + real(c_double), value :: my_double + real(c_long_double), value :: my_long_double + character(c_char), value :: my_char + logical(c_bool), value :: my_bool + + if(my_short /= 1_c_short) call abort() + if(my_int /= 2_c_int) call abort() + if(my_long /= 3_c_long) call abort() + if(my_long_long /= 4_c_long_long) call abort() + + if(my_int8_t /= 1_c_int8_t) call abort() + if(my_int_least8_t /= 2_c_int_least8_t ) call abort() + print *, 'c_int_fast8_t is: ', c_int_fast8_t + + if(my_int16_t /= 1_c_int16_t) call abort() + if(my_int_least16_t /= 2_c_int_least16_t) call abort() + print *, 'c_int_fast16_t is: ', c_int_fast16_t + + if(my_int32_t /= 1_c_int32_t) call abort() + if(my_int_least32_t /= 2_c_int_least32_t) call abort() + print *, 'c_int_fast32_t is: ', c_int_fast32_t + + if(my_int64_t /= 1_c_int64_t) call abort() + if(my_int_least64_t /= 2_c_int_least64_t) call abort() + print *, 'c_int_fast64_t is: ', c_int_fast64_t + + if(my_intmax_t /= 1_c_intmax_t) call abort() + if(my_intptr_t /= 0_c_intptr_t) call abort() + + if(my_float /= 1.0_c_float) call abort() + if(my_double /= 2.0_c_double) call abort() + if(my_long_double /= 3.0_c_long_double) call abort() + + if(my_char /= c_char_'y') call abort() + if(my_bool .neqv. .true._c_bool) call abort() + end subroutine param_test + +end module c_kind_params +! { dg-final { cleanup-modules "c_kind_params" } } diff --git a/gcc/testsuite/gfortran.dg/c_kind_tests_2.f03 b/gcc/testsuite/gfortran.dg/c_kind_tests_2.f03 new file mode 100644 index 00000000000..dcac65dec43 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_kind_tests_2.f03 @@ -0,0 +1,14 @@ +! { dg-do compile } +module c_kind_tests_2 + use, intrinsic :: iso_c_binding + + integer, parameter :: myF = c_float + real(myF), bind(c) :: myCFloat + integer(myF), bind(c) :: myCInt ! { dg-error "is for type REAL" } + integer(c_double), bind(c) :: myCInt2 ! { dg-error "is for type REAL" } + + integer, parameter :: myI = c_int + real(myI) :: myReal + real(myI), bind(c) :: myCFloat2 ! { dg-error "is for type INTEGER" } + real(4), bind(c) :: myFloat ! { dg-warning "may not be a C interoperable" } +end module c_kind_tests_2 diff --git a/gcc/testsuite/gfortran.dg/c_kinds.c b/gcc/testsuite/gfortran.dg/c_kinds.c new file mode 100644 index 00000000000..f79a70f7532 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_kinds.c @@ -0,0 +1,54 @@ +/* { dg-do compile } */ +/* { dg-options "-std=c99" } */ + +#include <stdint.h> + +/* Note: int_fast*_t is currently not supported, cf. PR 448 */ +void param_test(short int my_short, int my_int, long int my_long, + long long int my_long_long, int8_t my_int8_t, + int_least8_t my_int_least8_t, /*int_fast8_t my_int_fast8_t,*/ + int16_t my_int16_t, int_least16_t my_int_least16_t, + /*int_fast16_t my_int_fast16_t,*/ int32_t my_int32_t, + int_least32_t my_int_least32_t, /*int_fast32_t my_int_fast32_t,*/ + int64_t my_int64_t, int_least64_t my_int_least64_t, + /*int_fast64_t my_int_fast64_t,*/ intmax_t my_intmax_t, + intptr_t my_intptr_t, float my_float, double my_double, + long double my_long_double, char my_char, _Bool my_bool); + + +int main(int argc, char **argv) +{ + short int my_short = 1; + int my_int = 2; + long int my_long = 3; + long long int my_long_long = 4; + int8_t my_int8_t = 1; + int_least8_t my_int_least8_t = 2; + int_fast8_t my_int_fast8_t = 3; + int16_t my_int16_t = 1; + int_least16_t my_int_least16_t = 2; + int_fast16_t my_int_fast16_t = 3; + int32_t my_int32_t = 1; + int_least32_t my_int_least32_t = 2; + int_fast32_t my_int_fast32_t = 3; + int64_t my_int64_t = 1; + int_least64_t my_int_least64_t = 2; + int_fast64_t my_int_fast64_t = 3; + intmax_t my_intmax_t = 1; + intptr_t my_intptr_t = 0; + float my_float = 1.0; + double my_double = 2.0; + long double my_long_double = 3.0; + char my_char = 'y'; + _Bool my_bool = 1; + + param_test(my_short, my_int, my_long, my_long_long, my_int8_t, + my_int_least8_t, /*my_int_fast8_t, */ my_int16_t, + my_int_least16_t,/* my_int_fast16_t,*/ my_int32_t, + my_int_least32_t,/* my_int_fast32_t,*/ my_int64_t, + my_int_least64_t,/* my_int_fast64_t,*/ my_intmax_t, + my_intptr_t, my_float, my_double, my_long_double, my_char, + my_bool); + + return 0; +}/* end main() */ diff --git a/gcc/testsuite/gfortran.dg/c_loc_driver.c b/gcc/testsuite/gfortran.dg/c_loc_driver.c new file mode 100644 index 00000000000..9e010439600 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_driver.c @@ -0,0 +1,17 @@ +/* in fortran module */ +void test0(void); + +extern void abort(void); + +int main(int argc, char **argv) +{ + test0(); + return 0; +}/* end main() */ + +void test_address(void *c_ptr, int expected_value) +{ + if((*(int *)(c_ptr)) != expected_value) + abort(); + return; +}/* end test_address() */ diff --git a/gcc/testsuite/gfortran.dg/c_loc_test.f90 b/gcc/testsuite/gfortran.dg/c_loc_test.f90 new file mode 100644 index 00000000000..178a5164cef --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_test.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-additional-sources c_loc_driver.c } +module c_loc_test +implicit none + +contains + subroutine test0() bind(c) + use, intrinsic :: iso_c_binding + implicit none + integer, target :: x + type(c_ptr) :: my_c_ptr + interface + subroutine test_address(x, expected_value) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: x + integer(c_int), value :: expected_value + end subroutine test_address + end interface + x = 100 + my_c_ptr = c_loc(x) + call test_address(my_c_ptr, 100) + end subroutine test0 +end module c_loc_test +! { dg-final { cleanup-modules "c_loc_test.mod" } } diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_2.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_2.f03 new file mode 100644 index 00000000000..ae4449574fe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_2.f03 @@ -0,0 +1,88 @@ +! { dg-do run } +! { dg-additional-sources c_loc_tests_2_funcs.c } +module c_loc_tests_2 +use, intrinsic :: iso_c_binding +implicit none + +interface + function test_scalar_address(cptr) bind(c) + use, intrinsic :: iso_c_binding, only: c_ptr, c_int + type(c_ptr), value :: cptr + integer(c_int) :: test_scalar_address + end function test_scalar_address + + function test_array_address(cptr, num_elements) bind(c) + use, intrinsic :: iso_c_binding, only: c_ptr, c_int + type(c_ptr), value :: cptr + integer(c_int), value :: num_elements + integer(c_int) :: test_array_address + end function test_array_address + + function test_type_address(cptr) bind(c) + use, intrinsic :: iso_c_binding, only: c_ptr, c_int + type(c_ptr), value :: cptr + integer(c_int) :: test_type_address + end function test_type_address +end interface + +contains + subroutine test0() bind(c) + integer, target :: xtar + integer, pointer :: xptr + type(c_ptr) :: my_c_ptr_1 = c_null_ptr + type(c_ptr) :: my_c_ptr_2 = c_null_ptr + xtar = 100 + xptr => xtar + my_c_ptr_1 = c_loc(xtar) + my_c_ptr_2 = c_loc(xptr) + if(test_scalar_address(my_c_ptr_1) .ne. 1) then + call abort() + end if + if(test_scalar_address(my_c_ptr_2) .ne. 1) then + call abort() + end if + end subroutine test0 + + subroutine test1() bind(c) + integer, target, dimension(100) :: int_array_tar + type(c_ptr) :: my_c_ptr_1 = c_null_ptr + type(c_ptr) :: my_c_ptr_2 = c_null_ptr + + int_array_tar = 100 + my_c_ptr_1 = c_loc(int_array_tar) + if(test_array_address(my_c_ptr_1, 100) .ne. 1) then + call abort() + end if + end subroutine test1 + + subroutine test2() bind(c) + type, bind(c) f90type + integer(c_int) :: i + real(c_double) :: x + end type f90type + type(f90type), target :: type_tar + type(f90type), pointer :: type_ptr + type(c_ptr) :: my_c_ptr_1 = c_null_ptr + type(c_ptr) :: my_c_ptr_2 = c_null_ptr + + type_ptr => type_tar + type_tar%i = 100 + type_tar%x = 1.0d0 + my_c_ptr_1 = c_loc(type_tar) + my_c_ptr_2 = c_loc(type_ptr) + if(test_type_address(my_c_ptr_1) .ne. 1) then + call abort() + end if + if(test_type_address(my_c_ptr_2) .ne. 1) then + call abort() + end if + end subroutine test2 +end module c_loc_tests_2 + +program driver + use c_loc_tests_2 + call test0() + call test1() + call test2() +end program driver +! { dg-final { cleanup-modules "c_loc_tests_2" } } diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_2_funcs.c b/gcc/testsuite/gfortran.dg/c_loc_tests_2_funcs.c new file mode 100644 index 00000000000..d47ac81aeaa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_2_funcs.c @@ -0,0 +1,42 @@ +double fabs (double); + +typedef struct ctype +{ + int i; + double x; +}ctype_t; + +int test_scalar_address(int *ptr) +{ + /* The value in Fortran should be initialized to 100. */ + if(*ptr != 100) + return 0; + else + return 1; +} + +int test_array_address(int *int_array, int num_elements) +{ + int i = 0; + + for(i = 0; i < num_elements; i++) + /* Fortran will init all of the elements to 100; verify that here. */ + if(int_array[i] != 100) + return 0; + + /* all elements were equal to 100 */ + return 1; +} + +int test_type_address(ctype_t *type_ptr) +{ + /* i was set to 100 by Fortran */ + if(type_ptr->i != 100) + return 0; + + /* x was set to 1.0d0 by Fortran */ + if(fabs(type_ptr->x - 1.0) > 0.00000000) + return 0; + + return 1; +} diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_3.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_3.f03 new file mode 100644 index 00000000000..95eac4af380 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_3.f03 @@ -0,0 +1,8 @@ +! { dg-do compile } +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" } + +end diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_4.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_4.f03 new file mode 100644 index 00000000000..8453ec77272 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_4.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +module c_loc_tests_4 + use, intrinsic :: iso_c_binding + implicit none + +contains + subroutine sub0() bind(c) + integer(c_int), target, dimension(10) :: my_array + integer(c_int), pointer, dimension(:) :: my_array_ptr + 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" } + end subroutine sub0 +end module c_loc_tests_4 diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_5.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_5.f03 new file mode 100644 index 00000000000..a389437ce10 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_5.f03 @@ -0,0 +1,19 @@ +! { dg-do compile } +module c_loc_tests_5 + use, intrinsic :: iso_c_binding, only: c_char, c_ptr, c_loc, c_int + +contains + subroutine sub0() bind(c) + type(c_ptr) :: f_ptr, my_c_ptr + character(kind=c_char, len=20), target :: format + integer(c_int), dimension(:), pointer :: int_ptr + integer(c_int), dimension(10), target :: int_array + + f_ptr = c_loc(format(1:1)) + + int_ptr => int_array + my_c_ptr = c_loc(int_ptr(0)) + + end subroutine sub0 +end module c_loc_tests_5 +! { dg-final { cleanup-modules "c_loc_tests_5" } } diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_6.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_6.f03 new file mode 100644 index 00000000000..c82a2adbf78 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_6.f03 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Verifies that the c_loc scalar pointer tests recognize the string of length +! one as being allowable for the parameter to c_loc. +module x +use iso_c_binding +contains +SUBROUTINE glutInit_f03() + TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR + CHARACTER(C_CHAR), DIMENSION(10), TARGET :: empty_string=C_NULL_CHAR + argv(1)=C_LOC(empty_string) +END SUBROUTINE +end module x +! { dg-final { cleanup-modules "x" } } diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_7.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_7.f03 new file mode 100644 index 00000000000..78f5276bdef --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_7.f03 @@ -0,0 +1,11 @@ +! { dg-do compile } +module c_loc_tests_7 +use iso_c_binding +contains +SUBROUTINE glutInit_f03() + TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR + CHARACTER(C_CHAR), DIMENSION(1), TARGET :: empty_string=C_NULL_CHAR + argv(1)=C_LOC(empty_string) +END SUBROUTINE +end module c_loc_tests_7 +! { dg-final { cleanup-modules "c_loc_tests_7" } } diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_8.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_8.f03 new file mode 100644 index 00000000000..a094d690bdd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_8.f03 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Verifies that the c_loc scalar pointer tests recognize the string of length +! greater than one as not being allowable for the parameter to c_loc. +module x +use iso_c_binding +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" } +END SUBROUTINE +end module x + diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests.f03 b/gcc/testsuite/gfortran.dg/c_ptr_tests.f03 new file mode 100644 index 00000000000..0b7c98be714 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests.f03 @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-additional-sources c_ptr_tests_driver.c } +module c_ptr_tests + use, intrinsic :: iso_c_binding + + ! TODO:: + ! in order to be associated with a C address, + ! the derived type needs to be C interoperable, + ! which requires bind(c) and all fields interoperable. + type, bind(c) :: myType + type(c_ptr) :: myServices + type(c_funptr) :: mySetServices + type(c_ptr) :: myPort + end type myType + + type, bind(c) :: f90Services + integer(c_int) :: compId + type(c_ptr) :: globalServices = c_null_ptr + end type f90Services + + contains + + subroutine sub0(c_self, services) bind(c) + use, intrinsic :: iso_c_binding + implicit none + type(c_ptr), value :: c_self, services + type(myType), pointer :: self + type(f90Services), pointer :: localServices +! type(c_ptr) :: my_cptr + type(c_ptr), save :: my_cptr = c_null_ptr + + call c_f_pointer(c_self, self) + if(.not. associated(self)) then + print *, 'self is not associated' + end if + self%myServices = services + + ! c_null_ptr is defined in iso_c_binding + my_cptr = c_null_ptr + + ! get access to the local services obj from C + call c_f_pointer(self%myServices, localServices) + end subroutine sub0 +end module c_ptr_tests diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03 b/gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03 new file mode 100644 index 00000000000..d04786c7c74 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03 @@ -0,0 +1,18 @@ +! { dg-run } +! This test case exists because gfortran had an error in converting the +! expressions for the derived types from iso_c_binding in some cases. +module c_ptr_tests_10 + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr + +contains + subroutine sub0() bind(c) + print *, 'c_null_ptr is: ', c_null_ptr + end subroutine sub0 +end module c_ptr_tests_10 + +program main + use c_ptr_tests_10 + call sub0() +end program main + +! { dg-final { cleanup-modules "c_ptr_tests_10" } } diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_5.f03 b/gcc/testsuite/gfortran.dg/c_ptr_tests_5.f03 new file mode 100644 index 00000000000..437e3469127 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_5.f03 @@ -0,0 +1,16 @@ +! { dg-do compile } +module c_ptr_tests_5 +use, intrinsic :: iso_c_binding + +type, bind(c) :: my_f90_type + integer(c_int) :: i +end type my_f90_type + +contains + subroutine sub0(c_struct) bind(c) + type(c_ptr), value :: c_struct + type(my_f90_type) :: f90_type + + call c_f_pointer(c_struct, f90_type) ! { dg-error "must have the POINTER" } + end subroutine sub0 +end module c_ptr_tests_5 diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_7.f03 b/gcc/testsuite/gfortran.dg/c_ptr_tests_7.f03 new file mode 100644 index 00000000000..04cb8b22ab8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_7.f03 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-additional-sources c_ptr_tests_7_driver.c } +module c_ptr_tests_7 + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr + +contains + function func0() bind(c) + type(c_ptr) :: func0 + func0 = c_null_ptr + end function func0 +end module c_ptr_tests_7 +! { dg-final { cleanup-modules "c_ptr_tests_7" } } diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_7_driver.c b/gcc/testsuite/gfortran.dg/c_ptr_tests_7_driver.c new file mode 100644 index 00000000000..7d8b1e328c8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_7_driver.c @@ -0,0 +1,14 @@ +/* This is the driver for c_ptr_test_7. */ +extern void abort(void); + +void *func0(); + +int main(int argc, char **argv) +{ + /* The Fortran module c_ptr_tests_7 contains function func0, which has + return type of c_ptr, and should set the return value to c_null_ptr. */ + if (func0() != 0) + abort(); + + return 0; +} diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_8.f03 b/gcc/testsuite/gfortran.dg/c_ptr_tests_8.f03 new file mode 100644 index 00000000000..3b99ee8bb0f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_8.f03 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-additional-sources c_ptr_tests_8_funcs.c } +program main +use iso_c_binding, only: c_ptr +implicit none +interface + function create() bind(c) + use iso_c_binding, only: c_ptr + type(c_ptr) :: create + end function create + subroutine show(a) bind(c) + import :: c_ptr + type(c_ptr), VALUE :: a + end subroutine show +end interface + +type(c_ptr) :: ptr +ptr = create() +call show(ptr) +end program main diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_8_funcs.c b/gcc/testsuite/gfortran.dg/c_ptr_tests_8_funcs.c new file mode 100644 index 00000000000..2ad01211658 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_8_funcs.c @@ -0,0 +1,26 @@ +/* This file provides auxilliary functions for c_ptr_tests_8. */ + +#include <stdio.h> +#include <stdlib.h> + +extern void abort (void); + +void *create (void) +{ + int *a; + a = malloc (sizeof (a)); + *a = 444; + return a; + +} + +void show (int *a) +{ + if (*a == 444) + printf ("SUCCESS (%d)\n", *a); + else + { + printf ("FAILED: Expected 444, received %d\n", *a); + abort (); + } +} diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03 b/gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03 new file mode 100644 index 00000000000..db598590825 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03 @@ -0,0 +1,31 @@ +! { dg-do run } +! This test is pretty simple but is here just to make sure that the changes +! done to c_ptr and c_funptr (translating them to void *) works in the case +! where a component of a type is of type c_ptr or c_funptr. +module c_ptr_tests_9 + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr + + type myF90Derived + type(c_ptr) :: my_c_ptr + end type myF90Derived + +contains + subroutine sub0() bind(c) + type(myF90Derived), target :: my_f90_type + type(myF90Derived), pointer :: my_f90_type_ptr + + my_f90_type%my_c_ptr = c_null_ptr + print *, 'my_f90_type is: ', my_f90_type + my_f90_type_ptr => my_f90_type + print *, 'my_f90_type_ptr is: ', my_f90_type_ptr + end subroutine sub0 +end module c_ptr_tests_9 + + +program main + use c_ptr_tests_9 + + call sub0() +end program main + +! { dg-final { cleanup-modules "c_ptr_tests_9" } } diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_driver.c b/gcc/testsuite/gfortran.dg/c_ptr_tests_driver.c new file mode 100644 index 00000000000..cd81c7bccec --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_driver.c @@ -0,0 +1,34 @@ +/* this is the driver for c_ptr_test.f03 */ + +typedef struct services +{ + int compId; + void *globalServices; +}services_t; + +typedef struct comp +{ + void *myServices; + void (*setServices)(struct comp *self, services_t *myServices); + void *myPort; +}comp_t; + +/* prototypes for f90 functions */ +void sub0(comp_t *self, services_t *myServices); + +int main(int argc, char **argv) +{ + services_t servicesObj; + comp_t myComp; + + servicesObj.compId = 17; + servicesObj.globalServices = 0; /* NULL; */ + myComp.myServices = &servicesObj; + myComp.setServices = 0; /* NULL; */ + myComp.myPort = 0; /* NULL; */ + + sub0(&myComp, &servicesObj); + + return 0; +}/* end main() */ + diff --git a/gcc/testsuite/gfortran.dg/c_size_t_driver.c b/gcc/testsuite/gfortran.dg/c_size_t_driver.c new file mode 100644 index 00000000000..b2d49917142 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_size_t_driver.c @@ -0,0 +1,12 @@ +#include <stdlib.h> +void sub0(int my_c_size); + +int main(int argc, char **argv) +{ + int my_c_size; + + my_c_size = (int)sizeof(size_t); + sub0(my_c_size); + + return 0; +} diff --git a/gcc/testsuite/gfortran.dg/c_size_t_test.f03 b/gcc/testsuite/gfortran.dg/c_size_t_test.f03 new file mode 100644 index 00000000000..91d7aa57b05 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_size_t_test.f03 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-additional-sources c_size_t_driver.c } +module c_size_t_test + use, intrinsic :: iso_c_binding + +contains + subroutine sub0(my_c_size) bind(c) + integer(c_int), value :: my_c_size ! value of C's sizeof(size_t) + + ! if the value of c_size_t isn't equal to the value of C's sizeof(size_t) + ! we call abort. + if(c_size_t .ne. my_c_size) then + call abort () + end if + end subroutine sub0 +end module c_size_t_test diff --git a/gcc/testsuite/gfortran.dg/com_block_driver.f90 b/gcc/testsuite/gfortran.dg/com_block_driver.f90 new file mode 100644 index 00000000000..0445635c881 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/com_block_driver.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +module myComModule + use, intrinsic :: iso_c_binding + + common /COM2/ R2, S2 + real(c_double) :: r2 + real(c_double) :: s2 + bind(c) :: /COM2/ + +end module myComModule + +module comBlockTests + use, intrinsic :: iso_c_binding + use myComModule + + implicit none + + common /COM/ R, S + real(c_double) :: r + real(c_double) :: s + bind(c) :: /COM/ + + contains + + subroutine testTypes() + implicit none + end subroutine testTypes +end module comBlockTests + +program comBlockDriver + use comBlockTests + + call testTypes() +end program comBlockDriver diff --git a/gcc/testsuite/gfortran.dg/global_vars_c_init.f90 b/gcc/testsuite/gfortran.dg/global_vars_c_init.f90 new file mode 100644 index 00000000000..abcdccd3fb2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/global_vars_c_init.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-additional-sources global_vars_c_init_driver.c } +module global_vars_c_init + use, intrinsic :: iso_c_binding, only: c_int + implicit none + + integer(c_int), bind(c, name='i') :: I + +contains + subroutine test_globals() bind(c) + ! the value of I is initialized above + if(I .ne. 2) then + call abort() + endif + end subroutine test_globals +end module global_vars_c_init + + diff --git a/gcc/testsuite/gfortran.dg/global_vars_c_init_driver.c b/gcc/testsuite/gfortran.dg/global_vars_c_init_driver.c new file mode 100644 index 00000000000..b58c2c96661 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/global_vars_c_init_driver.c @@ -0,0 +1,13 @@ +int i = 2; +void test_globals(void); + +extern void abort(void); + +int main(int argc, char **argv) +{ + /* verify that i has been initialized by f90 */ + if(i != 2) + abort(); + test_globals(); + return 0; +}/* end main() */ diff --git a/gcc/testsuite/gfortran.dg/global_vars_f90_init.f90 b/gcc/testsuite/gfortran.dg/global_vars_f90_init.f90 new file mode 100644 index 00000000000..2ff3c52fb17 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/global_vars_f90_init.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-additional-sources global_vars_f90_init_driver.c } +module global_vars_f90_init + use, intrinsic :: iso_c_binding, only: c_int + implicit none + + integer(c_int), bind(c, name='i') :: I = 2 + +contains + subroutine test_globals() bind(c) + ! the value of I is initialized above + if(I .ne. 2) then + call abort() + endif + end subroutine test_globals +end module global_vars_f90_init + + diff --git a/gcc/testsuite/gfortran.dg/global_vars_f90_init_driver.c b/gcc/testsuite/gfortran.dg/global_vars_f90_init_driver.c new file mode 100644 index 00000000000..7869c83f712 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/global_vars_f90_init_driver.c @@ -0,0 +1,14 @@ +/* initialized by fortran */ +int i; +void test_globals(void); + +extern void abort(void); + +int main(int argc, char **argv) +{ + /* verify that i has been initialized by f90 */ + if(i != 2) + abort(); + test_globals(); + return 0; +}/* end main() */ diff --git a/gcc/testsuite/gfortran.dg/interop_params.f03 b/gcc/testsuite/gfortran.dg/interop_params.f03 new file mode 100644 index 00000000000..8163b4a5040 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interop_params.f03 @@ -0,0 +1,24 @@ +! { dg-do compile } +module interop_params +use, intrinsic :: iso_c_binding + +type my_f90_type + integer :: i + real :: x +end type my_f90_type + +contains + subroutine test_0(my_f90_int) bind(c) ! { dg-warning "may not be C interoperable" } + use, intrinsic :: iso_c_binding + integer, value :: my_f90_int + end subroutine test_0 + + subroutine test_1(my_f90_real) bind(c) ! { dg-error "is for type INTEGER" } + real(c_int), value :: my_f90_real + end subroutine test_1 + + subroutine test_2(my_type) bind(c) ! { dg-error "is not C interoperable" } + use, intrinsic :: iso_c_binding + type(my_f90_type) :: my_type + end subroutine test_2 +end module interop_params diff --git a/gcc/testsuite/gfortran.dg/iso_c_binding_only.f03 b/gcc/testsuite/gfortran.dg/iso_c_binding_only.f03 new file mode 100644 index 00000000000..40c45a46726 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iso_c_binding_only.f03 @@ -0,0 +1,9 @@ +! { dg-do compile } +module iso_c_binding_only + use, intrinsic :: iso_c_binding, only: c_null_ptr + ! This should be allowed since the C_PTR that the C_NULL_PTR needs will use + ! a mangled name to prevent collisions. + integer :: c_ptr +end module iso_c_binding_only +! { dg-final { cleanup-modules "iso_c_binding_only" } } + diff --git a/gcc/testsuite/gfortran.dg/iso_c_binding_rename_1.f03 b/gcc/testsuite/gfortran.dg/iso_c_binding_rename_1.f03 new file mode 100644 index 00000000000..215e487ada4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iso_c_binding_rename_1.f03 @@ -0,0 +1,83 @@ +! { dg-do run } +! { dg-additional-sources iso_c_binding_rename_1_driver.c } +module iso_c_binding_rename_0 + use, intrinsic :: iso_c_binding, only: my_c_ptr_0 => c_ptr, & + c_associated +end module iso_c_binding_rename_0 + + +module iso_c_binding_rename_1 + ! rename a couple of the symbols from iso_c_binding. the compiler + ! needs to be able to recognize the derived types with names different + ! from the one in iso_c_binding because it will look up the derived types + ! to define the args and return values of some of the procedures in + ! iso_c_binding. this should verify that this functionality works. + use, intrinsic :: iso_c_binding, my_c_int => c_int, my_c_ptr => c_ptr, & + my_c_associated => c_associated, my_c_f_pointer => c_f_pointer + +contains + subroutine sub0(my_int) bind(c) + integer(my_c_int), value :: my_int + if(my_int .ne. 1) then + call abort() + end if + end subroutine sub0 + + subroutine sub1(my_ptr) bind(c) + type(my_c_ptr), value :: my_ptr + + if(.not. my_c_associated(my_ptr)) then + call abort() + end if + end subroutine sub1 + + subroutine sub2(my_int, my_long) bind(c) + use, intrinsic :: iso_c_binding, my_c_int_2 => c_int, & + my_c_long_2 => c_long + integer(my_c_int_2), value :: my_int + integer(my_c_long_2), value :: my_long + + if(my_int .ne. 1) then + call abort() + end if + if(my_long .ne. 1) then + call abort() + end if + end subroutine sub2 + + subroutine sub3(cptr1, cptr2) bind(c) + type(my_c_ptr), value :: cptr1 + type(my_c_ptr), value :: cptr2 + integer(my_c_int), pointer :: my_f90_c_ptr + + if(.not. my_c_associated(cptr1)) then + call abort() + end if + + if(.not. my_c_associated(cptr1, cptr2)) then + call abort() + end if + + call my_c_f_pointer(cptr1, my_f90_c_ptr) + end subroutine sub3 + + subroutine sub4(cptr1, cptr2) bind(c) + ! rename the my_c_ptr_0 from iso_c_binding_rename_0 just to further test + ! both are actually aliases to c_ptr + use iso_c_binding_rename_0, my_c_ptr_local => my_c_ptr_0, & + my_c_associated_2 => c_associated + + implicit none + type(my_c_ptr_local), value :: cptr1 + type(my_c_ptr_local), value :: cptr2 + + if(.not. my_c_associated_2(cptr1)) then + call abort() + end if + + if(.not. my_c_associated_2(cptr2)) then + call abort() + end if + end subroutine sub4 +end module iso_c_binding_rename_1 + diff --git a/gcc/testsuite/gfortran.dg/iso_c_binding_rename_1_driver.c b/gcc/testsuite/gfortran.dg/iso_c_binding_rename_1_driver.c new file mode 100644 index 00000000000..26c21d912e5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iso_c_binding_rename_1_driver.c @@ -0,0 +1,19 @@ +void sub0(int); +void sub1(int *); +void sub2(int, long); +void sub3(int *, int *); +void sub4(int *, int *); + +int main(int argc, char **argv) +{ + int i = 1; + long j = 1; + + sub0(i); + sub1(&i); + sub2(i, j); + sub3(&i, &i); + sub4(&i, &i); + + return 0; +} diff --git a/gcc/testsuite/gfortran.dg/iso_c_binding_rename_2.f03 b/gcc/testsuite/gfortran.dg/iso_c_binding_rename_2.f03 new file mode 100644 index 00000000000..75797e78f73 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iso_c_binding_rename_2.f03 @@ -0,0 +1,40 @@ +! { dg-do run } +! { dg-additional-sources iso_c_binding_rename_2_driver.c } +module mod0 + use, intrinsic :: iso_c_binding, only: c_ptr, c_associated +end module mod0 + +module mod1 + use mod0, my_c_ptr => c_ptr, my_c_associated => c_associated +end module mod1 + +module mod2 +contains + subroutine sub2(my_ptr1) bind(c) + use mod1, my_c_ptr_2 => my_c_ptr, my_c_associated_2 => my_c_associated + implicit none + type(my_c_ptr_2) :: my_ptr1 + if( .not. my_c_associated_2(my_ptr1)) then + call abort() + end if + end subroutine sub2 + + subroutine sub3(my_ptr1) bind(c) + use mod1, my_c_ptr_2 => my_c_ptr + implicit none + type(my_c_ptr_2) :: my_ptr1 + if( .not. my_c_associated(my_ptr1)) then + call abort() + end if + end subroutine sub3 + + subroutine sub4(my_ptr1) bind(c) + use mod1, my_c_associated_3 => my_c_associated + implicit none + type(my_c_ptr) :: my_ptr1 + if( .not. my_c_associated_3(my_ptr1)) then + call abort() + end if + end subroutine sub4 + +end module mod2 diff --git a/gcc/testsuite/gfortran.dg/iso_c_binding_rename_2_driver.c b/gcc/testsuite/gfortran.dg/iso_c_binding_rename_2_driver.c new file mode 100644 index 00000000000..8be704c341b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iso_c_binding_rename_2_driver.c @@ -0,0 +1,16 @@ +void sub2(int **); +void sub3(int **); +void sub4(int **); + +int main(int argc, char **argv) +{ + int i = 1; + int *ptr; + + ptr = &i; + sub2(&ptr); + sub3(&ptr); + sub4(&ptr); + + return 0; +} diff --git a/gcc/testsuite/gfortran.dg/kind_tests_2.f03 b/gcc/testsuite/gfortran.dg/kind_tests_2.f03 new file mode 100644 index 00000000000..d740657a262 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/kind_tests_2.f03 @@ -0,0 +1,7 @@ +! { dg-do compile } +module kind_tests_2 + use, intrinsic :: iso_c_binding + + integer, parameter :: myFKind = c_float + real(myFKind), bind(c) :: myF +end module kind_tests_2 diff --git a/gcc/testsuite/gfortran.dg/kind_tests_3.f03 b/gcc/testsuite/gfortran.dg/kind_tests_3.f03 new file mode 100644 index 00000000000..83cb91e95d6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/kind_tests_3.f03 @@ -0,0 +1,10 @@ +! { dg-do compile } +module my_kinds + use, intrinsic :: iso_c_binding + integer, parameter :: myFKind = c_float +end module my_kinds + +module my_module + use my_kinds + real(myFKind), bind(c) :: myF +end module my_module diff --git a/gcc/testsuite/gfortran.dg/module_md5_1.f90 b/gcc/testsuite/gfortran.dg/module_md5_1.f90 index 7081804c494..45792bda389 100644 --- a/gcc/testsuite/gfortran.dg/module_md5_1.f90 +++ b/gcc/testsuite/gfortran.dg/module_md5_1.f90 @@ -10,5 +10,5 @@ program test use foo print *, pi end program test -! { dg-final { scan-module "foo" "MD5:18a257e13c90e3872b7b9400c2fc6e4b" } } +! { dg-final { scan-module "foo" "MD5:10e58dd12566bfc60412da6f8f8f7a07" } } ! { dg-final { cleanup-modules "foo" } } diff --git a/gcc/testsuite/gfortran.dg/only_clause_main.c b/gcc/testsuite/gfortran.dg/only_clause_main.c new file mode 100644 index 00000000000..2cc6c8dd317 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/only_clause_main.c @@ -0,0 +1,12 @@ +/* this is an f90 function */ +void testOnly(int *cIntPtr); + +int main(int argc, char **argv) +{ + int myCInt; + + myCInt = -11; + testOnly(&myCInt); + + return 0; +}/* end main() */ diff --git a/gcc/testsuite/gfortran.dg/print_c_kinds.f90 b/gcc/testsuite/gfortran.dg/print_c_kinds.f90 new file mode 100644 index 00000000000..a66323316b2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/print_c_kinds.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +program print_c_kinds + use, intrinsic :: iso_c_binding + implicit none + + print *, 'c_short is: ', c_short + print *, 'c_int is: ', c_int + print *, 'c_long is: ', c_long + print *, 'c_long_long is: ', c_long_long + print * + print *, 'c_int8_t is: ', c_int8_t + print *, 'c_int_least8_t is: ', c_int_least8_t + print *, 'c_int_fast8_t is: ', c_int_fast8_t + print * + print *, 'c_int16_t is: ', c_int16_t + print *, 'c_int_least16_t is: ', c_int_least16_t + print *, 'c_int_fast16_t is: ', c_int_fast16_t + print * + print *, 'c_int32_t is: ', c_int32_t + print *, 'c_int_least32_t is: ', c_int_least32_t + print *, 'c_int_fast32_t is: ', c_int_fast32_t + print * + print *, 'c_int64_t is: ', c_int64_t + print *, 'c_int_least64_t is: ', c_int_least64_t + print *, 'c_int_fast64_t is: ', c_int_fast64_t + print * + print *, 'c_intmax_t is: ', c_intmax_t + print *, 'c_intptr_t is: ', c_intptr_t + print * + print *, 'c_float is: ', c_float + print *, 'c_double is: ', c_double + print *, 'c_long_double is: ', c_long_double + print * + print *, 'c_char is: ', c_char +end program print_c_kinds diff --git a/gcc/testsuite/gfortran.dg/test_bind_c_parens.f03 b/gcc/testsuite/gfortran.dg/test_bind_c_parens.f03 new file mode 100644 index 00000000000..ee7b6a8ac63 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/test_bind_c_parens.f03 @@ -0,0 +1,7 @@ +! { dg-do compile } +module test_bind_c_parens + interface + subroutine sub bind(c) ! { dg-error "Missing required parentheses" } + end subroutine sub ! { dg-error "Expecting END INTERFACE" } + end interface +end module test_bind_c_parens diff --git a/gcc/testsuite/gfortran.dg/test_c_assoc.c b/gcc/testsuite/gfortran.dg/test_c_assoc.c new file mode 100644 index 00000000000..aa6571874ae --- /dev/null +++ b/gcc/testsuite/gfortran.dg/test_c_assoc.c @@ -0,0 +1,55 @@ +/* use 0 for NULL so no need for system header */ + +int test_c_assoc_0(void *my_c_ptr); +int test_c_assoc_1(void *my_c_ptr_1, void *my_c_ptr_2); +int test_c_assoc_2(void *my_c_ptr_1, void *my_c_ptr_2, int num_ptrs); +void verify_assoc(void *my_c_ptr_1, void *my_c_ptr_2); + +extern void abort(void); + +int main(int argc, char **argv) +{ + int i; + int j; + + if(test_c_assoc_0(0) != 0) + abort(); + + if(test_c_assoc_0(&i) != 1) + abort(); + + if(test_c_assoc_1(0, 0) != 0) + abort(); + + if(test_c_assoc_1(0, &i) != 0) + abort(); + + if(test_c_assoc_1(&i, &i) != 1) + abort(); + + if(test_c_assoc_1(&i, 0) != 0) + abort(); + + if(test_c_assoc_1(&i, &j) != 0) + abort(); + + /* this should be associated, cause only testing 1 ptr (i) */ + if(test_c_assoc_2(&i, 0, 1) != 1) + abort(); + + /* this should be associated */ + if(test_c_assoc_2(&i, &i, 2) != 1) + abort(); + + /* this should not be associated (i) */ + if(test_c_assoc_2(&i, &j, 2) != 0) + abort(); + + /* this should be associated, cause only testing 1 ptr (i) */ + if(test_c_assoc_2(&i, &j, 1) != 1) + abort(); + + verify_assoc(&i, &i); + + return 0; +}/* end main() */ diff --git a/gcc/testsuite/gfortran.dg/test_com_block.f90 b/gcc/testsuite/gfortran.dg/test_com_block.f90 new file mode 100644 index 00000000000..df3f643e72d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/test_com_block.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +module nonF03ComBlock + common /NONF03COM/ r, s + real :: r + real :: s + + contains + + subroutine hello(myArray) + integer, dimension(:) :: myArray + + r = 1.0 + s = 2.0 + end subroutine hello +end module nonF03ComBlock + +program testComBlock + use nonF03ComBlock + integer, dimension(1:10) :: myArray + + call hello(myArray) + + ! these are set in the call to hello() above + ! r and s are reals (default size) in com block, set to + ! 1.0 and 2.0, respectively, in hello() + if(r .ne. 1.0) then + call abort() + endif + if(s .ne. 2.0) then + call abort() + endif +end program testComBlock diff --git a/gcc/testsuite/gfortran.dg/test_common_binding_labels.f03 b/gcc/testsuite/gfortran.dg/test_common_binding_labels.f03 new file mode 100644 index 00000000000..ea9a59a35e4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/test_common_binding_labels.f03 @@ -0,0 +1,42 @@ +! { dg-do compile } +module x + use, intrinsic :: iso_c_binding, only: c_double + implicit none + + common /mycom/ r, s ! { dg-error "does not match" } + real(c_double) :: r + real(c_double) :: s + bind(c, name="my_common_block") :: /mycom/ +end module x + +module y + use, intrinsic :: iso_c_binding, only: c_double, c_int + implicit none + + common /mycom/ r, s + real(c_double) :: r + real(c_double) :: s + bind(c, name="my_common_block") :: /mycom/ + + common /com2/ i ! { dg-error "does not match" } + integer(c_int) :: i + bind(c, name="") /com2/ +end module y + +module z + use, intrinsic :: iso_c_binding, only: c_double, c_int + implicit none + + common /mycom/ r, s ! { dg-error "does not match" } + real(c_double) :: r + real(c_double) :: s + ! this next line is an error; if a common block is bind(c), the binding label + ! for it must match across all scoping units that declare it. + bind(c, name="my_common_block_2") :: /mycom/ + + common /com2/ i ! { dg-error "does not match" } + integer(c_int) :: i + bind(c, name="mycom2") /com2/ +end module z + +! { dg-final { cleanup-modules "x y" } } diff --git a/gcc/testsuite/gfortran.dg/test_common_binding_labels_2.f03 b/gcc/testsuite/gfortran.dg/test_common_binding_labels_2.f03 new file mode 100644 index 00000000000..d14c9b1168f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/test_common_binding_labels_2.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +module test_common_binding_labels_2 + use, intrinsic :: iso_c_binding, only: c_double, c_int + implicit none + + common /mycom/ r, s + real(c_double) :: r + real(c_double) :: s + bind(c, name="my_common_block") :: /mycom/ + + common /com2/ i + integer(c_int) :: i + bind(c, name="") /com2/ +end module test_common_binding_labels_2 + diff --git a/gcc/testsuite/gfortran.dg/test_common_binding_labels_2_main.f03 b/gcc/testsuite/gfortran.dg/test_common_binding_labels_2_main.f03 new file mode 100644 index 00000000000..1b4103ef4cc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/test_common_binding_labels_2_main.f03 @@ -0,0 +1,25 @@ +! { dg-do compile } +! This file depends on the module test_common_binding_labels_2. That module +! must be compiled first and not be removed until after this test. +module test_common_binding_labels_2_main + use, intrinsic :: iso_c_binding, only: c_double, c_int + implicit none + + common /mycom/ r, s ! { dg-error "does not match" } + real(c_double) :: r + real(c_double) :: s + ! this next line is an error; if a common block is bind(c), the binding label + ! for it must match across all scoping units that declare it. + bind(c, name="my_common_block_2") :: /mycom/ + + common /com2/ i ! { dg-error "does not match" } + integer(c_int) :: i + bind(c, name="mycom2") /com2/ +end module test_common_binding_labels_2_main + +program main + use test_common_binding_labels_2 ! { dg-error "does not match" } + use test_common_binding_labels_2_main +end program main + +! { dg-final { cleanup-modules "test_common_binding_labels_2_main test_common_binding_labels_2" } } diff --git a/gcc/testsuite/gfortran.dg/test_common_binding_labels_3.f03 b/gcc/testsuite/gfortran.dg/test_common_binding_labels_3.f03 new file mode 100644 index 00000000000..87d6c6b78f9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/test_common_binding_labels_3.f03 @@ -0,0 +1,10 @@ +! { dg-do compile } +module test_common_binding_labels_3 + use, intrinsic :: iso_c_binding, only: c_double + implicit none + + common /mycom/ r, s + real(c_double) :: r + real(c_double) :: s + bind(c, name="my_common_block") :: /mycom/ +end module test_common_binding_labels_3 diff --git a/gcc/testsuite/gfortran.dg/test_common_binding_labels_3_main.f03 b/gcc/testsuite/gfortran.dg/test_common_binding_labels_3_main.f03 new file mode 100644 index 00000000000..d2c67f65170 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/test_common_binding_labels_3_main.f03 @@ -0,0 +1,14 @@ +! { dg-do compile } +! This file depends on the module test_common_binding_labels_3. That module +! must be compiled first and not be removed until after this test. +module test_common_binding_labels_3_main + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int), bind(c, name="my_common_block") :: my_int ! { dg-error "collides" } +end module test_common_binding_labels_3_main + +program main + use test_common_binding_labels_3_main + use test_common_binding_labels_3 ! { dg-error "collides" } +end program main + +! { dg-final { cleanup-modules "test_common_binding_labels_3_main test_common_binding_labels_3" } } diff --git a/gcc/testsuite/gfortran.dg/test_only_clause.f90 b/gcc/testsuite/gfortran.dg/test_only_clause.f90 new file mode 100644 index 00000000000..7c63e2be167 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/test_only_clause.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-additional-sources only_clause_main.c } +module testOnlyClause + + contains + subroutine testOnly(cIntPtr) bind(c, name="testOnly") + use, intrinsic :: iso_c_binding, only: c_ptr, c_int, c_f_pointer + implicit none + type(c_ptr), value :: cIntPtr + integer(c_int), pointer :: f90IntPtr + + call c_f_pointer(cIntPtr, f90IntPtr) + + ! f90IntPtr coming in has value of -11; this will make it -12 + f90IntPtr = f90IntPtr - 1 + if(f90IntPtr .ne. -12) then + call abort() + endif + end subroutine testOnly +end module testOnlyClause diff --git a/gcc/testsuite/gfortran.dg/use_iso_c_binding.f90 b/gcc/testsuite/gfortran.dg/use_iso_c_binding.f90 new file mode 100644 index 00000000000..6e6a023bcfb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/use_iso_c_binding.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! this is to simply test that the various ways the use statement can +! appear are handled by the compiler, since i did a special treatment +! of the intrinsic iso_c_binding module. note: if the user doesn't +! provide the 'intrinsic' keyword, the compiler will check for a user +! provided module by the name of iso_c_binding before using the +! intrinsic one. --Rickett, 09.26.06 +module use_stmt_0 + ! this is an error because c_ptr_2 does not exist + use, intrinsic :: iso_c_binding, only: c_ptr_2 ! { dg-error "Symbol 'c_ptr_2' referenced at \\(1\\) does not exist" } +end module use_stmt_0 + +module use_stmt_1 + ! this is an error because c_ptr_2 does not exist + use iso_c_binding, only: c_ptr_2 ! { dg-error "Symbol 'c_ptr_2' referenced at \\(1\\) does not exist" } +end module use_stmt_1 + +module use_stmt_2 + ! works fine + use, intrinsic :: iso_c_binding, only: c_ptr +end module use_stmt_2 + +module use_stmt_3 + ! works fine + use iso_c_binding, only: c_ptr +end module use_stmt_3 + +module use_stmt_4 + ! works fine + use, intrinsic :: iso_c_binding +end module use_stmt_4 + +module use_stmt_5 + ! works fine + use iso_c_binding +end module use_stmt_5 + +module use_stmt_6 + ! hmm, is this an error? if so, it's not being caught... + ! --Rickett, 09.13.06 + use, intrinsic :: iso_c_binding, only: c_int, c_int +end module use_stmt_6 + +module use_stmt_7 + ! hmm, is this an error? if so, it's not being caught... + ! --Rickett, 09.13.06 + use iso_c_binding, only: c_int, c_int +end module use_stmt_7 + diff --git a/gcc/testsuite/gfortran.dg/value_5.f90 b/gcc/testsuite/gfortran.dg/value_5.f90 new file mode 100644 index 00000000000..4b0dcefb340 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_5.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +! Length of character dummy variable with VALUE attribute: +! - must be initialization expression or omitted +! - C interoperable: must be initialization expression of length one +! or omitted +! +! Contributed by Tobias Burnus +program x + implicit none + character(10) :: c1,c10 + c1 = 'H' + c10 = 'Main' + call foo1(c1) + call foo2(c1) + call foo3(c10) + call foo4(c10) + call bar1(c1) + call bar2(c1) + call bar3(c10) + call bar4(c10) + +contains + + subroutine foo1(a) + character :: a + value :: a + end subroutine foo1 + + subroutine foo2(a) + character(1) :: a + value :: a + end subroutine foo2 + + subroutine foo3(a) + character(10) :: a + value :: a + end subroutine foo3 + + subroutine foo4(a) ! { dg-error "VALUE attribute must have constant length" } + character(*) :: a + value :: a + end subroutine foo4 + + subroutine bar1(a) + use iso_c_binding, only: c_char + character(kind=c_char) :: a + value :: a + end subroutine bar1 + + subroutine bar2(a) + use iso_c_binding, only: c_char + !character(kind=c_char,len=1) :: a + character(1,kind=c_char) :: a + value :: a + end subroutine bar2 + + subroutine bar3(a) ! { dg-error "VALUE attribute must have length one" } + use iso_c_binding, only: c_char + character(kind=c_char,len=10) :: a + value :: a + end subroutine bar3 + + subroutine bar4(a) ! { dg-error "VALUE attribute must have constant length" } + use iso_c_binding, only: c_char + character(kind=c_char,len=*) :: a + value :: a + end subroutine bar4 +end program x diff --git a/gcc/testsuite/gfortran.dg/value_test.f90 b/gcc/testsuite/gfortran.dg/value_test.f90 new file mode 100644 index 00000000000..12313324c4d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_test.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +program valueTests + integer :: myInt + interface + subroutine mySub(myInt) + integer, value :: myInt + end subroutine mySub + end interface + + myInt = 10 + + call mySub(myInt) + ! myInt should be unchanged since pass-by-value + if(myInt .ne. 10) then + call abort () + endif +end program valueTests + +subroutine mySub(myInt) + integer, value :: myInt + myInt = 11 +end subroutine mySub + diff --git a/gcc/testsuite/gfortran.dg/value_tests_f03.f90 b/gcc/testsuite/gfortran.dg/value_tests_f03.f90 new file mode 100644 index 00000000000..65251736122 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_tests_f03.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +program value_tests_f03 + use, intrinsic :: iso_c_binding + real(c_double) :: myDouble + interface + subroutine value_test(myDouble) bind(c) + use, intrinsic :: iso_c_binding + real(c_double), value :: myDouble + end subroutine value_test + end interface + + myDouble = 9.0d0 + call value_test(myDouble) +end program value_tests_f03 + +subroutine value_test(myDouble) bind(c) + use, intrinsic :: iso_c_binding + real(c_double), value :: myDouble + interface + subroutine mySub(myDouble) + use, intrinsic :: iso_c_binding + real(c_double), value :: myDouble + end subroutine mySub + end interface + + myDouble = 10.0d0 + + call mySub(myDouble) +end subroutine value_test + +subroutine mySub(myDouble) + use, intrinsic :: iso_c_binding + real(c_double), value :: myDouble + + myDouble = 11.0d0 +end subroutine mySub + |