aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/trans-stmt.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/trans-stmt.c')
-rw-r--r--gcc/fortran/trans-stmt.c130
1 files changed, 108 insertions, 22 deletions
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 68601f61fd2..9c1f9204add 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5108,7 +5108,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;
@@ -5130,6 +5130,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;
@@ -5179,7 +5180,7 @@ gfc_trans_allocate (gfc_code * code)
_vptr, _len and element_size for expr3. */
if (code->expr3)
{
- bool vtab_needed = false;
+ bool vtab_needed = false, is_coarray = gfc_is_coarray (code->expr3);
/* expr3_tmp gets the tree when code->expr3.mold is set, i.e.,
the expression is only needed to get the _vptr, _len a.s.o. */
tree expr3_tmp = NULL_TREE;
@@ -5239,16 +5240,29 @@ gfc_trans_allocate (gfc_code * code)
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,
+ tree var;
+
+ tmp = is_coarray ? se.expr
+ : build_fold_indirect_ref_loc (input_location,
se.expr);
- tmp = gfc_evaluate_now (tmp, &block);
+
+ /* We need a regular (non-UID) symbol here, therefore give a
+ prefix. */
+ var = gfc_create_var (TREE_TYPE (tmp), "source");
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gfc_allocate_lang_decl (var);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = GFC_DECL_SAVED_DESCRIPTOR (tmp);
+ }
+ gfc_add_modify_loc (input_location, &block, var, tmp);
+ tmp = var;
}
else
tmp = se.expr;
+
if (!code->expr3->mold)
expr3 = tmp;
else
@@ -5284,6 +5298,16 @@ gfc_trans_allocate (gfc_code * code)
else if (expr3_tmp != NULL_TREE
&& (VAR_P (expr3_tmp) ||!code->expr3->ref))
tmp = gfc_class_vptr_get (expr3_tmp);
+ else if (is_coarray && expr3 != NULL_TREE)
+ {
+ /* Get the ref to coarray's data. May be wrapped in a
+ NOP_EXPR. */
+ tmp = POINTER_TYPE_P (TREE_TYPE (expr3)) ? TREE_OPERAND (expr3, 0)
+ : tmp;
+ /* Get to the base variable, i.e., strip _data.data. */
+ tmp = TREE_OPERAND (TREE_OPERAND (tmp, 0), 0);
+ tmp = gfc_class_vptr_get (tmp);
+ }
else
{
rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
@@ -5357,6 +5381,71 @@ 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.
+ Exclude variables since the following block does not handle
+ array sections. In any case, there is no harm in sending
+ variables to gfc_trans_assignment because there is no
+ evaluation of variables. */
+ if (code->expr3->expr_type != EXPR_VARIABLE
+ && code->expr3->mold != 1 && 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;
+ e3rhs->where = code->expr3->where;
+ /* 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);
@@ -5674,7 +5763,6 @@ gfc_trans_allocate (gfc_code * code)
{
/* Initialization via SOURCE block
(or static default initializer). */
- gfc_expr *rhs = gfc_copy_expr (code->expr3);
if (expr3 != NULL_TREE
&& ((POINTER_TYPE_P (TREE_TYPE (expr3))
&& TREE_CODE (expr3) != POINTER_PLUS_EXPR)
@@ -5688,25 +5776,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
- && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
- {
- 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 = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
/* Do a polymorphic deep copy. */
actual = gfc_get_actual_arglist ();
@@ -5818,6 +5894,8 @@ gfc_trans_allocate (gfc_code * code)
void_type_node, tmp, extcopy, stdcopy);
}
gfc_free_statements (ppc_code);
+ if (rhs != e3rhs)
+ gfc_free_expr (rhs);
}
else
{
@@ -5826,10 +5904,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
@@ -5847,6 +5924,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)
{
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-20 17:35:08 +0000