diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 0804d45..3803cf8 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3165,7 +3165,7 @@ add_to_offset (tree *cst_offset, tree *offset, tree t) static tree -build_array_ref (tree desc, tree offset, tree decl) +build_array_ref (tree desc, tree offset, tree decl, tree vptr) { tree tmp; tree type; @@ -3212,7 +3212,7 @@ build_array_ref (tree desc, tree offset, tree decl) tmp = gfc_conv_array_data (desc); tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_build_array_ref (tmp, offset, decl); + tmp = gfc_build_array_ref (tmp, offset, decl, vptr); return tmp; } @@ -3375,7 +3375,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, offset, cst_offset); - se->expr = build_array_ref (se->expr, offset, sym->backend_decl); + se->expr = build_array_ref (se->expr, offset, sym->ts.type == BT_CLASS ? + NULL_TREE : sym->backend_decl, se->class_vptr); } @@ -6270,7 +6271,7 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, return; } - tmp = build_array_ref (desc, offset, NULL); + tmp = build_array_ref (desc, offset, NULL, NULL); /* Offset the data pointer for pointer assignments from arrays with subreferences; e.g. my_integer => my_type(:)%integer_component. */ @@ -7029,6 +7030,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) pointer/allocatable or associated. */ if (onebased && se->use_offset && expr->symtree + && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS + && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer) && !expr->symtree->n.sym->attr.allocatable && !expr->symtree->n.sym->attr.pointer && !expr->symtree->n.sym->attr.host_assoc diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 895733b..4c18920 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1031,9 +1031,9 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; /* The dummy is returned for pointer, allocatable or assumed rank arrays. - The check for pointerness needs to be repeated here (it is done in - IS_CLASS_ARRAY (), too), because for class arrays that are pointers, as - is the one of the sym, which is incorrect here. */ + For class arrays the information if sym is an allocatable or pointer + object needs to be checked explicitly (IS_CLASS_ARRAY can be false for + too many reasons to be of use here). */ if ((sym->ts.type != BT_CLASS && sym->attr.pointer) || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) || array_attr->allocatable diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 790d537..81b72273 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2273,6 +2273,16 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) field = f2; } + if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS + && strcmp ("_data", c->name) == 0) + { + /* Found a ref to the _data component. Store the associated ref to + the vptr in se->class_vptr. */ + se->class_vptr = gfc_class_vptr_get (decl); + } + else + se->class_vptr = NULL_TREE; + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 394745e..6da464a 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -321,7 +321,7 @@ gfc_build_addr_expr (tree type, tree t) /* Build an ARRAY_REF with its natural type. */ tree -gfc_build_array_ref (tree base, tree offset, tree decl) +gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) { tree type = TREE_TYPE (base); tree tmp; @@ -353,37 +353,47 @@ gfc_build_array_ref (tree base, tree offset, tree decl) /* If the array reference is to a pointer, whose target contains a subreference, use the span that is stored with the backend decl and reference the element with pointer arithmetic. */ - if (decl && (TREE_CODE (decl) == FIELD_DECL - || TREE_CODE (decl) == VAR_DECL - || TREE_CODE (decl) == PARM_DECL) - && ((GFC_DECL_SUBREF_ARRAY_P (decl) - && !integer_zerop (GFC_DECL_SPAN(decl))) + if ((decl && (TREE_CODE (decl) == FIELD_DECL + || TREE_CODE (decl) == VAR_DECL + || TREE_CODE (decl) == PARM_DECL) + && ((GFC_DECL_SUBREF_ARRAY_P (decl) + && !integer_zerop (GFC_DECL_SPAN (decl))) || GFC_DECL_CLASS (decl))) + || vptr) { - if (GFC_DECL_CLASS (decl)) + if (decl) { - /* When a temporary is in place for the class array, then the original - class' declaration is stored in the saved descriptor. */ - if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) - decl = GFC_DECL_SAVED_DESCRIPTOR (decl); - else + if (GFC_DECL_CLASS (decl)) { - /* Allow for dummy arguments and other good things. */ - if (POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref_loc (input_location, decl); - - /* Check if '_data' is an array descriptor. If it is not, - the array must be one of the components of the class object, - so return a normal array reference. */ - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl)))) - return build4_loc (input_location, ARRAY_REF, type, base, - offset, NULL_TREE, NULL_TREE); + /* When a temporary is in place for the class array, then the + original class' declaration is stored in the saved + descriptor. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + else + { + /* Allow for dummy arguments and other good things. */ + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + + /* Check if '_data' is an array descriptor. If it is not, + the array must be one of the components of the class + object, so return a normal array reference. */ + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE ( + gfc_class_data_get (decl)))) + return build4_loc (input_location, ARRAY_REF, type, base, + offset, NULL_TREE, NULL_TREE); + } + + span = gfc_class_vtab_size_get (decl); } - - span = gfc_class_vtab_size_get (decl); + else if (GFC_DECL_SUBREF_ARRAY_P (decl)) + span = GFC_DECL_SPAN (decl); + else + gcc_unreachable (); } - else if (GFC_DECL_SUBREF_ARRAY_P (decl)) - span = GFC_DECL_SPAN(decl); + else if (vptr) + span = gfc_vptr_size_get (vptr); else gcc_unreachable (); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 1998358..e2a1fea 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -49,6 +49,10 @@ typedef struct gfc_se /* The length of a character string value. */ tree string_length; + /* When expr is a reference to a class object, store its vptr access + here. */ + tree class_vptr; + /* If set gfc_conv_variable will return an expression for the array descriptor. When set, want_pointer should also be set. If not set scalarizing variables will be substituted. */ @@ -528,7 +532,7 @@ tree gfc_get_function_decl (gfc_symbol *); tree gfc_build_addr_expr (tree, tree); /* Build an ARRAY_REF. */ -tree gfc_build_array_ref (tree, tree, tree); +tree gfc_build_array_ref (tree, tree, tree, tree vptr = NULL_TREE); /* Creates a label. Decl is artificial if label_id == NULL_TREE. */ tree gfc_build_label_decl (tree); diff --git a/gcc/testsuite/gfortran.dg/class_array_21.f03 b/gcc/testsuite/gfortran.dg/class_array_21.f03 new file mode 100644 index 0000000..1e89d38 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_array_21.f03 @@ -0,0 +1,97 @@ +! {dg-do run} +! +! Contributed by Andre Vehreschild +! Check more elaborate class array addressing. + +module m1 + + type InnerBaseT + integer, allocatable :: a(:) + end type InnerBaseT + + type, extends(InnerBaseT) :: InnerT + integer :: i + end type InnerT + + type BaseT + class(InnerT), allocatable :: arr(:,:) + contains + procedure P + end type BaseT + +contains + + subroutine indir(this, mat) + class(BaseT) :: this + class(InnerT), intent(inout) :: mat(:,:) + + call this%P(mat) + end subroutine indir + + subroutine P(this, mat) + class(BaseT) :: this + class(InnerT), intent(inout) :: mat(:,:) + integer :: i,j + + mat%i = 42 + do i= 1, ubound(mat, 1) + do j= 1, ubound(mat, 2) + if (.not. allocated(mat(i,j)%a)) then + allocate(mat(i,j)%a(10), source = 72) + end if + end do + end do + mat(1,1)%i = 9 + mat(1,1)%a(5) = 1 + end subroutine + +end module m1 + +program test + use m1 + + class(BaseT), allocatable, target :: o + class(InnerT), pointer :: i_p(:,:) + class(InnerBaseT), allocatable :: i_a(:,:) + integer i,j,l + + allocate(o) + allocate(o%arr(2,2)) + allocate(InnerT::i_a(2,2)) + o%arr%i = 1 + + i_p => o%arr + call o%P(i_p) + if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) call abort() + do l= 1, 10 + do i= 1, 2 + do j= 1,2 + if ((i == 1 .and. j == 1 .and. l == 5 .and. & + o%arr(i,j)%a(5) /= 1) & + .or. (.not. (i == 1 .and. j == 1 .and. l == 5) & + .and. o%arr(i,j)%a(l) /= 72)) call abort() + end do + end do + end do + + select type (i_a) + type is (InnerT) + call o%P(i_a) + do l= 1, 10 + do i= 1, 2 + do j= 1,2 + if ((i == 1 .and. j == 1 .and. l == 5 .and. & + i_a(i,j)%a(5) /= 1) & + .or. (.not. (i == 1 .and. j == 1 .and. l == 5) & + .and. i_a(i,j)%a(l) /= 72)) call abort() + end do + end do + end do + end select + + i_p%i = 4 + call indir(o, i_p) + if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) call abort() +end program test + +! vim:ts=2:sts=2:cindent:sw=2:tw=80: