Skip to content

R
riscv-gcc-1
Commit db7ffcab by Andre Vehreschild Committed by Andre Vehreschild
Options

re PR fortran/65548 (gfc_conv_procedure_call) 

gcc/fortran/ChangeLog:

2015-05-19  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/65548
	* trans-stmt.c (gfc_trans_allocate): Always retrieve the
	descriptor or a reference to a source= expression for
	arrays and non-arrays, respectively.  Use a temporary
	symbol and gfc_trans_assignment for all source=
	assignments to allocated objects besides for class and
	derived types.

gcc/testsuite/ChangeLog:

2015-05-19  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/65548
	* gfortran.dg/allocate_with_source_5.f90: Extend test.

From-SVN: r223445
parent cf4ef6f7
Showing with 293 additions and 112 deletions
gcc/fortran/ChangeLog
2015-05-20 Andre Vehreschild <vehre@gmx.de>
PR fortran/65548
* trans-stmt.c (gfc_trans_allocate): Always retrieve the
descriptor or a reference to a source= expression for
arrays and non-arrays, respectively. Use a temporary
symbol and gfc_trans_assignment for all source=
assignments to allocated objects besides for class and
derived types.
2015-05-19 Jakub Jelinek <jakub@redhat.com>
PR middle-end/66199
......
gcc/fortran/trans-stmt.c
......@@ -5088,7 +5088,7 @@ tree
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;
......@@ -5109,6 +5109,7 @@ gfc_trans_allocate (gfc_code * code)
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;
......@@ -5148,14 +5149,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 +5166,77 @@ 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);
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
......@@ -5246,11 +5246,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
{
......@@ -5325,6 +5329,64 @@ gfc_trans_allocate (gfc_code * code)
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);
......@@ -5628,13 +5690,12 @@ gfc_trans_allocate (gfc_code * code)
}
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))
......@@ -5644,24 +5705,13 @@ gfc_trans_allocate (gfc_code * code)
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 ();
......@@ -5688,8 +5738,8 @@ gfc_trans_allocate (gfc_code * code)
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++)
{
......@@ -5758,8 +5808,8 @@ gfc_trans_allocate (gfc_code * code)
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 ();
......@@ -5773,6 +5823,7 @@ gfc_trans_allocate (gfc_code * code)
void_type_node, tmp, extcopy, stdcopy);
}
gfc_free_statements (ppc_code);
gfc_free_expr (rhs);
}
else
{
......@@ -5781,10 +5832,9 @@ gfc_trans_allocate (gfc_code * code)
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
......@@ -5802,6 +5852,15 @@ gfc_trans_allocate (gfc_code * code)
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)
{
......
gcc/testsuite/ChangeLog
2015-05-20 Andre Vehreschild <vehre@gmx.de>
PR fortran/65548
* gfortran.dg/allocate_with_source_5.f90: Extend test.
2015-05-20 Bin Cheng <bin.cheng@arm.com>
PR tree-optimization/65447
......
gcc/testsuite/gfortran.dg/allocate_with_source_5.f90
! { 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
......@@ -34,19 +34,126 @@ 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment