https://gcc.gnu.org/g:7e0b91f09a9502ec170cd1bad4c99262c4979b65
commit 7e0b91f09a9502ec170cd1bad4c99262c4979b65 Author: Mikael Morin <[email protected]> Date: Mon Sep 28 09:59:55 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 at least; 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. 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 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. In gfc_check_pointer_assign, the change causes a more generic error to be emitted before the function result check that triggered an error before; move the generic error after the function result check. In gfc_check_c_funloc, the function attribute was needed to enable the function result check; remove that attribute from the guarding condition. 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 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 | 23 ++++++++++++++++-- gcc/testsuite/gfortran.dg/optional_class_2.f90 | 32 ++++++++++++++++++++++++++ 4 files changed, 65 insertions(+), 14 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..855981644d7c 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -4414,17 +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) { /* Check for intrinsics. */ @@ -4452,6 +4441,17 @@ 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..ff6a3e528321 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,18 @@ 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.flavor = FL_VARIABLE; + } optional = attr.optional; if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived) @@ -3117,9 +3130,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..73ff0ee109ac --- /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 +end program
