https://gcc.gnu.org/g:dfe38eb88b4e69be691e3495038d292edff77f36
commit r16-9107-gdfe38eb88b4e69be691e3495038d292edff77f36 Author: Jerry DeLisle <[email protected]> Date: Wed May 27 15:10:07 2026 -0700 fortran: ICE or wrong-code for ASSOCIATE selector that is a type-bound user-defined operator Three related bugs prevented ASSOCIATE selectors that are type-bound user-defined operator expressions from compiling correctly. Bug 1 (class.cc): find_typebound_proc_uop returned NULL immediately when the derived type has no f2k_derived namespace, bypassing the parent-type inheritance walk. This caused inherited UDOs to be silently not found. Fix: set root = NULL and let the loop reach the parent type instead. Bug 2 (resolve.cc): resolve_typebound_procedures called resolve_symbol on the parent type only after an early return that fires when the derived type has no direct type-bound bindings. This left parent-type bindings unresolved when searched via gfc_find_typebound_user_op. Fix: move resolve_symbol(super_type) before the early return. Bug 3 (match.cc): match_association_list did not handle ASSOCIATE selectors of the form .uop. expr or the nested case .uop2. (.uop1. expr). When the selector's type was BT_UNKNOWN at parse time the name of the associate variable was left untyped, producing a "Syntax error in expression" ICE in the body of the ASSOCIATE construct. Add three helpers before match_association_list: - resolve_assoc_operand: attempts gfc_resolve_expr on EXPR_FUNCTION operands and falls back to gfc_find_dt_in_generic for constructor calls whose argument types are not yet known. - infer_typebound_uop_type: reads the return type of a type-bound UDO directly from specific_st->n.tb->u.specific->n.sym without calling gfc_resolve_symbol, avoiding a resolve_symbol_called race condition. - extend_assoc_op: walks the expression tree bottom-up, propagating types through INTRINSIC_PARENTHESES wrappers before calling the two helpers above on each INTRINSIC_USER node. When the selector is an INTRINSIC_USER EXPR_OP with BT_UNKNOWN type, call extend_assoc_op on the operands, then gfc_extend_expr (errors suppressed). Accept the result when gfc_extend_expr returns MATCH_YES or when it returns MATCH_ERROR but has already converted the node to EXPR_COMPCALL with a known type (the full resolution pass finishes it). Assisted-by: Claude Sonnet 4.6 PR fortran/125528 gcc/fortran/ChangeLog: * class.cc (find_typebound_proc_uop): Set root = NULL instead of returning NULL when derived type lacks f2k_derived, so parent-type type-bound procedures and operators are still found via inheritance. * match.cc (resolve_assoc_operand): New helper. (infer_typebound_uop_type): New helper. (extend_assoc_op): New helper. (match_association_list): Handle ASSOCIATE selectors that are type-bound user-defined operator expressions, including nested cases. * resolve.cc (resolve_typebound_procedures): Move resolve_symbol call for the parent type before the early return so inherited type-bound bindings are resolved even when the child type has none of its own. gcc/testsuite/ChangeLog: * gfortran.dg/associate_80.f90: New test. (cherry picked from commit 6340639219bb2d1816c94e5de76ec3642453bcb2) Diff: --- gcc/fortran/class.cc | 4 +- gcc/fortran/match.cc | 186 ++++++++++++++++++++++++++++- gcc/fortran/resolve.cc | 10 +- gcc/testsuite/gfortran.dg/associate_80.f90 | 83 +++++++++++++ 4 files changed, 273 insertions(+), 10 deletions(-) diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc index 9c02b9bc81e9..4073ca3330dc 100644 --- a/gcc/fortran/class.cc +++ b/gcc/fortran/class.cc @@ -3131,7 +3131,9 @@ find_typebound_proc_uop (gfc_symbol* derived, bool* t, root = (uop ? derived->f2k_derived->tb_uop_root : derived->f2k_derived->tb_sym_root); else - return NULL; + /* No f2k_derived namespace; allow the extension check below to proceed + so inherited type-bound procedures/operators are still found. */ + root = NULL; /* Try to find it in the current type's namespace. */ res = gfc_find_symtree (root, name); diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 3fd42890239b..8055416b3ccb 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -1980,6 +1980,155 @@ check_coarray_assoc (const char *name, gfc_association_list *assoc) return true; } +/* Try to resolve an EXPR_FUNCTION operand so its return type is known. + Called during ASSOCIATE selector parsing, before type-bound operator + extension, when the operand is an unresolved generic constructor call + such as `scalar_1D_t(initializer, order=2, ...)`. Errors are suppressed + since we are still in the parsing phase. */ + +static void +resolve_assoc_operand (gfc_expr *e) +{ + if (!e || e->ts.type != BT_UNKNOWN || e->expr_type != EXPR_FUNCTION) + return; + + /* First, try full expression resolution (works when argument types are + already known at parse time). */ + gfc_push_suppress_errors (); + gfc_resolve_expr (e); + gfc_pop_suppress_errors (); + + if (e->ts.type != BT_UNKNOWN) + return; + + /* Fallback for generic constructor interfaces such as + scalar_1D_t(initializer, order=2, cells=16, x_min=0D0, x_max=5D0) + where full argument resolution is not possible at parse time. + If the function name resolves to a generic interface that wraps a + derived type (a constructor interface), infer the return type as + that derived type. */ + if (!e->symtree || !e->symtree->n.sym) + return; + + gfc_symbol *dt_sym = gfc_find_dt_in_generic (e->symtree->n.sym); + if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor)) + { + e->ts.type = BT_DERIVED; + e->ts.u.derived = dt_sym; + } +} + +/* Infer the return type of a type-bound user-defined operator without + converting the expression node or triggering gfc_resolve_symbol on the + return type. This is used during ASSOCIATE selector parsing to propagate + type information bottom-up through nested UDO expressions such as + (.div. (.grad. x)), so that the outer gfc_extend_expr can locate the + type-bound .div. once the type of (.grad. x) is known. + + Calling gfc_extend_expr for this purpose would partially resolve the + return type's derived-type symbol (setting resolve_symbol_called before + resolve_typebound_procedures has run), which prevents the subsequent + outer gfc_extend_expr from properly resolving the type-bound operator + on the return type. We avoid that by reading the return type directly + from the procedure's result variable without triggering resolution. */ + +static void +infer_typebound_uop_type (gfc_expr *e) +{ + if (!e || e->expr_type != EXPR_OP || e->value.op.op != INTRINSIC_USER + || e->ts.type != BT_UNKNOWN) + return; + + /* Find the operand and strip parentheses. */ + gfc_expr *operand = e->value.op.op1; + while (operand && operand->expr_type == EXPR_OP + && operand->value.op.op == INTRINSIC_PARENTHESES) + operand = operand->value.op.op1; + + if (!operand || operand->ts.type != BT_DERIVED || !operand->ts.u.derived) + return; + + /* Look up the UDO binding in the derived type's namespace (and its + parent types, via the recursion in find_typebound_proc_uop). This + does not call resolve_symbol, so it leaves resolve_symbol_called + untouched for all types involved. */ + bool ok = true; + gfc_symtree *tb_uop + = gfc_find_typebound_user_op (operand->ts.u.derived, &ok, + e->value.op.uop->name, false, NULL); + if (!tb_uop || !tb_uop->n.tb) + return; + + gfc_typebound_proc *tb = tb_uop->n.tb; + if (!tb->is_generic || !tb->u.generic) + return; + + /* Take the first specific binding. specific_st is set from module reading; + its n.tb is the gfc_typebound_proc for that specific binding (same as + what resolve_typebound_procedures later stores in g->specific). Follow + the chain specific_st->n.tb->u.specific->n.sym to reach the actual + implementing function symbol, whose ts holds the return type. + This mirrors what build_compcall_for_operator does via + g->specific->u.specific->n.sym->ts after resolution. */ + gfc_tbp_generic *g = tb->u.generic; + if (!g->specific_st || !g->specific_st->n.tb) + return; + + gfc_typebound_proc *specific_tb = g->specific_st->n.tb; + if (specific_tb->is_generic || !specific_tb->u.specific + || !specific_tb->u.specific->n.sym) + return; + + gfc_symbol *proc = specific_tb->u.specific->n.sym; + if (proc->ts.type != BT_UNKNOWN) + e->ts = proc->ts; +} + +/* Recursively propagate type information bottom-up through a nested UDO + expression tree so that when gfc_extend_expr is called on the outermost + operator during ASSOCIATE selector parsing, the inner operands already have + their types set and the type-bound lookup can succeed. Uses + infer_typebound_uop_type rather than gfc_extend_expr to avoid triggering + resolve_symbol on the return types, which would prevent the outer + gfc_extend_expr from working correctly. */ + +static void +extend_assoc_op (gfc_expr *e) +{ + if (!e || e->expr_type != EXPR_OP) + return; + + /* Bottom-up: process children first. */ + extend_assoc_op (e->value.op.op1); + extend_assoc_op (e->value.op.op2); + + /* Propagate the child's type upward through parentheses nodes. + gfc_extend_expr's matching_typebound_op checks ts.type BEFORE stripping + INTRINSIC_PARENTHESES wrappers, so an untyped parentheses node prevents + the outer operator from being found. */ + if (e->value.op.op == INTRINSIC_PARENTHESES + && e->ts.type == BT_UNKNOWN + && e->value.op.op1 + && e->value.op.op1->ts.type != BT_UNKNOWN) + { + e->ts = e->value.op.op1->ts; + return; + } + + /* Only handle unresolved user-defined operators. */ + if (e->value.op.op != INTRINSIC_USER || e->ts.type != BT_UNKNOWN) + return; + + /* Try to infer the type of each operand if it is an unresolved constructor + call (EXPR_FUNCTION whose return type is still BT_UNKNOWN). */ + resolve_assoc_operand (e->value.op.op1); + resolve_assoc_operand (e->value.op.op2); + + /* Infer this operator's return type from the type-bound procedure's result + variable, without calling gfc_resolve_symbol on the return type. */ + infer_typebound_uop_type (e); +} + match match_association_list (bool for_change_team = false) { @@ -2142,12 +2291,37 @@ match_association_list (bool for_change_team = false) } } else if (newAssoc->target->ts.type == BT_UNKNOWN - && newAssoc->target->expr_type == EXPR_OP) - { - /* This will work for sure if the operator is type bound to a use - associated derived type. */ - gfc_expr *tmp =gfc_copy_expr (newAssoc->target); - if (gfc_extend_expr (tmp) == MATCH_YES) + && newAssoc->target->expr_type == EXPR_OP + && newAssoc->target->value.op.op == INTRINSIC_USER) + { + /* If the selector is an unresolved type-bound user-defined operator + expression, try to extend it now so the associate name gets a usable + type. For nested operators such as + (.div. (.grad. x)) + first propagate types bottom-up through the inner operands + (extend_assoc_op). For a direct operator applied to a constructor + call such as + (.div. vector_t(init_fn, n=8)) + additionally resolve the direct operands as constructor calls + (resolve_assoc_operand). Then call gfc_extend_expr on the + outermost operator. Only handle INTRINSIC_USER here; arithmetic + operators are left to the normal resolution pass. */ + gfc_expr *tmp = gfc_copy_expr (newAssoc->target); + extend_assoc_op (tmp->value.op.op1); + extend_assoc_op (tmp->value.op.op2); + resolve_assoc_operand (tmp->value.op.op1); + resolve_assoc_operand (tmp->value.op.op2); + /* Suppress errors from gfc_extend_expr: during parsing the full + resolution has not run yet, so gfc_resolve_expr(COMPCALL) may + fail even when the type-bound operator was found and the node + was correctly converted to EXPR_COMPCALL. Accept the conversion + in that case and let the normal resolution pass finish it. */ + gfc_push_suppress_errors (); + match ext_m = gfc_extend_expr (tmp); + gfc_pop_suppress_errors (); + if (ext_m == MATCH_YES + || (tmp->expr_type == EXPR_COMPCALL + && tmp->ts.type != BT_UNKNOWN)) gfc_replace_expr (newAssoc->target, tmp); else gfc_free_expr (tmp); diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 90fc7b1cfe78..b095f043058d 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -17019,13 +17019,17 @@ resolve_typebound_procedures (gfc_symbol* derived) int op; gfc_symbol* super_type; - if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root) - return true; - + /* Resolve the super-type first so that inherited bindings (including + user operators) are fully resolved before we look them up via + gfc_find_typebound_user_op. This must happen even when 'derived' + has no direct type-bound bindings of its own. */ super_type = gfc_get_derived_super_type (derived); if (super_type) resolve_symbol (super_type); + if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root) + return true; + resolve_bindings_derived = derived; resolve_bindings_result = true; diff --git a/gcc/testsuite/gfortran.dg/associate_80.f90 b/gcc/testsuite/gfortran.dg/associate_80.f90 new file mode 100644 index 000000000000..14c405c8f220 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_80.f90 @@ -0,0 +1,83 @@ +! { dg-do run } +! +! Test ASSOCIATE selectors that are type-bound user-defined operators (UDOs), +! including inherited operators and nested expressions such as +! .div. (.grad. x). PR fortran/125515 +! +module associate_80_m + implicit none + + type :: scalar_t + real :: val + contains + generic :: operator(.grad.) => do_grad + procedure, private :: do_grad + generic :: operator(.sq.) => do_sq + procedure, private :: do_sq + generic :: get => get_val + procedure :: get_val + end type + + type, extends(scalar_t) :: vector_t + contains + generic :: operator(.div.) => do_div + procedure, private :: do_div + end type + +contains + + ! .grad. on scalar_t -> vector_t + pure function do_grad (self) result (r) + class(scalar_t), intent(in) :: self + type(vector_t) :: r + r%val = self%val * 2.0 + end function + + ! .sq. on scalar_t -> scalar_t + pure function do_sq (self) result (r) + class(scalar_t), intent(in) :: self + type(scalar_t) :: r + r%val = self%val * self%val + end function + + ! .div. on vector_t -> scalar_t + pure function do_div (self) result (r) + class(vector_t), intent(in) :: self + type(scalar_t) :: r + r%val = self%val / 2.0 + end function + + pure function get_val (self) result (r) + class(scalar_t), intent(in) :: self + real :: r + r = self%val + end function + +end module associate_80_m + +program associate_80 + use associate_80_m + implicit none + + type(scalar_t) :: s + s%val = 3.0 + + ! Case 1: direct type-bound UDO as ASSOCIATE selector + associate (g => .grad. s) + if (abs (g%val - 6.0) > 1.0e-6) stop 1 + if (abs (g%get () - 6.0) > 1.0e-6) stop 2 + end associate + + ! Case 2: inherited UDO (.sq. defined on scalar_t, used via scalar_t) + associate (q => .sq. s) + if (abs (q%val - 9.0) > 1.0e-6) stop 3 + end associate + + ! Case 3: nested UDOs — .div. (.grad. s) + ! .grad. s gives vector_t with val=6, .div. gives scalar_t with val=3 + associate (r => .div. (.grad. s)) + if (abs (r%val - 3.0) > 1.0e-6) stop 4 + if (abs (r%get () - 3.0) > 1.0e-6) stop 5 + end associate + +end program associate_80
