2011-08-25 Tobias Burnus <burnus@net-b.de>

        * trans-array.c (gfc_conv_descriptor_token): Add assert.
        * trans-decl.c (gfc_build_qualified_array,
        create_function_arglist): Handle assumed-shape arrays.
        * trans-expr.c (gfc_conv_procedure_call): Ditto.
        * trans-types.c (gfc_get_array_descriptor_base): Ditto, don't
        add "caf_token" to assumed-shape descriptors, new akind argument.
        (gfc_get_array_type_bounds): Pass akind.
        * trans.h (lang_decl): New elements caf_offset and token.
        (GFC_DECL_TOKEN, GFC_DECL_CAF_OFFSET): New macros.

2011-08-25  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/coarray_lib_token_4.f90: New.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1c4a6737f1274fbfb1488e8fd9c0116abd5424bc..5cab38d5c8582c597a59a0652c2fe2ccf5f3686a 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2011-08-25  Tobias Burnus  <burnus@net-b.de>
+
+       * trans-array.c (gfc_conv_descriptor_token): Add assert.
+       * trans-decl.c (gfc_build_qualified_array,
+       create_function_arglist): Handle assumed-shape arrays.
+       * trans-expr.c (gfc_conv_procedure_call): Ditto.
+       * trans-types.c (gfc_get_array_descriptor_base): Ditto, don't
+       add "caf_token" to assumed-shape descriptors, new akind argument.
+       (gfc_get_array_type_bounds): Pass akind.
+       * trans.h (lang_decl): New elements caf_offset and token.
+       (GFC_DECL_TOKEN, GFC_DECL_CAF_OFFSET): New macros.
+
 2011-08-25  Tobias Burnus  <burnus@net-b.de>
 
        * trans-array.c (structure_alloc_comps): Fix for allocatable

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index bd9e88efd3ac0be50246a743b311ed51b9f7ad77..6dc1e17a7d41ef37fe2448c116b31d9913f3a8c6 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -277,6 +277,7 @@ gfc_conv_descriptor_token (tree desc)
 
   type = TREE_TYPE (desc);
   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+  gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE);
   gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
   field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == prvoid_type_node);

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index cdbb3752e3faeb547ed5681556b3c347adfe4138..1059a42f8abbc191887b6bfb1e8e93c893570b19 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -755,6 +755,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
         && !sym->attr.contained;
 
   if (sym->attr.codimension && gfc_option.coarray == GFC_FCOARRAY_LIB
+      && sym->as->type != AS_ASSUMED_SHAPE
       && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
     {
       tree token;
@@ -2104,12 +2105,11 @@ create_function_arglist (gfc_symbol * sym)
 
       f->sym->backend_decl = parm;
 
-      /* Coarrays which do not use a descriptor pass with -fcoarray=lib the
-        token and the offset as hidden arguments.  */
+      /* Coarrays which are descriptorless or assumed-shape pass with
+        -fcoarray=lib the token and the offset as hidden arguments.  */
       if (f->sym->attr.codimension
          && gfc_option.coarray == GFC_FCOARRAY_LIB
-         && !f->sym->attr.allocatable
-         && f->sym->as->type != AS_ASSUMED_SHAPE)
+         && !f->sym->attr.allocatable)
        {
          tree caf_type;
          tree token;
@@ -2119,12 +2119,24 @@ create_function_arglist (gfc_symbol * sym)
                      && !sym->attr.is_bind_c);
          caf_type = TREE_TYPE (f->sym->backend_decl);
 
-         gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
          token = build_decl (input_location, PARM_DECL,
                              create_tmp_var_name ("caf_token"),
                              build_qualified_type (pvoid_type_node,
                                                    TYPE_QUAL_RESTRICT));
-         GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
+         if (f->sym->as->type == AS_ASSUMED_SHAPE)
+           {
+             gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
+                         || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
+             if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
+               gfc_allocate_lang_decl (f->sym->backend_decl);
+             GFC_DECL_TOKEN (f->sym->backend_decl) = token;
+           }
+          else
+           {
+             gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
+             GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
+           }
+           
          DECL_CONTEXT (token) = fndecl;
          DECL_ARTIFICIAL (token) = 1;
          DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
@@ -2132,12 +2144,21 @@ create_function_arglist (gfc_symbol * sym)
          hidden_arglist = chainon (hidden_arglist, token);
          gfc_finish_decl (token);
 
-         gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
          offset = build_decl (input_location, PARM_DECL,
                               create_tmp_var_name ("caf_offset"),
                               gfc_array_index_type);
 
-         GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
+         if (f->sym->as->type == AS_ASSUMED_SHAPE)
+           {
+             gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
+                                              == NULL_TREE);
+             GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
+           }
+         else
+           {
+             gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
+             GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
+           }
          DECL_CONTEXT (offset) = fndecl;
          DECL_ARTIFICIAL (offset) = 1;
          DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 531a135c2f432de2afebd8df63cd5fef94a0a52a..628930a340dcda47014cfd20eac1cf08239ebaae 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3391,11 +3391,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
        VEC_safe_push (tree, gc, stringargs, parmse.string_length);
 
