gfc_trans_allocate (gfc_code * code)
{
gfc_alloc *al;
- gfc_expr *expr;
+ gfc_expr *expr, *e3rhs = NULL;
gfc_se se, se_sz;
tree tmp;
tree parm;
stmtblock_t post;
tree nelems;
bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set;
+ gfc_symtree *newsym = NULL;
if (!code->ext.alloc.list)
return NULL_TREE;
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;
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);
+ symbol_attribute attr;
+ /* Get the descriptor for all arrays, that are not allocatable or
+ pointer, because the latter are descriptors already. */
+ attr = gfc_expr_attr (code->expr3);
+ if (code->expr3->rank != 0 && !attr.allocatable && !attr.pointer)
+ 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))
+ {
+ tree var;
+ tmp = build_fold_indirect_ref_loc (input_location,
+ se.expr);
+ /* We need a regular (non-UID) symbol here, therefore give a
+ prefix. */
+ var = gfc_create_var (TREE_TYPE (tmp), "atmp");
+ gfc_add_modify_loc (input_location, &block, var, tmp);
+ tmp = var;
}
+ 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
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
{
else
expr3_esize = TYPE_SIZE_UNIT (
gfc_typenode_for_spec (&code->expr3->ts));
+
+ /* The routine gfc_trans_assignment () already implements all
+ techniques needed. Unfortunately we may have a temporary
+ variable for the source= expression here. When that is the
+ case convert this variable into a temporary gfc_expr of type
+ EXPR_VARIABLE and used it as rhs for the assignment. The
+ advantage is, that we get scalarizer support for free,
+ don't have to take care about scalar to array treatment and
+ will benefit of every enhancements gfc_trans_assignment ()
+ gets. */
+ if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
+ {
+ /* Build a temporary symtree and symbol. Do not add it to
+ the current namespace to prevent accidently modifying
+ a colliding symbol's as. */
+ newsym = XCNEW (gfc_symtree);
+ /* The name of the symtree should be unique, because
+ gfc_create_var () took care about generating the
+ identifier. */
+ newsym->name = gfc_get_string (IDENTIFIER_POINTER (
+ DECL_NAME (expr3)));
+ newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
+ /* The backend_decl is known. It is expr3, which is inserted
+ here. */
+ newsym->n.sym->backend_decl = expr3;
+ e3rhs = gfc_get_expr ();
+ e3rhs->ts = code->expr3->ts;
+ e3rhs->rank = code->expr3->rank;
+ e3rhs->symtree = newsym;
+ /* Mark the symbol referenced or gfc_trans_assignment will
+ bug. */
+ newsym->n.sym->attr.referenced = 1;
+ e3rhs->expr_type = EXPR_VARIABLE;
+ /* Set the symbols type, upto it was BT_UNKNOWN. */
+ newsym->n.sym->ts = e3rhs->ts;
+ /* Check whether the expr3 is array valued. */
+ if (e3rhs->rank)
+ {
+ gfc_array_spec *arr;
+ arr = gfc_get_array_spec ();
+ arr->rank = e3rhs->rank;
+ arr->type = AS_DEFERRED;
+ /* Set the dimension and pointer attribute for arrays
+ to be on the safe side. */
+ newsym->n.sym->attr.dimension = 1;
+ newsym->n.sym->attr.pointer = 1;
+ newsym->n.sym->as = arr;
+ gfc_add_full_array_ref (e3rhs, arr);
+ }
+ else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
+ newsym->n.sym->attr.pointer = 1;
+ /* The string length is known to. Set it for char arrays. */
+ if (e3rhs->ts.type == BT_CHARACTER)
+ newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
+ gfc_commit_symbol (newsym->n.sym);
+ }
+ else
+ e3rhs = gfc_copy_expr (code->expr3);
}
gcc_assert (expr3_esize);
expr3_esize = fold_convert (sizetype, expr3_esize);
}
if (code->expr3 && !code->expr3->mold)
{
- /* Initialization via SOURCE block
- (or static default initializer). */
- gfc_expr *rhs = gfc_copy_expr (code->expr3);
+ /* Initialization via SOURCE block (or static default initializer).
+ Classes need some special handling, so catch them first. */
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))
tmp = gfc_copy_class_to_class (expr3, to,
nelems, upoly_expr);
}
- else if (code->expr3->ts.type == BT_CHARACTER)
- {
- tmp = 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);
- tmp = NULL_TREE;
- }
else if (al->expr->ts.type == BT_CLASS)
{
gfc_actual_arglist *actual, *last_arg;
gfc_expr *ppc;
gfc_code *ppc_code;
gfc_ref *ref, *dataref;
+ gfc_expr *rhs = gfc_copy_expr (code->expr3);
/* Do a polymorphic deep copy. */
actual = gfc_get_actual_arglist ();
gfc_ref *ref = dataref->next;
ref->u.ar.type = AR_SECTION;
/* We have to set up the array reference to give ranges
- in all dimensions and ensure that the end and stride
- are set so that the copy can be scalarized. */
+ in all dimensions and ensure that the end and stride
+ are set so that the copy can be scalarized. */
dim = 0;
for (; dim < dataref->u.c.component->as->rank; dim++)
{
gfc_add_len_component (last_arg->expr);
}
else if (code->expr3->ts.type == BT_CHARACTER)
- last_arg->expr =
- gfc_copy_expr (code->expr3->ts.u.cl->length);
+ last_arg->expr =
+ gfc_copy_expr (code->expr3->ts.u.cl->length);
else
gcc_unreachable ();
void_type_node, tmp, extcopy, stdcopy);
}
gfc_free_statements (ppc_code);
+ gfc_free_expr (rhs);
}
else
{
int realloc_lhs = flag_realloc_lhs;
flag_realloc_lhs = 0;
tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
- rhs, false, false);
+ e3rhs, false, false);
flag_realloc_lhs = realloc_lhs;
}
- gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
}
else if (code->expr3 && code->expr3->mold
gfc_free_expr (expr);
} // for-loop
+ if (e3rhs)
+ {
+ if (newsym)
+ {
+ gfc_free_symbol (newsym->n.sym);
+ XDELETE (newsym);
+ }
+ gfc_free_expr (e3rhs);
+ }
/* STAT. */
if (code->expr1)
{
! { dg-do run }
!
+! Contributed by Juergen Reuter
! Check that pr65548 is fixed.
-! Contributed by Juergen Reuter <juergen.reuter@desy.de>
-
-module allocate_with_source_5_module
+!
+module selectors
type :: selector_t
- integer, dimension(:), allocatable :: map
- real, dimension(:), allocatable :: weight
- contains
- procedure :: init => selector_init
- end type selector_t
+ integer, dimension(:), allocatable :: map
+ real, dimension(:), allocatable :: weight
+ contains
+ procedure :: init => selector_init
+ end type selector_t
contains
end if
end subroutine selector_init
-end module allocate_with_source_5_module
+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(abs(sel%weight - [2., 3., 4.] / 9.) > 1E-6)) call abort()
-program allocate_with_source_5
- use allocate_with_source_5_module
+ phs_config%n_in = 2
+ allocate (phs_config%flv (phs_config%n_in, 1))
+ call phs_base_init (phs, phs_config)
- class(selector_t), allocatable :: sel;
- real, dimension(5) :: w = [ 1, 0, 2, 0, 3];
+ if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) call abort()
- allocate (sel)
- call sel%init(w)
+ o%n = 2
+ allocate (o%val(2,4))
+ call o%make()
- if (any(sel%map /= [ 1, 3, 5])) call abort()
- if (any(abs(sel%weight - [1, 2, 3] / 6) < 1E-6)) call abort()
-end program allocate_with_source_5
-! { dg-final { cleanup-modules "allocate_with_source_5_module" } }
+ 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
projects / gcc.git / commitdiff