procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/15620 (Statement functions and optimization cause IC)

Browse source 
PR fortran/15620
	* trans-decl.c (gfc_shadow_sym, gfc_restore_sym): New functions.
	* trans-expr.c (gfc_trans_string_copy): New function.
	(gfc_conv_statement_function): Use them.  Create temp vars.  Enforce
	character lengths.
	(gfc_conv_string_parameter): Use gfc_trans_string_copy.
	* trans-stmt.c (gfc_trans_forall_1): Use gfc_{shadow,restore}_sym.
	* trans.h (struct gfc_saved_var): Define.
	(gfc_shadow_sym, gfc_restore_sym): Add prototypes.
testsuite/
	* gfortran.fortran-torture/execute/st_function_1.f90: New test.
	* gfortran.fortran-torture/execute/st_function_2.f90: New test.

From-SVN: r82452
This commit is contained in:
Paul Brook 2004-05-30 14:37:25 +00:00 • committed by Paul Brook
parent 7a70d70c54
commit 7b5b57b7dc
8 changed files with 186 additions and 62 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
gcc/fortran/ChangeLog
View file

@ -1,3 +1,15 @@
2004-05-30 Paul Brook <paul@codesourcery.com>
PR fortran/15620
* trans-decl.c (gfc_shadow_sym, gfc_restore_sym): New functions.
* trans-expr.c (gfc_trans_string_copy): New function.
(gfc_conv_statement_function): Use them. Create temp vars. Enforce
character lengths.
(gfc_conv_string_parameter): Use gfc_trans_string_copy.
* trans-stmt.c (gfc_trans_forall_1): Use gfc_{shadow,restore}_sym.
* trans.h (struct gfc_saved_var): Define.
(gfc_shadow_sym, gfc_restore_sym): Add prototypes.
2004-05-30 Steven G. Kargl <kargls@comcast.net>
* iresolve.c (gfc_resolve_random_number): Clean up conditional.

26
gcc/fortran/trans-decl.c
View file

@ -866,6 +866,32 @@ gfc_get_symbol_decl (gfc_symbol * sym)
}
/* Substitute a temporary variable in place of the real one. */
void
gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
{
save->attr = sym->attr;
save->decl = sym->backend_decl;
gfc_clear_attr (&sym->attr);
sym->attr.referenced = 1;
sym->attr.flavor = FL_VARIABLE;
sym->backend_decl = decl;
}
/* Restore the original variable. */
void
gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
{
sym->attr = save->attr;
sym->backend_decl = save->decl;
}
/* Get a basic decl for an external function. */
tree

111
gcc/fortran/trans-expr.c
View file

@ -1182,6 +1182,24 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
}
/* Generate code to copy a string. */
static void
gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
tree slen, tree src)
{
tree tmp;
tmp = NULL_TREE;
tmp = gfc_chainon_list (tmp, dlen);
tmp = gfc_chainon_list (tmp, dest);
tmp = gfc_chainon_list (tmp, slen);
tmp = gfc_chainon_list (tmp, src);
tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
gfc_add_expr_to_block (block, tmp);
}
/* Translate a statement function.
The value of a statement function reference is obtained by evaluating the
expression using the values of the actual arguments for the values of the
@ -1196,69 +1214,98 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
gfc_actual_arglist *args;
gfc_se lse;
gfc_se rse;
gfc_saved_var *saved_vars;
tree *temp_vars;
tree type;
tree tmp;
int n;
sym = expr->symtree->n.sym;
args = expr->value.function.actual;
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
n = 0;
for (fargs = sym->formal; fargs; fargs = fargs->next)
n++;
saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
{
/* Each dummy shall be specified, explicitly or implicitly, to be
scalar. */
assert (fargs->sym->attr.dimension == 0);
fsym = fargs->sym;
assert (fsym->backend_decl);
/* Convert non-pointer string dummy. */
if (fsym->ts.type == BT_CHARACTER && !fsym->attr.pointer)
/* Create a temporary to hold the value. */
type = gfc_typenode_for_spec (&fsym->ts);
temp_vars[n] = gfc_create_var (type, fsym->name);
if (fsym->ts.type == BT_CHARACTER)
{
tree len1;
tree len2;
tree arg;
tree tmp;
tree type;
tree var;
/* Copy string arguments. */
tree arglen;
assert (fsym->ts.cl && fsym->ts.cl->length
&& fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
type = gfc_get_character_type (fsym->ts.kind, fsym->ts.cl);
len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
var = gfc_build_addr_expr (build_pointer_type (type),
fsym->backend_decl);
arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
tmp = gfc_build_addr_expr (build_pointer_type (type),
temp_vars[n]);
gfc_conv_expr (&rse, args->expr);
gfc_conv_string_parameter (&rse);
len2 = rse.string_length;
gfc_add_block_to_block (&se->pre, &lse.pre);
gfc_add_block_to_block (&se->pre, &rse.pre);
arg = NULL_TREE;
arg = gfc_chainon_list (arg, len1);
arg = gfc_chainon_list (arg, var);
arg = gfc_chainon_list (arg, len2);
arg = gfc_chainon_list (arg, rse.expr);
tmp = gfc_build_function_call (gfor_fndecl_copy_string, arg);
gfc_add_expr_to_block (&se->pre, tmp);
gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
rse.expr);
gfc_add_block_to_block (&se->pre, &lse.post);
gfc_add_block_to_block (&se->pre, &rse.post);
}
else
{
/* For everything else, just evaluate the expression. */
if (fsym->attr.pointer == 1)
lse.want_pointer = 1;
gfc_conv_expr (&lse, args->expr);
gfc_add_block_to_block (&se->pre, &lse.pre);
gfc_add_modify_expr (&se->pre, fsym->backend_decl, lse.expr);
gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
gfc_add_block_to_block (&se->pre, &lse.post);
}
args = args->next;
}
/* Use the temporary variables in place of the real ones. */
for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
gfc_conv_expr (se, sym->value);
if (sym->ts.type == BT_CHARACTER)
{
gfc_conv_const_charlen (sym->ts.cl);
/* Force the expression to the correct length. */
if (!INTEGER_CST_P (se->string_length)
|| tree_int_cst_lt (se->string_length,
sym->ts.cl->backend_decl))
{
type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
tmp = gfc_create_var (type, sym->name);
tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
se->string_length, se->expr);
se->expr = tmp;
}
se->string_length = sym->ts.cl->backend_decl;
}
/* Resore the original variables. */
for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
gfc_restore_sym (fargs->sym, &saved_vars[n]);
gfc_free (saved_vars);
}
@ -1617,17 +1664,12 @@ gfc_conv_string_parameter (gfc_se * se)
tree
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
{
tree tmp;
tree args;
stmtblock_t block;
gfc_init_block (&block);
if (type == BT_CHARACTER)
{
args = NULL_TREE;
assert (lse->string_length != NULL_TREE
&& rse->string_length != NULL_TREE);
@ -1637,13 +1679,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
args = gfc_chainon_list (args, lse->string_length);
args = gfc_chainon_list (args, lse->expr);
args = gfc_chainon_list (args, rse->string_length);
args = gfc_chainon_list (args, rse->expr);
tmp = gfc_build_function_call (gfor_fndecl_copy_string, args);
gfc_add_expr_to_block (&block, tmp);
gfc_trans_string_copy (&block, lse->string_length, lse->expr,
rse->string_length, rse->expr);
}
else
{

33
gcc/fortran/trans-stmt.c
View file

@ -2121,8 +2121,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
gfc_forall_iterator *fa;
gfc_se se;
gfc_code *c;
tree *saved_var_decl;
symbol_attribute *saved_var_attr;
gfc_saved_var *saved_vars;
iter_info *this_forall, *iter_tmp;
forall_info *info, *forall_tmp;
temporary_list *temp;
@ -2141,9 +2140,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
end = (tree *) gfc_getmem (nvar * sizeof (tree));
step = (tree *) gfc_getmem (nvar * sizeof (tree));
varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
saved_var_decl = (tree *) gfc_getmem (nvar * sizeof (tree));
saved_var_attr = (symbol_attribute *)
gfc_getmem (nvar * sizeof (symbol_attribute));
saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
/* Allocate the space for info. */
info = (forall_info *) gfc_getmem (sizeof (forall_info));
@ -2155,20 +2152,11 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
/* allocate space for this_forall. */
this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
/* Save the FORALL index's backend_decl. */
saved_var_decl[n] = sym->backend_decl;
/* Save the attribute. */
saved_var_attr[n] = sym->attr;
/* Set the proper attributes. */
gfc_clear_attr (&sym->attr);
sym->attr.referenced = 1;
sym->attr.flavor = FL_VARIABLE;
/* Create a temporary variable for the FORALL index. */
tmp = gfc_typenode_for_spec (&sym->ts);
var[n] = gfc_create_var (tmp, sym->name);
gfc_shadow_sym (sym, var[n], &saved_vars[n]);
/* Record it in this_forall. */
this_forall->var = var[n];
@ -2396,13 +2384,9 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
c = c->next;
}
/* Restore the index original backend_decl and the attribute. */
for (fa = code->ext.forall_iterator, n=0; fa; fa = fa->next, n++)
{
gfc_symbol *sym = fa->var->symtree->n.sym;
sym->backend_decl = saved_var_decl[n];
sym->attr = saved_var_attr[n];
}
/* Restore the original index variables. */
for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
/* Free the space for var, start, end, step, varexpr. */
gfc_free (var);
@ -2410,8 +2394,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
gfc_free (end);
gfc_free (step);
gfc_free (varexpr);
gfc_free (saved_var_decl);
gfc_free (saved_var_attr);
gfc_free (saved_vars);
if (pmask)
{

16
gcc/fortran/trans.h
View file

@ -235,6 +235,16 @@ typedef struct gfc_loopinfo
}
gfc_loopinfo;
/* Information about a symbol that has been shadowed by a temporary. */
typedef struct
{
symbol_attribute attr;
tree decl;
}
gfc_saved_var;
/* Advance the SS chain to the next term. */
void gfc_advance_se_ss_chain (gfc_se *);
@ -364,6 +374,12 @@ void gfc_build_builtin_function_decls (void);
/* Return the variable decl for a symbol. */
tree gfc_get_symbol_decl (gfc_symbol *);
/* Substitute a temporary variable in place of the real one. */
void gfc_shadow_sym (gfc_symbol *, tree, gfc_saved_var *);
/* Restore the original variable. */
void gfc_restore_sym (gfc_symbol *, gfc_saved_var *);
/* Allocate the lang-spcific part of a decl node. */
void gfc_allocate_lang_decl (tree);

6
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,9 @@
2004-05-30 Paul Brook <paul@codesourcery.com>
PR fortran/15620
* gfortran.fortran-torture/execute/st_function_1.f90: New test.
* gfortran.fortran-torture/execute/st_function_2.f90: New test.
2004-05-30 Steven G. Kargl <kargls@comcast.net>
* gfortran.fortran-torture/execute/random_1.f90: New test.

23
gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 Normal file
View file

@ -0,0 +1,23 @@
! Check that character valued statement functions honour length parameters
program st_function_1
character(8) :: foo
character(15) :: bar
character(6) :: p
character (7) :: s
foo(p) = p // "World"
bar(p) = p // "World"
! Expression longer than function, actual arg shorter than dummy.
call check (foo("Hello"), "Hello Wo")
! Expression shorter than function, actual arg longer than dummy.
! Result shorter than type
s = "Hello"
call check (bar(s), "Hello World ")
contains
subroutine check(a, b)
character (len=*) :: a, b
if ((a .ne. b) .or. (len(a) .ne. len(b))) call abort ()
end subroutine
end program

21
gcc/testsuite/gfortran.fortran-torture/execute/st_function_2.f90 Normal file
View file

@ -0,0 +1,21 @@
! PR15620
! Check that evaluating a statement function doesn't affect the value of
! its dummy argument variables.
program st_function_2
integer fn, a, b
fn(a, b) = a + b
if (foo(1) .ne. 43) call abort
! Check that values aren't modified when avaluating the arguments.
a = 1
b = 5
if (fn (b + 2, a + 3) .ne. 11) call abort
contains
function foo (x)
integer z, y, foo, x
bar(z) = z*z
z = 42
t = bar(x)
foo = t + z
end function
end program