procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

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

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

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

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

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

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

From-SVN: r126185
This commit is contained in:
Christopher D. Rickett 2007-07-02 02:47:21 +00:00 • committed by Steven G. Kargl
parent 5edfe9e86f
commit a8b3b0b633
128 changed files with 7586 additions and 162 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

168
gcc/fortran/ChangeLog
View 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

1134
gcc/fortran/decl.c
View file

File diff suppressed because it is too large Load diff

19
gcc/fortran/expr.c
View 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;

113
gcc/fortran/gfortran.h
View 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 *);

23
gcc/fortran/interface.c
View 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)

158
gcc/fortran/iso-c-binding.def Normal file
View file

@ -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

157
gcc/fortran/match.c
View 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",

27
gcc/fortran/match.h
View 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 **);

21
gcc/fortran/misc.c
View 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;
}

312
gcc/fortran/module.c
View 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)
}
/* Add an integer named constant from a given module. */
static void
create_int_parameter (const char *name, int value, const char *modname)
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,
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)

7
gcc/fortran/parse.c
View 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)

25
gcc/fortran/primary.c
View 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;

773
gcc/fortran/resolve.c
View 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);

964
gcc/fortran/symbol.c
View file

File diff suppressed because it is too large Load diff

34
gcc/fortran/trans-common.c
View 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;

14
gcc/fortran/trans-const.c
View 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)

85
gcc/fortran/trans-decl.c
View 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

34
gcc/fortran/trans-expr.c
View 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:

11
gcc/fortran/trans-io.c
View 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;

203
gcc/fortran/trans-types.c
View 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))

101
gcc/testsuite/ChangeLog
View 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.

14
gcc/testsuite/gfortran.dg/bind_c_array_params.f03 Normal file
View file

@ -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

51
gcc/testsuite/gfortran.dg/bind_c_coms.f90 Normal file
View file

@ -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" } }

42
gcc/testsuite/gfortran.dg/bind_c_coms_driver.c Normal file
View file

@ -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() */

41
gcc/testsuite/gfortran.dg/bind_c_dts.f90 Normal file
View file

@ -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

61
gcc/testsuite/gfortran.dg/bind_c_dts_2.f03 Normal file
View file

@ -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

37
gcc/testsuite/gfortran.dg/bind_c_dts_2_driver.c Normal file
View file

@ -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;
}

39
gcc/testsuite/gfortran.dg/bind_c_dts_3.f03 Normal file
View file

@ -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" } }

10
gcc/testsuite/gfortran.dg/bind_c_dts_4.f03 Normal file
View file

@ -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" } }

66
gcc/testsuite/gfortran.dg/bind_c_dts_driver.c Normal file
View file

@ -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() */

10
gcc/testsuite/gfortran.dg/bind_c_implicit_vars.f03 Normal file
View file

@ -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

39
gcc/testsuite/gfortran.dg/bind_c_procs.f03 Normal file
View file

@ -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" } }

15
gcc/testsuite/gfortran.dg/bind_c_usage_2.f03 Normal file
View file

@ -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

19
gcc/testsuite/gfortran.dg/bind_c_usage_3.f03 Normal file
View file

@ -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

8
gcc/testsuite/gfortran.dg/bind_c_usage_5.f03 Normal file
View file

@ -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

48
gcc/testsuite/gfortran.dg/bind_c_usage_6.f03 Normal file
View file

@ -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

16
gcc/testsuite/gfortran.dg/bind_c_usage_7.f03 Normal file
View file

@ -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" } }

38
gcc/testsuite/gfortran.dg/bind_c_vars.f90 Normal file
View file

@ -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

46
gcc/testsuite/gfortran.dg/bind_c_vars_driver.c Normal file
View file

@ -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() */

14
gcc/testsuite/gfortran.dg/binding_c_table_15_1.f03 Normal file
View file

@ -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

77
gcc/testsuite/gfortran.dg/binding_label_tests.f03 Normal file
View file

@ -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" } }

10
gcc/testsuite/gfortran.dg/binding_label_tests_10.f03 Normal file
View file

@ -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

15
gcc/testsuite/gfortran.dg/binding_label_tests_10_main.f03 Normal file
View file

@ -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" } }

14
gcc/testsuite/gfortran.dg/binding_label_tests_11.f03 Normal file
View file

@ -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

19
gcc/testsuite/gfortran.dg/binding_label_tests_11_main.f03 Normal file
View file

