aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
authorChristopher D. Rickett <crickett@lanl.gov>2007-07-02 02:47:21 +0000
committerSteven G. Kargl <kargl@gcc.gnu.org>2007-07-02 02:47:21 +0000
commita8b3b0b633eb1f33d41c8f49a77641d4f767cd01 (patch)
treeac4b8eff52a0e3e3d04868300cc36392b6ca3faa /gcc/fortran
parent5edfe9e86fb349a11ad604074fcbdfc917f3c04a (diff)
downloadgcc-a8b3b0b633eb1f33d41c8f49a77641d4f767cd01.zip
gcc-a8b3b0b633eb1f33d41c8f49a77641d4f767cd01.tar.gz
gcc-a8b3b0b633eb1f33d41c8f49a77641d4f767cd01.tar.bz2
[multiple changes]
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. From-SVN: r126185
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog168
-rw-r--r--gcc/fortran/decl.c1126
-rw-r--r--gcc/fortran/expr.c19
-rw-r--r--gcc/fortran/gfortran.h113
-rw-r--r--gcc/fortran/interface.c23
-rw-r--r--gcc/fortran/iso-c-binding.def158
-rw-r--r--gcc/fortran/match.c157
-rw-r--r--gcc/fortran/match.h27
-rw-r--r--gcc/fortran/misc.c21
-rw-r--r--gcc/fortran/module.c310
-rw-r--r--gcc/fortran/parse.c7
-rw-r--r--gcc/fortran/primary.c25
-rw-r--r--gcc/fortran/resolve.c773
-rw-r--r--gcc/fortran/symbol.c964
-rw-r--r--gcc/fortran/trans-common.c34
-rw-r--r--gcc/fortran/trans-const.c14
-rw-r--r--gcc/fortran/trans-decl.c85
-rw-r--r--gcc/fortran/trans-expr.c34
-rw-r--r--gcc/fortran/trans-io.c11
-rw-r--r--gcc/fortran/trans-types.c203
20 files changed, 4139 insertions, 133 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d0fe5d7..02060ee 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 2568a50..24f1a3d 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 (&current_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 (&current_attr, &seen_at[d]);
break;
+ case DECL_IS_BIND_C:
+ t = gfc_add_is_bind_c(&current_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 = &current_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 (&current_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 d3f0ddf..0ca7dbf 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 9a653ce..8419118 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 da8696b..69ab326 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 0000000..664c43a
--- /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 ee376f5..8db0b63 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 8a309c5..8bcc5b1 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 f1fdbf5..bf0eca8 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 14d26d9..665f6a1 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 0daac0c..f1f9028 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 14253f6..0e3b6c0 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 43711cd..fde5043 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 e1b27dc..867c6ef 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, &param_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, &param_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, &param_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 78cb7be..7b862c7 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 24aa809..7aaed0b 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 e1379ba..1a94982 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 d70e4d5..c9cee1c 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 a1a0570..00d0ebd 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 897b4ca..dace23a 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))