mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 00:31:30 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/16939 (Pointers not passed as subroutine arguments)

Browse Source 
2005-05-29 Paul Thomas  <pault@gcc.gnu.org>

	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.

From-SVN: r100324
This commit is contained in:
Paul Thomas 2005-05-29 16:02:09 +00:00
parent 0ac2a27ad7
commit 72caba17ea
2 changed files with 107 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
gcc/fortran/trans-array.c
View File

@ -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

142
gcc/fortran/trans-expr.c
View File

@ -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);