@ -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" } }

24
gcc/testsuite/gfortran.dg/binding_label_tests_12.f03 Normal file
View file

@ -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" } }

8
gcc/testsuite/gfortran.dg/binding_label_tests_13.f03 Normal file
View file

@ -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

16
gcc/testsuite/gfortran.dg/binding_label_tests_13_main.f03 Normal file
View file

@ -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" } }

12
gcc/testsuite/gfortran.dg/binding_label_tests_14.f03 Normal file
View file

@ -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

35
gcc/testsuite/gfortran.dg/binding_label_tests_2.f03 Normal file
View file

@ -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" } }

30
gcc/testsuite/gfortran.dg/binding_label_tests_3.f03 Normal file
View file

@ -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

24
gcc/testsuite/gfortran.dg/binding_label_tests_4.f03 Normal file
View file

@ -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

12
gcc/testsuite/gfortran.dg/binding_label_tests_5.f03 Normal file
View file

@ -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

6
gcc/testsuite/gfortran.dg/binding_label_tests_6.f03 Normal file
View file

@ -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

15
gcc/testsuite/gfortran.dg/binding_label_tests_7.f03 Normal file
View file

@ -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

9
gcc/testsuite/gfortran.dg/binding_label_tests_8.f03 Normal file
View file

@ -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

23
gcc/testsuite/gfortran.dg/binding_label_tests_9.f03 Normal file
View file

@ -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" } }

68
gcc/testsuite/gfortran.dg/c_assoc.f90 Normal file
View file

@ -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

36
gcc/testsuite/gfortran.dg/c_assoc_2.f03 Normal file
View file

@ -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

19
gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 Normal file
View file

@ -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

68
gcc/testsuite/gfortran.dg/c_f_pointer_tests.f90 Normal file
View file

@ -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

66
gcc/testsuite/gfortran.dg/c_f_tests_driver.c Normal file
View file

@ -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() */

21
gcc/testsuite/gfortran.dg/c_funloc_tests.f03 Normal file
View file

@ -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" } }

16
gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03 Normal file
View file

@ -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

36
gcc/testsuite/gfortran.dg/c_funloc_tests_3.f03 Normal file
View file

@ -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" } }

25
gcc/testsuite/gfortran.dg/c_funloc_tests_3_funcs.c Normal file
View file

@ -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);
}

76
gcc/testsuite/gfortran.dg/c_kind_params.f90 Normal file
View file

@ -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" } }

14
gcc/testsuite/gfortran.dg/c_kind_tests_2.f03 Normal file
View file

@ -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

54
gcc/testsuite/gfortran.dg/c_kinds.c Normal file
View file

@ -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() */

17
gcc/testsuite/gfortran.dg/c_loc_driver.c Normal file
View file

@ -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() */

24
gcc/testsuite/gfortran.dg/c_loc_test.f90 Normal file
View file

@ -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" } }

88
gcc/testsuite/gfortran.dg/c_loc_tests_2.f03 Normal file
View file

@ -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" } }

42
gcc/testsuite/gfortran.dg/c_loc_tests_2_funcs.c Normal file
View file

@ -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;
}

8
gcc/testsuite/gfortran.dg/c_loc_tests_3.f03 Normal file
View file

@ -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

15
gcc/testsuite/gfortran.dg/c_loc_tests_4.f03 Normal file
View file

@ -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

19
gcc/testsuite/gfortran.dg/c_loc_tests_5.f03 Normal file
View file

@ -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" } }

13
gcc/testsuite/gfortran.dg/c_loc_tests_6.f03 Normal file
View file

@ -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" } }

11
gcc/testsuite/gfortran.dg/c_loc_tests_7.f03 Normal file
View file

@ -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" } }

13
gcc/testsuite/gfortran.dg/c_loc_tests_8.f03 Normal file
View file

@ -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

44
gcc/testsuite/gfortran.dg/c_ptr_tests.f03 Normal file
View file

@ -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

18
gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03 Normal file
View file

@ -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" } }

16
gcc/testsuite/gfortran.dg/c_ptr_tests_5.f03 Normal file
View file

@ -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

12
gcc/testsuite/gfortran.dg/c_ptr_tests_7.f03 Normal file
View file

@ -0,0 +1,12 @@
! { dg-do run }
! { dg-additional-sources c_ptr_tests_7_driver.c }
module c_ptr_tests_7
use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr
contains
function func0() bind(c)
type(c_ptr) :: func0
func0 = c_null_ptr
end function func0
end module c_ptr_tests_7
! { dg-final { cleanup-modules "c_ptr_tests_7" } }

