[multiple changes]

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

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

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

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

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

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

From-SVN: r126185

1 files changed, 772 insertions, 1 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 43711cd..fde5043 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1540,6 +1540,284 @@ pure_function (gfc_expr *e, const char **name)
 }
 
 
+static try
+is_scalar_expr_ptr (gfc_expr *expr)
+{
+  try retval = SUCCESS;
+  gfc_ref *ref;
+  int start;
+  int end;
+
+  /* See if we have a gfc_ref, which means we have a substring, array
+     reference, or a component.  */
+  if (expr->ref != NULL)
+    {
+      ref = expr->ref;
+      while (ref->next != NULL)
+        ref = ref->next;
+
+      switch (ref->type)
+        {
+        case REF_SUBSTRING:
+          if (ref->u.ss.length != NULL 
+              && ref->u.ss.length->length != NULL
+              && ref->u.ss.start
+              && ref->u.ss.start->expr_type == EXPR_CONSTANT 
+              && ref->u.ss.end
+              && ref->u.ss.end->expr_type == EXPR_CONSTANT)
+            {
+              start = (int) mpz_get_si (ref->u.ss.start->value.integer);
+              end = (int) mpz_get_si (ref->u.ss.end->value.integer);
+              if (end - start + 1 != 1)
+                retval = FAILURE;
+            }
+          else
+            retval = FAILURE;
+          break;
+        case REF_ARRAY:
+          if (ref->u.ar.type == AR_ELEMENT)
+            retval = SUCCESS;
+          else if (ref->u.ar.type == AR_FULL)
+            {
+              /* The user can give a full array if the array is of size 1.  */
+              if (ref->u.ar.as != NULL
+                  && ref->u.ar.as->rank == 1
+                  && ref->u.ar.as->type == AS_EXPLICIT
+                  && ref->u.ar.as->lower[0] != NULL
+                  && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
+                  && ref->u.ar.as->upper[0] != NULL
+                  && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
+                {
+		  /* If we have a character string, we need to check if
+		     its length is one.	 */
+		  if (expr->ts.type == BT_CHARACTER)
+		    {
+		      if (expr->ts.cl == NULL
+			  || expr->ts.cl->length == NULL
+			  || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
+			  != 0)
+                        retval = FAILURE;
+		    }
+		  else
+		    {
+                  /* We have constant lower and upper bounds.  If the
+                     difference between is 1, it can be considered a
+                     scalar.  */
+                  start = (int) mpz_get_si
+                                (ref->u.ar.as->lower[0]->value.integer);
+                  end = (int) mpz_get_si
+                              (ref->u.ar.as->upper[0]->value.integer);
+                  if (end - start + 1 != 1)
+                    retval = FAILURE;
+                }
+                }
+              else
+                retval = FAILURE;
+            }
+          else
+            retval = FAILURE;
+          break;
+        default:
+          retval = SUCCESS;
+          break;
+        }
+    }
+  else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
+    {
+      /* Character string.  Make sure it's of length 1.  */
+      if (expr->ts.cl == NULL
+          || expr->ts.cl->length == NULL
+          || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
+        retval = FAILURE;
+    }
+  else if (expr->rank != 0)
+    retval = FAILURE;
+
+  return retval;
+}
+
+
+/* Match one of the iso_c_binding functions (c_associated or c_loc)
+   and, in the case of c_associated, set the binding label based on
+   the arguments.  */
+
+static try
+gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
+                          gfc_symbol **new_sym)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+  int optional_arg = 0;
+  try retval = SUCCESS;
+  gfc_symbol *args_sym;
+
+  args_sym = args->expr->symtree->n.sym;
+   
+  if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
+    {
+      /* If the user gave two args then they are providing something for
+	 the optional arg (the second cptr).  Therefore, set the name and
+	 binding label to the c_associated for two cptrs.  Otherwise,
+	 set c_associated to expect one cptr.  */
+      if (args->next)
+	{
+	  /* two args.  */
+	  sprintf (name, "%s_2", sym->name);
+	  sprintf (binding_label, "%s_2", sym->binding_label);
+	  optional_arg = 1;
+	}
+      else
+	{
+	  /* one arg.  */
+	  sprintf (name, "%s_1", sym->name);
+	  sprintf (binding_label, "%s_1", sym->binding_label);
+	  optional_arg = 0;
+	}
+
+      /* Get a new symbol for the version of c_associated that
+	 will get called.  */
+      *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
+    }
+  else if (sym->intmod_sym_id == ISOCBINDING_LOC
+	   || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
+    {
+      sprintf (name, "%s", sym->name);
+      sprintf (binding_label, "%s", sym->binding_label);
+
+      /* Error check the call.  */
+      if (args->next != NULL)
+        {
+          gfc_error_now ("More actual than formal arguments in '%s' "
+                         "call at %L", name, &(args->expr->where));
+          retval = FAILURE;
+        }
+      else if (sym->intmod_sym_id == ISOCBINDING_LOC)
+        {
+          /* Make sure we have either the target or pointer attribute.  */
+          if (!(args->expr->symtree->n.sym->attr.target)
+	      && !(args->expr->symtree->n.sym->attr.pointer))
+            {
+              gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
+                             "a TARGET or an associated pointer",
+                             args->expr->symtree->n.sym->name,
+                             sym->name, &(args->expr->where));
+              retval = FAILURE;
+            }
+
+          /* See if we have interoperable type and type param.  */
+          if (verify_c_interop (&(args->expr->symtree->n.sym->ts),
+                                args->expr->symtree->n.sym->name,
+                                &(args->expr->where)) == SUCCESS
+              || gfc_check_any_c_kind (&(args_sym->ts)) == SUCCESS)
+            {
+              if (args_sym->attr.target == 1)
+                {
+                  /* Case 1a, section 15.1.2.5, J3/04-007: variable that
+                     has the target attribute and is interoperable.  */
+                  /* Case 1b, section 15.1.2.5, J3/04-007: allocated
+                     allocatable variable that has the TARGET attribute and
+                     is not an array of zero size.  */
+                  if (args_sym->attr.allocatable == 1)
+                    {
+                      if (args_sym->attr.dimension != 0 
+                          && (args_sym->as && args_sym->as->rank == 0))
+                        {
+                          gfc_error_now ("Allocatable variable '%s' used as a "
+                                         "parameter to '%s' at %L must not be "
+                                         "an array of zero size",
+                                         args_sym->name, sym->name,
+                                         &(args->expr->where));
+                          retval = FAILURE;
+                        }
+                    }
+                  else
+                    {
+                      /* Make sure it's not a character string.  Arrays of
+                         any type should be ok if the variable is of a C
+                         interoperable type.  */
+                      if (args_sym->ts.type == BT_CHARACTER 
+                          && is_scalar_expr_ptr (args->expr) != SUCCESS)
+                        {
+                          gfc_error_now ("CHARACTER argument '%s' to '%s' at "
+                                         "%L must have a length of 1",
+                                         args_sym->name, sym->name,
+                                         &(args->expr->where));
+                          retval = FAILURE;
+                        }
+                    }
+                }
+              else if (args_sym->attr.pointer == 1
+                       && is_scalar_expr_ptr (args->expr) != SUCCESS)
+                {
+                  /* Case 1c, section 15.1.2.5, J3/04-007: an associated
+                     scalar pointer.  */
+                  gfc_error_now ("Argument '%s' to '%s' at %L must be an "
+                                 "associated scalar POINTER", args_sym->name,
+                                 sym->name, &(args->expr->where));
+                  retval = FAILURE;
+                }
+            }
+          else
+            {
+              /* The parameter is not required to be C interoperable.  If it
+                 is not C interoperable, it must be a nonpolymorphic scalar
+                 with no length type parameters.  It still must have either
+                 the pointer or target attribute, and it can be
+                 allocatable (but must be allocated when c_loc is called).  */
+              if (args_sym->attr.dimension != 0
+                  && is_scalar_expr_ptr (args->expr) != SUCCESS)
+                {
+                  gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
+                                 "scalar", args_sym->name, sym->name,
+                                 &(args->expr->where));
+                  retval = FAILURE;
+                }
+              else if (args_sym->ts.type == BT_CHARACTER 
+                       && args_sym->ts.cl != NULL)
+                {
+                  gfc_error_now ("CHARACTER parameter '%s' to '%s' at %L "
+                                 "cannot have a length type parameter",
+                                 args_sym->name, sym->name,
+                                 &(args->expr->where));
+                  retval = FAILURE;
+                }
+            }
+        }
+      else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
+        {
+          if (args->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE)
+            {
+              /* TODO: Update this error message to allow for procedure
+                 pointers once they are implemented.  */
+              gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
+                             "procedure",
+                             args->expr->symtree->n.sym->name, sym->name,
+                             &(args->expr->where));
+              retval = FAILURE;
+            }
+          else if (args->expr->symtree->n.sym->attr.is_c_interop != 1)
+            {
+              gfc_error_now ("Parameter '%s' to '%s' at %L must be C "
+                             "interoperable",
+                             args->expr->symtree->n.sym->name, sym->name,
+                             &(args->expr->where));
+              retval = FAILURE;
+            }
+        }
+      
+      /* for c_loc/c_funloc, the new symbol is the same as the old one */
+      *new_sym = sym;
+    }
+  else
+    {
+      gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
+			  "iso_c_binding function: '%s'!\n", sym->name);
+    }
+
+  return retval;
+}
+
+
 /* Resolve a function call, which means resolving the arguments, then figuring
    out which entity the name refers to.  */
 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
@@ -1583,7 +1861,20 @@ resolve_function (gfc_expr *expr)
   if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
       return FAILURE;
 
-  /* Resume assumed_size checking. */
+  /* Need to setup the call to the correct c_associated, depending on
+     the number of cptrs to user gives to compare.  */
+  if (sym && sym->attr.is_iso_c == 1)
+    {
+      if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
+          == FAILURE)
+        return FAILURE;
+      
+      /* Get the symtree for the new symbol (resolved func).
+         the old one will be freed later, when it's no longer used.  */
+      gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
+    }
+  
+  /* Resume assumed_size checking.  */
   need_full_assumed_size--;
 
   if (sym && sym->ts.type == BT_CHARACTER
@@ -1850,6 +2141,164 @@ generic:
 }
 
 
+/* Set the name and binding label of the subroutine symbol in the call
+   expression represented by 'c' to include the type and kind of the
+   second parameter.  This function is for resolving the appropriate
+   version of c_f_pointer() and c_f_procpointer().  For example, a
+   call to c_f_pointer() for a default integer pointer could have a
+   name of c_f_pointer_i4.  If no second arg exists, which is an error
+   for these two functions, it defaults to the generic symbol's name
+   and binding label.  */
+
+static void
+set_name_and_label (gfc_code *c, gfc_symbol *sym,
+                    char *name, char *binding_label)
+{
+  gfc_expr *arg = NULL;
+  char type;
+  int kind;
+
+  /* The second arg of c_f_pointer and c_f_procpointer determines
+     the type and kind for the procedure name.  */
+  arg = c->ext.actual->next->expr;
+
+  if (arg != NULL)
+    {
+      /* Set up the name to have the given symbol's name,
+         plus the type and kind.  */
+      /* a derived type is marked with the type letter 'u' */
+      if (arg->ts.type == BT_DERIVED)
+        {
+          type = 'd';
+          kind = 0; /* set the kind as 0 for now */
+        }
+      else
+        {
+          type = gfc_type_letter (arg->ts.type);
+          kind = arg->ts.kind;
+        }
+      sprintf (name, "%s_%c%d", sym->name, type, kind);
+      /* Set up the binding label as the given symbol's label plus
+         the type and kind.  */
+      sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
+    }
+  else
+    {
+      /* If the second arg is missing, set the name and label as
+         was, cause it should at least be found, and the missing
+         arg error will be caught by compare_parameters().  */
+      sprintf (name, "%s", sym->name);
+      sprintf (binding_label, "%s", sym->binding_label);
+    }
+   
+  return;
+}
+
+
+/* Resolve a generic version of the iso_c_binding procedure given
+   (sym) to the specific one based on the type and kind of the
+   argument(s).  Currently, this function resolves c_f_pointer() and
+   c_f_procpointer based on the type and kind of the second argument
+   (FPTR).  Other iso_c_binding procedures aren't specially handled.
+   Upon successfully exiting, c->resolved_sym will hold the resolved
+   symbol.  Returns MATCH_ERROR if an error occurred; MATCH_YES
+   otherwise.  */
+
+match
+gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
+{
+  gfc_symbol *new_sym;
+  /* this is fine, since we know the names won't use the max */
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+  /* default to success; will override if find error */
+  match m = MATCH_YES;
+  gfc_symbol *tmp_sym;
+
+  if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
+      (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
+    {
+      set_name_and_label (c, sym, name, binding_label);
+      
+      if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
+	{
+	  if (c->ext.actual != NULL && c->ext.actual->next != NULL)
+	    {
+	      /* Make sure we got a third arg.	The type/rank of it will
+		 be checked later if it's there (gfc_procedure_use()).	*/
+	      if (c->ext.actual->next->expr->rank != 0 &&
+		  c->ext.actual->next->next == NULL)
+		{
+		  m = MATCH_ERROR;
+		  gfc_error ("Missing SHAPE parameter for call to %s "
+			     "at %L", sym->name, &(c->loc));
+		}
+              /* Make sure the param is a POINTER.  No need to make sure
+                 it does not have INTENT(IN) since it is a POINTER.  */
+              tmp_sym = c->ext.actual->next->expr->symtree->n.sym;
+              if (tmp_sym != NULL && tmp_sym->attr.pointer != 1)
+                {
+                  gfc_error ("Argument '%s' to '%s' at %L "
+                             "must have the POINTER attribute",
+                             tmp_sym->name, sym->name, &(c->loc));
+                  m = MATCH_ERROR;
+                }
+	    }
+	}
+      
+      if (m != MATCH_ERROR)
+	{
+	  /* the 1 means to add the optional arg to formal list */
+	  new_sym = get_iso_c_sym (sym, name, binding_label, 1);
+	 
+	  /* for error reporting, say it's declared where the original was */
+	  new_sym->declared_at = sym->declared_at;
+	}
+    }
+  else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
+    {
+      /* TODO: Figure out if this is even reacable; this part of the
+         conditional may not be necessary.  */
+      int num_args = 0;
+      if (c->ext.actual->next == NULL)
+	{
+	  /* The user did not give two args, so resolve to the version
+	     of c_associated expecting one arg.	 */
+	  num_args = 1;
+	  /* get rid of the second arg */
+	  /* TODO!! Should free up the memory here!  */
+	  sym->formal->next = NULL;
+	}
+      else
+	{
+	  num_args = 2;
+	}
+
+      new_sym = sym;
+      sprintf (name, "%s_%d", sym->name, num_args);
+      sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
+      sym->name = gfc_get_string (name);
+      strcpy (sym->binding_label, binding_label);
+    }
+  else
+    {
+      /* no differences for c_loc or c_funloc */
+      new_sym = sym;
+    }
+
+  /* set the resolved symbol */
+  if (m != MATCH_ERROR)
+    {
+      gfc_procedure_use (new_sym, &c->ext.actual, &c->loc);
+      c->resolved_sym = new_sym;
+    }
+  else
+    c->resolved_sym = sym;
+  
+  return m;
+}
+
+
 /* Resolve a subroutine call known to be specific.  */
 
 static match
@@ -1857,6 +2306,12 @@ resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
 {
   match m;
 
+  if(sym->attr.is_iso_c)
+    {
+      m = gfc_iso_c_sub_interface (c,sym);
+      return m;
+    }
+  
   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
     {
       if (sym->attr.dummy)
@@ -5498,6 +5953,206 @@ resolve_values (gfc_symbol *sym)
 }
 
 
+/* Verify the binding labels for common blocks that are BIND(C).  The label
+   for a BIND(C) common block must be identical in all scoping units in which
+   the common block is declared.  Further, the binding label can not collide
+   with any other global entity in the program.  */
+
+static void
+resolve_bind_c_comms (gfc_symtree *comm_block_tree)
+{
+  if (comm_block_tree->n.common->is_bind_c == 1)
+    {
+      gfc_gsymbol *binding_label_gsym;
+      gfc_gsymbol *comm_name_gsym;
+
+      /* See if a global symbol exists by the common block's name.  It may
+         be NULL if the common block is use-associated.  */
+      comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
+                                         comm_block_tree->n.common->name);
+      if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
+        gfc_error ("Binding label '%s' for common block '%s' at %L collides "
+                   "with the global entity '%s' at %L",
+                   comm_block_tree->n.common->binding_label,
+                   comm_block_tree->n.common->name,
+                   &(comm_block_tree->n.common->where),
+                   comm_name_gsym->name, &(comm_name_gsym->where));
+      else if (comm_name_gsym != NULL
+	       && strcmp (comm_name_gsym->name,
+			  comm_block_tree->n.common->name) == 0)
+        {
+          /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
+             as expected.  */
+          if (comm_name_gsym->binding_label == NULL)
+            /* No binding label for common block stored yet; save this one.  */
+            comm_name_gsym->binding_label =
+              comm_block_tree->n.common->binding_label;
+          else
+            if (strcmp (comm_name_gsym->binding_label,
+                        comm_block_tree->n.common->binding_label) != 0)
+              {
+                /* Common block names match but binding labels do not.  */
+                gfc_error ("Binding label '%s' for common block '%s' at %L "
+                           "does not match the binding label '%s' for common "
+                           "block '%s' at %L",
+                           comm_block_tree->n.common->binding_label,
+                           comm_block_tree->n.common->name,
+                           &(comm_block_tree->n.common->where),
+                           comm_name_gsym->binding_label,
+                           comm_name_gsym->name,
+                           &(comm_name_gsym->where));
+                return;
+              }
+        }
+
+      /* There is no binding label (NAME="") so we have nothing further to
+         check and nothing to add as a global symbol for the label.  */
+      if (comm_block_tree->n.common->binding_label[0] == '\0' )
+        return;
+      
+      binding_label_gsym =
+        gfc_find_gsymbol (gfc_gsym_root,
+                          comm_block_tree->n.common->binding_label);
+      if (binding_label_gsym == NULL)
+        {
+          /* Need to make a global symbol for the binding label to prevent
+             it from colliding with another.  */
+          binding_label_gsym =
+            gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
+          binding_label_gsym->sym_name = comm_block_tree->n.common->name;
+          binding_label_gsym->type = GSYM_COMMON;
+        }
+      else
+        {
+          /* If comm_name_gsym is NULL, the name common block is use
+             associated and the name could be colliding.  */
+          if (binding_label_gsym->type != GSYM_COMMON)
+            gfc_error ("Binding label '%s' for common block '%s' at %L "
+                       "collides with the global entity '%s' at %L",
+                       comm_block_tree->n.common->binding_label,
+                       comm_block_tree->n.common->name,
+                       &(comm_block_tree->n.common->where),
+                       binding_label_gsym->name,
+                       &(binding_label_gsym->where));
+          else if (comm_name_gsym != NULL
+		   && (strcmp (binding_label_gsym->name,
+			       comm_name_gsym->binding_label) != 0)
+		   && (strcmp (binding_label_gsym->sym_name,
+			       comm_name_gsym->name) != 0))
+            gfc_error ("Binding label '%s' for common block '%s' at %L "
+                       "collides with global entity '%s' at %L",
+                       binding_label_gsym->name, binding_label_gsym->sym_name,
+                       &(comm_block_tree->n.common->where),
+                       comm_name_gsym->name, &(comm_name_gsym->where));
+        }
+    }
+  
+  return;
+}
+
+
+/* Verify any BIND(C) derived types in the namespace so we can report errors
+   for them once, rather than for each variable declared of that type.  */
+
+static void
+resolve_bind_c_derived_types (gfc_symbol *derived_sym)
+{
+  if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
+      && derived_sym->attr.is_bind_c == 1)
+    verify_bind_c_derived_type (derived_sym);
+  
+  return;
+}
+
+
+/* Verify that any binding labels used in a given namespace do not collide 
+   with the names or binding labels of any global symbols.  */
+
+static void
+gfc_verify_binding_labels (gfc_symbol *sym)
+{
+  int has_error = 0;
+  
+  if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0 
+      && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
+    {
+      gfc_gsymbol *bind_c_sym;
+
+      bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
+      if (bind_c_sym != NULL 
+          && strcmp (bind_c_sym->name, sym->binding_label) == 0)
+        {
+          if (sym->attr.if_source == IFSRC_DECL 
+              && (bind_c_sym->type != GSYM_SUBROUTINE 
+                  && bind_c_sym->type != GSYM_FUNCTION) 
+              && ((sym->attr.contained == 1 
+                   && strcmp (bind_c_sym->sym_name, sym->name) != 0) 
+                  || (sym->attr.use_assoc == 1 
+                      && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
+            {
+              /* Make sure global procedures don't collide with anything.  */
+              gfc_error ("Binding label '%s' at %L collides with the global "
+                         "entity '%s' at %L", sym->binding_label,
+                         &(sym->declared_at), bind_c_sym->name,
+                         &(bind_c_sym->where));
+              has_error = 1;
+            }
+          else if (sym->attr.contained == 0 
+                   && (sym->attr.if_source == IFSRC_IFBODY 
+                       && sym->attr.flavor == FL_PROCEDURE) 
+                   && (bind_c_sym->sym_name != NULL 
+                       && strcmp (bind_c_sym->sym_name, sym->name) != 0))
+            {
+              /* Make sure procedures in interface bodies don't collide.  */
+              gfc_error ("Binding label '%s' in interface body at %L collides "
+                         "with the global entity '%s' at %L",
+                         sym->binding_label,
+                         &(sym->declared_at), bind_c_sym->name,
+                         &(bind_c_sym->where));
+              has_error = 1;
+            }
+          else if (sym->attr.contained == 0 
+                   && (sym->attr.if_source == IFSRC_UNKNOWN))
+            if ((sym->attr.use_assoc 
+                 && (strcmp (bind_c_sym->mod_name, sym->module) != 0)) 
+                || sym->attr.use_assoc == 0)
+              {
+                gfc_error ("Binding label '%s' at %L collides with global "
+                           "entity '%s' at %L", sym->binding_label,
+                           &(sym->declared_at), bind_c_sym->name,
+                           &(bind_c_sym->where));
+                has_error = 1;
+              }
+
+          if (has_error != 0)
+            /* Clear the binding label to prevent checking multiple times.  */
+            sym->binding_label[0] = '\0';
+        }
+      else if (bind_c_sym == NULL)
+	{
+	  bind_c_sym = gfc_get_gsymbol (sym->binding_label);
+	  bind_c_sym->where = sym->declared_at;
+	  bind_c_sym->sym_name = sym->name;
+
+          if (sym->attr.use_assoc == 1)
+            bind_c_sym->mod_name = sym->module;
+          else
+            if (sym->ns->proc_name != NULL)
+              bind_c_sym->mod_name = sym->ns->proc_name->name;
+
+          if (sym->attr.contained == 0)
+            {
+              if (sym->attr.subroutine)
+                bind_c_sym->type = GSYM_SUBROUTINE;
+              else if (sym->attr.function)
+                bind_c_sym->type = GSYM_FUNCTION;
+            }
+        }
+    }
+  return;
+}
+
+
 /* Resolve an index expression.  */
 
 static try
@@ -6013,6 +6668,45 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
 			"'%s' at %L is obsolescent in fortran 95",
 			sym->name, &sym->declared_at);
     }
+
+  if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
+    {
+      gfc_formal_arglist *curr_arg;
+
+      if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
+                             sym->common_block) == FAILURE)
+        {
+          /* Clear these to prevent looking at them again if there was an
+             error.  */
+          sym->attr.is_bind_c = 0;
+          sym->attr.is_c_interop = 0;
+          sym->ts.is_c_interop = 0;
+        }
+      else
+        {
+          /* So far, no errors have been found.  */
+          sym->attr.is_c_interop = 1;
+          sym->ts.is_c_interop = 1;
+        }
+      
+      curr_arg = sym->formal;
+      while (curr_arg != NULL)
+        {
+          /* Skip implicitly typed dummy args here.  */
+          if (curr_arg->sym->attr.implicit_type == 0
+	      && verify_c_interop_param (curr_arg->sym) == FAILURE)
+            {
+              /* If something is found to fail, mark the symbol for the
+                 procedure as not being BIND(C) to try and prevent multiple
+                 errors being reported.  */
+              sym->attr.is_c_interop = 0;
+              sym->ts.is_c_interop = 0;
+              sym->attr.is_bind_c = 0;
+            }
+          curr_arg = curr_arg->next;
+        }
+    }
+  
   return SUCCESS;
 }
 
@@ -6381,6 +7075,76 @@ resolve_symbol (gfc_symbol *sym)
 		     sym->name, &sym->declared_at);
 	  return;
 	}
+
+      if (sym->ts.is_c_interop
+	  && mpz_cmp_si (cl->length->value.integer, 1) != 0)
+	{
+	  gfc_error ("C interoperable character dummy variable '%s' at %L "
+		     "with VALUE attribute must have length one",
+		     sym->name, &sym->declared_at);
+	  return;
+	}
+    }
+
+  /* If the symbol is marked as bind(c), verify it's type and kind.  Do not
+     do this for something that was implicitly typed because that is handled
+     in gfc_set_default_type.  Handle dummy arguments and procedure
+     definitions separately.  Also, anything that is use associated is not
+     handled here but instead is handled in the module it is declared in.
+     Finally, derived type definitions are allowed to be BIND(C) since that
+     only implies that they're interoperable, and they are checked fully for
+     interoperability when a variable is declared of that type.  */
+  if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
+      sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
+      sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
+    {
+      try t = SUCCESS;
+      
+      /* First, make sure the variable is declared at the
+	 module-level scope (J3/04-007, Section 15.3).	*/
+      if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
+          sym->attr.in_common == 0)
+	{
+	  gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
+		     "is neither a COMMON block nor declared at the "
+		     "module level scope", sym->name, &(sym->declared_at));
+	  t = FAILURE;
+	}
+      else if (sym->common_head != NULL)
+        {
+          t = verify_com_block_vars_c_interop (sym->common_head);
+        }
+      else
+	{
+	  /* If type() declaration, we need to verify that the components
+	     of the given type are all C interoperable, etc.  */
+	  if (sym->ts.type == BT_DERIVED &&
+              sym->ts.derived->attr.is_c_interop != 1)
+            {
+              /* Make sure the user marked the derived type as BIND(C).  If
+                 not, call the verify routine.  This could print an error
+                 for the derived type more than once if multiple variables
+                 of that type are declared.  */
+              if (sym->ts.derived->attr.is_bind_c != 1)
+                verify_bind_c_derived_type (sym->ts.derived);
+              t = FAILURE;
+            }
+	  
+	  /* Verify the variable itself as C interoperable if it
+             is BIND(C).  It is not possible for this to succeed if
+             the verify_bind_c_derived_type failed, so don't have to handle
+             any error returned by verify_bind_c_derived_type.  */
+          t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
+                                 sym->common_block);
+	}
+
+      if (t == FAILURE)
+        {
+          /* clear the is_bind_c flag to prevent reporting errors more than
+             once if something failed.  */
+          sym->attr.is_bind_c = 0;
+          return;
+        }
     }
 
   /* If a derived type symbol has reached this point, without its
@@ -7428,6 +8192,8 @@ resolve_types (gfc_namespace *ns)
 
   resolve_contained_functions (ns);
 
+  gfc_traverse_ns (ns, resolve_bind_c_derived_types);
+
   for (cl = ns->cl_list; cl; cl = cl->next)
     resolve_charlen (cl);
 
@@ -7460,6 +8226,11 @@ resolve_types (gfc_namespace *ns)
   iter_stack = NULL;
   gfc_traverse_ns (ns, gfc_formalize_init_value);
 
+  gfc_traverse_ns (ns, gfc_verify_binding_labels);
+
+  if (ns->common_root != NULL)
+    gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
+
   for (eq = ns->equiv; eq; eq = eq->next)
     resolve_equivalence (eq);