[PATCH] PR125528 ICE or wrong-code for ASSOCIATE selector that is a, type-bound user-defined operator

From 9bab576f32c66218f9b8e7f3c95d9e12988579ea Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Wed, 27 May 2026 15:10:07 -0700
Subject: [PATCH] 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.
Fix: 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).

PR fortran/125528

Assisted by: Claude Sonnet 4.6

gcc/fortran/ChangeLog:

	PR fortran/125528
	* 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:

	PR fortran/125528
	* gfortran.dg/associate_80.f90: New test.
---
 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(-)
 create mode 100644 gcc/testsuite/gfortran.dg/associate_80.f90

diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index a4c3c37104a..d811ee2929c 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -3136,7 +3136,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 d892a4588b2..9172f46ed7c 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 a31f395709d..df91671e171 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -17218,13 +17218,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 00000000000..14c405c8f22
--- /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
-- 
2.54.0