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