Patchwork [Fortran] CLASS handling for assumed-rank arrays

login
register
mail settings
Submitter Tobias Burnus
Date June 26, 2012, 5:12 p.m.
Message ID <4FE9ED73.5050807@net-b.de>
Download mbox | patch
Permalink /patch/167431/
State New
Headers show

Comments

Tobias Burnus - June 26, 2012, 5:12 p.m.
This patch assumes that the basic assumed-rank support is included, 
http://gcc.gnu.org/ml/fortran/2012-06/msg00144.html

The attached patch implements the support of passing non-assumed-rank 
type/class arrays to assumed-rank class/type dummy arguments (type was 
working before). And passing assumed-rank class arrays to assumed-rank 
class arrays. It does not support passing assumed-rank class arrays to 
type arrays.

The problem with the latter is that gfortran uses the TYPE_SIZE_UNIT to 
access the array elements, which imlies a copy in/copy out. For 
arguments with descriptor, a better choice would be to use the stride 
multiplier. (Catch: The current descriptor doesn't have one.) As the 
scalarizer doesn't work for assumed-rank arrays, the copy-in/copy-out 
fails at run time.

(See also http://j3-fortran.org/pipermail/j3/2012-June/005438.html for 
the fun with pointer association when passing a  CLASS with TARGET to a 
TYPE with TARGET.)

Additionally, I think that this patch makes gfortran the second front 
end  (after Ada), which uses a range for the assignment: I do not 
iterate through for dim, but use a.dim[1:rank] = b.dim[1:rank] in the 
assignment. The reason that I have to do a component wise assignment is 
that the class container directly contains the descriptor as a component 
- not as pointer. Thus, the descriptors can have different ranks...

Build and regtested on x86-64-linux.
OK for the trunk?

Tobias
Tobias Burnus - June 26, 2012, 5:19 p.m.
On 06/26/2012 07:12 PM, Tobias Burnus wrote:
> +i = 1

That should be i = 0, sorry for attaching an old version of the patch.

Tobias

> +call foo(ac)
> +call foo(at)
> +call bar(ac)
> +call bar(at)
> +if (i /= 12) call abort()
> +
Mikael Morin - July 5, 2012, 1:57 p.m.
On 26.06.2012 19:12, Tobias Burnus wrote:
> Build and regtested on x86-64-linux.
> OK for the trunk?
>
> Tobias

OK once the preliminary patch gets approved.
Mikael

Patch

2012-06-26  Tobias Burnus  <burnus@net-b.de>

	PR fortran/48820
	* class.c (gfc_build_class_symbol): Regard assumed-rank arrays
	as having GFC_MAX_DIMENSIONS.
	* trans-array.c (gfc_get_descriptor_dimension): New function,
	which returns the descriptor.
	(gfc_conv_descriptor_dimension): Use it.
	* trans-array.h (gfc_get_descriptor_dimension): New prototype.
	* trans-expr.c (class_array_data_assign): New static function.
	(gfc_conv_derived_to_class, gfc_conv_class_to_class): Use it.

2012-06-26  Tobias Burnus  <burnus@net-b.de>

	PR fortran/48820
	* gfortran.dg/assumed_rank_7.f90: New.

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index c71aa4a..479014e 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -219,7 +219,7 @@  gfc_add_component_ref (gfc_expr *e, const char *name)
 void
 gfc_add_class_array_ref (gfc_expr *e)
 {
-  int rank =  CLASS_DATA (e)->as->rank;
+  int rank = CLASS_DATA (e)->as->rank;
   gfc_array_spec *as = CLASS_DATA (e)->as;
   gfc_ref *ref = NULL;
   gfc_add_component_ref (e, "_data");
@@ -497,6 +497,7 @@  gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   gfc_symbol *fclass;
   gfc_symbol *vtab;
   gfc_component *c;
+  int rank;
 
   if (as && *as && (*as)->type == AS_ASSUMED_SIZE)
     {
@@ -517,11 +518,12 @@  gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
     return SUCCESS;
 
   /* Determine the name of the encapsulating type.  */
+  rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
   get_unique_hashed_string (tname, ts->u.derived);
   if ((*as) && attr->allocatable)
-    sprintf (name, "__class_%s_%d_%da", tname, (*as)->rank, (*as)->corank);
+    sprintf (name, "__class_%s_%d_%da", tname, rank, (*as)->corank);
   else if ((*as))
-    sprintf (name, "__class_%s_%d_%d", tname, (*as)->rank, (*as)->corank);
+    sprintf (name, "__class_%s_%d_%d", tname, rank, (*as)->corank);
   else if (attr->pointer)
     sprintf (name, "__class_%s_p", tname);
   else if (attr->allocatable)
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index f135af1..36db6ac 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -247,12 +247,11 @@  gfc_conv_descriptor_dtype (tree desc)
 			  desc, field, NULL_TREE);
 }
 
-static tree
-gfc_conv_descriptor_dimension (tree desc, tree dim)
+
+tree
+gfc_get_descriptor_dimension (tree desc)
 {
-  tree field;
-  tree type;
-  tree tmp;
+  tree type, field;
 
   type = TREE_TYPE (desc);
   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
@@ -262,10 +261,19 @@  gfc_conv_descriptor_dimension (tree desc, tree dim)
 	  && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
 	  && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
 
-  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
-			 desc, field, NULL_TREE);
-  tmp = gfc_build_array_ref (tmp, dim, NULL);
-  return tmp;
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			  desc, field, NULL_TREE);
+}
+
+
+static tree
+gfc_conv_descriptor_dimension (tree desc, tree dim)
+{
+  tree tmp;
+
+  tmp = gfc_get_descriptor_dimension (desc);
+
+  return gfc_build_array_ref (tmp, dim, NULL);
 }
 
 
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 9bafb94..b7ab806 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -154,6 +154,7 @@  tree gfc_conv_descriptor_data_get (tree);
 tree gfc_conv_descriptor_data_addr (tree);
 tree gfc_conv_descriptor_offset_get (tree);
 tree gfc_conv_descriptor_dtype (tree);
