diff options
Diffstat (limited to 'gcc/fortran/trans-expr.cc')
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 92 |
1 files changed, 52 insertions, 40 deletions
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 0db7ba3..97431d9 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1168,7 +1168,6 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, else { parmse->ss = ss; - parmse->use_offset = 1; gfc_conv_expr_descriptor (parmse, e); /* Array references with vector subscripts and non-variable expressions @@ -5485,16 +5484,6 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77, /* Translate the expression. */ gfc_conv_expr (&rse, expr); - /* Reset the offset for the function call since the loop - is zero based on the data pointer. Note that the temp - comes first in the loop chain since it is added second. */ - if (gfc_is_class_array_function (expr)) - { - tmp = loop.ss->loop_chain->info->data.array.descriptor; - gfc_conv_descriptor_offset_set (&loop.pre, tmp, - gfc_index_zero_node); - } - gfc_conv_tmp_array_ref (&lse); if (intent != INTENT_OUT) @@ -6521,6 +6510,20 @@ conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond) } +/* Returns true if the type specified in TS is a character type whose length + is constant. Otherwise returns false. */ + +static bool +gfc_const_length_character_type_p (gfc_typespec *ts) +{ + return (ts->type == BT_CHARACTER + && ts->u.cl + && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT + && ts->u.cl->length->ts.type == BT_INTEGER); +} + + /* Helper function for the handling of (currently) scalar dummy variables with the VALUE attribute. Argument parmse should already be set up. */ static void @@ -6531,6 +6534,20 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym, gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension); + if (e && e->ts.type == BT_DERIVED && e->ts.u.derived->attr.pdt_type) + { + tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT"); + gfc_add_modify (&parmse->pre, tmp, parmse->expr); + gfc_add_expr_to_block (&parmse->pre, + gfc_copy_alloc_comp (e->ts.u.derived, + parmse->expr, tmp, + e->rank, 0)); + parmse->expr = tmp; + tmp = gfc_deallocate_pdt_comp (e->ts.u.derived, tmp, e->rank); + gfc_add_expr_to_block (&parmse->post, tmp); + return; + } + /* Absent actual argument for optional scalar dummy. */ if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional) { @@ -6562,6 +6579,26 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym, return; } + /* Truncate a too long constant character actual argument. */ + if (gfc_const_length_character_type_p (&fsym->ts) + && e->expr_type == EXPR_CONSTANT + && mpz_cmp_ui (fsym->ts.u.cl->length->value.integer, + e->value.character.length) < 0) + { + gfc_charlen_t flen = mpz_get_ui (fsym->ts.u.cl->length->value.integer); + + /* Truncate actual string argument. */ + gfc_conv_expr (parmse, e); + parmse->expr = gfc_build_wide_string_const (e->ts.kind, flen, + e->value.character.string); + parmse->string_length = build_int_cst (gfc_charlen_type_node, flen); + + /* Indicate value,optional scalar dummy argument as present. */ + if (fsym->attr.optional) + vec_safe_push (optionalargs, boolean_true_node); + return; + } + /* gfortran argument passing conventions: actual arguments to CHARACTER(len=1),VALUE dummy arguments are actually passed by value. @@ -7552,7 +7589,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, || CLASS_DATA (fsym)->attr.codimension)) { /* Pass a class array. */ - parmse.use_offset = 1; gfc_conv_expr_descriptor (&parmse, e); bool defer_to_dealloc_blk = false; @@ -8864,28 +8900,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)) && expr->must_finalize) { - int n; - if (se->ss && se->ss->loop) - { - gfc_add_block_to_block (&se->ss->loop->pre, &se->pre); - se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre); - tmp = gfc_class_data_get (se->expr); - info->descriptor = tmp; - info->data = gfc_conv_descriptor_data_get (tmp); - info->offset = gfc_conv_descriptor_offset_get (tmp); - for (n = 0; n < se->ss->loop->dimen; n++) - { - tree dim = gfc_rank_cst[n]; - se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim); - se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim); - } - } - else - { - /* TODO Eliminate the doubling of temporaries. This - one is necessary to ensure no memory leakage. */ - se->expr = gfc_evaluate_now (se->expr, &se->pre); - } + /* TODO Eliminate the doubling of temporaries. This + one is necessary to ensure no memory leakage. */ + se->expr = gfc_evaluate_now (se->expr, &se->pre); /* Finalize the result, if necessary. */ attr = expr->value.function.esym @@ -9612,8 +9629,8 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, /* Shift the lbound and ubound of temporaries to being unity, rather than zero, based. Always calculate the offset. */ + gfc_conv_descriptor_offset_set (&block, dest, gfc_index_zero_node); offset = gfc_conv_descriptor_offset_get (dest); - gfc_add_modify (&block, offset, gfc_index_zero_node); tmp2 =gfc_create_var (gfc_array_index_type, NULL); for (n = 0; n < expr->rank; n++) @@ -11177,11 +11194,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) { rse.expr = gfc_class_data_get (rse.expr); gfc_add_modify (&lse.pre, desc, rse.expr); - /* Set the lhs span. */ - tmp = TREE_TYPE (rse.expr); - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp)); - tmp = fold_convert (gfc_array_index_type, tmp); - gfc_conv_descriptor_span_set (&lse.pre, desc, tmp); } else { |