diff mbox series

[v2] fortran: refresh associate-name kind once selector is resolved [PR125172] When the ASSOCIATE target is a forward reference to an internal or contained function whose return type is not yet known at parse time, primary.cc infers a type for the associa

Message ID 20260506180629.123737-1-samirmath01@gmail.com
State New
Headers
Series [v2] fortran: refresh associate-name kind once selector is resolved [PR125172] When the ASSOCIATE target is a forward reference to an internal or contained function whose return type is not yet known at parse time, primary.cc infers a type for the associa |

Commit Message

s.ouchene May 6, 2026, 6:06 p.m. UTC 
  Signed-off-by: Samir Ouchene <samirmath01@gmail.com>
v2: resending; v1 was sent through a webmail client and the commit
    message body collapsed into the Subject header.  The diff is
    unchanged.
Hi,
The fortran list confirmed this as PR fortran/125172.  Tested on
x86_64-pc-linux-gnu (Ubuntu 24.04, WSL2) against current trunk; the
new gfortran.dg/associate_79.f90 fails on unpatched trunk and passes
after the fix.  No new gfortran.dg regressions observed.
I do not have commit access; could a maintainer push this when
reviewed?
Thanks,
Samir
---
 gcc/fortran/resolve.cc                     | 26 +++++++++++++++++
 gcc/testsuite/gfortran.dg/associate_79.f90 | 34 ++++++++++++++++++++++
 2 files changed, 60 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/associate_79.f90

Comments

Jonathan Wakely May 6, 2026, 8:27 p.m. UTC | #1 
On Wed, 06 May 2026 at 20:06 +0200, Samir Ouchene wrote:
>Signed-off-by: Samir Ouchene <samirmath01@gmail.com>
>v2: resending; v1 was sent through a webmail client and the commit
>    message body collapsed into the Subject header.  The diff is
>    unchanged.

v2 has the same problem:
https://gcc.gnu.org/pipermail/gcc-patches/2026-May/715964.html


>Hi,
>The fortran list confirmed this as PR fortran/125172.  Tested on
>x86_64-pc-linux-gnu (Ubuntu 24.04, WSL2) against current trunk; the
>new gfortran.dg/associate_79.f90 fails on unpatched trunk and passes
>after the fix.  No new gfortran.dg regressions observed.
>I do not have commit access; could a maintainer push this when
>reviewed?
>Thanks,
>Samir
>---
> gcc/fortran/resolve.cc                     | 26 +++++++++++++++++
> gcc/testsuite/gfortran.dg/associate_79.f90 | 34 ++++++++++++++++++++++
> 2 files changed, 60 insertions(+)
> create mode 100644 gcc/testsuite/gfortran.dg/associate_79.f90
>
>diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
>index a5d9add9d..0db362758 100644
>--- a/gcc/fortran/resolve.cc
>+++ b/gcc/fortran/resolve.cc
>@@ -6578,6 +6578,13 @@ resolve_variable (gfc_expr *e)
>       if (e->expr_type == EXPR_CONSTANT)
> 	return true;
>     }
>+  else if (IS_INFERRED_TYPE (e)
>+	   && sym->ts.type != BT_UNKNOWN
>+	   && (sym->ts.type != e->ts.type || sym->ts.kind != e->ts.kind))
>+    /* No subobject ref, but the expression's typespec was set at parse
>+       time before the target's actual type/kind was known.  Refresh from
>+       the now-resolved associate-name symbol.  */
>+    e->ts = sym->ts;
>   else if (sym->attr.select_type_temporary
> 	   && sym->ns->assoc_name_inferred)
>     gfc_fixup_inferred_type_refs (e);
>@@ -6962,6 +6969,15 @@ gfc_fixup_inferred_type_refs (gfc_expr *e)
> 					   sym->assoc->target->ts.kind);
> 	  gfc_replace_expr (e, ne);
> 	}
>+      else if (ref && ref->type == REF_INQUIRY
>+	       && (ref->u.i == INQUIRY_RE || ref->u.i == INQUIRY_IM)
>+	       && sym->ts.type == BT_COMPLEX
>+	       && e->ts.type == BT_REAL
>+	       && e->ts.kind != sym->ts.kind)
>+	/* primary.cc set the inquiry-result kind to the default real kind
>+	   when the associate-name's type was inferred from %re/%im before
>+	   the target was resolved.  Now use the (resolved) selector kind.  */
>+	e->ts.kind = sym->ts.kind;
>
>       /* Now that the references are all sorted out, set the expression rank
> 	 and return.  */
>@@ -10680,6 +10696,16 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
> 	/* Confirmed to be either a derived type or misidentified to be a
> 	   scalar class object, when the selector is a class array.  */
> 	sym->ts = target->ts;
>+      else if (sym->assoc->inferred_type
>+	       && (sym->ts.type == BT_COMPLEX
>+		   || sym->ts.type == BT_CHARACTER)
>+	       && target->ts.type == sym->ts.type
>+	       && sym->ts.kind != target->ts.kind)
>+	/* The inferred type was set from a %re, %im or %len inquiry on
>+	   the associate name with the default kind, before the target's
>+	   actual type was known.  Now that the target has been resolved,
>+	   update the kind to match.  */
>+	sym->ts = target->ts;
>     }
>
>
>diff --git a/gcc/testsuite/gfortran.dg/associate_79.f90 b/gcc/testsuite/gfortran.dg/associate_79.f90
>new file mode 100644
>index 000000000..c7b04e0ab
>--- /dev/null
>+++ b/gcc/testsuite/gfortran.dg/associate_79.f90
>@@ -0,0 +1,34 @@
>+! { dg-do run }
>+!
>+! Verify that an associate-name whose target is a call to an internal
>+! procedure (CONTAINS in a program) gets the correct declared kind from
>+! the function's return type, instead of falling back to default kind.
>+!
>+program demo
>+  use, intrinsic :: iso_fortran_env, only: wp => real64
>+  implicit none
>+  complex(wp) :: z
>+  real(wp) :: re_ref, im_ref
>+
>+  z = (1.0_wp, 2.0_wp)
>+  re_ref = real (sin (z), wp)
>+  im_ref = aimag (sin (z))
>+
>+  associate (k => myfunc (z))
>+    if (kind (k%re) /= kind (1.0_wp)) stop 1
>+    if (kind (k%im) /= kind (1.0_wp)) stop 2
>+    if (kind (aimag (k)) /= kind (1.0_wp)) stop 3
>+    if (abs (k%re - re_ref) > 1.0e-12_wp) stop 4
>+    if (abs (k%im - im_ref) > 1.0e-12_wp) stop 5
>+    if (abs (aimag (k) - im_ref) > 1.0e-12_wp) stop 6
>+  end associate
>+
>+contains
>+
>+  complex(wp) function myfunc (x)
>+    complex(wp), intent(in) :: x
>+    myfunc = sin (x)
>+  end function myfunc
>+
>+end program demo
>+
>-- 
>2.54.0
>
>
diff mbox series