14
gcc/testsuite/gfortran.dg/c_ptr_tests_7_driver.c Normal file
View file

@ -0,0 +1,14 @@
/* This is the driver for c_ptr_test_7. */
extern void abort(void);
void *func0();
int main(int argc, char **argv)
{
/* The Fortran module c_ptr_tests_7 contains function func0, which has
return type of c_ptr, and should set the return value to c_null_ptr. */
if (func0() != 0)
abort();
return 0;
}

20
gcc/testsuite/gfortran.dg/c_ptr_tests_8.f03 Normal file
View file

@ -0,0 +1,20 @@
! { dg-do run }
! { dg-additional-sources c_ptr_tests_8_funcs.c }
program main
use iso_c_binding, only: c_ptr
implicit none
interface
function create() bind(c)
use iso_c_binding, only: c_ptr
type(c_ptr) :: create
end function create
subroutine show(a) bind(c)
import :: c_ptr
type(c_ptr), VALUE :: a
end subroutine show
end interface
type(c_ptr) :: ptr
ptr = create()
call show(ptr)
end program main

26
gcc/testsuite/gfortran.dg/c_ptr_tests_8_funcs.c Normal file
View file

@ -0,0 +1,26 @@
/* This file provides auxilliary functions for c_ptr_tests_8. */
#include <stdio.h>
#include <stdlib.h>
extern void abort (void);
void *create (void)
{
int *a;
a = malloc (sizeof (a));
*a = 444;
return a;
}
void show (int *a)
{
if (*a == 444)
printf ("SUCCESS (%d)\n", *a);
else
{
printf ("FAILED: Expected 444, received %d\n", *a);
abort ();
}
}

31
gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03 Normal file
View file

@ -0,0 +1,31 @@
! { dg-do run }
! This test is pretty simple but is here just to make sure that the changes
! done to c_ptr and c_funptr (translating them to void *) works in the case
! where a component of a type is of type c_ptr or c_funptr.
module c_ptr_tests_9
use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr
type myF90Derived
type(c_ptr) :: my_c_ptr
end type myF90Derived
contains
subroutine sub0() bind(c)
type(myF90Derived), target :: my_f90_type
type(myF90Derived), pointer :: my_f90_type_ptr
my_f90_type%my_c_ptr = c_null_ptr
print *, 'my_f90_type is: ', my_f90_type
my_f90_type_ptr => my_f90_type
print *, 'my_f90_type_ptr is: ', my_f90_type_ptr
end subroutine sub0
end module c_ptr_tests_9
program main
use c_ptr_tests_9
call sub0()
end program main
! { dg-final { cleanup-modules "c_ptr_tests_9" } }

34
gcc/testsuite/gfortran.dg/c_ptr_tests_driver.c Normal file
View file

@ -0,0 +1,34 @@
/* this is the driver for c_ptr_test.f03 */
typedef struct services
{
int compId;
void *globalServices;
}services_t;
typedef struct comp
{
void *myServices;
void (*setServices)(struct comp *self, services_t *myServices);
void *myPort;
}comp_t;
/* prototypes for f90 functions */
void sub0(comp_t *self, services_t *myServices);
int main(int argc, char **argv)
{
services_t servicesObj;
comp_t myComp;
servicesObj.compId = 17;
servicesObj.globalServices = 0; /* NULL; */
myComp.myServices = &servicesObj;
myComp.setServices = 0; /* NULL; */
myComp.myPort = 0; /* NULL; */
sub0(&myComp, &servicesObj);
return 0;
}/* end main() */

12
gcc/testsuite/gfortran.dg/c_size_t_driver.c Normal file
View file

@ -0,0 +1,12 @@
#include <stdlib.h>
void sub0(int my_c_size);
int main(int argc, char **argv)
{
int my_c_size;
my_c_size = (int)sizeof(size_t);
sub0(my_c_size);
return 0;
}

16
gcc/testsuite/gfortran.dg/c_size_t_test.f03 Normal file
View file

@ -0,0 +1,16 @@
! { dg-do run }
! { dg-additional-sources c_size_t_driver.c }
module c_size_t_test
use, intrinsic :: iso_c_binding
contains
subroutine sub0(my_c_size) bind(c)
integer(c_int), value :: my_c_size ! value of C's sizeof(size_t)
! if the value of c_size_t isn't equal to the value of C's sizeof(size_t)
! we call abort.
if(c_size_t .ne. my_c_size) then
call abort ()
end if
end subroutine sub0
end module c_size_t_test

