trans-array.c (gfc_conv_descriptor_token): Add assert.

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.

From-SVN: r178069

gcc/fortran/ChangeLog

 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
 	scalar coarray components.
 	* trans-expr.c (gfc_conv_component_ref): Ditto.

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);

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));
+	  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);
 
+	  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);

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
 	    {

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);
 

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)

gcc/testsuite/ChangeLog

 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.
 
 2011-08-25  Richard Guenther  <rguenther@suse.de>

gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90

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