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
2012-06-26 Tobias Burnus <bur...@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 <bur...@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
