@@ -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)
new file mode 100644
@@ -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
+