From bf7e666b57e0ff40a901195fdf858bb555f60092 Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 29 May 2005 16:02:09 +0000 Subject: [PATCH] 2005-05-29 Paul Thomas PR fortran/16939 PR fortran/17192 PR fortran/17193 PR fortran/17202 PR fortran/18689 PR fortran/18890 PR fortran/21297 * fortran/trans-array.c (gfc_conv_resolve_dependencies): Add string length to temp_ss for character pointer array assignments. * fortran/trans-expr.c (gfc_conv_variable): Correct errors in dereferencing of characters and character pointers. * fortran/trans-expr.c (gfc_conv_function_call): Provide string length as return argument for various kinds of handling of return. Return a char[]* temporary for character pointer functions and dereference the temporary upon return. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@100324 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 3 +- gcc/fortran/trans-expr.c | 144 ++++++++++++++++++++++++++++++++++------------ 2 files changed, 108 insertions(+), 39 deletions(-) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 6dc33d3..047f8bc 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2342,7 +2342,7 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, loop->temp_ss->type = GFC_SS_TEMP; loop->temp_ss->data.temp.type = gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor)); - loop->temp_ss->string_length = NULL_TREE; + loop->temp_ss->string_length = dest->string_length; loop->temp_ss->data.temp.dimen = loop->dimen; loop->temp_ss->next = gfc_ss_terminator; gfc_add_ss_to_loop (loop, loop->temp_ss); @@ -3617,6 +3617,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) loop.temp_ss->type = GFC_SS_TEMP; loop.temp_ss->next = gfc_ss_terminator; loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts); + /* ... which can hold our string, if present. */ if (expr->ts.type == BT_CHARACTER) se->string_length = loop.temp_ss->string_length diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 52a532d..c04efd2 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -354,30 +354,43 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) se->expr = gfc_build_addr_expr (NULL, se->expr); } return; - } - - /* Dereference scalar dummy variables. */ - if (sym->attr.dummy - && sym->ts.type != BT_CHARACTER - && !sym->attr.dimension) - se->expr = gfc_build_indirect_ref (se->expr); - - /* Dereference scalar hidden result. */ - if (gfc_option.flag_f2c - && (sym->attr.function || sym->attr.result) - && sym->ts.type == BT_COMPLEX - && !sym->attr.dimension) - se->expr = gfc_build_indirect_ref (se->expr); - - /* Dereference pointer variables. */ - if ((sym->attr.pointer || sym->attr.allocatable) - && (sym->attr.dummy - || sym->attr.result - || sym->attr.function - || !sym->attr.dimension) - && sym->ts.type != BT_CHARACTER) - se->expr = gfc_build_indirect_ref (se->expr); - + } + + + /* Dereference the expression, where needed. Since characters + are entirely different from other types, they are treated + separately. */ + if (sym->ts.type == BT_CHARACTER) + { + /* Dereference character pointer dummy arguments + or results. */ + if ((sym->attr.pointer || sym->attr.allocatable) + && ((sym->attr.dummy) + || (sym->attr.function + || sym->attr.result))) + se->expr = gfc_build_indirect_ref (se->expr); + } + else + { + /* Dereference non-charcter scalar dummy arguments. */ + if ((sym->attr.dummy) && (!sym->attr.dimension)) + se->expr = gfc_build_indirect_ref (se->expr); + + /* Dereference scalar hidden result. */ + if ((gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX) + && (sym->attr.function || sym->attr.result) + && (!sym->attr.dimension)) + se->expr = gfc_build_indirect_ref (se->expr); + + /* Dereference non-character pointer variables. + These must be dummys or results or scalars. */ + if ((sym->attr.pointer || sym->attr.allocatable) + && ((sym->attr.dummy) + || (sym->attr.function || sym->attr.result) + || (!sym->attr.dimension))) + se->expr = gfc_build_indirect_ref (se->expr); + } + ref = expr->ref; } @@ -1083,6 +1096,15 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, var = NULL_TREE; len = NULL_TREE; + /* Obtain the string length now because it is needed often below. */ + if (sym->ts.type == BT_CHARACTER) + { + gcc_assert (sym->ts.cl && sym->ts.cl->length + && sym->ts.cl->length->expr_type == EXPR_CONSTANT); + len = gfc_conv_mpz_to_tree + (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind); + } + if (se->ss != NULL) { if (!sym->attr.elemental) @@ -1097,6 +1119,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, /* Access the previously obtained result. */ gfc_conv_tmp_array_ref (se); gfc_advance_se_ss_chain (se); + + /* Bundle in the string length. */ + se->string_length=len; return; } } @@ -1108,14 +1133,26 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, byref = gfc_return_by_reference (sym); if (byref) { - if (se->direct_byref) - arglist = gfc_chainon_list (arglist, se->expr); + if (se->direct_byref) + { + arglist = gfc_chainon_list (arglist, se->expr); + + /* Add string length to argument list. */ + if (sym->ts.type == BT_CHARACTER) + { + sym->ts.cl->backend_decl = len; + arglist = gfc_chainon_list (arglist, + convert (gfc_charlen_type_node, len)); + } + } else if (sym->result->attr.dimension) { - gcc_assert (se->loop && se->ss); + gcc_assert (se->loop && se->ss); + /* Set the type of the array. */ tmp = gfc_typenode_for_spec (&sym->ts); - info->dimen = se->loop->dimen; + info->dimen = se->loop->dimen; + /* Allocate a temporary to store the result. */ gfc_trans_allocate_temp_array (se->loop, info, tmp); @@ -1124,22 +1161,46 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]); gfc_add_modify_expr (&se->pre, tmp, convert (TREE_TYPE (tmp), integer_zero_node)); + /* Pass the temporary as the first argument. */ tmp = info->descriptor; tmp = gfc_build_addr_expr (NULL, tmp); arglist = gfc_chainon_list (arglist, tmp); + + /* Add string length to argument list. */ + if (sym->ts.type == BT_CHARACTER) + { + sym->ts.cl->backend_decl = len; + arglist = gfc_chainon_list (arglist, + convert (gfc_charlen_type_node, len)); + } + } else if (sym->ts.type == BT_CHARACTER) { - gcc_assert (sym->ts.cl && sym->ts.cl->length - && sym->ts.cl->length->expr_type == EXPR_CONSTANT); - len = gfc_conv_mpz_to_tree - (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind); + + /* Pass the string length. */ sym->ts.cl->backend_decl = len; type = gfc_get_character_type (sym->ts.kind, sym->ts.cl); type = build_pointer_type (type); - var = gfc_conv_string_tmp (se, type, len); + /* Return an address to a char[4]* temporary for character pointers. */ + if (sym->attr.pointer || sym->attr.allocatable) + { + /* Build char[4] * pstr. */ + tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len, + convert (gfc_charlen_type_node, integer_one_node)); + tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); + tmp = build_array_type (gfc_character1_type_node, tmp); + var = gfc_create_var (build_pointer_type (tmp), "pstr"); + + /* Provide an address expression for the function arguments. */ + var = gfc_build_addr_expr (NULL, var); + } + else + { + var = gfc_conv_string_tmp (se, type, len); + } arglist = gfc_chainon_list (arglist, var); arglist = gfc_chainon_list (arglist, convert (gfc_charlen_type_node, len)); @@ -1205,8 +1266,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, && arg->expr->expr_type != EXPR_NULL) { /* Scalar pointer dummy args require an extra level of - indirection. The null pointer already contains - this level of indirection. */ + indirection. The null pointer already contains + this level of indirection. */ parmse.expr = gfc_build_addr_expr (NULL, parmse.expr); } } @@ -1299,10 +1360,17 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre); } se->expr = info->descriptor; + /* Bundle in the string length. */ + se->string_length = len; } else if (sym->ts.type == BT_CHARACTER) - { - se->expr = var; + { + /* Dereference for character pointer results. */ + if (sym->attr.pointer || sym->attr.allocatable) + se->expr = gfc_build_indirect_ref (var); + else + se->expr = var; + se->string_length = len; } else @@ -2229,7 +2297,7 @@ 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); gfc_add_expr_to_block (&body, tmp); -- 2.7.4