OSDN Git Service

2007-07-01 Christopher D. Rickett <crickett@lanl.gov>
authorkargl <kargl@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 2 Jul 2007 02:47:21 +0000 (02:47 +0000)
committerkargl <kargl@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 2 Jul 2007 02:47:21 +0000 (02:47 +0000)
* interface.c (gfc_compare_derived_types): Special case for comparing
derived types across namespaces.
(gfc_compare_types): Deal with BT_VOID.
(compare_parameter): Use BT_VOID to accept ISO C Binding pointers.
* trans-expr.c (gfc_conv_function_call): Remove setting parm_kind
to SCALAR
(gfc_conv_initializer): Deal with ISO C Binding NULL_PTR and
NULL_FUNPTR.
(gfc_conv_expr): Convert expressions for ISO C Binding derived types.
* symbol.c (gfc_set_default_type): BIND(C) variables should not be
implicitly declared.
(check_conflict): Add BIND(C) and check for conflicts.
(gfc_add_explicit_interface): Whitespace.
(gfc_add_is_bind_c): New function.
(gfc_copy_attr): Use it.
(gfc_new_symbol): Initialize ISO C Binding objects.
(get_iso_c_binding_dt):  New function.
(verify_bind_c_derived_type): Ditto.
(gen_special_c_interop_ptr): Ditto.
(add_formal_arg): Ditto.
(gen_cptr_param): Ditto.
(gen_fptr_param): Ditto.
(gen_shape_param): Ditto.
(add_proc_interface): Ditto.
(build_formal_args): Ditto.
(generate_isocbinding_symbol):  Ditto.
(get_iso_c_sym):  Ditto.
* decl.c (num_idents_on_line, has_name_equals): New variables.
(verify_c_interop_param): New function.
(build_sym): Finish binding labels and deal with COMMON blocks.
(add_init_expr_to_sym): Check if the initialized expression is
an iso_c_binding named constants
(variable_decl): Set ISO C Binding type_spec components.
(gfc_match_kind_spec): Check match for C interoperable kind.
(match_char_spec): Fix comment. Chnage gfc_match_small_int
to gfc_match_small_int_expr.  Check for C interoperable kind.
(match_type_spec): Clear the current binding label.
(match_attr_spec): Add DECL_IS_BIND_C.  If BIND(C) is found, use it
to set attributes.
(set_binding_label): New function.
(set_com_block_bind_c): Ditto.
(verify_c_interop): Ditto.
(verify_com_block_vars_c_interop): Ditto.
(verify_bind_c_sym): Ditto.
(set_verify_bind_c_sym): Ditto.
(set_verify_bind_c_com_block): Ditto.
(get_bind_c_idents): Ditto.
(gfc_match_bind_c_stmt): Ditto.
(gfc_match_data_decl): Use num_idents_on_line.
(match_result): Deal with right paren in BIND(C).
(gfc_match_suffix): New function.
(gfc_match_function_decl): Use it.  Code is re-arranged to deal with
ISO C Binding result clauses.
(gfc_match_subroutine):  Deal with BIND(C).
  (gfc_match_bind_c): New function.
(gfc_get_type_attr_spec): New function.  Code is re-arranged in and
taken from gfc_match_derived_decl.
(gfc_match_derived_decl): Add check for BIND(C).
* trans-common.c: Forward declare gfc_get_common.
(gfc_sym_mangled_common_id): Change arg from 'const char *name' to
'gfc_common_head *com'.  Check for ISO C Binding of the common block.
(build_common_decl): 'com->name' to 'com in SET_DECL_ASSEMBLER_NAME.
* gfortran.h: Add GFC_MAX_BINDING_LABEL_LEN
(bt): Add BT_VOID
(sym_flavor): Add FL_VOID.
  (iso_fortran_env_symbol, iso_c_binding_symbol, intmod_id): New enum
(CInteropKind_t): New struct.
(c_interop_kinds_table): Use it.  Declare an array of structs.
(symbol_attribute): Add is_bind_c, is_c_interop, and is_iso_c
bitfields.
(gfc_typespec): Add is_c_interop; is_iso_c, and f90_type members.
(gfc_symbol): Add from_intmod, intmod_sym_id, binding_label, and
common_block members.
(gfc_common_head): Add binding_label and is_bind_c members.
(gfc_gsymbol): Add sym_name, mod_name, and binding_label members.
Add prototypes for get_c_kind, gfc_validate_c_kind,
gfc_check_any_c_kind, gfc_add_is_bind_c, gfc_add_value,
verify_c_interop, verify_c_interop_param, verify_bind_c_sym,
verify_bind_c_derived_type, verify_com_block_vars_c_interop,
generate_isocbinding_symbol, get_iso_c_sym, gfc_iso_c_sub_interface
* iso-c-binding.def: New file. This file contains the definitions
of the types provided by the Fortran 2003 ISO_C_BINDING intrinsic
module.
* trans-const.c (gfc_conv_constant_to_tree): Deal with C_NULL_PTR
 or C_NULL_FUNPTR expressions.
* expr.c (gfc_copy_expr): Add BT_VOID case.  For BT_CHARACTER, the
ISO C Binding requires a minimum string length of 1 for '\0'.
* module.c (intmod_sym): New struct.
(pointer_info): Add binding_label member.
(write_atom): Set len to 0 for NULL pointers. Check for NULL p and *p.
(ab_attribute): Add AB_IS_BIND_C, AB_IS_C_INTEROP and AB_IS_ISO_C.
(attr_bits): Add "IS_BIND_C", "IS_C_INTEROP", and "IS_ISO_C".
(mio_symbol_attribute): Deal with ISO C Binding attributes.
(bt_types): Add "VOID".
(mio_typespec): Deal with ISO C Binding components.
(mio_namespace_ref): Add intmod variable.
(mio_symbol): Check for symbols from an intrinsic module.
(load_commons): Check for BIND(C) common block.
(read_module): Read binding_label and use it.
(write_common): Add label.  Write BIND(C) info.
(write_blank_common): Blank commons are not BIND(C).  Explicitly
set is_bind_c=0.
(write_symbol): Deal with binding_label.
(sort_iso_c_rename_list): New function.
(import_iso_c_binding_module): Ditto.
(create_int_parameter): Add to args.
(use_iso_fortran_env_module): Adjust to deal with iso_c_binding
intrinsic module.
* trans-types.c (c_interop_kinds_table): new array of structs.
(gfc_validate_c_kind): New function.
(gfc_check_any_c_kind): Ditto.
(get_real_kind_from_node): Ditto.
(get_int_kind_from_node): Ditto.
(get_int_kind_from_width): Ditto.
(get_int_kind_from_minimal_width): Ditto.
(init_c_interop_kinds): Ditto.
(gfc_init_kinds): call init_c_interop_kinds.
(gfc_typenode_for_spec): Adjust for BT_VOID and ISO C Binding pointers.
Adjust handling of BT_DERIVED.
(gfc_sym_type): Whitespace.
(gfc_get_derived_type):  Account for iso_c_binding derived types
* resolve.c (is_scalar_expr_ptr): New function.
(gfc_iso_c_func_interface): Ditto.
(resolve_function): Use gfc_iso_c_func_interface.
(set_name_and_label): New function.
(gfc_iso_c_sub_interface): Ditto.
(resolve_specific_s0): Use gfc_iso_c_sub_interface.
(resolve_bind_c_comms): New function.
(resolve_bind_c_derived_types): Ditto.
(gfc_verify_binding_labels): Ditto.
(resolve_fl_procedure): Check for ISO C interoperability.
(resolve_symbol): Check C interoperability.
(resolve_types): Walk the namespace.  Check COMMON blocks.
* trans-decl.c (gfc_sym_mangled_identifier):  Prevent the mangling
of identifiers that have an assigned binding label.
(gfc_sym_mangled_function_id): Use the binding label rather than
the mangled name.
(gfc_finish_var_decl): Put variables that are BIND(C) into a common
segment of the object file, because this is what C would do.
(gfc_create_module_variable): Conver to proper types
(set_tree_decl_type_code): New function.
(generate_local_decl): Check dummy variables and derived types for
ISO C Binding attributes.
* match.c (gfc_match_small_int_expr): New function.
(gfc_match_name_C): Ditto.
(match_common_name): Deal with ISO C Binding in COMMON blocks
* trans-io.c (transfer_expr):  Deal with C_NULL_PTR or C_NULL_FUNPTR
expressions
* match.h: Add prototypes for gfc_match_small_int_expr,
gfc_match_name_C, match_common_name, set_com_block_bind_c,
set_binding_label, set_verify_bind_c_sym,
set_verify_bind_c_com_block, get_bind_c_idents,
gfc_match_bind_c_stmt, gfc_match_suffix, gfc_match_bind_c,
gfc_get_type_attr_spec
* parse.c (decode_statement): Use gfc_match_bind_c_stmt
(parse_derived): Init *derived_sym = NULL, and gfc_current_block
later for valiadation.
* primary.c (got_delim): Set ISO C Binding components of ts.
(match_logical_constant): Ditto.
(match_complex_constant): Ditto.
(match_complex_constant): Ditto.
(gfc_match_rvalue): Check for existence of at least one arg for
C_LOC, C_FUNLOC, and C_ASSOCIATED.
* misc.c (gfc_clear_ts): Clear ISO C Bindoing components in ts.
(get_c_kind): New function.

2007-07-01  Christopher D. Rickett  <crickett@lanl.gov>

* Makefile.in: Add support for iso_c_generated_procs.c and
iso_c_binding.c.
* Makefile.am: Ditto.
* intrinsics/iso_c_generated_procs.c: New file containing helper
functions.
* intrinsics/iso_c_binding.c: Ditto.
* intrinsics/iso_c_binding.h: New file
* gfortran.map: Include the __iso_c_binding_c_* functions.
* libgfortran.h: define GFC_NUM_RANK_BITS.

2007-06-23  Christopher D. Rickett  <crickett@lanl.gov>

* bind_c_array_params.f03: New files for Fortran 2003 ISO C Binding.
* bind_c_coms.f90: Ditto.
* bind_c_coms_driver.c: Ditto.
* bind_c_dts.f90: Ditto.
* bind_c_dts_2.f03: Ditto.
* bind_c_dts_2_driver.c: Ditto.
* bind_c_dts_3.f03: Ditto.
* bind_c_dts_4.f03: Ditto.
* bind_c_dts_driver.c: Ditto.
* bind_c_implicit_vars.f03: Ditto.
* bind_c_procs.f03: Ditto.
* bind_c_usage_2.f03: Ditto.
* bind_c_usage_3.f03: Ditto.
* bind_c_usage_5.f03: Ditto.
* bind_c_usage_6.f03: Ditto.
* bind_c_usage_7.f03: Ditto.
* bind_c_vars.f90: Ditto.
* bind_c_vars_driver.c: Ditto.
* binding_c_table_15_1.f03: Ditto.
* binding_label_tests.f03: Ditto.
* binding_label_tests_10.f03: Ditto.
* binding_label_tests_10_main.f03: Ditto.
* binding_label_tests_11.f03: Ditto.
* binding_label_tests_11_main.f03: Ditto.
* binding_label_tests_12.f03: Ditto.
* binding_label_tests_13.f03: Ditto.
* binding_label_tests_13_main.f03: Ditto.
* binding_label_tests_14.f03: Ditto.
* binding_label_tests_2.f03: Ditto.
* binding_label_tests_3.f03: Ditto.
* binding_label_tests_4.f03: Ditto.
* binding_label_tests_5.f03: Ditto.
* binding_label_tests_6.f03: Ditto.
* binding_label_tests_7.f03: Ditto.
* binding_label_tests_8.f03: Ditto.
* binding_label_tests_9.f03: Ditto.
* c_assoc.f90: Ditto.
* c_assoc_2.f03: Ditto.
* c_f_pointer_shape_test.f90: Ditto.
* c_f_pointer_tests.f90: Ditto.
* c_f_tests_driver.c: Ditto.
* c_funloc_tests.f03: Ditto.
* c_funloc_tests_2.f03: Ditto.
* c_funloc_tests_3.f03: Ditto.
* c_funloc_tests_3_funcs.c: Ditto.
* c_kind_params.f90: Ditto.
* c_kind_tests_2.f03: Ditto.
* c_kinds.c: Ditto.
* c_loc_driver.c: Ditto.
* c_loc_test.f90: Ditto.
* c_loc_tests_2.f03: Ditto.
* c_loc_tests_2_funcs.c: Ditto.
* c_loc_tests_3.f03: Ditto.
* c_loc_tests_4.f03: Ditto.
* c_loc_tests_5.f03: Ditto.
* c_loc_tests_6.f03: Ditto.
* c_loc_tests_7.f03: Ditto.
* c_loc_tests_8.f03: Ditto.
* c_ptr_tests.f03: Ditto.
* c_ptr_tests_10.f03: Ditto.
* c_ptr_tests_5.f03: Ditto.
* c_ptr_tests_7.f03: Ditto.
* c_ptr_tests_7_driver.c: Ditto.
* c_ptr_tests_8.f03: Ditto.
* c_ptr_tests_8_funcs.c: Ditto.
* c_ptr_tests_9.f03: Ditto.
* c_ptr_tests_driver.c: Ditto.
* c_size_t_driver.c: Ditto.
* c_size_t_test.f03: Ditto.
* com_block_driver.f90: Ditto.
* global_vars_c_init.f90: Ditto.
* global_vars_c_init_driver.c: Ditto.
* global_vars_f90_init.f90: Ditto.
* global_vars_f90_init_driver.c: Ditto.
* interop_params.f03: Ditto.
* iso_c_binding_only.f03: Ditto.
* iso_c_binding_rename_1.f03: Ditto.
* iso_c_binding_rename_1_driver.c: Ditto.
* iso_c_binding_rename_2.f03: Ditto.
* iso_c_binding_rename_2_driver.c: Ditto.
* kind_tests_2.f03: Ditto.
* kind_tests_3.f03: Ditto.
* module_md5_1.f90: Ditto.
* only_clause_main.c: Ditto.
* print_c_kinds.f90: Ditto.
* test_bind_c_parens.f03: Ditto.
* test_c_assoc.c: Ditto.
* test_com_block.f90: Ditto.
* test_common_binding_labels.f03: Ditto.
* test_common_binding_labels_2.f03: Ditto.
* test_common_binding_labels_2_main.f03: Ditto.
* test_common_binding_labels_3.f03: Ditto.
* test_common_binding_labels_3_main.f03: Ditto.
* test_only_clause.f90: Ditto.
* use_iso_c_binding.f90: Ditto.
* value_5.f90: Ditto.
* value_test.f90: Ditto.
* value_tests_f03.f90: Ditto.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@126185 138bc75d-0d04-0410-961f-82ee72b054a4

