https://gcc.gnu.org/g:ccaa39a268bef2a1d8880022696ff2dcaa6af941
commit r15-1468-gccaa39a268bef2a1d8880022696ff2dcaa6af941
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Thu Jun 20 08:01:36 2024 +0100
Fortran: Auto array allocation with function dependencies [PR59104]
2024-06-20 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran
PR fortran/59104
* dependency.cc (dependency_fcn, gfc_function_dependency): New
functions to detect dependency in array bounds and character
lengths on old style function results.
* dependency.h : Add prototype for gfc_function_dependency.
* error.cc (error_print): Remove trailing space.
* gfortran.h : Remove dummy_order and add fn_result_spec.
* symbol.cc : Remove declaration of next_dummy_order..
(gfc_set_sym_referenced): remove setting of symbol dummy order.
* trans-array.cc (gfc_trans_auto_array_allocation): Detect
non-dummy symbols with function dependencies and put the
allocation at the end of the initialization code.
* trans-decl.cc : Include dependency.h.
(decl_order): New function that determines uses the location
field of the symbol 'declared_at' to determine the order of two
declarations.
(gfc_defer_symbol_init): Call gfc_function_dependency to put
dependent symbols in the right part of the tlink chain. Use
the location field of the symbol declared_at to determine the
order of declarations.
(gfc_trans_auto_character_variable): Put character length
initialization of dependent symbols at the end of the chain.
* trans.cc (gfc_add_init_cleanup): Add boolean argument with
default false that determines whther an expression is placed at
the back or the front of the initialization chain.
* trans.h : Update the prototype for gfc_add_init_cleanup.
gcc/testsuite/
PR fortran/59104
* gfortran.dg/dependent_decls_2.f90: New test.
Diff:
---
gcc/fortran/dependency.cc | 82 +++++++++++++++++++++++
gcc/fortran/dependency.h | 4 +-
gcc/fortran/error.cc | 2 +-
gcc/fortran/gfortran.h | 6 +-
gcc/fortran/symbol.cc | 10 ---
gcc/fortran/trans-array.cc | 15 ++++-
gcc/fortran/trans-decl.cc | 51 ++++++++++++--
gcc/fortran/trans.cc | 5 +-
gcc/fortran/trans.h | 3 +-
gcc/testsuite/gfortran.dg/dependent_decls_2.f90 | 89 +++++++++++++++++++++++++
10 files changed, 238 insertions(+), 29 deletions(-)
diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc
index bafe8cbc5bc3..15edf1af9dff 100644
--- a/gcc/fortran/dependency.cc
+++ b/gcc/fortran/dependency.cc
@@ -2497,3 +2497,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 ea4bd04b0e82..8f172f86f08f 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 a0e1a1c36844..e89667613b18 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 36ed8eeac2df..ed1213a41cbb 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1893,10 +1893,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
@@ -1935,6 +1931,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 5db3c887127b..2f326492d5fb 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;
@@ -941,15 +936,10 @@ conflict:
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 cc50b961a979..19d69aec9c0d 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6885,6 +6885,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));
@@ -6896,6 +6897,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. */
@@ -6923,7 +6930,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;
}
@@ -7010,10 +7018,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 f7fb6eec336a..8d4f06a4e1d2 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,18 +864,34 @@ 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)
{
/* 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. */
+ This is a circular list, so don't go past the head. */
while (p != head
- && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
- {
- last = p;
- p = p->tlink;
- }
+ && (!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;
@@ -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 1335b8cc48bb..1067e032621b 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -2806,14 +2806,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 5e064af5ccbd..f019c89edf22 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -473,7 +473,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/dependent_decls_2.f90
b/gcc/testsuite/gfortran.dg/dependent_decls_2.f90
new file mode 100644
index 000000000000..73c84ea3bc50
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dependent_decls_2.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