-      /* For descriptorless coarrays, we pass the token and the offset
-        as additional arguments.  */
+      /* For descriptorless coarrays and assumed-shape coarray dummies, we
+        pass the token and the offset as additional arguments.  */
       if (fsym && fsym->attr.codimension
          && gfc_option.coarray == GFC_FCOARRAY_LIB
-         && !fsym->attr.allocatable && fsym->as->type != AS_ASSUMED_SHAPE
+         && !fsym->attr.allocatable
          && e == NULL)
        {
          /* Token and offset. */
@@ -3405,7 +3405,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          gcc_assert (fsym->attr.optional);
        }
       else if (fsym && fsym->attr.codimension
-              && !fsym->attr.allocatable && fsym->as->type != AS_ASSUMED_SHAPE
+              && !fsym->attr.allocatable
               && gfc_option.coarray == GFC_FCOARRAY_LIB)
        {
          tree caf_decl, caf_type;
@@ -3414,8 +3414,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          caf_decl = get_tree_for_caf_expr (e);
          caf_type = TREE_TYPE (caf_decl);
 
-         if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+         if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+             && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
            tmp = gfc_conv_descriptor_token (caf_decl);
+         else if (DECL_LANG_SPECIFIC (caf_decl)
+                  && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+           tmp = GFC_DECL_TOKEN (caf_decl);
          else
            {
              gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
@@ -3425,8 +3429,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          
          VEC_safe_push (tree, gc, stringargs, tmp);
 
-         if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+         if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+             && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
            offset = build_int_cst (gfc_array_index_type, 0);
+         else if (DECL_LANG_SPECIFIC (caf_decl)
+                  && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
+           offset = GFC_DECL_CAF_OFFSET (caf_decl);
          else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
            offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
          else
@@ -3440,7 +3448,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
              tmp = caf_decl;
            }
 
-         if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
+          if (fsym->as->type == AS_ASSUMED_SHAPE)
+           {
+             gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+             gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
+                                                  (TREE_TYPE (parmse.expr))));
+             tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
+             tmp2 = gfc_conv_descriptor_data_get (tmp2);
+           }
+         else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
            tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
          else
            {

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index bac5b31e9c3d644b1254c5d22b2a636b56943ae0..f66878a1c89573cd63c99311b4cdfc8387e5c9e1 100644 (file)
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1614,10 +1614,12 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
   return type;
 }
 
+
 /* Return or create the base type for an array descriptor.  */
 
 static tree
-gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
+gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
+                              enum gfc_array_kind akind)
 {
   tree fat_type, decl, arraytype, *chain = NULL;
   char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
@@ -1671,7 +1673,8 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
                                    arraytype, &chain);
   TREE_NO_WARNING (decl) = 1;
 
-  if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen)
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen
+      && akind == GFC_ARRAY_ALLOCATABLE)
     {
       decl = gfc_add_field_to_struct_1 (fat_type,
                                        get_identifier ("token"),
@@ -1683,7 +1686,8 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
   gfc_finish_type (fat_type);
   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
 
-  if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen)
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen
+      && akind == GFC_ARRAY_ALLOCATABLE)
     gfc_array_descriptor_base_caf[idx] = fat_type;
   else
     gfc_array_descriptor_base[idx] = fat_type;
@@ -1691,6 +1695,7 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
   return fat_type;
 }
 
+
 /* Build an array (descriptor) type with given bounds.  */
 
 tree
@@ -1703,11 +1708,11 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
   const char *type_name;
   int n;
 
-  base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
+  base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted, akind);
   fat_type = build_distinct_type_copy (base_type);
   /* Make sure that nontarget and target array type have the same canonical
      type (and same stub decl for debug info).  */
-  base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
+  base_type = gfc_get_array_descriptor_base (dimen, codimen, false, akind);
   TYPE_CANONICAL (fat_type) = base_type;
   TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
 

diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index bb94780ab646fc201a30389ffc071e194e3a44c1..0c249a6736a7a61017128719e33a1cf35d0290a3 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -750,12 +750,16 @@ struct GTY((variable_size)) lang_decl {
   tree stringlen;
   tree addr;
   tree span;
+  /* For assumed-shape coarrays.  */
+  tree token, caf_offset;
 };
 
 
 #define GFC_DECL_ASSIGN_ADDR(node) DECL_LANG_SPECIFIC(node)->addr
 #define GFC_DECL_STRING_LEN(node) DECL_LANG_SPECIFIC(node)->stringlen
 #define GFC_DECL_SPAN(node) DECL_LANG_SPECIFIC(node)->span
+#define GFC_DECL_TOKEN(node) DECL_LANG_SPECIFIC(node)->token
+#define GFC_DECL_CAF_OFFSET(node) DECL_LANG_SPECIFIC(node)->caf_offset
 #define GFC_DECL_SAVED_DESCRIPTOR(node) \
   (DECL_LANG_SPECIFIC(node)->saved_descriptor)
 #define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 30b48b4e03dfc2f29d8b14cab6336435455148dc..c904def866d846b3bb5bcbd531f0002a02e0e36d 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2011-08-25  Tobias Burnus  <burnus@net-b.de>
+
+       * gfortran.dg/coarray_lib_token_4.f90: New.
+
 2011-08-25  Tobias Burnus  <burnus@net-b.de>
 
        * gfortran.dg/coarray/alloc_comp_1.f90: New.

diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90
new file mode 100644 (file)
index 0000000..2616d25
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90
@@ -0,0 +1,53 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+! Check argument passing with assumed-shape coarray dummies
+!
+program test_caf
+  implicit none
+  integer, allocatable :: A(:)[:]
+  integer, save :: B(3)[*]
+  integer :: i
+
+  allocate (A(3)[*])
+  A = [1, 2, 3 ] 
+  B = [9, 7, 4 ]
+  call foo (A, A, test=1)
+  call foo (A(2:3), B, test=2)
+  call foo (B, A, test=3)
+contains
+  subroutine foo(x, y, test)
+    integer :: x(:)[*]
+    integer, contiguous :: y(:)[*]
+    integer :: test
+    call bar (x)
+    call expl (y)
+  end subroutine foo
+
+  subroutine bar(y)
+    integer :: y(:)[*]
+  end subroutine bar
+
+  subroutine expl(z)
+    integer :: z(*)[*]
+  end subroutine expl
+end program test_caf
+
+! { dg-final { scan-tree-dump-times "expl \\(integer\\(kind=4\\).0:. . restrict z, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "bar \\(struct array2_integer\\(kind=4\\) & restrict y, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "foo \\(struct array2_integer\\(kind=4\\) & restrict x, struct array2_integer\\(kind=4\\) & restrict y, integer\\(kind=4\\) & restrict test, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) x.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 1 "original" } }
+! { d_g-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) x.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "expl \\(\\(integer\\(kind=4\\).0:. .\\) parm.\[0-9\]+.data, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(\\(integer\\(kind=.\\)\\) y.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 0 "original" } }
+!
+! { dg-final { scan-tree-dump-times "foo \\(&a, &a, &C.\[0-9\]+, a.token, 0, a.token, 0\\);" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "foo \\(&parm.\[0-9\]+, &parm.\[0-9\]+, &C.\[0-9\]+, a.token, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) a.data, caf_token.\[0-9\]+, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) b\\);" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "foo \\(&parm.\[0-9\]+, &a, &C.\[0-9\]+, caf_token.\[0-9\]+, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) b, a.token, 0\\);" 1 "original" } }
+!
+! { dg-final { cleanup-tree-dump "original" } }