Hi Both, Thanks for the highly constructive comments. I think that I have incorporated them fully in the attached.
OK for mainline and ...?
Paul
On Mon, 10 Jun 2024 at 08:19, Andre Vehreschild <ve...@gmx.de> wrote:
> Hi Paul,
>
> while looking at your patch I see calls to gfc_add_init_cleanup (...,
> back),
> while the function signature is gfc_add_init_cleanup (..., bool front).
> This
> slightly confuses me. I would at least expect to see
> gfc_add_init_cleanup(...,
> !back) calls. Just to get the semantics right.
>
> Then I wonder why not doing:
>
> 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)
> +{
> + return (e && e->expr_type == EXPR_VARIABLE
> + && e->symtree
> + && e->symtree->n.sym == sym);
> +}
>
> Instead of the multiple if-statements?
>
> +
> +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);
>
> This can overwrite a previous front == true, right? Is this intended?
>
> + }
> + return front;
> + }
>
> The rest - besides the front-back confusion - looks fine to me. Thanks for
> the
> patch.
>
> Regards,
> Andre
>
> On Sun, 9 Jun 2024 07:14:39 +0100
> Paul Richard Thomas <paul.richard.tho...@gmail.com> wrote:
>
> > Hi All,
> >
> > The attached fixes a problem that, judging by the comments, has been
> looked
> > at periodically over the last ten years but just looked to be too
> > fiendishly complicated to fix. This is not in small part because of the
> > confusing ordering of dummies in the tlink chain and the unintuitive
> > placement of all deferred initializations to the front of the init chain
> in
> > the wrapped block.
> >
> > The result of the existing ordering is that the initialization code for
> > non-dummy variables that depends on the function result occurs before any
> > initialization code for the function result itself. The fix ensures that:
> > (i) These variables are placed correctly in the tlink chain, respecting
> > inter-dependencies; and (ii) The dependent initializations are placed at
> > the end of the wrapped block init chain. The details appear in the
> > comments in the patch. It is entirely possible that a less clunky fix
> > exists but I failed to find it.
> >
> > OK for mainline?
> >
> > Regards
> >
> > Paul
>
>
> --
> Andre Vehreschild * Email: vehre ad gmx dot de
>
diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc
index fb4d94de641..e299508e53a 100644
--- a/gcc/fortran/dependency.cc
+++ b/gcc/fortran/dependency.cc
@@ -2465,3 +2465,85 @@ 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)
+ {
+ if (e->symtree && e->symtree->n.sym == sym)
+ return true;
+ /* Recurse to see if this symbol is dependent on the function result. If
+ so an indirect dependence exists, which should be handled in the same
+ way as a direct dependence. The recursion is prevented from being
+ infinite by statement order. */
+ else if (e->symtree && e->symtree->n.sym)
+ return gfc_function_dependency (e->symtree->n.sym, sym);
+ }
+
+ return false;
+}
+
+
+bool
+gfc_function_dependency (gfc_symbol *sym, gfc_symbol *proc_name)
+{
+ bool dep = false;
+
+ if (proc_name && proc_name->attr.function
+ && proc_name == proc_name->result
+ && !(sym->attr.dummy || sym->attr.result))
+ {
+ if (sym->fn_result_dep)
+ return true;
+
+ 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)
+ dep = gfc_traverse_expr (sym->as->lower[dim], proc_name,
+ dependency_fcn, 0);
+ if (dep)
+ {
+ sym->fn_result_dep = 1;
+ return true;
+ }
+ if (sym->as->upper[dim]
+ && sym->as->upper[dim]->expr_type != EXPR_CONSTANT)
+ dep = gfc_traverse_expr (sym->as->upper[dim], proc_name,
+ dependency_fcn, 0);
+ if (dep)
+ {
+ sym->fn_result_dep = 1;
+ return true;
+ }
+ }
+ }
+
+ if (sym->ts.type == BT_CHARACTER
+ && sym->ts.u.cl && sym->ts.u.cl->length
+ && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ dep = gfc_traverse_expr (sym->ts.u.cl->length, proc_name,
+ dependency_fcn, 0);
+ if (dep)
+ {
+ sym->fn_result_dep = 1;
+ return true;
+ }
+ }
+
+ return false;
+ }
diff --git a/gcc/fortran/dependency.h b/gcc/fortran/dependency.h
index ea4bd04b0e8..8f172f86f08 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 *);
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/gfortran.h b/gcc/fortran/gfortran.h
index de1a7cd0935..7fcc3ea051a 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1888,10 +1888,6 @@ typedef struct gfc_symbol
points to C and B's is NULL. */
struct gfc_common_head* common_head;
- /* Make sure setup code for dummy arguments is generated in the correct
- order. */
- int dummy_order;
-
gfc_namelist *namelist, *namelist_tail;
/* The tlink field is used in the front end to carry the module
@@ -1930,6 +1926,8 @@ typedef struct gfc_symbol
unsigned forall_index:1;
/* Set if the symbol is used in a function result specification . */
unsigned fn_result_spec:1;
+ /* Set if the symbol spec. depends on an old-style function result. */
+ unsigned fn_result_dep:1;
/* Used to avoid multiple resolutions of a single symbol. */
/* = 2 if this has already been resolved as an intrinsic,
in gfc_resolve_intrinsic,
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 0a1646def67..cf3d83a5431 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -96,11 +96,6 @@ const mstring dtio_procs[] =
minit ("_dtio_unformatted_write", DTIO_WUF),
};
-/* This is to make sure the backend generates setup code in the correct
- order. */
-
-static int next_dummy_order = 1;
-
gfc_namespace *gfc_current_ns;
gfc_namespace *gfc_global_ns_list;
@@ -948,15 +943,10 @@ conflict_std:
void
gfc_set_sym_referenced (gfc_symbol *sym)
{
-
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++;
}
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index c5b56f4e273..664667596da 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 = sym->fn_result_dep;
+
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..dc37a98f55c 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
@@ -833,6 +834,19 @@ gfc_allocate_lang_decl (tree decl)
DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc<struct lang_decl> ();
}
+
+/* Determine order of two symbol declarations. */
+
+static bool
+decl_order (gfc_symbol *sym1, gfc_symbol *sym2)
+{
+ if (sym1->declared_at.lb->location > sym2->declared_at.lb->location)
+ return true;
+ else
+ return false;
+}
+
+
/* Remember a symbol to generate initialization/cleanup code at function
entry/exit. */
@@ -850,6 +864,8 @@ gfc_defer_symbol_init (gfc_symbol * sym)
last = head = sym->ns->proc_name;
p = last->tlink;
+ 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)
@@ -857,12 +873,26 @@ gfc_defer_symbol_init (gfc_symbol * sym)
/* Find the first dummy arg seen after us, or the first non-dummy arg.
This is a circular list, so don't go past the head. */
while (p != head
- && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
+ && (!p->attr.dummy || decl_order (p, sym)))
{
last = p;
p = p->tlink;
}
}
+ else if (sym->fn_result_dep)
+ {
+ /* 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 || decl_order (sym, p)))
+ {
+ last = p;
+ p = p->tlink;
+ }
+ }
/* Insert in between last and p. */
last->tlink = sym;
sym->tlink = p;
@@ -4183,12 +4213,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 = sym->fn_result_dep;
+
/* Evaluate the string length expression. */
gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
@@ -4201,7 +4238,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..721823c251d 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 back)
{
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, !back);
add_expr_to_chain (&block->cleanup, cleanup, false);
}
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index f94fa601400..bcf599cd0ac 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 back = false);
/* 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/pr59104.f90 b/gcc/testsuite/gfortran.dg/pr59104.f90
new file mode 100644
index 00000000000..73c84ea3bc5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr59104.f90
@@ -0,0 +1,89 @@
+! { 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 <bur...@gcc.gnu.org>
+!
+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
+ integer w(size (f) + size (y) + x) ! Check dummy is OK
+ integer :: l1(size(y))
+ integer :: l2(size(z))
+ integer :: l3(size(w))
+ f = 10.0
+ y = 1 ! Stop -Wall from complaining
+ z = 1; g = 1; w = 1; l1 = 1; l2 = 1; l3 = 1
+ if (size (f) .ne. 1) stop 1
+ if (size (g) .ne. 1) stop 2
+ if (size (y) .ne. 2) stop 3
+ if (size (z) .ne. 3) stop 4
+ if (size (w) .ne. 5) stop 5
+ if (size (l1) .ne. 2) stop 6 ! Check indirect dependencies
+ if (size (l2) .ne. 3) stop 7
+ if (size (l3) .ne. 5) stop 8
+
+ 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.
+ integer w(size (f) + size (y) + x)
+ integer :: l1(size(y))
+ integer :: l2(size(z))
+ integer :: l3(size(w))
+ f = 10.0
+ y = 1; z = 1; g = 1; w = 1; l1 = 1; l2 = 1; l3 = 1
+ if (size (f) .ne. 2) stop 9
+ if (size (g) .ne. 2) stop 10
+ if (size (y) .ne. 3) stop 11
+ if (size (z) .ne. 5) stop 12
+ if (size (w) .ne. 9) stop 13
+ if (size (l1) .ne. 3) stop 14 ! Check indirect dependencies
+ if (size (l2) .ne. 5) stop 15
+ if (size (l3) .ne. 9) stop 16
+ 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)) :: line2
+ character(len = len (d) + len (line) + x) :: line3
+! Commented out lines give implicit type warnings with gfortran and nagfor
+! character(len = len (d)) :: line4 (len (line3))
+ character(len = len (line3)) :: line4 (len (line3))
+! character(len = size(len4, 1)) :: line5
+ line = repeat ("a", len (d))
+ line2 = repeat ("b", x)
+ line3 = repeat ("c", len (line3))
+ if (len (line2) .ne. x) stop 17
+ if (line3 .ne. "cccccccc") stop 18
+ d = line
+ line4 = line3
+ if (size (line4) .ne. 8) stop 19
+ if (any (line4 .ne. "cccccccc")) stop 20
+ end
+end module m
+
+program p
+ use m
+ implicit none
+ real(dp) y
+
+ y = sum (f (2))
+ if (int (y) .ne. 10) stop 21
+ y = sum (e (4))
+ if (int (y) .ne. 20) stop 22
+ if (d (4) .ne. "aa") stop 23
+end program p
Change.Logs
Description: Binary data
