From: Mikael Morin <[email protected]>
Fortran-tested on aarch64-unknown-linux-gnu.
OK for mainline?
-- >8 --
The majority of the attributes returned by gfc_variable_attr are taken from
the last component reference if there is one; otherwise from the root
symbol. This misses some attributes if the last component reference is the
implicit _data reference of a class container, as those only store the
allocatable, dimension, codimension and pointer attributes. The rest of
attributes remain in the original entity and are not returned if there
is a component reference that follows.
This change adds a tracking of the current type through the reference chain
walk, and a check on each component ref to avoid overwriting the current set
of attributes if the current type is a class container, and the component
its _data field. The attributes stored in the _data component are
unaffected by this as they are already tracked in dedicated variables
outside of the main attribute set.
The optional variable, tracking the optional attribute value, was cleared on
the first component ref. Move that under the new check for the same reason.
With the _data components ignored, the attributes returned for a reference
to a polymorphic function result would become those of the procedure itself.
Add a check of the current namespace and adjust the attributes if the
namespace is the procedure body, meaning the reference is to the function
result.
The removal of some attributes for function results has some impact when
the function is not polymorphic, requiring additional adjustments to prevent
regressions. In gfc_check_pointer_assign, the change causes an earlier
check to trigger, emitting a less specific error; move it after the function
result check that emitted the error before the change. In
gfc_check_c_funloc, the function attribute was guarding a check for function
result, causing it to be skipped and a later check to emit a worse error
message after the change; remove that attribute from the guarding condition.
The testcase catches a missed optional attribute causing an uninitialized
loop bound to be used.
PR fortran/127637
gcc/fortran/ChangeLog:
* primary.cc (gfc_variable_attr): Track the current type through
the data reference walk. Don't overwrite the attribute set and the
optional variable if the current type is a class container and the
component its _data field. If the expression symbol is a function
without separate result name, and the current namespace is the
symbol's procedure body, adjust the attributes to those of the
function result.
* expr.cc (gfc_check_pointer_assign): Move the generic error check
after the specific function result error check.
* check.cc (gfc_check_c_funloc): Drop the function attribute from
the condition guarding the function result check.
gcc/testsuite/ChangeLog:
* gfortran.dg/optional_class_2.f90: New test.
---
gcc/fortran/check.cc | 2 +-
gcc/fortran/expr.cc | 22 +++++++------
gcc/fortran/primary.cc | 27 ++++++++++++++--
.../gfortran.dg/optional_class_2.f90 | 32 +++++++++++++++++++
4 files changed, 70 insertions(+), 13 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/optional_class_2.f90
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 7ef12d23331..14cae2df23e 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -6462,7 +6462,7 @@ gfc_check_c_funloc (gfc_expr *x)
attr = gfc_expr_attr (x);
- if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE
+ if (!attr.proc_pointer && x->expr_type == EXPR_VARIABLE
&& x->symtree->n.sym == x->symtree->n.sym->result)
for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
if (x->symtree->n.sym == ns->proc_name)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 63ae0f86357..bdd7a200822 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -4414,16 +4414,6 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr
*rvalue,
const char *name;
attr = gfc_expr_attr (rvalue);
- if (!((rvalue->expr_type == EXPR_NULL)
- || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
- || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
- || (rvalue->expr_type == EXPR_VARIABLE
- && attr.flavor == FL_PROCEDURE)))
- {
- gfc_error ("Invalid procedure pointer assignment at %L",
- &rvalue->where);
- return false;
- }
if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer)
{
@@ -4452,6 +4442,18 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr
*rvalue,
}
}
}
+
+ if (!((rvalue->expr_type == EXPR_NULL)
+ || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
+ || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
+ || (rvalue->expr_type == EXPR_VARIABLE
+ && attr.flavor == FL_PROCEDURE)))
+ {
+ gfc_error ("Invalid procedure pointer assignment at %L",
+ &rvalue->where);
+ return false;
+ }
+
if (attr.abstract)
{
gfc_error ("Abstract interface %qs is invalid "
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index bb38461c81c..5f6aac3328a 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -3030,6 +3030,7 @@ gfc_variable_attr (gfc_expr *expr)
gfc_ref *ref;
gfc_symbol *sym;
gfc_component *comp;
+ gfc_typespec *current_ts;
if (expr->expr_type != EXPR_VARIABLE
&& expr->expr_type != EXPR_FUNCTION
@@ -3038,6 +3039,22 @@ gfc_variable_attr (gfc_expr *expr)
sym = expr->symtree->n.sym;
attr = sym->attr;
+ current_ts = &sym->ts;
+
+ /* If we are in the body of a function, the function name references the
+ function result, not the function itself. */
+ if (attr.function
+ && sym->result == sym
+ && gfc_current_ns
+ && gfc_current_ns->proc_name == sym)
+ {
+ attr.function = 0;
+ attr.elemental = 0;
+ attr.pure = 0;
+ attr.recursive = 0;
+ attr.flavor = FL_VARIABLE;
+ attr.result = 1;
+ }
optional = attr.optional;
if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
@@ -3117,9 +3134,15 @@ gfc_variable_attr (gfc_expr *expr)
break;
case REF_COMPONENT:
- optional = false;
comp = ref->u.c.component;
- attr = comp->attr;
+ if (!(current_ts->type == BT_CLASS
+ && current_ts->u.derived->attr.is_class
+ && strcmp (comp->name, "_data") == 0))
+ {
+ optional = false;
+ attr = comp->attr;
+ }
+ current_ts = &sym->ts;
if (comp->ts.type == BT_CLASS)
{
diff --git a/gcc/testsuite/gfortran.dg/optional_class_2.f90
b/gcc/testsuite/gfortran.dg/optional_class_2.f90
new file mode 100644
index 00000000000..2cbe5f95fb8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_class_2.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+!
+! PR fortran/127637
+! Check that the scalarization of the assignment picks the loop upper bound
from
+! the non-optional array.
+
+program prog
+ implicit none
+ integer, parameter :: n = 5
+ type :: t
+ integer :: c
+ end type
+ type(t), allocatable :: x(:)
+ integer :: i
+ call sub()
+contains
+ elemental function f(v, a) result(r)
+ integer, intent(in) :: v
+ type(t), optional, intent(in) :: a
+ integer :: r
+ r = v + 42
+ if (present(a)) r = a%c
+ end function
+ subroutine sub(o)
+ class(t), optional, intent(in) :: o(:)
+ integer, allocatable :: y(:)
+ allocate(y(n))
+ y = 0
+ y(:) = f(y, o)
+ if (any(y /= 42)) error stop 1
+ end subroutine
+end program
--
2.53.0
