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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 575e1e947f3fa51b1353d8bf1a75770db78757e3..87e5c6afa97f7d075365642280f0041d29efab2a 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+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

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index d335f36d9553765d8c9aae3de9f49c9f963a8ab2..f50da8c95d879b20bf7ba71c144132262e5fa42a 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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;

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 30afd4bf0f2b37455de8607872dba2b3ac1fc797..f8ca9b31df50d05312e77869077d25f8281c27be 100644 (file)
--- a/gcc/fortran/symbol.c
+++ b/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 =

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d4816ec5f8916982e18445fe68d1e5ff388bc83d..b94b0e5cfedadfcb93ac7aec2042e39e3de48044 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_10.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_10.f03
new file mode 100644 (file)
index 0000000..867ba18
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_loc_tests_10.f03
@@ -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

diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_9.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_9.f03
new file mode 100644 (file)
index 0000000..fa32381
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_loc_tests_9.f03
@@ -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
+
+