From dbe603430d8925eb27f586333e14f95dc86db7af Mon Sep 17 00:00:00 2001 From: pbrook Date: Sun, 30 May 2004 14:37:25 +0000 Subject: [PATCH] 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@82452 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 12 +++ gcc/fortran/trans-decl.c | 26 +++++ gcc/fortran/trans-expr.c | 111 ++++++++++++++------- gcc/fortran/trans-stmt.c | 33 ++---- gcc/fortran/trans.h | 16 +++ gcc/testsuite/ChangeLog | 6 ++ .../execute/st_function_1.f90 | 23 +++++ .../execute/st_function_2.f90 | 21 ++++ 8 files changed, 186 insertions(+), 62 deletions(-) create mode 100644 gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 create mode 100644 gcc/testsuite/gfortran.fortran-torture/execute/st_function_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 3bc18098771..fa09538d585 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2004-05-30 Paul Brook + + 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 * iresolve.c (gfc_resolve_random_number): Clean up conditional. diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 32dfdc4a643..7bd912e7515 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 092daa70ea4..a1a8d469132 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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 { diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 8df85d77e32..bbaa19d1123 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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) { diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index ada575fc9e0..1c205ef0afd 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0535cfe5ce3..6d0c44bf1ea 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2004-05-30 Paul Brook + + 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 * gfortran.fortran-torture/execute/random_1.f90: New test. diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 new file mode 100644 index 00000000000..0387a5f71c7 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/st_function_2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/st_function_2.f90 new file mode 100644 index 00000000000..2dec735625f --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/st_function_2.f90 @@ -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 -- 2.11.4.GIT