re PR fortran/32801 (USE of ISO_C_BINDING, ONLY: C_LOC causes compiler seg fault)

2007-07-21  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-21  Christopher D. Rickett  <crickett@lanl.gov>

        PR fortran/32804
        * gfortran.dg/c_loc_tests_9.f03: New test case.
        * gfortran.dg/c_loc_tests_10.f03: Ditto.

From-SVN: r126812

gcc/fortran/ChangeLog

+2007-07-21  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-21  Lee Millward  <lee.millward@gmail.com>
 
 	PR fortran/32823

gcc/fortran/resolve.c

@@ -1806,19 +1806,53 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
                         }
                     }
                   else
-                    {
+		    {
+		      /* A non-allocatable target variable with C
+			 interoperable type and type parameters must be
+			 interoperable.	 */
+		      if (args_sym && args_sym->attr.dimension)
+			{
+			  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 *sym, gfc_actual_arglist *args,
                   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;

gcc/fortran/symbol.c

@@ -3765,11 +3765,9 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
                     /* Create the necessary derived type so we can continue
                        processing the file.  */
                     generate_isocbinding_symbol
-                      (mod_name, s == ISOCBINDING_FUNLOC
-		       || s == ISOCBINDING_F_PROCPOINTER
-		       ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
-                       (char *)(s == ISOCBINDING_FUNLOC 
-				|| s == ISOCBINDING_F_PROCPOINTER 
+		      (mod_name, s == ISOCBINDING_FUNLOC
+				 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
+		       (char *)(s == ISOCBINDING_FUNLOC
                                 ? "_gfortran_iso_c_binding_c_funptr"
 				: "_gfortran_iso_c_binding_c_ptr"));
                     tmp_sym->ts.derived =

gcc/testsuite/ChangeLog

+2007-07-19  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/32804
+	* gfortran.dg/c_loc_tests_9.f03: New test case.
+	* gfortran.dg/c_loc_tests_10.f03: Ditto.
+
 2007-07-21  Lee Millward  <lee.millward@gmail.com>
 
 	PR fortran/32823

gcc/testsuite/gfortran.dg/c_loc_tests_10.f03

+! { 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

gcc/testsuite/gfortran.dg/c_loc_tests_9.f03

+! { 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
+
+