128 files changed:
gcc/fortran/ChangeLog
gcc/fortran/decl.c
gcc/fortran/expr.c
gcc/fortran/gfortran.h
gcc/fortran/interface.c
gcc/fortran/iso-c-binding.def [new file with mode: 0644]
gcc/fortran/match.c
gcc/fortran/match.h
gcc/fortran/misc.c
gcc/fortran/module.c
gcc/fortran/parse.c
gcc/fortran/primary.c
gcc/fortran/resolve.c
gcc/fortran/symbol.c
gcc/fortran/trans-common.c
gcc/fortran/trans-const.c
gcc/fortran/trans-decl.c
gcc/fortran/trans-expr.c
gcc/fortran/trans-io.c
gcc/fortran/trans-types.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/bind_c_array_params.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_coms.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_coms_driver.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_dts.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_dts_2.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_dts_2_driver.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_dts_3.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_dts_4.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_dts_driver.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_implicit_vars.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_procs.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_usage_2.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_usage_3.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_usage_5.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_usage_6.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_usage_7.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_vars.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/bind_c_vars_driver.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_c_table_15_1.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_10.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_10_main.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_11.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_11_main.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_12.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_13.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_13_main.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_14.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_2.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_3.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_4.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_5.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_6.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_7.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_8.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/binding_label_tests_9.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_assoc.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_assoc_2.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_f_pointer_tests.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_f_tests_driver.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_funloc_tests.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_funloc_tests_3.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_funloc_tests_3_funcs.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_kind_params.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_kind_tests_2.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_kinds.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_loc_driver.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_loc_test.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_loc_tests_2.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_loc_tests_2_funcs.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_loc_tests_3.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_loc_tests_4.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_loc_tests_5.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_loc_tests_6.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_loc_tests_7.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_loc_tests_8.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_ptr_tests.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_ptr_tests_5.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_ptr_tests_7.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_ptr_tests_7_driver.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_ptr_tests_8.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_ptr_tests_8_funcs.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_ptr_tests_driver.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_size_t_driver.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_size_t_test.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/com_block_driver.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/global_vars_c_init.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/global_vars_c_init_driver.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/global_vars_f90_init.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/global_vars_f90_init_driver.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/interop_params.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/iso_c_binding_only.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/iso_c_binding_rename_1.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/iso_c_binding_rename_1_driver.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/iso_c_binding_rename_2.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/iso_c_binding_rename_2_driver.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/kind_tests_2.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/kind_tests_3.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/module_md5_1.f90
gcc/testsuite/gfortran.dg/only_clause_main.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/print_c_kinds.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/test_bind_c_parens.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/test_c_assoc.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/test_com_block.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/test_common_binding_labels.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/test_common_binding_labels_2.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/test_common_binding_labels_2_main.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/test_common_binding_labels_3.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/test_common_binding_labels_3_main.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/test_only_clause.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/use_iso_c_binding.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/value_5.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/value_test.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/value_tests_f03.f90 [new file with mode: 0644]
libgfortran/ChangeLog
libgfortran/Makefile.am
libgfortran/Makefile.in
libgfortran/gfortran.map
libgfortran/intrinsics/iso_c_binding.c [new file with mode: 0644]
libgfortran/intrinsics/iso_c_binding.h [new file with mode: 0644]
libgfortran/intrinsics/iso_c_generated_procs.c [new file with mode: 0644]
libgfortran/io/unit.c
libgfortran/libgfortran.h

index d0fe5d7..02060ee 100644 (file)
@@ -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
index 2568a50..24f1a3d 100644 (file)
@@ -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;
index d3f0ddf..0ca7dbf 100644 (file)
@@ -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;
index 9a653ce..8419118 100644 (file)
@@ -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 *);
index da8696b..69ab326 100644 (file)
@@ -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 (file)
index 0000000..664c43a
--- /dev/null
@@ -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
index ee376f5..8db0b63 100644 (file)
@@ -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",
index 8a309c5..8bcc5b1 100644 (file)
@@ -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 **);
index f1fdbf5..bf0eca8 100644 (file)
@@ -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;
+}
index 14d26d9..665f6a1 100644 (file)
@@ -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)
index 0daac0c..f1f9028 100644 (file)
@@ -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)
index 14253f6..0e3b6c0 100644 (file)
@@ -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;
 
index 43711cd..fde5043 100644 (file)
@@ -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);
 
index e1b27dc..867c6ef 100644 (file)
@@ -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;
+}
+
index 78cb7be..7b862c7 100644 (file)
@@ -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;
index 24aa809..7aaed0b 100644 (file)
@@ -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)
index e1379ba..1a94982 100644 (file)
@@ -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
index d70e4d5..c9cee1c 100644 (file)
@@ -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:
index a1a0570..00d0ebd 100644 (file)
@@ -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;
index 897b4ca..dace23a 100644 (file)
@@ -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))
index 6c58ee5..c08ccd9 100644 (file)
@@ -1,3 +1,104 @@
+2007-07-01  Christopher D. Rickett  <crickett@lanl.gov>
+
+       * bind_c_array_params.f03: New files for Fortran 2003 ISO C Binding.
+       * bind_c_coms.f90: Ditto.
+       * bind_c_coms_driver.c: Ditto.
+       * bind_c_dts.f90: Ditto.
+       * bind_c_dts_2.f03: Ditto.
+       * bind_c_dts_2_driver.c: Ditto.
+       * bind_c_dts_3.f03: Ditto.
+       * bind_c_dts_4.f03: Ditto.
+       * bind_c_dts_driver.c: Ditto.
+       * bind_c_implicit_vars.f03: Ditto.
+       * bind_c_procs.f03: Ditto.
+       * bind_c_usage_2.f03: Ditto.
+       * bind_c_usage_3.f03: Ditto.
+       * bind_c_usage_5.f03: Ditto.
+       * bind_c_usage_6.f03: Ditto.
+       * bind_c_usage_7.f03: Ditto.
+       * bind_c_vars.f90: Ditto.
+       * bind_c_vars_driver.c: Ditto.
+       * binding_c_table_15_1.f03: Ditto.
+       * binding_label_tests.f03: Ditto.
+       * binding_label_tests_10.f03: Ditto.
+       * binding_label_tests_10_main.f03: Ditto.
+       * binding_label_tests_11.f03: Ditto.
+       * binding_label_tests_11_main.f03: Ditto.
+       * binding_label_tests_12.f03: Ditto.
+       * binding_label_tests_13.f03: Ditto.
+       * binding_label_tests_13_main.f03: Ditto.
+       * binding_label_tests_14.f03: Ditto.
+       * binding_label_tests_2.f03: Ditto.
+       * binding_label_tests_3.f03: Ditto.
+       * binding_label_tests_4.f03: Ditto.
+       * binding_label_tests_5.f03: Ditto.
+       * binding_label_tests_6.f03: Ditto.
+       * binding_label_tests_7.f03: Ditto.
+       * binding_label_tests_8.f03: Ditto.
+       * binding_label_tests_9.f03: Ditto.
+       * c_assoc.f90: Ditto.
+       * c_assoc_2.f03: Ditto.
+       * c_f_pointer_shape_test.f90: Ditto.
+       * c_f_pointer_tests.f90: Ditto.
+       * c_f_tests_driver.c: Ditto.
+       * c_funloc_tests.f03: Ditto.
+       * c_funloc_tests_2.f03: Ditto.
+       * c_funloc_tests_3.f03: Ditto.
+       * c_funloc_tests_3_funcs.c: Ditto.
+       * c_kind_params.f90: Ditto.
+       * c_kind_tests_2.f03: Ditto.
+       * c_kinds.c: Ditto.
+       * c_loc_driver.c: Ditto.
+       * c_loc_test.f90: Ditto.
+       * c_loc_tests_2.f03: Ditto.
+       * c_loc_tests_2_funcs.c: Ditto.
+       * c_loc_tests_3.f03: Ditto.
+       * c_loc_tests_4.f03: Ditto.
+       * c_loc_tests_5.f03: Ditto.
+       * c_loc_tests_6.f03: Ditto.
+       * c_loc_tests_7.f03: Ditto.
+       * c_loc_tests_8.f03: Ditto.
+       * c_ptr_tests.f03: Ditto.
+       * c_ptr_tests_10.f03: Ditto.
+       * c_ptr_tests_5.f03: Ditto.
+       * c_ptr_tests_7.f03: Ditto.
+       * c_ptr_tests_7_driver.c: Ditto.
+       * c_ptr_tests_8.f03: Ditto.
+       * c_ptr_tests_8_funcs.c: Ditto.
+       * c_ptr_tests_9.f03: Ditto.
+       * c_ptr_tests_driver.c: Ditto.
+       * c_size_t_driver.c: Ditto.
+       * c_size_t_test.f03: Ditto.
+       * com_block_driver.f90: Ditto.
+       * global_vars_c_init.f90: Ditto.
+       * global_vars_c_init_driver.c: Ditto.
+       * global_vars_f90_init.f90: Ditto.
+       * global_vars_f90_init_driver.c: Ditto.
+       * interop_params.f03: Ditto.
+       * iso_c_binding_only.f03: Ditto.
+       * iso_c_binding_rename_1.f03: Ditto.
+       * iso_c_binding_rename_1_driver.c: Ditto.
+       * iso_c_binding_rename_2.f03: Ditto.
+       * iso_c_binding_rename_2_driver.c: Ditto.
+       * kind_tests_2.f03: Ditto.
+       * kind_tests_3.f03: Ditto.
+       * module_md5_1.f90: Ditto.
+       * only_clause_main.c: Ditto.
+       * print_c_kinds.f90: Ditto.
+       * test_bind_c_parens.f03: Ditto.
+       * test_c_assoc.c: Ditto.
+       * test_com_block.f90: Ditto.
+       * test_common_binding_labels.f03: Ditto.
+       * test_common_binding_labels_2.f03: Ditto.
+       * test_common_binding_labels_2_main.f03: Ditto.
+       * test_common_binding_labels_3.f03: Ditto.
+       * test_common_binding_labels_3_main.f03: Ditto.
+       * test_only_clause.f90: Ditto.
+       * use_iso_c_binding.f90: Ditto.
+       * value_5.f90: Ditto.
+       * value_test.f90: Ditto.
+       * value_tests_f03.f90: Ditto.
+
 2007-07-01  Daniel Jacobowitz  <dan@codesourcery.com>
 
        * gcc.dg/tls/opt-14.c: New.
diff --git a/gcc/testsuite/gfortran.dg/bind_c_array_params.f03 b/gcc/testsuite/gfortran.dg/bind_c_array_params.f03
new file mode 100644 (file)
index 0000000..6590db1
--- /dev/null
@@ -0,0 +1,14 @@
+! { dg-do compile }
+module bind_c_array_params
+use, intrinsic :: iso_c_binding
+implicit none
+
+contains
+  subroutine sub0(assumed_array) bind(c) ! { dg-error "cannot be an argument" }
+    integer(c_int), dimension(:) :: assumed_array
+  end subroutine sub0
+
+  subroutine sub1(deferred_array) bind(c) ! { dg-error "cannot" } 
+    integer(c_int), pointer :: deferred_array(:)
+  end subroutine sub1
+end module bind_c_array_params
diff --git a/gcc/testsuite/gfortran.dg/bind_c_coms.f90 b/gcc/testsuite/gfortran.dg/bind_c_coms.f90
new file mode 100644 (file)
index 0000000..e88d56d
--- /dev/null
@@ -0,0 +1,51 @@
+! { dg-do run }
+! { dg-additional-sources bind_c_coms_driver.c }
+! { dg-options "-w" }
+! the -w option is to prevent the warning about long long ints
+module bind_c_coms
+  use, intrinsic :: iso_c_binding
+  implicit none
+
+  common /COM/ R, S
+  real(c_double) :: r
+  real(c_double) :: t 
+  real(c_double) :: s 
+  bind(c) :: /COM/, /SINGLE/, /MYCOM/
+  common /SINGLE/ T
+  common /MYCOM/ LONG_INTS
+  integer(c_long) :: LONG_INTS
+  common /MYCOM2/ LONG_LONG_INTS
+  integer(c_long_long) :: long_long_ints
+  bind(c) :: /mycom2/
+
+  common /com2/ i, j
+  integer(c_int) :: i, j
+  bind(c, name="f03_com2") /com2/
+
+  common /com3/ m, n
+  integer(c_int) :: m, n
+  bind(c, name="") /com3/
+
+contains
+  subroutine test_coms() bind(c)
+    r = r + .1d0;
+    s = s + .1d0;
+    t = t + .1d0;
+    long_ints = long_ints + 1
+    long_long_ints = long_long_ints + 1
+    i = i + 1
+    j = j + 1
+
+    m = 1
+    n = 1
+  end subroutine test_coms
+end module bind_c_coms
+
+module bind_c_coms_2
+  use, intrinsic :: iso_c_binding, only: c_int
+  common /com3/ m, n
+  integer(c_int) :: m, n
+  bind(c, name="") /com3/
+end module bind_c_coms_2
+
+! { dg-final { cleanup-modules "bind_c_coms bind_c_coms_2" } }
diff --git a/gcc/testsuite/gfortran.dg/bind_c_coms_driver.c b/gcc/testsuite/gfortran.dg/bind_c_coms_driver.c
new file mode 100644 (file)
index 0000000..c83f22d
--- /dev/null
@@ -0,0 +1,42 @@
+double fabs(double);
+
+void test_coms(void);
+
+extern void abort(void);
+
+struct {double r, s; } com;     /* refers to the common block "com" */
+double single;                  /* refers to the common block "single" */
+long int mycom;                 /* refers to the common block "MYCOM" */
+long long int mycom2;           /* refers to the common block "MYCOM2" */
+struct {int i, j; } f03_com2;   /* refers to the common block "com2" */
+
+int main(int argc, char **argv)
+{
+  com.r = 1.0;
+  com.s = 2.0;
+  single = 1.0;
+  mycom = 1;
+  mycom2 = 2;
+  f03_com2.i = 1;
+  f03_com2.j = 2;
+
+  /* change the common block variables in F90 */
+  test_coms();
+
+  if(fabs(com.r - 1.1) > 0.00000000)
+    abort();
+  if(fabs(com.s - 2.1) > 0.00000000)
+    abort();
+  if(fabs(single - 1.1) > 0.00000000)
+    abort();
+  if(mycom != 2)
+    abort();
+  if(mycom2 != 3)
+    abort();
+  if(f03_com2.i != 2)
+    abort();
+  if(f03_com2.j != 3)
+    abort();
+  
+  return 0;
+}/* end main() */
diff --git a/gcc/testsuite/gfortran.dg/bind_c_dts.f90 b/gcc/testsuite/gfortran.dg/bind_c_dts.f90
new file mode 100644 (file)
index 0000000..f78630b
--- /dev/null
@@ -0,0 +1,41 @@
+! { dg-do run }
+! { dg-additional-sources bind_c_dts_driver.c }
+module bind_c_dts
+  use, intrinsic :: iso_c_binding
+  implicit none
+
+  type, bind(c) :: MYFTYPE_1
+     integer(c_int) :: i, j
+     real(c_float) :: s
+  end type MYFTYPE_1
+
+  TYPE, BIND(C) :: particle
+     REAL(C_DOUBLE) :: x,vx
+     REAL(C_DOUBLE) :: y,vy
+     REAL(C_DOUBLE) :: z,vz
+     REAL(C_DOUBLE) :: m
+  END TYPE particle
+
+  type(myftype_1), bind(c, name="myDerived") :: myDerived
+
+contains
+  subroutine types_test(my_particles, num_particles) bind(c)
+    integer(c_int), value :: num_particles
+    type(particle), dimension(num_particles) :: my_particles
+    integer :: i
+
+    ! going to set the particle in the middle of the list
+    i = num_particles / 2;
+    my_particles(i)%x = my_particles(i)%x + .2d0
+    my_particles(i)%vx = my_particles(i)%vx + .2d0
+    my_particles(i)%y = my_particles(i)%y + .2d0
+    my_particles(i)%vy = my_particles(i)%vy + .2d0
+    my_particles(i)%z = my_particles(i)%z + .2d0
+    my_particles(i)%vz = my_particles(i)%vz + .2d0
+    my_particles(i)%m = my_particles(i)%m + .2d0
+
+    myDerived%i = myDerived%i + 1
+    myDerived%j = myDerived%j + 1
+    myDerived%s = myDerived%s + 1.0;
+  end subroutine types_test
+end module bind_c_dts
diff --git a/gcc/testsuite/gfortran.dg/bind_c_dts_2.f03 b/gcc/testsuite/gfortran.dg/bind_c_dts_2.f03
new file mode 100644 (file)
index 0000000..4e5e61b
--- /dev/null
@@ -0,0 +1,61 @@
+! { dg-do run }
+! { dg-additional-sources bind_c_dts_2_driver.c }
+module bind_c_dts_2
+use, intrinsic :: iso_c_binding
+implicit none
+
+type, bind(c) :: my_c_type_0
+   integer(c_int) :: i
+   type(c_ptr) :: nested_c_address
+   integer(c_int) :: array(3)
+end type my_c_type_0
+
+type, bind(c) :: my_c_type_1
+   type(my_c_type_0) :: my_nested_type
+   type(c_ptr) :: c_address
+   integer(c_int) :: j
+end type my_c_type_1
+
+contains
+  subroutine sub0(my_type, expected_i, expected_nested_c_address, &
+       expected_array_1, expected_array_2, expected_array_3, &
+       expected_c_address, expected_j) bind(c)
+    type(my_c_type_1) :: my_type
+    integer(c_int), value :: expected_i
+    type(c_ptr), value :: expected_nested_c_address
+    integer(c_int), value :: expected_array_1
+    integer(c_int), value :: expected_array_2
+    integer(c_int), value :: expected_array_3
+    type(c_ptr), value :: expected_c_address
+    integer(c_int), value :: expected_j
+
+    if (my_type%my_nested_type%i .ne. expected_i) then
+       call abort ()
+    end if
+
+    if (.not. c_associated(my_type%my_nested_type%nested_c_address, &
+         expected_nested_c_address)) then
+       call abort ()
+    end if
+
+    if (my_type%my_nested_type%array(1) .ne. expected_array_1) then
+       call abort ()
+    end if
+
+    if (my_type%my_nested_type%array(2) .ne. expected_array_2) then
+       call abort ()
+    end if
+
+    if (my_type%my_nested_type%array(3) .ne. expected_array_3) then
+       call abort ()
+    end if
+
+    if (.not. c_associated(my_type%c_address, expected_c_address)) then
+       call abort ()
+    end if
+
+    if (my_type%j .ne. expected_j) then
+       call abort ()
+    end if
+  end subroutine sub0
+end module bind_c_dts_2
diff --git a/gcc/testsuite/gfortran.dg/bind_c_dts_2_driver.c b/gcc/testsuite/gfortran.dg/bind_c_dts_2_driver.c
new file mode 100644 (file)
index 0000000..53d2679
--- /dev/null
@@ -0,0 +1,37 @@
+typedef struct c_type_0
+{
+  int i;
+  int *ptr;
+  int array[3];
+}c_type_0_t;
+
+typedef struct c_type_1
+{
+  c_type_0_t nested_type;
+  int *ptr;
+  int j;
+}c_type_1_t;
+
+void sub0(c_type_1_t *c_type, int expected_i, int *expected_nested_ptr,
+          int array_0, int array_1, int array_2, 
+          int *expected_ptr, int expected_j);
+
+int main(int argc, char **argv)
+{
+  c_type_1_t c_type;
+
+  c_type.nested_type.i = 10;
+  c_type.nested_type.ptr = &(c_type.nested_type.i);
+  c_type.nested_type.array[0] = 1;
+  c_type.nested_type.array[1] = 2;
+  c_type.nested_type.array[2] = 3;
+  c_type.ptr = &(c_type.j);
+  c_type.j = 11;
+  
+  sub0(&c_type, c_type.nested_type.i, c_type.nested_type.ptr, 
+       c_type.nested_type.array[0],
+       c_type.nested_type.array[1], c_type.nested_type.array[2], 
+       c_type.ptr, c_type.j);
+  
+  return 0;
+}
diff --git a/gcc/testsuite/gfortran.dg/bind_c_dts_3.f03 b/gcc/testsuite/gfortran.dg/bind_c_dts_3.f03
new file mode 100644 (file)
index 0000000..6c6da9f
--- /dev/null
@@ -0,0 +1,39 @@
+! { dg-do compile }
+module bind_c_dts_3
+use, intrinsic :: iso_c_binding
+implicit none
+
+TYPE, bind(c) :: t
+  integer(c_int) :: i
+end type t
+
+type :: my_c_type_0 ! { dg-error "must have the BIND attribute" }
+   integer(c_int) :: i
+end type my_c_type_0
+
+type, bind(c) :: my_c_type_1 ! { dg-error "BIND.C. derived type" }
+   type(my_c_type_0) :: my_nested_type
+   type(c_ptr) :: c_address
+   integer(c_int), pointer :: j ! { dg-error "cannot have the POINTER" }
+end type my_c_type_1
+
+type, bind(c) :: t2 ! { dg-error "BIND.C. derived type" }
+   type (t2), pointer :: next ! { dg-error "cannot have the POINTER" }
+end type t2
+
+type, bind(c):: t3 ! { dg-error "BIND.C. derived type" }
+  type(t), allocatable :: c(:) ! { dg-error "cannot have the ALLOCATABLE" }
+end type t3
+
+contains
+  subroutine sub0(my_type, expected_value) bind(c) ! { dg-error "is not C interoperable" }
+    type(my_c_type_1) :: my_type
+    integer(c_int), value :: expected_value
+
+    if (my_type%my_nested_type%i .ne. expected_value) then
+       call abort ()
+    end if
+  end subroutine sub0
+end module bind_c_dts_3
+
+! { dg-final { cleanup-modules "bind_c_dts_3" } }
diff --git a/gcc/testsuite/gfortran.dg/bind_c_dts_4.f03 b/gcc/testsuite/gfortran.dg/bind_c_dts_4.f03
new file mode 100644 (file)
index 0000000..b2eb569
--- /dev/null
@@ -0,0 +1,10 @@
+! { dg-do compile }
+module test
+use iso_c_binding, only: c_int
+    type, bind(c) ::  foo
+      integer :: p ! { dg-warning "may not be C interoperable" }
+    end type
+    type(foo), bind(c) :: cp
+end module test
+
+! { dg-final { cleanup-modules "test" } }
diff --git a/gcc/testsuite/gfortran.dg/bind_c_dts_driver.c b/gcc/testsuite/gfortran.dg/bind_c_dts_driver.c
new file mode 100644 (file)
index 0000000..bf076ce
--- /dev/null
@@ -0,0 +1,66 @@
+double fabs (double);
+
+/* interops with myftype_1 */
+typedef struct {
+   int m, n;
+   float r;
+} myctype_t;
+
+/* interops with particle in f90 */
+typedef struct particle
+{
+   double x;  /* x position */
+   double vx; /* velocity in x direction */
+   double y;  /* y position */
+   double vy; /* velocity in y direction */
+   double z;  /* z position */
+   double vz; /* velocity in z direction */
+   double m;  /* mass */
+}particle_t;
+
+extern void abort(void);
+void types_test(particle_t *my_particles, int num_particles);
+/* declared in the fortran module bind_c_dts */
+extern myctype_t myDerived;
+
+int main(int argc, char **argv)
+{
+   particle_t my_particles[100];
+
+   /* the fortran code will modify the middle particle */
+   my_particles[49].x = 1.0;
+   my_particles[49].vx = 1.0;
+   my_particles[49].y = 1.0;
+   my_particles[49].vy = 1.0;
+   my_particles[49].z = 1.0;
+   my_particles[49].vz = 1.0;
+   my_particles[49].m = 1.0;
+
+   myDerived.m = 1;
+   myDerived.n = 2;
+   myDerived.r = 3.0;
+
+   types_test(&(my_particles[0]), 100);
+
+   if(fabs(my_particles[49].x - 1.2) > 0.00000000)
+      abort();
+   if(fabs(my_particles[49].vx - 1.2) > 0.00000000)
+      abort();
+   if(fabs(my_particles[49].y - 1.2) > 0.00000000)
+      abort();
+   if(fabs(my_particles[49].vy - 1.2) > 0.00000000)
+      abort();
+   if(fabs(my_particles[49].z - 1.2) > 0.00000000)
+      abort();
+   if(fabs(my_particles[49].vz - 1.2) > 0.00000000)
+      abort();
+   if(fabs(my_particles[49].m - 1.2) > 0.00000000)
+      abort();
+   if(myDerived.m != 2)
+      abort();
+   if(myDerived.n != 3)
+      abort();
+   if(fabs(myDerived.r - 4.0) > 0.00000000)
+      abort();
+   return 0;
+}/* end main() */
diff --git a/gcc/testsuite/gfortran.dg/bind_c_implicit_vars.f03 b/gcc/testsuite/gfortran.dg/bind_c_implicit_vars.f03
new file mode 100644 (file)
index 0000000..ff284ce
--- /dev/null
@@ -0,0 +1,10 @@
+! { dg-do compile }
+module bind_c_implicit_vars
+
+bind(c) :: j ! { dg-warning "may not be C interoperable" }
+
+contains
+  subroutine sub0(i) bind(c) ! { dg-warning "may not be C interoperable" }
+    i = 0
+  end subroutine sub0
+end module bind_c_implicit_vars
diff --git a/gcc/testsuite/gfortran.dg/bind_c_procs.f03 b/gcc/testsuite/gfortran.dg/bind_c_procs.f03
new file mode 100644 (file)
index 0000000..718042b
--- /dev/null
@@ -0,0 +1,39 @@
+! { dg-do compile }
+module bind_c_procs
+  use, intrinsic :: iso_c_binding, only: c_int
+
+  interface
+     ! warning for my_param possibly not being C interoperable
+     subroutine my_c_sub(my_param) bind(c) ! { dg-warning "may not be C interoperable" }
+       integer, value :: my_param
+     end subroutine my_c_sub
+
+     ! warning for my_c_func possibly not being a C interoperable kind
+     ! warning for my_param possibly not being C interoperable
+     ! error message truncated to provide an expression that both warnings
+     ! should match.
+     function my_c_func(my_param) bind(c) ! { dg-warning "may not be" }
+       integer, value :: my_param
+       integer :: my_c_func
+     end function my_c_func
+  end interface
+
+contains
+  ! warning for my_param possibly not being C interoperable
+  subroutine my_f03_sub(my_param) bind(c) ! { dg-warning "may not be" }
+    integer, value :: my_param
+  end subroutine my_f03_sub
+
+  ! warning for my_f03_func possibly not being a C interoperable kind
+  ! warning for my_param possibly not being C interoperable
+  ! error message truncated to provide an expression that both warnings
+  ! should match.
+  function my_f03_func(my_param) bind(c) ! { dg-warning "may not be" }
+    integer, value :: my_param
+    integer :: my_f03_func
+    my_f03_func = 1
+  end function my_f03_func
+
+end module bind_c_procs
+
+! { dg-final { cleanup-modules "bind_c_procs" } }
diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_2.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_2.f03
new file mode 100644 (file)
index 0000000..e76215e
--- /dev/null
@@ -0,0 +1,15 @@
+! { dg-do compile }
+use, intrinsic :: iso_c_binding
+type, bind(c) :: mytype
+  integer(c_int) :: j
+end type mytype
+
+type(mytype), bind(c) :: mytype_var ! { dg-error "cannot be BIND.C." }
+
+integer(c_int), bind(c) :: i ! { dg-error "cannot be declared with BIND.C." }
+integer(c_int), bind(c), dimension(10) :: my_array ! { dg-error "cannot be BIND.C." }
+
+common /COM/ i
+bind(c) :: /com/
+
+end
diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_3.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_3.f03
new file mode 100644 (file)
index 0000000..47f9d9a
--- /dev/null
@@ -0,0 +1,19 @@
+! { dg-do compile }
+module test
+  use, intrinsic :: iso_c_binding
+
+  type, bind(c) :: my_c_type ! { dg-error "BIND.C. derived type" }
+     integer(c_int), pointer :: ptr ! { dg-error "cannot have the POINTER attribute" }
+  end type my_c_type 
+  
+  type, bind(c) :: my_type ! { dg-error "BIND.C. derived type" }
+     integer(c_int), allocatable :: ptr(:) ! { dg-error "cannot have the ALLOCATABLE attribute" }
+  end type my_type
+
+  type foo ! { dg-error "must have the BIND attribute" }
+    integer(c_int) :: p 
+  end type foo 
+
+  type(foo), bind(c) :: cp ! { dg-error "is not C interoperable" }
+  real(c_double), pointer,bind(c) :: p ! { dg-error "cannot have both the POINTER and BIND.C." }
+end module test
diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_5.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_5.f03
new file mode 100644 (file)
index 0000000..95afa01
--- /dev/null
@@ -0,0 +1,8 @@
+! { dg-do compile }
+module bind_c_usage_5
+use, intrinsic :: iso_c_binding
+
+bind(c) c3, c4 
+integer(c_int), bind(c) :: c3 ! { dg-error "Duplicate BIND attribute" }
+integer(c_int) :: c4
+end module bind_c_usage_5
diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_6.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_6.f03
new file mode 100644 (file)
index 0000000..924dd40
--- /dev/null
@@ -0,0 +1,48 @@
+! { dg-do compile }
+module x
+  use iso_c_binding
+  bind(c) :: test, sub1 ! { dg-error "only be used for variables or common blocks" }
+  bind(c) :: sub2 ! { dg-error "only be used for variables or common blocks" }
+contains
+  function foo() bind(c,name="xx")
+    integer(c_int),bind(c,name="xy") :: foo ! { dg-error "only be used for variables or common blocks" }
+    ! NAG f95: "BIND(C) for non-variable FOO"  
+    ! g95: "Duplicate BIND attribute specified"
+    ! gfortran: Accepted
+    foo = 5_c_int
+  end function foo
+
+  function test()
+    integer(c_int) :: test
+    bind(c,name="kk") :: test ! { dg-error "only be used for variables or common blocks" }
+    ! NAG f95: "BIND(C) for non-variable TEST"
+    ! gfortran, g95: Accepted
+    test = 5_c_int
+  end function test
+
+  function bar() bind(c)
+    integer(c_int) :: bar 
+    bind(c,name="zx") :: bar ! { dg-error "only be used for variables or common blocks" }
+    bar = 5_c_int
+  end function bar
+
+  subroutine sub0() bind(c)
+    bind(c) :: sub0 ! { dg-error "only be used for variables or common blocks" }
+  end subroutine sub0
+
+  subroutine sub1(i) bind(c)
+    use, intrinsic :: iso_c_binding, only: c_int
+    integer(c_int), value :: i
+  end subroutine sub1
+
+  subroutine sub2(i) 
+    use, intrinsic :: iso_c_binding, only: c_int
+    integer(c_int), value :: i
+  end subroutine sub2
+
+  subroutine sub3(i) 
+    use, intrinsic :: iso_c_binding, only: c_int
+    integer(c_int), value :: i
+    bind(c) :: sub3 ! { dg-error "only be used for variables or common blocks" }
+  end subroutine sub3
+end module x
diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_7.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_7.f03
new file mode 100644 (file)
index 0000000..845aab9
--- /dev/null
@@ -0,0 +1,16 @@
+! { dg-do compile }
+module x
+  use iso_c_binding
+  implicit none
+contains
+  function bar() bind(c) ! { dg-error "cannot be an array" }
+    integer(c_int) :: bar(5)
+  end function bar
+
+  function my_string_func() bind(c) ! { dg-error "cannot be a character string" }
+    character(kind=c_char, len=10) :: my_string_func
+    my_string_func = 'my_string' // C_NULL_CHAR
+  end function my_string_func
+end module x
+
+! { dg-final { cleanup-modules "x" } }
diff --git a/gcc/testsuite/gfortran.dg/bind_c_vars.f90 b/gcc/testsuite/gfortran.dg/bind_c_vars.f90
new file mode 100644 (file)
index 0000000..4f4a0cf
--- /dev/null
@@ -0,0 +1,38 @@
+! { dg-do run }
+! { dg-additional-sources bind_c_vars_driver.c }
+module bind_c_vars
+  use, intrinsic :: iso_c_binding
+  implicit none
+
+  integer(c_int), bind(c) :: myF90Int
+  real(c_float), bind(c, name="myF90Real") :: f90_real
+  integer(c_int) :: c2
+  integer(c_int) :: c3
+  integer(c_int) :: c4
+  bind(c, name="myVariable") :: c2
+  bind(c) c3, c4 
+
+  integer(c_int), bind(c, name="myF90Array3D") :: A(18, 3:7, 10)
+  integer(c_int), bind(c, name="myF90Array2D") :: B(3, 2)
+
+contains
+  
+  subroutine changeF90Globals() bind(c, name='changeF90Globals')
+    implicit none
+    ! should make it 2
+    myF90Int = myF90Int + 1
+    ! should make it 3.0
+    f90_real = f90_real * 3.0;
+    ! should make it 4
+    c2 = c2 * 2;
+    ! should make it 6
+    c3 = c3 + 3;
+    ! should make it 2
+    c4 = c4 / 2;
+    ! should make it 2
+    A(5, 6, 3) = A(5, 6, 3) + 1
+    ! should make it 3
+    B(3, 2) = B(3, 2) + 1
+  end subroutine changeF90Globals
+
+end module bind_c_vars
diff --git a/gcc/testsuite/gfortran.dg/bind_c_vars_driver.c b/gcc/testsuite/gfortran.dg/bind_c_vars_driver.c
new file mode 100644 (file)
index 0000000..2af800a
--- /dev/null
@@ -0,0 +1,46 @@
+double fabs (double);
+
+/* defined in fortran module bind_c_vars */
+void changeF90Globals(void);
+
+extern void abort(void);
+
+/* module level scope in bind_c_vars */
+extern int myf90int;         /* myf90int in bind_c_vars */
+float myF90Real;             /* f90_real in bind_c_vars */
+int myF90Array3D[10][5][18]; /* A in bind_c_vars */
+int myF90Array2D[2][3];      /* B in bind_c_vars */
+int myVariable;              /* c2 in bind_c_vars */
+int c3;                      /* c3 in bind_c_vars */
+int c4;                      /* c4 in bind_c_vars */
+
+int main(int argc, char **argv)
+{
+   myf90int = 1;
+   myF90Real = 1.0;
+   myVariable = 2;
+   c3 = 3;
+   c4 = 4;
+   myF90Array3D[2][3][4] = 1;
+   myF90Array2D[1][2] = 2;
+
+   /* will change the global vars initialized above */
+   changeF90Globals();
+
+   if(myf90int != 2)
+      abort();
+   if(fabs(myF90Real-3.0) > 0.00000000)
+      abort();
+   if(myVariable != 4)
+      abort();
+   if(c3 != 6)
+      abort();
+   if(c4 != 2)
+      abort();
+   if(myF90Array3D[2][3][4] != 2)
+      abort();
+   if(myF90Array2D[1][2] != 3)
+      abort();
+   
+   return 0;
+}/* end main() */
diff --git a/gcc/testsuite/gfortran.dg/binding_c_table_15_1.f03 b/gcc/testsuite/gfortran.dg/binding_c_table_15_1.f03
new file mode 100644 (file)
index 0000000..a557309
--- /dev/null
@@ -0,0 +1,14 @@
+! { dg-do run }
+! Test the named constants in Table 15.1.
+program a
+  use, intrinsic :: iso_c_binding
+  implicit none
+  if (C_NULL_CHAR       /=  CHAR(0) ) call abort
+  if (C_ALERT           /= ACHAR(7) ) call abort
+  if (C_BACKSPACE       /= ACHAR(8) ) call abort
+  if (C_FORM_FEED       /= ACHAR(12)) call abort
+  if (C_NEW_LINE        /= ACHAR(10)) call abort
+  if (C_CARRIAGE_RETURN /= ACHAR(13)) call abort
+  if (C_HORIZONTAL_TAB  /= ACHAR(9) ) call abort
+  if (C_VERTICAL_TAB    /= ACHAR(11)) call abort
+end program a
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests.f03
new file mode 100644 (file)
index 0000000..3498650
--- /dev/null
@@ -0,0 +1,77 @@
+! { dg-do compile }
+module binding_label_tests
+  use, intrinsic :: iso_c_binding
+  implicit none
+
+  contains
+
+  subroutine c_sub() BIND(c, name = "C_Sub")
+    print *, 'hello from c_sub'
+  end subroutine c_sub
+
+  integer(c_int) function c_func() bind(C, name="__C_funC")
+    print *, 'hello from c_func'
+    c_func = 1
+  end function c_func
+
+  real(c_float) function f90_func() 
+    print *, 'hello from f90_func'
+    f90_func = 1.0
+  end function f90_func
+
+  real(c_float) function c_real_func() bind(c)
+    print *, 'hello from c_real_func'
+    c_real_func = 1.5
+  end function c_real_func
+
+  integer function f90_func_0() result ( f90_func_0_result ) 
+    print *, 'hello from f90_func_0'
+    f90_func_0_result = 0
+  end function f90_func_0
+
+  integer(c_int) function f90_func_1() result ( f90_func_1_result ) bind(c, name="__F90_Func_1__")
+    print *, 'hello from f90_func_1'
+    f90_func_1_result = 1
+  end function f90_func_1
+
+  integer(c_int) function f90_func_3() result ( f90_func_3_result ) bind(c)
+    print *, 'hello from f90_func_3'
+    f90_func_3_result = 3
+  end function f90_func_3
+
+  integer(c_int) function F90_func_2() bind(c) result ( f90_func_2_result ) 
+    print *, 'hello from f90_func_2'
+    f90_func_2_result = 2
+  end function f90_func_2
+
+  integer(c_int) function F90_func_4() bind(c, name="F90_func_4") result ( f90_func_4_result ) 
+    print *, 'hello from f90_func_4'
+    f90_func_4_result = 4
+  end function f90_func_4
+
+  integer(c_int) function F90_func_5() bind(c, name="F90_func_5") result ( f90_func_5_result ) 
+    print *, 'hello from f90_func_5'
+    f90_func_5_result = 5
+  end function f90_func_5
+
+  subroutine c_sub_2() bind(c, name='c_sub_2')
+    print *, 'hello from c_sub_2'
+  end subroutine c_sub_2
+
+  subroutine c_sub_3() BIND(c, name = "  C_Sub_3  ")
+    print *, 'hello from c_sub_3'
+  end subroutine c_sub_3
+
+  subroutine c_sub_5() BIND(c, name = "C_Sub_5        ")
+    print *, 'hello from c_sub_5'
+  end subroutine c_sub_5
+
+  ! nothing between the quotes except spaces, so name="".
+  ! the name will get set to the regularly mangled version of the name.  
+  ! perhaps it should be marked with some characters that are invalid for 
+  ! C names so C can not call it?
+  subroutine sub4() BIND(c, name = "        ") 
+  end subroutine sub4 
+end module binding_label_tests
+
+! { dg-final { cleanup-modules "binding_label_tests" } }
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_10.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_10.f03
new file mode 100644 (file)
index 0000000..99c9c52
--- /dev/null
@@ -0,0 +1,10 @@
+! { dg-do compile }
+! This file must be compiled BEFORE binding_label_tests_10_main.f03, which it 
+! should be because dejagnu will sort the files.
+module binding_label_tests_10
+  use iso_c_binding
+  implicit none
+  integer(c_int), bind(c,name="c_one") :: one
+end module binding_label_tests_10
+
+! Do not use dg-final to cleanup-modules
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_10_main.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_10_main.f03
new file mode 100644 (file)
index 0000000..aa24a6a
--- /dev/null
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! This file must be compiled AFTER binding_label_tests_10.f03, which it 
+! should be because dejagnu will sort the files.
+module binding_label_tests_10_main
+  use iso_c_binding
+  implicit none
+  integer(c_int), bind(c,name="c_one") :: one ! { dg-error "collides" }
+end module binding_label_tests_10_main
+
+program main
+  use binding_label_tests_10 ! { dg-error "collides" }
+  use binding_label_tests_10_main
+end program main
+
+! { dg-final { cleanup-modules "binding_label_tests_10_main binding_label_tests_10" } }
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_11.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_11.f03
new file mode 100644 (file)
index 0000000..5e889a7
--- /dev/null
@@ -0,0 +1,14 @@
+! { dg-do compile }
+! This file must be compiled BEFORE binding_label_tests_11_main.f03, which it 
+! should be because dejagnu will sort the files.
+module binding_label_tests_11
+  use iso_c_binding, only: c_int
+  implicit none
+contains
+  function one() bind(c, name="c_one")
+    integer(c_int) one
+    one = 1
+  end function one
+end module binding_label_tests_11
+
+! Do not use dg-final to cleanup-modules
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_11_main.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_11_main.f03
new file mode 100644 (file)
index 0000000..53eac7c
--- /dev/null
@@ -0,0 +1,19 @@
+! { dg-do compile }
+! This file must be compiled AFTER binding_label_tests_11.f03, which it 
+! should be because dejagnu will sort the files.
+module binding_label_tests_11_main
+  use iso_c_binding, only: c_int
+  implicit none
+contains
+  function one() bind(c, name="c_one") ! { dg-error "collides" }
+    integer(c_int) one
+    one = 1
+  end function one
+end module binding_label_tests_11_main
+
+program main
+  use binding_label_tests_11 ! { dg-error "collides" }
+  use binding_label_tests_11_main
+end program main
+
+! { dg-final { cleanup-modules "binding_label_tests_11_main binding_label_tests_11" } }
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_12.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_12.f03
new file mode 100644 (file)
index 0000000..0a00066
--- /dev/null
@@ -0,0 +1,24 @@
+! { dg-do run }
+! This verifies that the compiler will correctly accpet the name="", write out
+! an empty string for the binding label to the module file, and then read it
+! back in.  Also, during gfc_verify_binding_labels, the name="" will prevent
+! any verification (since there is no label to verify).
+module one
+contains
+  subroutine foo() bind(c)
+  end subroutine foo
+end module one
+
+module two
+contains
+  ! This procedure is only used accessed in C
+  ! as procedural pointer
+  subroutine foo() bind(c, name="")
+  end subroutine foo
+end module two
+
+use one, only: foo_one => foo
+use two, only: foo_two => foo
+end
+
+! { dg-final { cleanup-modules "one two" } }
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_13.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_13.f03
new file mode 100644 (file)
index 0000000..786945d
--- /dev/null
@@ -0,0 +1,8 @@
+! { dg-do compile }
+! This file must be compiled BEFORE binding_label_tests_13_main.f03, which it 
+! should be because dejagnu will sort the files.  
+module binding_label_tests_13
+ use, intrinsic :: iso_c_binding, only: c_int
+  integer(c_int) :: c3
+  bind(c) c3
+end module binding_label_tests_13
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_13_main.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_13_main.f03
new file mode 100644 (file)
index 0000000..1addc9c
--- /dev/null
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! This file must be compiled AFTER binding_label_tests_13.f03, which it 
+! should be because dejagnu will sort the files.  The module file 
+! binding_label_tests_13.mod can not be removed until after this test is done.
+module binding_label_tests_13_main
+  use, intrinsic :: iso_c_binding, only: c_int
+  integer(c_int) :: c3 ! { dg-error "collides" }
+  bind(c) c3
+
+contains
+  subroutine c_sub() BIND(c, name = "C_Sub")
+    use binding_label_tests_13 ! { dg-error "collides" }
+  end subroutine c_sub
+end module binding_label_tests_13_main
+! { dg-final { cleanup-modules "binding_label_tests_13 binding_label_tests_13_main" } }
+
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_14.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_14.f03
new file mode 100644 (file)
index 0000000..041237b
--- /dev/null
@@ -0,0 +1,12 @@
+! { dg-do run }
+subroutine display() bind(c)
+  implicit none
+end subroutine display
+
+program main
+  implicit none
+  interface
+     subroutine display() bind(c)
+     end subroutine display
+  end interface
+end program main
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_2.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_2.f03
new file mode 100644 (file)
index 0000000..bf9da11
--- /dev/null
@@ -0,0 +1,35 @@
+! { dg-do compile }
+module binding_label_tests_2
+
+contains
+  ! this is just here so at least one of the subroutines will be accepted so
+  ! gfortran doesn't give an Extension warning when using -pedantic-errors
+  subroutine ok() 
+  end subroutine ok
+
+  subroutine sub0() bind(c, name="   1") ! { dg-error "Invalid C name" }
+  end subroutine sub0 ! { dg-error "Expecting END MODULE" }
+
+  subroutine sub1() bind(c, name="$") ! { dg-error "Invalid C name" }
+  end subroutine sub1 ! { dg-error "Expecting END MODULE" }
+
+  subroutine sub2() bind(c, name="abc$") ! { dg-error "Invalid C name" }
+  end subroutine sub2 ! { dg-error "Expecting END MODULE" }
+
+  subroutine sub3() bind(c, name="abc d") ! { dg-error "Embedded space" }
+  end subroutine sub3 ! { dg-error "Expecting END MODULE" }
+
+  subroutine sub5() BIND(C, name=" myvar 2 ") ! { dg-error "Embedded space" }
+  end subroutine sub5 ! { dg-error "Expecting END MODULE" }
+
+  subroutine sub6() bind(c, name="         ) ! { dg-error "Invalid C name" }
+  end subroutine sub6 ! { dg-error "Expecting END MODULE" }
+
+  subroutine sub7() bind(c, name=) ! { dg-error "Syntax error" }
+  end subroutine sub7 ! { dg-error "Expecting END MODULE" }
+
+  subroutine sub8() bind(c, name) ! { dg-error "Syntax error" }
+  end subroutine sub8 ! { dg-error "Expecting END MODULE" }
+end module binding_label_tests_2 
+
+! { dg-final { cleanup-modules "binding_label_tests_2" } }
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_3.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_3.f03
new file mode 100644 (file)
index 0000000..6e12447
--- /dev/null
@@ -0,0 +1,30 @@
+! { dg-do compile }
+program main
+use iso_c_binding
+  interface
+     subroutine p1(f, a1, a2, a3, a4) bind(c, name='printf') ! { dg-error "collides" }
+       import :: c_ptr, c_int, c_double
+       type(c_ptr), value :: f
+       integer(c_int), value :: a1, a3
+       real(c_double), value :: a2, a4
+     end subroutine p1
+
+     subroutine p2(f, a1, a2, a3, a4) bind(c, name='printf') ! { dg-error "collides" }
+       import :: c_ptr, c_int, c_double
+       type(c_ptr), value :: f
+       real(c_double), value :: a1, a3
+       integer(c_int), value :: a2, a4
+     end subroutine p2
+  end interface
+
+  type(c_ptr) :: f_ptr
+  character(len=20), target :: format
+
+  f_ptr = c_loc(format(1:1))
+
+  format = 'Hello %d %f %d %f\n' // char(0)
+  call p1(f_ptr, 10, 1.23d0, 20, 2.46d0)
+
+  format = 'World %f %d %f %d\n' // char(0)
+  call p2(f_ptr, 1.23d0, 10, 2.46d0, 20)
+end program main
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_4.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_4.f03
new file mode 100644 (file)
index 0000000..5a0767d
--- /dev/null
@@ -0,0 +1,24 @@
+! { dg-do compile }
+module A
+  use, intrinsic :: iso_c_binding
+contains
+  subroutine pA() bind(c, name='printf') ! { dg-error "collides" }
+    print *, 'hello from pA'
+  end subroutine pA
+end module A
+
+module B
+  use, intrinsic :: iso_c_binding
+
+contains
+  subroutine pB() bind(c, name='printf') ! { dg-error "collides" }
+    print *, 'hello from pB'
+  end subroutine pB
+end module B
+
+module C
+use A
+use B ! { dg-error "Can't open module file" }
+end module C
+
+
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_5.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_5.f03
new file mode 100644 (file)
index 0000000..c8aa4e8
--- /dev/null
@@ -0,0 +1,12 @@
+! { dg-do compile }
+module binding_label_tests_5
+  use, intrinsic :: iso_c_binding
+  
+  interface
+     subroutine sub0() bind(c, name='c_sub') ! { dg-error "collides" }
+     end subroutine sub0
+     
+     subroutine sub1() bind(c, name='c_sub') ! { dg-error "collides" }
+     end subroutine sub1
+  end interface
+end module binding_label_tests_5
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_6.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_6.f03
new file mode 100644 (file)
index 0000000..0784de1
--- /dev/null
@@ -0,0 +1,6 @@
+! { dg-do compile }
+module binding_label_tests_6
+  use, intrinsic :: iso_c_binding
+  integer(c_int), bind(c, name='my_int') :: my_f90_int_1 ! { dg-error "collides" }
+  integer(c_int), bind(c, name='my_int') :: my_f90_int_2 ! { dg-error "collides" }
+end module binding_label_tests_6
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_7.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_7.f03
new file mode 100644 (file)
index 0000000..1234bb5
--- /dev/null
@@ -0,0 +1,15 @@
+! { dg-do compile }
+module A
+  use, intrinsic :: iso_c_binding, only: c_int
+  integer(c_int), bind(c, name='my_c_print') :: my_int ! { dg-error "collides" }
+end module A
+
+program main
+use A
+interface
+   subroutine my_c_print() bind(c) ! { dg-error "collides" }
+   end subroutine my_c_print
+end interface
+
+call my_c_print()
+end program main
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_8.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_8.f03
new file mode 100644 (file)
index 0000000..c49ee62
--- /dev/null
@@ -0,0 +1,9 @@
+! { dg-do compile }
+module binding_label_tests_8
+  use, intrinsic :: iso_c_binding, only: c_int
+  integer(c_int), bind(c, name='my_f90_sub') :: my_c_int ! { dg-error "collides" }
+
+contains
+  subroutine my_f90_sub() bind(c) ! { dg-error "collides" }
+  end subroutine my_f90_sub
+end module binding_label_tests_8
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_9.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_9.f03
new file mode 100644 (file)
index 0000000..0f50a08
--- /dev/null
@@ -0,0 +1,23 @@
+! { dg-do compile }
+module x
+  use iso_c_binding
+  implicit none
+  private :: bar ! { dg-warning "PRIVATE but has been given the binding label" }
+  private :: my_private_sub
+  private :: my_private_sub_2 ! { dg-warning "PRIVATE but has been given the binding label" }
+  public :: my_public_sub
+contains
+  subroutine bar() bind(c,name="foo") 
+  end subroutine bar
+  
+  subroutine my_private_sub() bind(c, name="")
+  end subroutine my_private_sub
+
+  subroutine my_private_sub_2() bind(c) 
+  end subroutine my_private_sub_2
+
+  subroutine my_public_sub() bind(c, name="my_sub")
+  end subroutine my_public_sub
+end module x
+
+! { dg-final { cleanup-modules "x" } }
diff --git a/gcc/testsuite/gfortran.dg/c_assoc.f90 b/gcc/testsuite/gfortran.dg/c_assoc.f90
new file mode 100644 (file)
index 0000000..9b2af24
--- /dev/null
@@ -0,0 +1,68 @@
+! { dg-do run }
+! { dg-additional-sources test_c_assoc.c }
+module c_assoc
+  use, intrinsic :: iso_c_binding
+  implicit none
+
+contains
+
+  function test_c_assoc_0(my_c_ptr) bind(c)
+    use, intrinsic :: iso_c_binding, only: c_ptr, c_int, c_associated
+    integer(c_int) :: test_c_assoc_0
+    type(c_ptr), value :: my_c_ptr
+
+    if(c_associated(my_c_ptr)) then
+       test_c_assoc_0 = 1
+    else
+       test_c_assoc_0 = 0
+    endif
+  end function test_c_assoc_0
+
+  function test_c_assoc_1(my_c_ptr_1, my_c_ptr_2) bind(c)
+    use, intrinsic :: iso_c_binding, only: c_ptr, c_int, c_associated
+    integer(c_int) :: test_c_assoc_1
+    type(c_ptr), value :: my_c_ptr_1
+    type(c_ptr), value :: my_c_ptr_2
+
+    if(c_associated(my_c_ptr_1, my_c_ptr_2)) then
+       test_c_assoc_1 = 1
+    else
+       test_c_assoc_1 = 0
+    endif
+  end function test_c_assoc_1
+
+  function test_c_assoc_2(my_c_ptr_1, my_c_ptr_2, num_ptrs) bind(c)
+    integer(c_int) :: test_c_assoc_2
+    type(c_ptr), value :: my_c_ptr_1
+    type(c_ptr), value :: my_c_ptr_2
+    integer(c_int), value :: num_ptrs
+    
+    if(num_ptrs .eq. 1) then
+       if(c_associated(my_c_ptr_1)) then
+          test_c_assoc_2 = 1
+       else
+          test_c_assoc_2 = 0
+       endif
+    else
+       if(c_associated(my_c_ptr_1, my_c_ptr_2)) then
+          test_c_assoc_2 = 1
+       else
+          test_c_assoc_2 = 0
+       endif
+    endif
+  end function test_c_assoc_2
+
+  subroutine verify_assoc(my_c_ptr_1, my_c_ptr_2) bind(c)
+    type(c_ptr), value :: my_c_ptr_1
+    type(c_ptr), value :: my_c_ptr_2
+
+    if(.not. c_associated(my_c_ptr_1)) then
+       call abort()
+    else if(.not. c_associated(my_c_ptr_2)) then
+       call abort()
+    else if(.not. c_associated(my_c_ptr_1, my_c_ptr_2)) then
+       call abort()
+    endif
+  end subroutine verify_assoc
+  
+end module c_assoc
diff --git a/gcc/testsuite/gfortran.dg/c_assoc_2.f03 b/gcc/testsuite/gfortran.dg/c_assoc_2.f03
new file mode 100644 (file)
index 0000000..9bb2f1b
--- /dev/null
@@ -0,0 +1,36 @@
+! { dg-do compile }
+module c_assoc_2
+  use, intrinsic :: iso_c_binding, only: c_ptr, c_associated
+
+contains
+  subroutine sub0(my_c_ptr) bind(c)
+    type(c_ptr), value :: my_c_ptr
+    type(c_ptr), pointer :: my_c_ptr_2
+    integer :: my_integer
+    
+    if(.not. c_associated(my_c_ptr)) then
+       call abort()
+    end if
+    
+    if(.not. c_associated(my_c_ptr, my_c_ptr)) then
+       call abort()
+    end if
+
+    if(.not. c_associated(my_c_ptr, my_c_ptr, my_c_ptr)) then ! { dg-error "More actual than formal arguments" }
+       call abort()
+    end if
+
+    if(.not. c_associated()) then ! { dg-error "Missing argument" }
+       call abort()
+    end if ! { dg-error "Expecting END SUBROUTINE" }
+
+    if(.not. c_associated(my_c_ptr_2)) then
+       call abort()
+    end if
+
+    if(.not. c_associated(my_integer)) then ! { dg-error "Type/rank mismatch" }
+       call abort()
+    end if
+  end subroutine sub0
+
+end module c_assoc_2
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90
new file mode 100644 (file)
index 0000000..c6204bd
--- /dev/null
@@ -0,0 +1,19 @@
+! { dg-do compile }
+! verify that the compiler catches the error in the call to c_f_pointer 
+! because it is missing the required SHAPE parameter.  the SHAPE parameter 
+! is optional, in general, but must exist if given a fortran pointer 
+! to a non-zero rank object.  --Rickett, 09.26.06
+module c_f_pointer_shape_test
+contains
+  subroutine test_0(myAssumedArray, cPtr)
+    use, intrinsic :: iso_c_binding
+    integer, dimension(*) :: myAssumedArray
+    integer, dimension(:), pointer :: myArrayPtr
+    integer, dimension(1:2), target :: myArray
+    type(c_ptr), value :: cPtr
+    
+    myArrayPtr => myArray
+    call c_f_pointer(cPtr, myArrayPtr) ! { dg-error "Missing SHAPE parameter" }
+  end subroutine test_0
+end module c_f_pointer_shape_test
+
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests.f90
new file mode 100644 (file)
index 0000000..1e4dbc0
--- /dev/null
@@ -0,0 +1,68 @@
+! { dg-do run }
+! { dg-additional-sources c_f_tests_driver.c }
+module c_f_pointer_tests
+  use, intrinsic :: iso_c_binding
+
+  type myF90Derived
+     integer(c_int) :: cInt
+     real(c_double) :: cDouble
+     real(c_float) :: cFloat
+     integer(c_short) :: cShort
+     type(c_funptr) :: myFunPtr
+  end type myF90Derived
+
+  type dummyDerived
+     integer(c_int) :: myInt
+  end type dummyDerived
+
+  contains
+
+  subroutine testDerivedPtrs(myCDerived, derivedArray, arrayLen, &
+       derived2DArray, dim1, dim2) &
+       bind(c, name="testDerivedPtrs")
+    implicit none
+    type(c_ptr), value :: myCDerived
+    type(c_ptr), value :: derivedArray
+    integer(c_int), value :: arrayLen
+    type(c_ptr), value :: derived2DArray
+    integer(c_int), value :: dim1
+    integer(c_int), value :: dim2
+    type(myF90Derived), pointer :: myF90Type
+    type(myF90Derived), dimension(:), pointer :: myF90DerivedArray
+    type(myF90Derived), dimension(:,:), pointer :: derivedArray2D
+    ! one dimensional array coming in (derivedArray)
+    integer(c_int), dimension(1:1) :: shapeArray
+    integer(c_int), dimension(1:2) :: shapeArray2
+    type(myF90Derived), dimension(1:10), target :: tmpArray
+
+    call c_f_pointer(myCDerived, myF90Type)
+    ! make sure numbers are ok.  initialized in c_f_tests_driver.c
+    if(myF90Type%cInt .ne. 1) then
+       call abort()
+    endif
+    if(myF90Type%cDouble .ne. 2.0d0) then
+       call abort()
+    endif
+    if(myF90Type%cFloat .ne. 3.0) then
+       call abort()
+    endif
+    if(myF90Type%cShort .ne. 4) then
+       call abort()
+    endif
+
+    shapeArray(1) = arrayLen
+    call c_f_pointer(derivedArray, myF90DerivedArray, shapeArray)
+
+    ! upper bound of each dim is arrayLen2
+    shapeArray2(1) = dim1
+    shapeArray2(2) = dim2
+    call c_f_pointer(derived2DArray, derivedArray2D, shapeArray2)
+    ! make sure the last element is ok
+    if((derivedArray2D(dim1, dim2)%cInt .ne. 4) .or. &
+         (derivedArray2D(dim1, dim2)%cDouble .ne. 4.0d0) .or. &
+         (derivedArray2D(dim1, dim2)%cFloat .ne. 4.0) .or. &
+         (derivedArray2D(dim1, dim2)%cShort .ne. 4)) then
+       call abort()
+    endif
+  end subroutine testDerivedPtrs
+end module c_f_pointer_tests
diff --git a/gcc/testsuite/gfortran.dg/c_f_tests_driver.c b/gcc/testsuite/gfortran.dg/c_f_tests_driver.c
new file mode 100644 (file)
index 0000000..5079cf7
--- /dev/null
@@ -0,0 +1,66 @@
+extern void abort(void);
+
+typedef struct myCDerived
+{
+   int cInt;
+   double cDouble;
+   float cFloat;
+   short cShort;
+   void *ptr;
+}myCDerived_t;
+
+#define DERIVED_ARRAY_LEN 10
+#define ARRAY_LEN_2 3
+#define DIM1 2
+#define DIM2 3
+
+void testDerivedPtrs(myCDerived_t *cDerivedPtr,
+                     myCDerived_t *derivedArray, int arrayLen,
+                     myCDerived_t *derived2d, int dim1, int dim2);
+
+int main(int argc, char **argv)
+{
+   myCDerived_t cDerived;
+   myCDerived_t derivedArray[DERIVED_ARRAY_LEN];
+   myCDerived_t derived2DArray[DIM1][DIM2];
+   int i = 0;
+   int j = 0;
+
+   cDerived.cInt = 1;
+   cDerived.cDouble = 2.0;
+   cDerived.cFloat = 3.0;
+   cDerived.cShort = 4;
+/*    cDerived.ptr = NULL; */
+   /* nullify the ptr */
+   cDerived.ptr = 0;
+
+   for(i = 0; i < DERIVED_ARRAY_LEN; i++)
+   {
+      derivedArray[i].cInt = (i+1) * 1;
+      derivedArray[i].cDouble = (i+1) * 1.0; /* 2.0; */
+      derivedArray[i].cFloat = (i+1) * 1.0; /* 3.0; */
+      derivedArray[i].cShort = (i+1) * 1; /* 4; */
+/*       derivedArray[i].ptr = NULL; */
+      derivedArray[i].ptr = 0;
+   }
+
+   for(i = 0; i < DIM1; i++)
+   {
+      for(j = 0; j < DIM2; j++)
+      {
+         derived2DArray[i][j].cInt = ((i*DIM1) * 1) + j;
+         derived2DArray[i][j].cDouble = ((i*DIM1) * 1.0) + j;
+         derived2DArray[i][j].cFloat = ((i*DIM1) * 1.0) + j;
+         derived2DArray[i][j].cShort = ((i*DIM1) * 1) + j;
+/*          derived2DArray[i][j].ptr = NULL; */
+         derived2DArray[i][j].ptr = 0;
+      }
+   }
+
+   /* send in the transpose size (dim2 is dim1, dim1 is dim2) */
+   testDerivedPtrs(&cDerived, derivedArray, DERIVED_ARRAY_LEN,
+                   derived2DArray[0], DIM2, DIM1);
+   
+   return 0;
+}/* end main() */
+
diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests.f03
new file mode 100644 (file)
index 0000000..c34ef2b
--- /dev/null
@@ -0,0 +1,21 @@
+! { dg-do run }
+! This test case simply checks that c_funloc exists, accepts arguments of 
+! flavor FL_PROCEDURE, and returns the type c_funptr
+module c_funloc_tests
+  use, intrinsic :: iso_c_binding, only: c_funptr, c_funloc
+
+contains
+  subroutine sub0() bind(c)
+    type(c_funptr) :: my_c_funptr
+
+    my_c_funptr = c_funloc(sub0)
+  end subroutine sub0
+end module c_funloc_tests
+
+program driver
+  use c_funloc_tests
+  
+  call sub0()
+end program driver
+
+! { dg-final { cleanup-modules "c_funloc_tests" } }
diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03
new file mode 100644 (file)
index 0000000..afaf29f
--- /dev/null
@@ -0,0 +1,16 @@
+! { dg-do compile }
+module c_funloc_tests_2
+  use, intrinsic :: iso_c_binding, only: c_funptr, c_funloc
+  implicit none
+
+contains
+  subroutine sub0() bind(c)
+    type(c_funptr) :: my_c_funptr
+    integer :: my_local_variable
+    
+    my_c_funptr = c_funloc() ! { dg-error "Missing argument" }
+    my_c_funptr = c_funloc(sub0)
+    my_c_funptr = c_funloc(sub0, sub0) ! { dg-error "More actual than formal" }
+    my_c_funptr = c_funloc(my_local_variable) ! { dg-error "must be a procedure" }
+  end subroutine sub0
+end module c_funloc_tests_2
diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_3.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests_3.f03
new file mode 100644 (file)
index 0000000..2d23efb
--- /dev/null
@@ -0,0 +1,36 @@
+! { dg-do run }
+! { dg-additional-sources c_funloc_tests_3_funcs.c }
+! This testcase tests c_funloc and c_funptr from iso_c_binding.  It uses 
+! functions defined in c_funloc_tests_3_funcs.c.
+module c_funloc_tests_3
+ implicit none
+contains
+  function ffunc(j) bind(c)
+    use iso_c_binding, only: c_funptr, c_int
+    integer(c_int)        :: ffunc
+    integer(c_int), value :: j
+    ffunc = -17*j
+  end function ffunc
+end module c_funloc_tests_3
+program main
+  use iso_c_binding, only: c_funptr, c_funloc
+  use c_funloc_tests_3, only: ffunc
+  implicit none
+  interface
+    function returnFunc() bind(c,name="returnFunc")
+       use iso_c_binding, only: c_funptr
+       type(c_funptr) :: returnFunc
+    end function returnFunc
+    subroutine callFunc(func,pass,compare) bind(c,name="callFunc")
+       use iso_c_binding, only: c_funptr, c_int
+       type(c_funptr), value :: func
+       integer(c_int), value :: pass,compare
+    end subroutine callFunc
+  end interface
+  type(c_funptr) :: p
+  p = returnFunc()
+  call callFunc(p, 13,3*13)
+  p = c_funloc(ffunc)
+  call callFunc(p, 21,-17*21)
+end program main
+! { dg-final { cleanup-modules "c_funloc_tests_3" } }
diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_3_funcs.c b/gcc/testsuite/gfortran.dg/c_funloc_tests_3_funcs.c
new file mode 100644 (file)
index 0000000..994da0a
--- /dev/null
@@ -0,0 +1,25 @@
+/* These functions support the test case c_funloc_tests_3.  */
+#include <stdlib.h>
+#include <stdio.h>
+
+int printIntC(int i)
+{
+  return 3*i;
+}
+
+int (*returnFunc(void))(int)
+{
+  return &printIntC;
+}
+
+void callFunc(int(*func)(int), int pass, int compare)
+{
+  int result = (*func)(pass);
+  if(result != compare)
+    {
+       printf("FAILED: Got %d, expected %d\n", result, compare);
+       abort();
+    }
+  else
+    printf("SUCCESS: Got %d, expected %d\n", result, compare);
+}
diff --git a/gcc/testsuite/gfortran.dg/c_kind_params.f90 b/gcc/testsuite/gfortran.dg/c_kind_params.f90
new file mode 100644 (file)
index 0000000..a7e577a
--- /dev/null
@@ -0,0 +1,76 @@
+! { dg-do run }
+! { dg-additional-sources c_kinds.c }
+! { dg-options "-w -std=c99" }
+! the -w option is needed to make f951 not report a warning for 
+! the -std=c99 option that the C file needs.
+!
+! Note: int_fast*_t currently not supported, cf. PR 448.
+module c_kind_params
+  use, intrinsic :: iso_c_binding
+  implicit none
+
+contains
+  subroutine param_test(my_short, my_int, my_long, my_long_long, &
+       my_int8_t, my_int_least8_t, my_int16_t, &
+       my_int_least16_t, my_int32_t, my_int_least32_t, &
+       my_int64_t, my_int_least64_t, &
+       my_intmax_t, my_intptr_t, my_float, my_double, my_long_double, &
+       my_char, my_bool) bind(c)
+    integer(c_short), value :: my_short
+    integer(c_int), value :: my_int
+    integer(c_long), value :: my_long
+    integer(c_long_long), value :: my_long_long
+    integer(c_int8_t), value :: my_int8_t
+    integer(c_int_least8_t), value :: my_int_least8_t
+!   integer(c_int_fast8_t), value :: my_int_fast8_t
+    integer(c_int16_t), value :: my_int16_t
+    integer(c_int_least16_t), value :: my_int_least16_t
+!   integer(c_int_fast16_t), value :: my_int_fast16_t
+    integer(c_int32_t), value :: my_int32_t
+    integer(c_int_least32_t), value :: my_int_least32_t
+!   integer(c_int_fast32_t), value :: my_int_fast32_t
+    integer(c_int64_t), value :: my_int64_t
+    integer(c_int_least64_t), value :: my_int_least64_t
+!   integer(c_int_fast64_t), value :: my_int_fast64_t
+    integer(c_intmax_t), value :: my_intmax_t
+    integer(c_intptr_t), value :: my_intptr_t
+    real(c_float), value :: my_float
+    real(c_double), value :: my_double
+    real(c_long_double), value :: my_long_double
+    character(c_char), value :: my_char
+    logical(c_bool), value :: my_bool
+
+    if(my_short     /= 1_c_short)     call abort()
+    if(my_int       /= 2_c_int)       call abort()
+    if(my_long      /= 3_c_long)      call abort()
+    if(my_long_long /= 4_c_long_long) call abort()
+
+    if(my_int8_t      /= 1_c_int8_t)        call abort()
+    if(my_int_least8_t  /= 2_c_int_least8_t ) call abort()
+    print *, 'c_int_fast8_t is:        ', c_int_fast8_t
+
+    if(my_int16_t     /= 1_c_int16_t)       call abort()
+    if(my_int_least16_t /= 2_c_int_least16_t) call abort()
+    print *, 'c_int_fast16_t is:       ', c_int_fast16_t
+
+    if(my_int32_t     /= 1_c_int32_t)       call abort()
+    if(my_int_least32_t /= 2_c_int_least32_t) call abort()
+    print *, 'c_int_fast32_t is:       ', c_int_fast32_t
+
+    if(my_int64_t     /= 1_c_int64_t)       call abort()
+    if(my_int_least64_t /= 2_c_int_least64_t) call abort()
+    print *, 'c_int_fast64_t is:       ', c_int_fast64_t
+
+    if(my_intmax_t /= 1_c_intmax_t) call abort()
+    if(my_intptr_t /= 0_c_intptr_t) call abort()
+
+    if(my_float       /= 1.0_c_float) call abort()
+    if(my_double      /= 2.0_c_double) call abort()
+    if(my_long_double /= 3.0_c_long_double) call abort()
+
+    if(my_char        /= c_char_'y') call abort()
+    if(my_bool      .neqv. .true._c_bool) call abort()
+  end subroutine param_test
+    
+end module c_kind_params
+! { dg-final { cleanup-modules "c_kind_params" } }
diff --git a/gcc/testsuite/gfortran.dg/c_kind_tests_2.f03 b/gcc/testsuite/gfortran.dg/c_kind_tests_2.f03
new file mode 100644 (file)
index 0000000..dcac65d
--- /dev/null
@@ -0,0 +1,14 @@
+! { dg-do compile }
+module c_kind_tests_2
+  use, intrinsic :: iso_c_binding
+
+  integer, parameter :: myF = c_float
+  real(myF), bind(c) :: myCFloat
+  integer(myF), bind(c) :: myCInt ! { dg-error "is for type REAL" }
+  integer(c_double), bind(c) :: myCInt2 ! { dg-error "is for type REAL" }
+
+  integer, parameter :: myI = c_int
+  real(myI) :: myReal
+  real(myI), bind(c) :: myCFloat2 ! { dg-error "is for type INTEGER" }
+  real(4), bind(c) :: myFloat ! { dg-warning "may not be a C interoperable" }
+end module c_kind_tests_2
diff --git a/gcc/testsuite/gfortran.dg/c_kinds.c b/gcc/testsuite/gfortran.dg/c_kinds.c
new file mode 100644 (file)
index 0000000..f79a70f
--- /dev/null
@@ -0,0 +1,54 @@
+/* { dg-do compile } */
+/* { dg-options "-std=c99" } */
+
+#include <stdint.h>
+
+/* Note: int_fast*_t is currently not supported, cf. PR 448 */
+void param_test(short int my_short, int my_int, long int my_long,
+                long long int my_long_long, int8_t my_int8_t,
+                int_least8_t my_int_least8_t, /*int_fast8_t my_int_fast8_t,*/
+                int16_t my_int16_t, int_least16_t my_int_least16_t,
+                /*int_fast16_t my_int_fast16_t,*/ int32_t my_int32_t,
+                int_least32_t my_int_least32_t, /*int_fast32_t my_int_fast32_t,*/
+                int64_t my_int64_t, int_least64_t my_int_least64_t,
+                /*int_fast64_t my_int_fast64_t,*/ intmax_t my_intmax_t,
+                intptr_t my_intptr_t, float my_float, double my_double,
+                long double my_long_double, char my_char, _Bool my_bool);
+   
+
+int main(int argc, char **argv)
+{
+   short int my_short = 1;
+   int my_int = 2;
+   long int my_long = 3;
+   long long int my_long_long = 4;
+   int8_t my_int8_t = 1;
+   int_least8_t my_int_least8_t = 2;
+   int_fast8_t my_int_fast8_t = 3;
+   int16_t my_int16_t = 1;
+   int_least16_t my_int_least16_t = 2;
+   int_fast16_t my_int_fast16_t = 3;
+   int32_t my_int32_t = 1;
+   int_least32_t my_int_least32_t = 2;
+   int_fast32_t my_int_fast32_t = 3;
+   int64_t my_int64_t = 1;
+   int_least64_t my_int_least64_t = 2;
+   int_fast64_t my_int_fast64_t = 3;
+   intmax_t my_intmax_t = 1;
+   intptr_t my_intptr_t = 0;  
+   float my_float = 1.0;
+   double my_double = 2.0;
+   long double my_long_double = 3.0;
+   char my_char = 'y';
+   _Bool my_bool = 1;
+
+   param_test(my_short, my_int, my_long, my_long_long, my_int8_t,
+              my_int_least8_t, /*my_int_fast8_t,  */ my_int16_t,
+              my_int_least16_t,/* my_int_fast16_t,*/ my_int32_t,
+              my_int_least32_t,/* my_int_fast32_t,*/ my_int64_t,
+              my_int_least64_t,/* my_int_fast64_t,*/ my_intmax_t,
+              my_intptr_t, my_float, my_double, my_long_double, my_char,
+              my_bool);
+
+   return 0;
+}/* end main() */
diff --git a/gcc/testsuite/gfortran.dg/c_loc_driver.c b/gcc/testsuite/gfortran.dg/c_loc_driver.c
new file mode 100644 (file)
index 0000000..9e01043
--- /dev/null
@@ -0,0 +1,17 @@
+/* in fortran module */
+void test0(void);
+
+extern void abort(void);
+
+int main(int argc, char **argv)
+{
+   test0();
+   return 0;
+}/* end main() */
+
+void test_address(void *c_ptr, int expected_value)
+{
+   if((*(int *)(c_ptr)) != expected_value)
+      abort();
+   return;
+}/* end test_address() */
diff --git a/gcc/testsuite/gfortran.dg/c_loc_test.f90 b/gcc/testsuite/gfortran.dg/c_loc_test.f90
new file mode 100644 (file)
index 0000000..178a516
--- /dev/null
@@ -0,0 +1,24 @@
+! { dg-do run }
+! { dg-additional-sources c_loc_driver.c }
+module c_loc_test
+implicit none
+
+contains
+  subroutine test0() bind(c)
+    use, intrinsic :: iso_c_binding
+    implicit none
+    integer, target :: x
+    type(c_ptr) :: my_c_ptr
+    interface
+       subroutine test_address(x, expected_value) bind(c)
+         use, intrinsic :: iso_c_binding
+         type(c_ptr), value :: x
+         integer(c_int), value :: expected_value
+       end subroutine test_address
+    end interface
+    x = 100
+    my_c_ptr = c_loc(x)
+    call test_address(my_c_ptr, 100)
+  end subroutine test0
+end module c_loc_test
+! { dg-final { cleanup-modules "c_loc_test.mod" } }
diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_2.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_2.f03
new file mode 100644 (file)
index 0000000..ae44495
--- /dev/null
@@ -0,0 +1,88 @@
+! { dg-do run }
+! { dg-additional-sources c_loc_tests_2_funcs.c }
+module c_loc_tests_2
+use, intrinsic :: iso_c_binding
+implicit none
+
+interface 
+   function test_scalar_address(cptr) bind(c)
+     use, intrinsic :: iso_c_binding, only: c_ptr, c_int
+     type(c_ptr), value :: cptr
+     integer(c_int) :: test_scalar_address
+   end function test_scalar_address
+
+   function test_array_address(cptr, num_elements) bind(c)
+     use, intrinsic :: iso_c_binding, only: c_ptr, c_int
+     type(c_ptr), value :: cptr
+     integer(c_int), value :: num_elements
+     integer(c_int) :: test_array_address
+   end function test_array_address
+
+   function test_type_address(cptr) bind(c)
+     use, intrinsic :: iso_c_binding, only: c_ptr, c_int
+     type(c_ptr), value :: cptr
+     integer(c_int) :: test_type_address
+   end function test_type_address
+end interface
+
+contains
+  subroutine test0() bind(c)
+    integer, target :: xtar
+    integer, pointer :: xptr
+    type(c_ptr) :: my_c_ptr_1 = c_null_ptr
+    type(c_ptr) :: my_c_ptr_2 = c_null_ptr
+    xtar = 100
+    xptr => xtar
+    my_c_ptr_1 = c_loc(xtar)
+    my_c_ptr_2 = c_loc(xptr)
+    if(test_scalar_address(my_c_ptr_1) .ne. 1) then
+       call abort()
+    end if
+    if(test_scalar_address(my_c_ptr_2) .ne. 1) then
+       call abort()
+    end if
+  end subroutine test0
+
+  subroutine test1() bind(c)
+    integer, target, dimension(100) :: int_array_tar
+    type(c_ptr) :: my_c_ptr_1 = c_null_ptr
+    type(c_ptr) :: my_c_ptr_2 = c_null_ptr
+    
+    int_array_tar = 100
+    my_c_ptr_1 = c_loc(int_array_tar)
+    if(test_array_address(my_c_ptr_1, 100) .ne. 1) then
+       call abort()
+    end if
+  end subroutine test1
+
+  subroutine test2() bind(c)
+    type, bind(c) f90type
+       integer(c_int) :: i
+       real(c_double) :: x
+    end type f90type
+    type(f90type), target :: type_tar
+    type(f90type), pointer :: type_ptr
+    type(c_ptr) :: my_c_ptr_1 = c_null_ptr
+    type(c_ptr) :: my_c_ptr_2 = c_null_ptr
+    
+    type_ptr => type_tar
+    type_tar%i = 100
+    type_tar%x = 1.0d0
+    my_c_ptr_1 = c_loc(type_tar)
+    my_c_ptr_2 = c_loc(type_ptr)
+    if(test_type_address(my_c_ptr_1) .ne. 1) then
+       call abort()
+    end if
+    if(test_type_address(my_c_ptr_2) .ne. 1) then
+       call abort()
+    end if
+  end subroutine test2
+end module c_loc_tests_2
+
+program driver
+  use c_loc_tests_2
+  call test0()
+  call test1()
+  call test2()
+end program driver
+! { dg-final { cleanup-modules "c_loc_tests_2" } }
diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_2_funcs.c b/gcc/testsuite/gfortran.dg/c_loc_tests_2_funcs.c
new file mode 100644 (file)
index 0000000..d47ac81
--- /dev/null
@@ -0,0 +1,42 @@
+double fabs (double);
+
+typedef struct ctype
+{
+  int i;
+  double x;
+}ctype_t;
+
+int test_scalar_address(int *ptr)
+{
+  /* The value in Fortran should be initialized to 100. */
+  if(*ptr != 100)
+    return 0;
+  else
+    return 1;
+}
+
+int test_array_address(int *int_array, int num_elements)
+{
+  int i = 0;
+
+  for(i = 0; i < num_elements; i++)
+    /* Fortran will init all of the elements to 100; verify that here. */
+    if(int_array[i] != 100)
+      return 0;
+
+  /* all elements were equal to 100 */
+  return 1;
+}
+
+int test_type_address(ctype_t *type_ptr)
+{
+  /* i was set to 100 by Fortran */
+  if(type_ptr->i != 100)
+    return 0;
+  
+  /* x was set to 1.0d0 by Fortran */
+  if(fabs(type_ptr->x - 1.0) > 0.00000000)
+    return 0;
+  
+  return 1;
+}
diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_3.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_3.f03
new file mode 100644 (file)
index 0000000..95eac4a
--- /dev/null
@@ -0,0 +1,8 @@
+! { dg-do compile }
+use iso_c_binding
+implicit none
+character(kind=c_char,len=256),target :: arg
+type(c_ptr),pointer :: c
+c = c_loc(arg) ! { dg-error "must have a length of 1" }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_4.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_4.f03
new file mode 100644 (file)
index 0000000..8453ec7
--- /dev/null
@@ -0,0 +1,15 @@
+! { dg-do compile }
+module c_loc_tests_4
+  use, intrinsic :: iso_c_binding
+  implicit none
+
+contains
+  subroutine sub0() bind(c)
+    integer(c_int), target, dimension(10) :: my_array
+    integer(c_int), pointer, dimension(:) :: my_array_ptr
+    type(c_ptr) :: my_c_ptr
+
+    my_array_ptr => my_array
+    my_c_ptr = c_loc(my_array_ptr) ! { dg-error "must be an associated scalar POINTER" }
+  end subroutine sub0
+end module c_loc_tests_4
diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_5.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_5.f03
new file mode 100644 (file)
index 0000000..a389437
--- /dev/null
@@ -0,0 +1,19 @@
+! { dg-do compile }
+module c_loc_tests_5
+  use, intrinsic :: iso_c_binding, only: c_char, c_ptr, c_loc, c_int
+
+contains
+  subroutine sub0() bind(c)
+    type(c_ptr) :: f_ptr, my_c_ptr
+    character(kind=c_char, len=20), target :: format
+    integer(c_int), dimension(:), pointer :: int_ptr
+    integer(c_int), dimension(10), target :: int_array
+
+    f_ptr = c_loc(format(1:1))
+
+    int_ptr => int_array
+    my_c_ptr = c_loc(int_ptr(0))
+
+  end subroutine sub0
+end module c_loc_tests_5
+! { dg-final { cleanup-modules "c_loc_tests_5" } }
diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_6.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_6.f03
new file mode 100644 (file)
index 0000000..c82a2ad
--- /dev/null
@@ -0,0 +1,13 @@
+! { dg-do compile }
+! Verifies that the c_loc scalar pointer tests recognize the string of length
+! one as being allowable for the parameter to c_loc.
+module x
+use iso_c_binding
+contains
+SUBROUTINE glutInit_f03()
+  TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR
+  CHARACTER(C_CHAR), DIMENSION(10), TARGET :: empty_string=C_NULL_CHAR
+  argv(1)=C_LOC(empty_string)
+END SUBROUTINE
+end module x
+! { dg-final { cleanup-modules "x" } }  
diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_7.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_7.f03
new file mode 100644 (file)
index 0000000..78f5276
--- /dev/null
@@ -0,0 +1,11 @@
+! { dg-do compile }
+module c_loc_tests_7
+use iso_c_binding
+contains
+SUBROUTINE glutInit_f03()
+  TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR
+  CHARACTER(C_CHAR), DIMENSION(1), TARGET :: empty_string=C_NULL_CHAR
+  argv(1)=C_LOC(empty_string)
+END SUBROUTINE
+end module c_loc_tests_7
+! { dg-final { cleanup-modules "c_loc_tests_7" } }
diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_8.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_8.f03
new file mode 100644 (file)
index 0000000..a094d69
--- /dev/null
@@ -0,0 +1,13 @@
+! { dg-do compile }
+! Verifies that the c_loc scalar pointer tests recognize the string of length
+! greater than one as not being allowable for the parameter to c_loc.
+module x
+use iso_c_binding
+contains
+SUBROUTINE glutInit_f03()
+  TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR
+  character(kind=c_char, len=5), target :: string="hello"
+  argv(1)=C_LOC(string) ! { dg-error "must have a length of 1" }
+END SUBROUTINE
+end module x
+
diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests.f03 b/gcc/testsuite/gfortran.dg/c_ptr_tests.f03
new file mode 100644 (file)
index 0000000..0b7c98b
--- /dev/null
@@ -0,0 +1,44 @@
+! { dg-do run }
+! { dg-additional-sources c_ptr_tests_driver.c }
+module c_ptr_tests
+  use, intrinsic :: iso_c_binding
+
+  ! TODO::
+  ! in order to be associated with a C address, 
+  ! the derived type needs to be C interoperable, 
+  ! which requires bind(c) and all fields interoperable.
+  type, bind(c) :: myType
+     type(c_ptr) :: myServices
+     type(c_funptr) :: mySetServices
+     type(c_ptr) :: myPort
+  end type myType
+
+  type, bind(c) :: f90Services
+     integer(c_int) :: compId
+     type(c_ptr) :: globalServices = c_null_ptr
+  end type f90Services
+
+  contains
+    
+    subroutine sub0(c_self, services) bind(c)
+      use, intrinsic :: iso_c_binding
+      implicit none
+      type(c_ptr), value :: c_self, services
+      type(myType), pointer :: self
+      type(f90Services), pointer :: localServices
+!      type(c_ptr) :: my_cptr 
+      type(c_ptr), save :: my_cptr = c_null_ptr
+
+      call c_f_pointer(c_self, self)
+      if(.not. associated(self)) then
+         print *, 'self is not associated'
+      end if
+      self%myServices = services
+
+      ! c_null_ptr is defined in iso_c_binding
+      my_cptr = c_null_ptr
+
+      ! get access to the local services obj from C
+      call c_f_pointer(self%myServices, localServices)
+    end subroutine sub0
+end module c_ptr_tests
diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03 b/gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03
new file mode 100644 (file)
index 0000000..d04786c
--- /dev/null
@@ -0,0 +1,18 @@
+! { dg-run }
+! This test case exists because gfortran had an error in converting the 
+! expressions for the derived types from iso_c_binding in some cases.
+module c_ptr_tests_10
+  use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr
+
+contains
+  subroutine sub0() bind(c)
+    print *, 'c_null_ptr is: ', c_null_ptr
+  end subroutine sub0
+end module c_ptr_tests_10
+
+program main
+  use c_ptr_tests_10
+  call sub0()
+end program main
+
+! { dg-final { cleanup-modules "c_ptr_tests_10" } }
diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_5.f03 b/gcc/testsuite/gfortran.dg/c_ptr_tests_5.f03
new file mode 100644 (file)
index 0000000..437e346
--- /dev/null
@@ -0,0 +1,16 @@
+! { dg-do compile }
+module c_ptr_tests_5
+use, intrinsic :: iso_c_binding
+
+type, bind(c) :: my_f90_type
+   integer(c_int) :: i
+end type my_f90_type
+
+contains
+  subroutine sub0(c_struct) bind(c)
+    type(c_ptr), value :: c_struct
+    type(my_f90_type) :: f90_type
+
+    call c_f_pointer(c_struct, f90_type) ! { dg-error "must have the POINTER" }
+  end subroutine sub0
+end module c_ptr_tests_5
diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_7.f03 b/