diff options
Diffstat (limited to 'gcc/fortran/trans-expr.c')
| -rw-r--r-- | gcc/fortran/trans-expr.c | 202 |
1 files changed, 185 insertions, 17 deletions
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 4bce65e..c5a4be3 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1701,7 +1701,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, if (intent != INTENT_OUT) { - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); gfc_trans_scalarizing_loops (&loop, &body); @@ -1792,7 +1792,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, gcc_assert (lse.ss == gfc_ss_terminator); - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false); gfc_add_expr_to_block (&body, tmp); /* Generate the copying loops. */ @@ -1864,6 +1864,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, gfc_ss *argss; gfc_ss_info *info; int byref; + int parm_kind; tree type; tree var; tree len; @@ -1877,6 +1878,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, gfc_expr *e; gfc_symbol *fsym; stmtblock_t post; + enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; arglist = NULL_TREE; retargs = NULL_TREE; @@ -1919,6 +1921,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, { e = arg->expr; fsym = formal ? formal->sym : NULL; + parm_kind = MISSING; if (e == NULL) { @@ -1947,6 +1950,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, /* An elemental function inside a scalarized loop. */ gfc_init_se (&parmse, se); gfc_conv_expr_reference (&parmse, e); + parm_kind = ELEMENTAL; } else { @@ -1957,12 +1961,14 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, if (argss == gfc_ss_terminator) { gfc_conv_expr_reference (&parmse, e); + parm_kind = SCALAR; if (fsym && fsym->attr.pointer && e->expr_type != EXPR_NULL) { /* Scalar pointer dummy args require an extra level of indirection. The null pointer already contains this level of indirection. */ + parm_kind = SCALAR_POINTER; parmse.expr = build_fold_addr_expr (parmse.expr); } } @@ -2050,6 +2056,49 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&post, &parmse.post); + /* Allocated allocatable components of derived types must be + deallocated for INTENT(OUT) dummy arguments and non-variable + scalars. Non-variable arrays are dealt with in trans-array.c + (gfc_conv_array_parameter). */ + if (e && e->ts.type == BT_DERIVED + && e->ts.derived->attr.alloc_comp + && ((formal && formal->sym->attr.intent == INTENT_OUT) + || + (e->expr_type != EXPR_VARIABLE && !e->rank))) + { + int parm_rank; + tmp = build_fold_indirect_ref (parmse.expr); + parm_rank = e->rank; + switch (parm_kind) + { + case (ELEMENTAL): + case (SCALAR): + parm_rank = 0; + break; + + case (SCALAR_POINTER): + tmp = build_fold_indirect_ref (tmp); + break; + case (ARRAY): + tmp = parmse.expr; + break; + } + + tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank); + if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) + tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym), + tmp, build_empty_stmt ()); + + if (e->expr_type != EXPR_VARIABLE) + /* Don't deallocate non-variables until they have been used. */ + gfc_add_expr_to_block (&se->post, tmp); + else + { + gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT); + gfc_add_expr_to_block (&se->pre, tmp); + } + } + /* Character strings are passed as two parameters, a length and a pointer. */ if (parmse.string_length != NULL_TREE) @@ -2636,7 +2685,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_conv_expr (&rse, expr); - tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type); + tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); @@ -2657,17 +2706,22 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) return gfc_finish_block (&block); } + /* Assign a single component of a derived type constructor. */ static tree gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) { gfc_se se; + gfc_se lse; gfc_ss *rss; stmtblock_t block; tree tmp; + tree offset; + int n; gfc_start_block (&block); + if (cm->pointer) { gfc_init_se (&se, NULL); @@ -2700,8 +2754,68 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) } else if (cm->dimension) { - tmp = gfc_trans_subarray_assign (dest, cm, expr); - gfc_add_expr_to_block (&block, tmp); + if (cm->allocatable && expr->expr_type == EXPR_NULL) + gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); + else if (cm->allocatable) + { + tree tmp2; + + gfc_init_se (&se, NULL); + + rss = gfc_walk_expr (expr); + se.want_pointer = 0; + gfc_conv_expr_descriptor (&se, expr, rss); + gfc_add_block_to_block (&block, &se.pre); + + tmp = fold_convert (TREE_TYPE (dest), se.expr); + gfc_add_modify_expr (&block, dest, tmp); + + if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp) + tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest, + cm->as->rank); + else + tmp = gfc_duplicate_allocatable (dest, se.expr, + TREE_TYPE(cm->backend_decl), + cm->as->rank); + + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &se.post); + gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node); + + /* Shift the lbound and ubound of temporaries to being unity, rather + than zero, based. Calculate the offset for all cases. */ + offset = gfc_conv_descriptor_offset (dest); + gfc_add_modify_expr (&block, offset, gfc_index_zero_node); + tmp2 =gfc_create_var (gfc_array_index_type, NULL); + for (n = 0; n < expr->rank; n++) + { + if (expr->expr_type != EXPR_VARIABLE + && expr->expr_type != EXPR_CONSTANT) + { + tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]); + gfc_add_modify_expr (&block, tmp, + fold_build2 (PLUS_EXPR, + gfc_array_index_type, + tmp, gfc_index_one_node)); + tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]); + gfc_add_modify_expr (&block, tmp, gfc_index_one_node); + } + tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, + gfc_conv_descriptor_lbound (dest, + gfc_rank_cst[n]), + gfc_conv_descriptor_stride (dest, + gfc_rank_cst[n])); + gfc_add_modify_expr (&block, tmp2, tmp); + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2); + gfc_add_modify_expr (&block, offset, tmp); + } + } + else + { + tmp = gfc_trans_subarray_assign (dest, cm, expr); + gfc_add_expr_to_block (&block, tmp); + } } else if (expr->ts.type == BT_DERIVED) { @@ -2722,8 +2836,6 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) else { /* Scalar component. */ - gfc_se lse; - gfc_init_se (&se, NULL); gfc_init_se (&lse, NULL); @@ -2731,7 +2843,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) if (cm->ts.type == BT_CHARACTER) lse.string_length = cm->ts.cl->backend_decl; lse.expr = dest; - tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type); + tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false); gfc_add_expr_to_block (&block, tmp); } return gfc_finish_block (&block); @@ -2791,10 +2903,14 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) } cm = expr->ts.derived->components; + for (c = expr->value.constructor; c; c = c->next, cm = cm->next) { - /* Skip absent members in default initializers. */ - if (!c->expr) + /* Skip absent members in default initializers and allocatable + components. Although the latter have a default initializer + of EXPR_NULL,... by default, the static nullify is not needed + since this is done every time we come into scope. */ + if (!c->expr || cm->allocatable) continue; val = gfc_conv_initializer (c->expr, &cm->ts, @@ -3089,16 +3205,19 @@ gfc_conv_string_parameter (gfc_se * se) /* Generate code for assignment of scalar variables. Includes character - strings. */ + strings and derived types with allocatable components. */ tree -gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type) +gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, + bool l_is_temp, bool r_is_var) { stmtblock_t block; + tree tmp; + tree cond; gfc_init_block (&block); - if (type == BT_CHARACTER) + if (ts.type == BT_CHARACTER) { gcc_assert (lse->string_length != NULL_TREE && rse->string_length != NULL_TREE); @@ -3112,6 +3231,50 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type) gfc_trans_string_copy (&block, lse->string_length, lse->expr, rse->string_length, rse->expr); } + else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp) + { + cond = NULL_TREE; + + /* Are the rhs and the lhs the same? */ + if (r_is_var) + { + cond = fold_build2 (EQ_EXPR, boolean_type_node, + build_fold_addr_expr (lse->expr), + build_fold_addr_expr (rse->expr)); + cond = gfc_evaluate_now (cond, &lse->pre); + } + + /* Deallocate the lhs allocated components as long as it is not + the same as the rhs. */ + if (!l_is_temp) + { + tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0); + if (r_is_var) + tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp); + gfc_add_expr_to_block (&lse->pre, tmp); + } + + gfc_add_block_to_block (&block, &lse->pre); + gfc_add_block_to_block (&block, &rse->pre); + + gfc_add_modify_expr (&block, lse->expr, + fold_convert (TREE_TYPE (lse->expr), rse->expr)); + + /* Do a deep copy if the rhs is a variable, if it is not the + same as the lhs. Otherwise, nullify the data fields so that the + lhs retains the allocated resources. */ + if (r_is_var) + { + tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0); + tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp); + gfc_add_expr_to_block (&block, tmp); + } + else + { + tmp = gfc_nullify_alloc_comp (ts.derived, rse->expr, 0); + gfc_add_expr_to_block (&block, tmp); + } + } else { gfc_add_block_to_block (&block, &lse->pre); @@ -3217,6 +3380,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) tree tmp; stmtblock_t block; stmtblock_t body; + bool l_is_temp; /* Special case a single function returning an array. */ if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) @@ -3295,10 +3459,12 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) else gfc_init_block (&body); + l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL); + /* Translate the expression. */ gfc_conv_expr (&rse, expr2); - if (lss != gfc_ss_terminator && loop.temp_ss != NULL) + if (l_is_temp) { gfc_conv_tmp_array_ref (&lse); gfc_advance_se_ss_chain (&lse); @@ -3306,7 +3472,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) else gfc_conv_expr (&lse, expr1); - tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp, + expr2->expr_type == EXPR_VARIABLE); gfc_add_expr_to_block (&body, tmp); if (lss == gfc_ss_terminator) @@ -3319,7 +3486,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) gcc_assert (lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator); - if (loop.temp_ss != NULL) + if (l_is_temp) { gfc_trans_scalarized_loop_boundary (&loop, &body); @@ -3339,9 +3506,10 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) gcc_assert (lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator); - tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false); gfc_add_expr_to_block (&body, tmp); } + /* Generate the copying loops. */ gfc_trans_scalarizing_loops (&loop, &body); |