trans-decl.c (create_function_arglist): Add hidden coarray

2014-04-30  Tobias Burnus  <burnus@net-b.de>

        * trans-decl.c (create_function_arglist): Add hidden coarray
        * arguments
        also for polymorphic coarrays.
        * trans-expr.c (gfc_conv_procedure_call): Pass hidden coarray
        arguments also for polymorphic coarrays.

2014-04-30  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/coarray_poly_7.f90
        * gfortran.dg/coarray_poly_8.f90
        * gfortran.dg/coarray_poly_9.f90

From-SVN: r209953

gcc/fortran/ChangeLog

 2014-04-30  Tobias Burnus  <burnus@net-b.de>
 
+	* trans-decl.c (create_function_arglist): Add hidden coarray arguments
+	also for polymorphic coarrays.
+	* trans-expr.c (gfc_conv_procedure_call): Pass hidden coarray arguments
+	also for polymorphic coarrays.
+
+2014-04-30  Tobias Burnus  <burnus@net-b.de>
+
 	* resolve.c (resolve_function): Don't do
 	assumed-size check for lcobound/ucobound.
 	* trans-types.c (gfc_build_array_type): Only build an array

gcc/fortran/trans-decl.c

@@ -2234,9 +2234,12 @@ create_function_arglist (gfc_symbol * sym)
 
       /* 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)
+      if (gfc_option.coarray == GFC_FCOARRAY_LIB
+	  && ((f->sym->ts.type != BT_CLASS && f->sym->attr.codimension
+	       && !f->sym->attr.allocatable)
+	      || (f->sym->ts.type == BT_CLASS
+		  && CLASS_DATA (f->sym)->attr.codimension
+		  && !CLASS_DATA (f->sym)->attr.allocatable)))
 	{
 	  tree caf_type;
 	  tree token;
@@ -2244,13 +2247,18 @@ create_function_arglist (gfc_symbol * sym)
 
 	  gcc_assert (f->sym->backend_decl != NULL_TREE
 		      && !sym->attr.is_bind_c);
-	  caf_type = TREE_TYPE (f->sym->backend_decl);
+	  caf_type = f->sym->ts.type == BT_CLASS
+		     ? TREE_TYPE (CLASS_DATA (f->sym)->backend_decl)
+		     : TREE_TYPE (f->sym->backend_decl);
 
 	  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)
+	  if ((f->sym->ts.type != BT_CLASS
+	       && f->sym->as->type != AS_DEFERRED)
+	      || (f->sym->ts.type == BT_CLASS
+		  && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
 	    {
 	      gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
 			  || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
@@ -2275,7 +2283,10 @@ create_function_arglist (gfc_symbol * sym)
 			       create_tmp_var_name ("caf_offset"),
 			       gfc_array_index_type);
 
-	  if (f->sym->as->type == AS_ASSUMED_SHAPE)
+	  if ((f->sym->ts.type != BT_CLASS
+	       && f->sym->as->type != AS_DEFERRED)
+	      || (f->sym->ts.type == BT_CLASS
+		  && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
 	    {
 	      gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
 					       == NULL_TREE);

gcc/fortran/trans-expr.c

@@ -4783,19 +4783,24 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
       /* 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
-	  && e == NULL)
+      if (fsym && e == NULL && gfc_option.coarray == GFC_FCOARRAY_LIB
+	  && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
+	       && !fsym->attr.allocatable)
+	      || (fsym->ts.type == BT_CLASS
+		  && CLASS_DATA (fsym)->attr.codimension
+		  && !CLASS_DATA (fsym)->attr.allocatable)))
 	{
 	  /* Token and offset. */
 	  vec_safe_push (stringargs, null_pointer_node);
 	  vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
 	  gcc_assert (fsym->attr.optional);
 	}
-      else if (fsym && fsym->attr.codimension
-	       && !fsym->attr.allocatable
-	       && gfc_option.coarray == GFC_FCOARRAY_LIB)
+      else if (fsym && gfc_option.coarray == GFC_FCOARRAY_LIB
+	       && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
+		    && !fsym->attr.allocatable)
+		   || (fsym->ts.type == BT_CLASS
+		       && CLASS_DATA (fsym)->attr.codimension
+		       && !CLASS_DATA (fsym)->attr.allocatable)))
 	{
 	  tree caf_decl, caf_type;
 	  tree offset, tmp2;
@@ -4837,22 +4842,30 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      tmp = caf_decl;
 	    }
 
-          if (fsym->as->type == AS_ASSUMED_SHAPE
-	      || (fsym->as->type == AS_ASSUMED_RANK && !fsym->attr.pointer
-		  && !fsym->attr.allocatable))
+          tmp2 = fsym->ts.type == BT_CLASS
+		 ? gfc_class_data_get (parmse.expr) : parmse.expr;
+          if ((fsym->ts.type != BT_CLASS
+	       && (fsym->as->type == AS_ASSUMED_SHAPE
+		   || fsym->as->type == AS_ASSUMED_RANK))
+	      || (fsym->ts.type == BT_CLASS
+		  && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
+		      || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
 	    {
-	      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);
+	      if (fsym->ts.type == BT_CLASS)
+		gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
+	      else
+		{
+		  gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
+		  tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
+		}
+	      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
 	      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 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
+	    tmp2 = gfc_conv_descriptor_data_get (tmp2);
 	  else
 	    {
-	      gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
-	      tmp2 = parmse.expr;
+	      gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
 	    }
 
 	  tmp = fold_build2_loc (input_location, MINUS_EXPR,

gcc/testsuite/ChangeLog

 2014-04-30  Tobias Burnus  <burnus@net-b.de>
 
+	* gfortran.dg/coarray_poly_7.f90
+	* gfortran.dg/coarray_poly_8.f90
+	* gfortran.dg/coarray_poly_9.f90
+
+2014-04-30  Tobias Burnus  <burnus@net-b.de>
+
 	* gfortran.dg/coarray_lib_this_image_2.f90: Update dump.
 	* gfortran.dg/coarray_lib_token_4.f90: Ditto.
 	* gfortran.dg/coarray/codimension.f90: New.

gcc/testsuite/gfortran.dg/coarray_poly_6.f90

+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+  implicit none
+  type t
+  end type t
+  class(t), allocatable :: y[:]
+  call bar()
+  call foo(y)
+contains
+  subroutine bar(x)
+    class(t), optional :: x[*]
+  end subroutine bar
+  subroutine foo(x)
+    class(t) :: x[*]
+  end subroutine foo
+end
+! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_0_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_0_1t \\* x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=8\\)\\) class..._data.data - \\(integer\\(kind=8\\)\\) y._data._data.data\\);" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/coarray_poly_7.f90

+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+  implicit none
+  type t
+  end type t
+  class(t), allocatable :: y(:)[:]
+  call bar()
+  call foo(y)
+contains
+  subroutine bar(x)
+    class(t), optional :: x(:)[*]
+  end subroutine bar
+  subroutine foo(x)
+    class(t) :: x(:)[*]
+  end subroutine foo
+end
+! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=8\\)\\) class..._data.data - \\(integer\\(kind=8\\)\\) y._data._data.data\\);" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/coarray_poly_8.f90

+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+  implicit none
+  type t
+  end type t
+  class(t), allocatable :: y(:)[:]
+  call bar()
+  call foo(y)
+contains
+  subroutine bar(x)
+    class(t), optional :: x(2)[*]
+  end subroutine bar
+  subroutine foo(x)
+    class(t) :: x(2)[*]
+  end subroutine foo
+end
+! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=8\\)\\) class..._data.data - \\(integer\\(kind=8\\)\\) y._data._data.data\\);" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }