diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 53e9bcc..1e435be 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5148,14 +5148,11 @@ gfc_trans_allocate (gfc_code * code) TREE_USED (label_finish) = 0; } - /* When an expr3 is present, try to evaluate it only once. In most - cases expr3 is invariant for all elements of the allocation list. - Only exceptions are arrays. Furthermore the standards prevent a - dependency of expr3 on the objects in the allocate list. Therefore - it is safe to pre-evaluate expr3 for complicated expressions, i.e. - everything not a variable or constant. When an array allocation - is wanted, then the following block nevertheless evaluates the - _vptr, _len and element_size for expr3. */ + /* When an expr3 is present evaluate it only once. The standards prevent a + dependency of expr3 on the objects in the allocate list. An expr3 can + be pre-evaluated in all cases. One just has to make sure, to use the + correct way, i.e., to get the descriptor or to get a reference + expression. */ if (code->expr3) { bool vtab_needed = false; @@ -5168,75 +5165,86 @@ gfc_trans_allocate (gfc_code * code) al = al->next) vtab_needed = (al->expr->ts.type == BT_CLASS); - /* A array expr3 needs the scalarizer, therefore do not process it - here. */ - if (code->expr3->expr_type != EXPR_ARRAY - && (code->expr3->rank == 0 - || code->expr3->expr_type == EXPR_FUNCTION) - && (!code->expr3->symtree - || !code->expr3->symtree->n.sym->as) - && !gfc_is_class_array_ref (code->expr3, NULL)) - { - /* When expr3 is a variable, i.e., a very simple expression, + /* When expr3 is a variable, i.e., a very simple expression, then convert it once here. */ - if ((code->expr3->expr_type == EXPR_VARIABLE) - || code->expr3->expr_type == EXPR_CONSTANT) - { - if (!code->expr3->mold - || code->expr3->ts.type == BT_CHARACTER - || vtab_needed) - { - /* Convert expr3 to a tree. */ - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, code->expr3); - if (!code->expr3->mold) - expr3 = se.expr; - else - expr3_tmp = se.expr; - expr3_len = se.string_length; - gfc_add_block_to_block (&block, &se.pre); - gfc_add_block_to_block (&post, &se.post); - } - /* else expr3 = NULL_TREE set above. */ - } - else + if (code->expr3->expr_type == EXPR_VARIABLE + || code->expr3->expr_type == EXPR_ARRAY + || code->expr3->expr_type == EXPR_CONSTANT) + { + if (!code->expr3->mold + || code->expr3->ts.type == BT_CHARACTER + || vtab_needed) { - /* In all other cases evaluate the expr3 and create a - temporary. */ + /* Convert expr3 to a tree. */ gfc_init_se (&se, NULL); - if (code->expr3->rank != 0 - && code->expr3->expr_type == EXPR_FUNCTION - && code->expr3->value.function.isym) + /* For all "simple" expression just get the descriptor or the + reference, respectively, depending on the rank of the expr. */ + if (code->expr3->rank != 0) gfc_conv_expr_descriptor (&se, code->expr3); else gfc_conv_expr_reference (&se, code->expr3); - if (code->expr3->ts.type == BT_CLASS) - gfc_conv_class_to_class (&se, code->expr3, - code->expr3->ts, - false, true, - false, false); + if (!code->expr3->mold) + expr3 = se.expr; + else + expr3_tmp = se.expr; + expr3_len = se.string_length; gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); - /* Prevent aliasing, i.e., se.expr may be already a + } + /* else expr3 = NULL_TREE set above. */ + } + else + { + /* In all other cases evaluate the expr3 and create a + temporary. */ + gfc_init_se (&se, NULL); + /* For more complicated expression, the decision when to get the + descriptor and when to get a reference is depending on more + conditions. The descriptor is only retrieved for functions + that are intrinsic, elemental user-defined and known, or neither + of the two, or are a class or type, that has a not deferred type + array_spec. */ + if (code->expr3->rank != 0 + && (code->expr3->expr_type != EXPR_FUNCTION + || code->expr3->value.function.isym + || (code->expr3->value.function.esym && + code->expr3->value.function.esym->attr.elemental) + || (!code->expr3->value.function.isym + && !code->expr3->value.function.esym) + || (code->expr3->ts.type == BT_DERIVED + && code->expr3->ts.u.derived->as + && code->expr3->ts.u.derived->as->type != AS_DEFERRED) + || (code->expr3->ts.type == BT_CLASS + && CLASS_DATA (code->expr3)->as + && CLASS_DATA (code->expr3)->as->type != AS_DEFERRED))) + gfc_conv_expr_descriptor (&se, code->expr3); + else + gfc_conv_expr_reference (&se, code->expr3); + if (code->expr3->ts.type == BT_CLASS) + gfc_conv_class_to_class (&se, code->expr3, + code->expr3->ts, + false, true, + false, false); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post, &se.post); + /* Prevent aliasing, i.e., se.expr may be already a variable declaration. */ - if (!VAR_P (se.expr)) - { - tmp = build_fold_indirect_ref_loc (input_location, - se.expr); - tmp = gfc_evaluate_now (tmp, &block); - } - else - tmp = se.expr; - if (!code->expr3->mold) - expr3 = tmp; - else - expr3_tmp = tmp; - /* When he length of a char array is easily available - here, fix it for future use. */ - if (se.string_length) - expr3_len = gfc_evaluate_now (se.string_length, &block); + if (!VAR_P (se.expr)) + { + tmp = build_fold_indirect_ref_loc (input_location, + se.expr); + tmp = gfc_evaluate_now (tmp, &block); } + else + tmp = se.expr; + if (!code->expr3->mold) + expr3 = tmp; + else + expr3_tmp = tmp; + /* When he length of a char array is easily available + here, fix it for future use. */ + if (se.string_length) + expr3_len = gfc_evaluate_now (se.string_length, &block); } /* Figure how to get the _vtab entry. This also obtains the tree @@ -5246,11 +5254,15 @@ gfc_trans_allocate (gfc_code * code) if (code->expr3->ts.type == BT_CLASS) { gfc_expr *rhs; - /* Polymorphic SOURCE: VPTR must be determined at run time. */ - if (expr3 != NULL_TREE && (VAR_P (expr3) || !code->expr3->ref)) + /* Polymorphic SOURCE: VPTR must be determined at run time. + expr3 may be a temporary array declaration, therefore check for + GFC_CLASS_TYPE_P before trying to get the _vptr component. */ + if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)) + && (VAR_P (expr3) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3); else if (expr3_tmp != NULL_TREE - && (VAR_P (expr3_tmp) ||!code->expr3->ref)) + && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp)) + && (VAR_P (expr3_tmp) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3_tmp); else { @@ -5634,7 +5646,7 @@ gfc_trans_allocate (gfc_code * code) if (expr3 != NULL_TREE && ((POINTER_TYPE_P (TREE_TYPE (expr3)) && TREE_CODE (expr3) != POINTER_PLUS_EXPR) - || VAR_P (expr3)) + || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))) && code->expr3->ts.type == BT_CLASS && (expr->ts.type == BT_CLASS || expr->ts.type == BT_DERIVED)) @@ -5646,14 +5658,50 @@ gfc_trans_allocate (gfc_code * code) } else if (code->expr3->ts.type == BT_CHARACTER) { - tmp = INDIRECT_REF_P (se.expr) ? + tree dst, src, dlen, slen; + /* For arrays of char arrays, a ref to the data component still + needs to be added, because se.expr upto now only contains the + descritor. */ + if (expr->ref && se.expr && TREE_TYPE (se.expr) != NULL_TREE + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) + { + dst = gfc_conv_array_data (se.expr); + src = gfc_conv_array_data (expr3); + /* For CHARACTER (len=string_length), dimension (nelems) + compute the total length of the string to copy. */ + if (nelems) + { + dlen = fold_build2_loc (input_location, MULT_EXPR, + size_type_node, + fold_convert (size_type_node, + se.string_length), + fold_convert (size_type_node, + nelems)); + slen = fold_build2_loc (input_location, MULT_EXPR, + size_type_node, + fold_convert (size_type_node, + expr3_len), + fold_convert (size_type_node, + nelems)); + } + else + { + dlen = se.string_length; + slen = expr3_len; + } + } + else + { + dst = INDIRECT_REF_P (se.expr) ? se.expr : build_fold_indirect_ref_loc (input_location, se.expr); - gfc_trans_string_copy (&block, al_len, tmp, - code->expr3->ts.kind, - expr3_len, expr3, - code->expr3->ts.kind); + src = expr3; + dlen = al_len; + slen = expr3_len; + } + gfc_trans_string_copy (&block, dlen, dst, code->expr3->ts.kind, + slen, src, code->expr3->ts.kind); tmp = NULL_TREE; } else if (al->expr->ts.type == BT_CLASS) diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_6.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f90 new file mode 100644 index 0000000..d7c9ca0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f90 @@ -0,0 +1,159 @@ +! { dg-do run } +! +! Contributed by Juergen Reuter +! Check that pr65548 is fixed. +! + +module selectors + type :: selector_t + integer, dimension(:), allocatable :: map + real, dimension(:), allocatable :: weight + contains + procedure :: init => selector_init + end type selector_t + +contains + + subroutine selector_init (selector, weight) + class(selector_t), intent(out) :: selector + real, dimension(:), intent(in) :: weight + real :: s + integer :: n, i + logical, dimension(:), allocatable :: mask + s = sum (weight) + allocate (mask (size (weight)), source = weight /= 0) + n = count (mask) + if (n > 0) then + allocate (selector%map (n), & + source = pack ([(i, i = 1, size (weight))], mask)) + allocate (selector%weight (n), & + source = pack (weight / s, mask)) + else + allocate (selector%map (1), source = 1) + allocate (selector%weight (1), source = 0.) + end if + end subroutine selector_init + +end module selectors + +module phs_base + type :: flavor_t + contains + procedure :: get_mass => flavor_get_mass + end type flavor_t + + type :: phs_config_t + integer :: n_in = 0 + type(flavor_t), dimension(:,:), allocatable :: flv + end type phs_config_t + + type :: phs_t + class(phs_config_t), pointer :: config => null () + real, dimension(:), allocatable :: m_in + end type phs_t + +contains + + elemental function flavor_get_mass (flv) result (mass) + real :: mass + class(flavor_t), intent(in) :: flv + mass = 42.0 + end function flavor_get_mass + + subroutine phs_base_init (phs, phs_config) + class(phs_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + phs%config => phs_config + allocate (phs%m_in (phs%config%n_in), & + source = phs_config%flv(:phs_config%n_in, 1)%get_mass ()) + end subroutine phs_base_init + +end module phs_base + +module foo + type :: t + integer :: n + real, dimension(:,:), allocatable :: val + contains + procedure :: make => t_make + generic :: get_int => get_int_array, get_int_element + procedure :: get_int_array => t_get_int_array + procedure :: get_int_element => t_get_int_element + end type t + +contains + + subroutine t_make (this) + class(t), intent(inout) :: this + real, dimension(:), allocatable :: int + allocate (int (0:this%n-1), source=this%get_int()) + end subroutine t_make + + pure function t_get_int_array (this) result (array) + class(t), intent(in) :: this + real, dimension(this%n) :: array + array = this%val (0:this%n-1, 4) + end function t_get_int_array + + pure function t_get_int_element (this, set) result (element) + class(t), intent(in) :: this + integer, intent(in) :: set + real :: element + element = this%val (set, 4) + end function t_get_int_element +end module foo +module foo2 + type :: t2 + integer :: n + character(32), dimension(:), allocatable :: md5 + contains + procedure :: init => t2_init + end type t2 + +contains + + subroutine t2_init (this) + class(t2), intent(inout) :: this + character(32), dimension(:), allocatable :: md5 + allocate (md5 (this%n), source=this%md5) + if (md5(1) /= "tst ") call abort() + if (md5(2) /= " ") call abort() + if (md5(3) /= "fooblabar ") call abort() + end subroutine t2_init +end module foo2 + +program test + use selectors + use phs_base + use foo + use foo2 + + type(selector_t) :: sel + type(phs_t) :: phs + type(phs_config_t) :: phs_config + type(t) :: o + type(t2) :: o2 + + call sel%init([2., 0., 3., 0., 4.]) + + if (any(sel%map /= [1, 3, 5])) call abort() + if (any(sel%weight /= [2./9., 3./9., 4./9.])) call abort() + + phs_config%n_in = 2 + allocate (phs_config%flv (phs_config%n_in, 1)) + call phs_base_init (phs, phs_config) + + if (any (phs%m_in /= [42.0, 42.0])) call abort() + + o%n = 2 + allocate (o%val(2,4)) + call o%make() + + o2%n = 3 + allocate(o2%md5(o2%n)) + o2%md5(1) = "tst" + o2%md5(2) = "" + o2%md5(3) = "fooblabar" + call o2%init() +end program test +