34
gcc/testsuite/gfortran.dg/com_block_driver.f90 Normal file
View file

@ -0,0 +1,34 @@
! { dg-do run }
module myComModule
use, intrinsic :: iso_c_binding
common /COM2/ R2, S2
real(c_double) :: r2
real(c_double) :: s2
bind(c) :: /COM2/
end module myComModule
module comBlockTests
use, intrinsic :: iso_c_binding
use myComModule
implicit none
common /COM/ R, S
real(c_double) :: r
real(c_double) :: s
bind(c) :: /COM/
contains
subroutine testTypes()
implicit none
end subroutine testTypes
end module comBlockTests
program comBlockDriver
use comBlockTests
call testTypes()
end program comBlockDriver

18
gcc/testsuite/gfortran.dg/global_vars_c_init.f90 Normal file
View file

@ -0,0 +1,18 @@
! { dg-do run }
! { dg-additional-sources global_vars_c_init_driver.c }
module global_vars_c_init
use, intrinsic :: iso_c_binding, only: c_int
implicit none
integer(c_int), bind(c, name='i') :: I
contains
subroutine test_globals() bind(c)
! the value of I is initialized above
if(I .ne. 2) then
call abort()
endif
end subroutine test_globals
end module global_vars_c_init

13
gcc/testsuite/gfortran.dg/global_vars_c_init_driver.c Normal file
View file

@ -0,0 +1,13 @@
int i = 2;
void test_globals(void);
extern void abort(void);
int main(int argc, char **argv)
{
/* verify that i has been initialized by f90 */
if(i != 2)
abort();
test_globals();
return 0;
}/* end main() */

18
gcc/testsuite/gfortran.dg/global_vars_f90_init.f90 Normal file
View file

@ -0,0 +1,18 @@
! { dg-do run }
! { dg-additional-sources global_vars_f90_init_driver.c }
module global_vars_f90_init
use, intrinsic :: iso_c_binding, only: c_int
implicit none
integer(c_int), bind(c, name='i') :: I = 2
contains
subroutine test_globals() bind(c)
! the value of I is initialized above
if(I .ne. 2) then
call abort()
endif
end subroutine test_globals
end module global_vars_f90_init

14
gcc/testsuite/gfortran.dg/global_vars_f90_init_driver.c Normal file
View file

@ -0,0 +1,14 @@
/* initialized by fortran */
int i;
void test_globals(void);
extern void abort(void);
int main(int argc, char **argv)
{
/* verify that i has been initialized by f90 */
if(i != 2)
abort();
test_globals();
return 0;
}/* end main() */

24
gcc/testsuite/gfortran.dg/interop_params.f03 Normal file
View file

@ -0,0 +1,24 @@
! { dg-do compile }
module interop_params
use, intrinsic :: iso_c_binding
type my_f90_type
integer :: i
real :: x
end type my_f90_type
contains
subroutine test_0(my_f90_int) bind(c) ! { dg-warning "may not be C interoperable" }
use, intrinsic :: iso_c_binding
integer, value :: my_f90_int
end subroutine test_0
subroutine test_1(my_f90_real) bind(c) ! { dg-error "is for type INTEGER" }
real(c_int), value :: my_f90_real
end subroutine test_1
subroutine test_2(my_type) bind(c) ! { dg-error "is not C interoperable" }
use, intrinsic :: iso_c_binding
type(my_f90_type) :: my_type
end subroutine test_2
end module interop_params

9
gcc/testsuite/gfortran.dg/iso_c_binding_only.f03 Normal file
View file

@ -0,0 +1,9 @@
! { dg-do compile }
module iso_c_binding_only
use, intrinsic :: iso_c_binding, only: c_null_ptr
! This should be allowed since the C_PTR that the C_NULL_PTR needs will use
! a mangled name to prevent collisions.
integer :: c_ptr
end module iso_c_binding_only
! { dg-final { cleanup-modules "iso_c_binding_only" } }

83
gcc/testsuite/gfortran.dg/iso_c_binding_rename_1.f03 Normal file
View file

@ -0,0 +1,83 @@
! { dg-do run }
! { dg-additional-sources iso_c_binding_rename_1_driver.c }
module iso_c_binding_rename_0
use, intrinsic :: iso_c_binding, only: my_c_ptr_0 => c_ptr, &
c_associated
end module iso_c_binding_rename_0
module iso_c_binding_rename_1
! rename a couple of the symbols from iso_c_binding. the compiler
! needs to be able to recognize the derived types with names different
! from the one in iso_c_binding because it will look up the derived types
! to define the args and return values of some of the procedures in
! iso_c_binding. this should verify that this functionality works.
use, intrinsic :: iso_c_binding, my_c_int => c_int, my_c_ptr => c_ptr, &
my_c_associated => c_associated, my_c_f_pointer => c_f_pointer
contains
subroutine sub0(my_int) bind(c)
integer(my_c_int), value :: my_int
if(my_int .ne. 1) then
call abort()
end if
end subroutine sub0
subroutine sub1(my_ptr) bind(c)
type(my_c_ptr), value :: my_ptr
if(.not. my_c_associated(my_ptr)) then
call abort()
end if
end subroutine sub1
subroutine sub2(my_int, my_long) bind(c)
use, intrinsic :: iso_c_binding, my_c_int_2 => c_int, &
my_c_long_2 => c_long
integer(my_c_int_2), value :: my_int
integer(my_c_long_2), value :: my_long
if(my_int .ne. 1) then
call abort()
end if
if(my_long .ne. 1) then
call abort()
end if
end subroutine sub2
subroutine sub3(cptr1, cptr2) bind(c)
type(my_c_ptr), value :: cptr1
type(my_c_ptr), value :: cptr2
integer(my_c_int), pointer :: my_f90_c_ptr
if(.not. my_c_associated(cptr1)) then
call abort()
end if
if(.not. my_c_associated(cptr1, cptr2)) then
call abort()
end if
call my_c_f_pointer(cptr1, my_f90_c_ptr)
end subroutine sub3
subroutine sub4(cptr1, cptr2) bind(c)
! rename the my_c_ptr_0 from iso_c_binding_rename_0 just to further test
! both are actually aliases to c_ptr
use iso_c_binding_rename_0, my_c_ptr_local => my_c_ptr_0, &
my_c_associated_2 => c_associated
implicit none
type(my_c_ptr_local), value :: cptr1
type(my_c_ptr_local), value :: cptr2
if(.not. my_c_associated_2(cptr1)) then
call abort()
end if
if(.not. my_c_associated_2(cptr2)) then
call abort()
end if
end subroutine sub4
end module iso_c_binding_rename_1

19
gcc/testsuite/gfortran.dg/iso_c_binding_rename_1_driver.c Normal file
View file

@ -0,0 +1,19 @@
void sub0(int);
void sub1(int *);
void sub2(int, long);
void sub3(int *, int *);
void sub4(int *, int *);
int main(int argc, char **argv)
{
int i = 1;
long j = 1;
sub0(i);
sub1(&i);
sub2(i, j);
sub3(&i, &i);
sub4(&i, &i);
return 0;
}

40
gcc/testsuite/gfortran.dg/iso_c_binding_rename_2.f03 Normal file
View file

@ -0,0 +1,40 @@
! { dg-do run }
! { dg-additional-sources iso_c_binding_rename_2_driver.c }
module mod0
use, intrinsic :: iso_c_binding, only: c_ptr, c_associated
end module mod0
module mod1
use mod0, my_c_ptr => c_ptr, my_c_associated => c_associated
end module mod1
module mod2
contains
subroutine sub2(my_ptr1) bind(c)
use mod1, my_c_ptr_2 => my_c_ptr, my_c_associated_2 => my_c_associated
implicit none
type(my_c_ptr_2) :: my_ptr1
if( .not. my_c_associated_2(my_ptr1)) then
call abort()
end if
end subroutine sub2
subroutine sub3(my_ptr1) bind(c)
use mod1, my_c_ptr_2 => my_c_ptr
implicit none
type(my_c_ptr_2) :: my_ptr1
if( .not. my_c_associated(my_ptr1)) then
call abort()
end if
end subroutine sub3
subroutine sub4(my_ptr1) bind(c)
use mod1, my_c_associated_3 => my_c_associated
implicit none
type(my_c_ptr) :: my_ptr1
if( .not. my_c_associated_3(my_ptr1)) then
call abort()
end if
end subroutine sub4
end module mod2

Some files were not shown because too many files have changed in this diff Show more