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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@126812 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 575e1e9..87e5c6a 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 d335f36..f50da8c 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 30afd4b..f8ca9b3 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 d4816ec..b94b0e5 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
+
+