+tree gfc_get_descriptor_dimension (tree);
 tree gfc_conv_descriptor_stride_get (tree, tree);
 tree gfc_conv_descriptor_lbound_get (tree, tree);
 tree gfc_conv_descriptor_ubound_get (tree, tree);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7d1a6d4..82caadd 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -158,7 +158,34 @@  gfc_get_vptr_from_expr (tree expr)
   tmp = gfc_class_vptr_get (tmp);
   return tmp;
 }
- 
+
+
+static void
+class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
+			 bool lhs_type)
+{
+  tree tmp, tmp2, type;
+
+  gfc_conv_descriptor_data_set (block, lhs_desc,
+				gfc_conv_descriptor_data_get (rhs_desc));
+  gfc_conv_descriptor_offset_set (block, lhs_desc,
+				  gfc_conv_descriptor_offset_get (rhs_desc));
+
+  gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
+		  gfc_conv_descriptor_dtype (rhs_desc));
+
+  /* Assign the dimension as range-ref.  */
+  tmp = gfc_get_descriptor_dimension (lhs_desc);
+  tmp2 = gfc_get_descriptor_dimension (rhs_desc);
+
+  type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
+  tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
+		    gfc_index_zero_node, NULL_TREE, NULL_TREE);
+  tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
+		     gfc_index_zero_node, NULL_TREE, NULL_TREE);
+  gfc_add_modify (block, tmp, tmp2);
+}
+
 
 /* Takes a derived type expression and returns the address of a temporary
    class object of the 'declared' type.  If vptr is not NULL, this is
@@ -222,7 +249,12 @@  gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 	{
 	  parmse->ss = ss;
 	  gfc_conv_expr_descriptor (parmse, e, ss);
-	  gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+
+	  if (e->rank != class_ts.u.derived->components->as->rank)
+	    class_array_data_assign (&parmse->pre, ctree, parmse->expr,
+				     TREE_TYPE (parmse->expr));
+	  else
+	    gfc_add_modify (&parmse->pre, ctree, parmse->expr);
 	}
     }
 
@@ -273,13 +305,23 @@  gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
 
   /* Set the data.  */
   ctree = gfc_class_data_get (var);
-  gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+  if (class_ts.u.derived->components->as
+      && e->rank != class_ts.u.derived->components->as->rank)
+    class_array_data_assign (&parmse->pre, ctree, parmse->expr, false);
+  else
+    gfc_add_modify (&parmse->pre, ctree, parmse->expr);
 
   /* Return the data component, except in the case of scalarized array
      references, where nullification of the cannot occur and so there
      is no need.  */
   if (!elemental && full_array)
-    gfc_add_modify (&parmse->post, parmse->expr, ctree);
+    {
+      if (class_ts.u.derived->components->as
+	  && e->rank != class_ts.u.derived->components->as->rank)
+	class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
+      else
+	gfc_add_modify (&parmse->post, parmse->expr, ctree);
+    }
 
   /* Set the vptr.  */
   ctree = gfc_class_vptr_get (var);
--- /dev/null	2012-06-26 07:11:42.215802679 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_7.f90	2012-06-26 17:46:53.000000000 +0200
@@ -0,0 +1,63 @@ 
+! { dg-do run }
+!
+! PR fortran/48820
+!
+! Handle type/class for assumed-rank arrays
+!
+implicit none
+type t
+  integer :: i
+end type
+
+class(T), allocatable :: ac(:,:)
+type(T), allocatable :: at(:,:)
+integer :: i
+
+allocate(ac(2:3,2:4))
+allocate(at(2:3,2:4))
+
+i = 1
+call foo(ac)
+call foo(at)
+call bar(ac)
+call bar(at)
+if (i /= 12) call abort()
+
+contains
+  subroutine bar(x)
+    type(t) :: x(..)
+    if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+    if (size(x) /= 6) call abort()
+    if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
+    if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+    i = i + 1
+    call foo(x)
+    call bar2(x)
+  end subroutine
+  subroutine bar2(x)
+    type(t) :: x(..)
+    if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+    if (size(x) /= 6) call abort()
+    if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
+    if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+    i = i + 1
+  end subroutine
+  subroutine foo(x)
+    class(t) :: x(..)
+    if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+    if (size(x) /= 6) call abort()
+    if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
+    if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+    i = i + 1
+    call foo2(x)
+!    call bar2(x) ! Passing a CLASS to a TYPE does not yet work
+  end subroutine
+  subroutine foo2(x)
+    class(t) :: x(..)
+    if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+    if (size(x) /= 6) call abort()
+    if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
+    if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+    i = i + 1
+  end subroutine
+end