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 associate-name from a %re/%im/%len
inquiry using the default kind (e.g. complex(4) when the user wrote
k%re). The actual selector kind cannot be known at that point.
The inferred-type cleanup in resolve_assoc_var only refreshed the
typespec when the target was BT_DERIVED/BT_CLASS, so for an inferred
intrinsic complex/character associate-name sym->ts kept the default
kind. Resolved expressions referencing the associate-name (or
applying the %re/%im inquiry) inherited that wrong kind, so for a
function returning complex(real64) one would see kind(k%re) == 4.
Refresh the kind in three places once the selector's actual type is
known:
- resolve_assoc_var: when the associate-name was inferred and the
target's resolved intrinsic type matches sym->ts.type but not its
kind, copy the target's typespec onto sym.
- resolve_variable: for a no-ref reference to an inferred-type
associate-name whose ts has changed at resolution, update e->ts
from sym->ts so callers like aimag(k) see the correct kind.
- gfc_fixup_inferred_type_refs: for an INQUIRY_RE/INQUIRY_IM ref on
a BT_COMPLEX associate-name, set e->ts.kind to sym->ts.kind so
kind(k%re) reflects the resolved kind.
PR fortran/125172
gcc/fortran/ChangeLog:
* resolve.cc (gfc_fixup_inferred_type_refs): Update kind for
INQUIRY_RE and INQUIRY_IM references on inferred complex
associate-name.
(resolve_variable): For an inferred-type associate-name with
no subobject ref, refresh e->ts from sym->ts.
(resolve_assoc_var): For an inferred-type complex/character
associate-name, refresh sym->ts from the resolved target when
only the kind differs.
gcc/testsuite/ChangeLog:
* gfortran.dg/associate_79.f90: New test.
Signed-off-by: Samir Ouchene <[email protected]>
Apologies; v1 and v2 went out malformed (commit msg folded into the
subject header). Please use v3.
Thank you.
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
