https://gcc.gnu.org/g:ad428b981ac3bc113f3cbb4041126c3c1fef4709
commit r17-4832-gad428b981ac3bc113f3cbb4041126c3c1fef4709 Author: Mikael Morin <[email protected]> Date: Fri Oct 2 14:34:18 2026 +0200 fortran: Ignore attributes of class containers's _data component [PR127637] 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. Diff: --- gcc/fortran/check.cc | 2 +- gcc/fortran/expr.cc | 22 ++++++++++-------- gcc/fortran/primary.cc | 27 ++++++++++++++++++++-- gcc/testsuite/gfortran.dg/optional_class_2.f90 | 32 ++++++++++++++++++++++++++ 4 files changed, 70 insertions(+), 13 deletions(-) diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 7ef12d23331e..14cae2df23e9 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 63ae0f86357c..bdd7a2008226 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 bb38461c81ce..5f6aac3328aa 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 000000000000..2cbe5f95fb83 --- /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