Patch

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index a5d9add9d..0db362758 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -6578,6 +6578,13 @@  resolve_variable (gfc_expr *e)
       if (e->expr_type == EXPR_CONSTANT)
 	return true;
     }
+  else if (IS_INFERRED_TYPE (e)
+	   && sym->ts.type != BT_UNKNOWN
+	   && (sym->ts.type != e->ts.type || sym->ts.kind != e->ts.kind))
+    /* No subobject ref, but the expression's typespec was set at parse
+       time before the target's actual type/kind was known.  Refresh from
+       the now-resolved associate-name symbol.  */
+    e->ts = sym->ts;
   else if (sym->attr.select_type_temporary
 	   && sym->ns->assoc_name_inferred)
     gfc_fixup_inferred_type_refs (e);
@@ -6962,6 +6969,15 @@  gfc_fixup_inferred_type_refs (gfc_expr *e)
 					   sym->assoc->target->ts.kind);
 	  gfc_replace_expr (e, ne);
 	}
+      else if (ref && ref->type == REF_INQUIRY
+	       && (ref->u.i == INQUIRY_RE || ref->u.i == INQUIRY_IM)
+	       && sym->ts.type == BT_COMPLEX
+	       && e->ts.type == BT_REAL
+	       && e->ts.kind != sym->ts.kind)
+	/* primary.cc set the inquiry-result kind to the default real kind
+	   when the associate-name's type was inferred from %re/%im before
+	   the target was resolved.  Now use the (resolved) selector kind.  */
+	e->ts.kind = sym->ts.kind;
 
       /* Now that the references are all sorted out, set the expression rank
 	 and return.  */
@@ -10680,6 +10696,16 @@  resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 	/* Confirmed to be either a derived type or misidentified to be a
 	   scalar class object, when the selector is a class array.  */
 	sym->ts = target->ts;
+      else if (sym->assoc->inferred_type
+	       && (sym->ts.type == BT_COMPLEX
+		   || sym->ts.type == BT_CHARACTER)
+	       && target->ts.type == sym->ts.type
+	       && sym->ts.kind != target->ts.kind)
+	/* The inferred type was set from a %re, %im or %len inquiry on
+	   the associate name with the default kind, before the target's
+	   actual type was known.  Now that the target has been resolved,
+	   update the kind to match.  */
+	sym->ts = target->ts;
     }
 
 
diff --git a/gcc/testsuite/gfortran.dg/associate_79.f90 b/gcc/testsuite/gfortran.dg/associate_79.f90
new file mode 100644
index 000000000..c7b04e0ab
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_79.f90
@@ -0,0 +1,34 @@ 
+! { dg-do run }
+!
+! Verify that an associate-name whose target is a call to an internal
+! procedure (CONTAINS in a program) gets the correct declared kind from
+! the function's return type, instead of falling back to default kind.
+!
+program demo
+  use, intrinsic :: iso_fortran_env, only: wp => real64
+  implicit none
+  complex(wp) :: z
+  real(wp) :: re_ref, im_ref
+
+  z = (1.0_wp, 2.0_wp)
+  re_ref = real (sin (z), wp)
+  im_ref = aimag (sin (z))
+
+  associate (k => myfunc (z))
+    if (kind (k%re) /= kind (1.0_wp)) stop 1
+    if (kind (k%im) /= kind (1.0_wp)) stop 2
+    if (kind (aimag (k)) /= kind (1.0_wp)) stop 3
+    if (abs (k%re - re_ref) > 1.0e-12_wp) stop 4
+    if (abs (k%im - im_ref) > 1.0e-12_wp) stop 5
+    if (abs (aimag (k) - im_ref) > 1.0e-12_wp) stop 6
+  end associate
+
+contains
+
+  complex(wp) function myfunc (x)
+    complex(wp), intent(in) :: x
+    myfunc = sin (x)
+  end function myfunc
+
+end program demo
+