[PATCH,fortran]: fix PR 32804, update PR 32801

[Christopher D. Rickett]

hi all,

the attached patch is primarily for PR 32804, which deals with argument 
checking for C_LOC.  gfortran now rejects assumed-shape args to C_LOC.  a 
bug in checking character args to C_LOC was also fixed.

the patch also modifies the one-line patch for symbol.c in PR 32801.  i 
realized i put in an unnecessary conditional in the call to 
generate_isocbinding_symbol.  it is now removed.  i apologize for making 
this obvious mistake the first time.

bootstrapped and regtested on x86 and x86_64 linux with no new failures.

Chris

:ADDPATCH fortran:

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

 	PR fortran/32801
 	* symbol.c (generate_isocbinding_symbol): Remove unnecessary
 	conditional.

 	PR fortran/32804
 	* resolve.c (gfc_iso_c_func_interface): Reject assumed-shape and
 	deferred-shape arrays as args to C_LOC.  Fix bug in testing
 	character args to C_LOC.

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

 	PR fortran/32804
 	* gfortran.dg/pr32804_1.f03: New test case.
 	* gfortran.dg/pr32804_2.f03: Ditto.


-------------- next part --------------
Index: gcc/testsuite/gfortran.dg/pr32804_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/pr32804_1.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/pr32804_1.f03	(revision 0)
@@ -0,0 +1,10 @@
+! { dg-do compile }
+subroutine aaa(in)
+  use iso_c_binding
+  implicit none
+  CHARACTER(KIND=C_CHAR), DIMENSION(*), TARGET  :: in
+  type(c_ptr) :: cptr
+  cptr = c_loc(in)
+end subroutine aaa
+
+
Index: gcc/testsuite/gfortran.dg/pr32804_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/pr32804_2.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/pr32804_2.f03	(revision 0)
@@ -0,0 +1,8 @@
+! { dg-do compile }
+subroutine aaa(in)
+  use iso_c_binding
+  implicit none
+  integer(KIND=C_int), DIMENSION(:), TARGET  :: in
+  type(c_ptr) :: cptr
+  cptr = c_loc(in) ! { dg-error "not C interoperable" }
+end subroutine aaa
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 126788)
+++ gcc/fortran/symbol.c	(working copy)
@@ -3765,11 +3771,9 @@ generate_isocbinding_symbol (const char 
                     /* Create the necessary derived type so we can continue
                        processing the file.  */
                     generate_isocbinding_symbol
-                      (mod_name, s == ISOCBINDING_FUNLOC
-		       || s == ISOCBINDING_F_PROCPOINTER
+		      (mod_name, s == ISOCBINDING_FUNLOC
 		       ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
-                       (char *)(s == ISOCBINDING_FUNLOC 
-				|| s == ISOCBINDING_F_PROCPOINTER 
+		       (char *)(s == ISOCBINDING_FUNLOC
                                 ? "_gfortran_iso_c_binding_c_funptr"
 				: "_gfortran_iso_c_binding_c_ptr"));
                     tmp_sym->ts.derived =
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 126788)
+++ gcc/fortran/resolve.c	(working copy)
@@ -1806,19 +1806,53 @@ gfc_iso_c_func_interface (gfc_symbol *sy
                         }
                     }
                   else
-                    {
+		    {
+		      /* A non-allocatable target variable with C
+			 interoperable type and type parameters must be
+			 interoperable.	 */
+		      if (args_sym->attr.dimension && args_sym != NULL)
+			{
+			  if (args_sym->as->type == AS_ASSUMED_SHAPE)
+			    {
+			      gfc_error ("Assumed-shape array '%s' at %L "
+					 "cannot be an argument to the "
+					 "procedure '%s' because "
+					 "it is not C interoperable",
+					 args_sym->name,
+					 &(args->expr->where), sym->name);
+			      retval = FAILURE;
+			    }
+			  else if (args_sym->as->type == AS_DEFERRED)
+			    {
+			      gfc_error ("Deferred-shape array '%s' at %L "
+					 "cannot be an argument to the "
+					 "procedure '%s' because "
+					 "it is not C interoperable",
+					 args_sym->name,
+					 &(args->expr->where), sym->name);
+			      retval = FAILURE;
+			    }
+			}
+                              
                       /* 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;
-                        }
+		      if (args_sym->ts.type == BT_CHARACTER)
+			if (args_sym->ts.cl != NULL
+			    &&	(args_sym->ts.cl->length == NULL
+				 || args_sym->ts.cl->length->expr_type
+				 != EXPR_CONSTANT
+				 || mpz_cmp_si
+				 (args_sym->ts.cl->length->value.integer, 1)
+				 != 0)
+			    && 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
@@ -1848,10 +1882,10 @@ gfc_iso_c_func_interface (gfc_symbol *sy
                   retval = FAILURE;
                 }
               else if (args_sym->ts.type == BT_CHARACTER 
-                       && args_sym->ts.cl != NULL)
+                       && is_scalar_expr_ptr (args->expr) != SUCCESS)
                 {
-                  gfc_error_now ("CHARACTER parameter '%s' to '%s' at %L "
-                                 "cannot have a length type parameter",
+                  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;