diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc index bafe8cbc5bc..97ace8c778e 100644 --- a/gcc/fortran/dependency.cc +++ b/gcc/fortran/dependency.cc @@ -2497,3 +2497,63 @@ gfc_omp_expr_prefix_same (gfc_expr *lexpr, gfc_expr *rexpr) return true; } + + +/* gfc_function_dependency returns true for non-dummy symbols with dependencies + on an old-fashioned function result (ie. proc_name = proc_name->result). + This is used to ensure that initialization code appears after the function + result is treated and that any mutual dependencies between these symbols are + respected. */ + +static bool +dependency_fcn (gfc_expr *e, gfc_symbol *sym, + int *f ATTRIBUTE_UNUSED) +{ + if (e == NULL) + return false; + + if (e && e->expr_type == EXPR_VARIABLE + && e->symtree + && e->symtree->n.sym == sym) + return true; + + return false; +} + + +bool +gfc_function_dependency (gfc_symbol *sym, gfc_symbol *proc_name) +{ + bool front = false; + + if (proc_name && proc_name->attr.function + && proc_name == proc_name->result + && !(sym->attr.dummy || sym->attr.result)) + { + if (sym->as && sym->as->type == AS_EXPLICIT) + { + for (int dim = 0; dim < sym->as->rank; dim++) + { + if (sym->as->lower[dim] + && sym->as->lower[dim]->expr_type != EXPR_CONSTANT) + front = gfc_traverse_expr (sym->as->lower[dim], proc_name, + dependency_fcn, 0); + if (front) + break; + if (sym->as->upper[dim] + && sym->as->upper[dim]->expr_type != EXPR_CONSTANT) + front = gfc_traverse_expr (sym->as->upper[dim], proc_name, + dependency_fcn, 0); + if (front) + break; + } + } + + if (sym->ts.type == BT_CHARACTER + && sym->ts.u.cl && sym->ts.u.cl->length + && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT) + front = gfc_traverse_expr (sym->ts.u.cl->length, proc_name, + dependency_fcn, 0); + } + return front; + } diff --git a/gcc/fortran/dependency.h b/gcc/fortran/dependency.h index ea4bd04b0e8..0fa5f93d0fc 100644 --- a/gcc/fortran/dependency.h +++ b/gcc/fortran/dependency.h @@ -23,7 +23,7 @@ enum gfc_dep_check { NOT_ELEMENTAL, /* Not elemental case: normal dependency check. */ ELEM_CHECK_VARIABLE, /* Test whether variables overlap. */ - ELEM_DONT_CHECK_VARIABLE /* Test whether variables overlap only if used + ELEM_DONT_CHECK_VARIABLE /* Test whether variables overlap only if used in an expression. */ }; @@ -43,3 +43,5 @@ bool gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *); bool gfc_omp_expr_prefix_same (gfc_expr *, gfc_expr *); gfc_expr * gfc_discard_nops (gfc_expr *); + +bool gfc_function_dependency (gfc_symbol *, gfc_symbol *); \ No newline at end of file diff --git a/gcc/fortran/error.cc b/gcc/fortran/error.cc index 65e38b0e866..60f607ecc4f 100644 --- a/gcc/fortran/error.cc +++ b/gcc/fortran/error.cc @@ -892,7 +892,7 @@ error_print (const char *type, const char *format0, va_list argp) #else m = INTTYPE_MAXIMUM (ptrdiff_t); #endif - m = 2 * m + 1; + m = 2 * m + 1; error_uinteger (a & m); } else diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 0a1646def67..7e39981e843 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -27,6 +27,7 @@ along with GCC; see the file COPYING3. If not see #include "parse.h" #include "match.h" #include "constructor.h" +#include "dependency.h" /* Strings for all symbol attributes. We use these for dumping the @@ -948,15 +949,18 @@ conflict_std: void gfc_set_sym_referenced (gfc_symbol *sym) { + gfc_symbol *proc_name = sym->ns->proc_name ? sym->ns->proc_name : NULL; if (sym->attr.referenced) return; sym->attr.referenced = 1; - /* Remember which order dummy variables are accessed in. */ - if (sym->attr.dummy) - sym->dummy_order = next_dummy_order++; + /* Remember which order dummy variables and symbols with function result + dependencies are accessed in. */ + if (sym->attr.dummy + || (proc_name && gfc_function_dependency (sym, proc_name))) + sym->dummy_order = next_dummy_order++; } diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index c5b56f4e273..678cbb6a138 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -6864,6 +6864,7 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree space; tree inittree; bool onstack; + bool back; gcc_assert (!(sym->attr.pointer || sym->attr.allocatable)); @@ -6875,6 +6876,12 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, gcc_assert (GFC_ARRAY_TYPE_P (type)); onstack = TREE_CODE (type) != POINTER_TYPE; + /* In the case of non-dummy symbols with dependencies on an old-fashioned + function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup + must be called with the last, optional argument false so that the alloc- + ation occurs after the processing of the result. */ + back = !gfc_function_dependency (sym, sym->ns->proc_name); + gfc_init_block (&init); /* Evaluate character string length. */ @@ -6902,7 +6909,8 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, if (onstack) { - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE, + back); return; } @@ -6989,10 +6997,11 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, addr = fold_build1_loc (gfc_get_location (&sym->declared_at), ADDR_EXPR, TREE_TYPE (decl), space); gfc_add_modify (&init, decl, addr); - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE, + back); tmp = NULL_TREE; } - gfc_add_init_cleanup (block, inittree, tmp); + gfc_add_init_cleanup (block, inittree, tmp, back); } diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index dca7779528b..cb34a0401d1 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -49,6 +49,7 @@ along with GCC; see the file COPYING3. If not see #include "omp-general.h" #include "attr-fnspec.h" #include "tree-iterator.h" +#include "dependency.h" #define MAX_LABEL_VALUE 99999 @@ -842,6 +843,7 @@ gfc_defer_symbol_init (gfc_symbol * sym) gfc_symbol *p; gfc_symbol *last; gfc_symbol *head; + bool back; /* Don't add a symbol twice. */ if (sym->tlink) @@ -850,6 +852,8 @@ gfc_defer_symbol_init (gfc_symbol * sym) last = head = sym->ns->proc_name; p = last->tlink; + back = gfc_function_dependency (sym, head); + /* Make sure that setup code for dummy variables which are used in the setup of other variables is generated first. */ if (sym->attr.dummy) @@ -863,6 +867,20 @@ gfc_defer_symbol_init (gfc_symbol * sym) p = p->tlink; } } + else if (back) + { + /* In the case of non-dummy symbols with dependencies on an old-fashioned + function result (ie. proc_name = proc_name->result), make sure that the + order in the tlink chain is such that the code appears in declaration + order. This ensures that mutual dependencies between these symbols are + respected. */ + while (p != head + && (!p->attr.result || p->dummy_order < sym->dummy_order)) + { + last = p; + p = p->tlink; + } + } /* Insert in between last and p. */ last->tlink = sym; sym->tlink = p; @@ -4183,12 +4201,19 @@ gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block) stmtblock_t init; tree decl; tree tmp; + bool back; gcc_assert (sym->backend_decl); gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length); gfc_init_block (&init); + /* In the case of non-dummy symbols with dependencies on an old-fashioned + function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup + must be called with the last, optional argument false so that the process + ing of the character length occurs after the processing of the result. */ + back = !gfc_function_dependency (sym, sym->ns->proc_name); + /* Evaluate the string length expression. */ gfc_conv_string_length (sym->ts.u.cl, NULL, &init); @@ -4201,7 +4226,7 @@ gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block) tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl); gfc_add_expr_to_block (&init, tmp); - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE, back); } /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */ diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index badad6ae892..b133221eb3b 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -2803,14 +2803,15 @@ gfc_start_wrapped_block (gfc_wrapped_block* block, tree code) /* Add a new pair of initializers/clean-up code. */ void -gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup) +gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup, + bool front) { gcc_assert (block); /* The new pair of init/cleanup should be "wrapped around" the existing block of code, thus the initialization is added to the front and the cleanup to the back. */ - add_expr_to_chain (&block->init, init, true); + add_expr_to_chain (&block->init, init, front); add_expr_to_chain (&block->cleanup, cleanup, false); } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index f94fa601400..a940b8960f8 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -471,7 +471,8 @@ void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool, void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code); /* Add a pair of init/cleanup code to the block. Each one might be a NULL_TREE if not required. */ -void gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup); +void gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup, + bool front = true); /* Finalize the block, that is, create a single expression encapsulating the original code together with init and clean-up code. */ tree gfc_finish_wrapped_block (gfc_wrapped_block* block); diff --git a/gcc/testsuite/gfortran.dg/dependent_decls_2.f90 b/gcc/testsuite/gfortran.dg/dependent_decls_2.f90 new file mode 100644 index 00000000000..5b7bdd27a40 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dependent_decls_2.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! +! Fix for PR59104 in which the dependence on the old style function result +! was not taken into account in the ordering of auto array allocation and +! characters with dependent lengths. +! +! Contributed by Tobias Burnus +! +module m + implicit none + integer, parameter :: dp = kind([double precision::]) + contains + function f(x) + integer, intent(in) :: x + real(dp) f(x/2) + real(dp) g(x/2) + integer y(size(f)+1) ! This was the original problem + integer z(size(f) + size(y)) ! Found in development of the fix + f = 10.0 + y = 1 ! Stop -Wall from complaining + z = 1 + g = 1 + if (size(f) .ne. 1) stop 1 + if (size(y) .ne. 2) stop 2 + if (size(z) .ne. 3) stop 3 + end function f + function e(x) result(f) + integer, intent(in) :: x + real(dp) f(x/2) + real(dp) g(x/2) + integer y(size(f)+1) + integer z(size(f) + size(y)) ! As was this. + f = 10.0 + y = 1 + z = 1 + g = 1 + if (size(f) .ne. 2) stop 4 + if (size(y) .ne. 3) stop 5 + if (size(z) .ne. 5) stop 6 + end function + function d(x) ! After fixes to arrays, what was needed was known! + integer, intent(in) :: x + character(len = x/2) :: d + character(len = len (d)) :: line + character(len = len (d) + len (line)) :: line_plus + line = repeat ("a", len (d)) + line_plus = repeat ("b", x) + if (len (line_plus) .ne. x) stop 7 + d = line + end +end module m + +program p + use m + implicit none + real(dp) y + + y = sum(f(2)) + if (int (y) .ne. 10) stop 8 + y = sum(e(4)) + if (int (y) .ne. 20) stop 9 + if (d(4) .ne. "aa") stop 10 +end program p