https://gcc.gnu.org/g:ed83521b3c747b7ddedeaa32b97801ca25d9633e
commit ed83521b3c747b7ddedeaa32b97801ca25d9633e
Author: Mikael Morin <morin-mik...@orange.fr>
Date: Fri Jun 20 12:08:02 2025 +0200
fortran: Mention user variable in SELECT TYPE temporary variable names
The temporary variables that are generated to implement SELECT TYPE
and TYPE IS statements have (before this change) a name depending only
on the type. This can produce confusing dumps with code having multiple
SELECT TYPE statements, as it isn't obvious which SELECT TYPE construct
the variable relates to. This is especially the case with nested SELECT
TYPE statements and with SELECT TYPE variables having identical types
(and thus identical names).
This change adds one additional user-provided discriminating string in
the variable names, using the value from the SELECT TYPE variable name
or last component reference name. The additional string may be
truncated to fit in the temporary buffer. This requires all buffers to
have matching sizes to get the same resulting name everywhere.
gcc/fortran/ChangeLog:
* misc.cc (gfc_var_name_for_select_type_temp): New function.
* gfortran.h (gfc_var_name_for_select_type_temp): Declare it.
* resolve.cc (resolve_select_type): Pick a discriminating name
from the SELECT TYPE variable reference and use it in the name
of the temporary variable that is generated. Truncate name to
the buffer size.
* match.cc (select_type_set_tmp): Likewise. Pass the
discriminating name...
(select_intrinsic_set_tmp): ... to this function. Use the
discriminating name likewise. Augment the buffer size to match
that of select_type_set_tmp and resolve_select_type.
gcc/testsuite/ChangeLog:
* gfortran.dg/select_type_51.f90: New test.
Diff:
---
gcc/fortran/gfortran.h | 2 ++
gcc/fortran/match.cc | 22 ++++++++++-------
gcc/fortran/misc.cc | 21 ++++++++++++++++
gcc/fortran/resolve.cc | 21 ++++++++++------
gcc/testsuite/gfortran.dg/select_type_51.f90 | 37 ++++++++++++++++++++++++++++
5 files changed, 86 insertions(+), 17 deletions(-)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index f73b5f9c23f4..6848bd1762d3 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3507,6 +3507,8 @@ void gfc_done_2 (void);
int get_c_kind (const char *, CInteropKind_t *);
+const char * gfc_var_name_for_select_type_temp (gfc_expr *);
+
const char *gfc_closest_fuzzy_match (const char *, char **);
inline void
vec_push (char **&optr, size_t &osz, const char *elt)
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index a99a757bede6..c3a6ded942d8 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -7171,9 +7171,9 @@ select_type_push (gfc_symbol *sel)
/* Set the temporary for the current intrinsic SELECT TYPE selector. */
static gfc_symtree *
-select_intrinsic_set_tmp (gfc_typespec *ts)
+select_intrinsic_set_tmp (gfc_typespec *ts, const char *var_name)
{
- char name[GFC_MAX_SYMBOL_LEN];
+ char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
gfc_symtree *tmp;
HOST_WIDE_INT charlen = 0;
gfc_symbol *selector = select_type_stack->selector;
@@ -7192,12 +7192,12 @@ select_intrinsic_set_tmp (gfc_typespec *ts)
charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
if (ts->type != BT_CHARACTER)
- sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
- ts->kind);
+ snprintf (name, sizeof (name), "__tmp_%s_%d_%s",
+ gfc_basic_typename (ts->type), ts->kind, var_name);
else
snprintf (name, sizeof (name),
- "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
- gfc_basic_typename (ts->type), charlen, ts->kind);
+ "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s",
+ gfc_basic_typename (ts->type), charlen, ts->kind, var_name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
sym = tmp->n.sym;
@@ -7239,7 +7239,9 @@ select_type_set_tmp (gfc_typespec *ts)
return;
}
- tmp = select_intrinsic_set_tmp (ts);
+ gfc_expr *select_type_expr = gfc_state_stack->construct->expr1;
+ const char *var_name = gfc_var_name_for_select_type_temp (select_type_expr);
+ tmp = select_intrinsic_set_tmp (ts, var_name);
if (tmp == NULL)
{
@@ -7247,9 +7249,11 @@ select_type_set_tmp (gfc_typespec *ts)
return;
if (ts->type == BT_CLASS)
- sprintf (name, "__tmp_class_%s", ts->u.derived->name);
+ snprintf (name, sizeof (name), "__tmp_class_%s_%s", ts->u.derived->name,
+ var_name);
else
- sprintf (name, "__tmp_type_%s", ts->u.derived->name);
+ snprintf (name, sizeof (name), "__tmp_type_%s_%s", ts->u.derived->name,
+ var_name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
sym = tmp->n.sym;
diff --git a/gcc/fortran/misc.cc b/gcc/fortran/misc.cc
index b8bdf7578de6..23393066fc75 100644
--- a/gcc/fortran/misc.cc
+++ b/gcc/fortran/misc.cc
@@ -472,3 +472,24 @@ gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op)
const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT);
wi::to_mpz (w, rop, SIGNED);
}
+
+
+/* Extract a name suitable for use in the name of the select type temporary
+ variable. We pick the last component name in the data reference if there
+ is one, otherwise the user variable name, and return the empty string by
+ default. */
+
+const char *
+gfc_var_name_for_select_type_temp (gfc_expr *e)
+{
+ const char *name = "";
+ if (e->symtree)
+ name = e->symtree->name;
+ for (gfc_ref *r = e->ref; r; r = r->next)
+ if (r->type == REF_COMPONENT
+ && !(strcmp (r->u.c.component->name, "_data") == 0
+ || strcmp (r->u.c.component->name, "_vptr") == 0))
+ name = r->u.c.component->name;
+
+ return name;
+}
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 5413d8f9c542..a4294647df5b 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10819,6 +10819,8 @@ resolve_select_type (gfc_code *code, gfc_namespace
*old_ns)
ref = gfc_copy_ref (ref);
}
+ gfc_expr *orig_expr1 = code->expr1;
+
/* Add EXEC_SELECT to switch on type. */
new_st = gfc_get_code (code->op);
new_st->expr1 = code->expr1;
@@ -10846,7 +10848,6 @@ resolve_select_type (gfc_code *code, gfc_namespace
*old_ns)
for (body = code->block; body; body = body->block)
{
gfc_symbol *vtab;
- gfc_expr *e;
c = body->ext.block.case_list;
/* Generate an index integer expression for address of the
@@ -10854,6 +10855,7 @@ resolve_select_type (gfc_code *code, gfc_namespace
*old_ns)
is stored in c->high and is used to resolve intrinsic cases. */
if (c->ts.type != BT_UNKNOWN)
{
+ gfc_expr *e;
if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
{
vtab = gfc_find_derived_vtab (c->ts.u.derived);
@@ -10886,11 +10888,13 @@ resolve_select_type (gfc_code *code, gfc_namespace
*old_ns)
when this case is actually true, so build a new ASSOCIATE
that does precisely this here (instead of using the
'global' one). */
-
+ const char * var_name = gfc_var_name_for_select_type_temp (orig_expr1);
if (c->ts.type == BT_CLASS)
- sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
+ snprintf (name, sizeof (name), "__tmp_class_%s_%s",
+ c->ts.u.derived->name, var_name);
else if (c->ts.type == BT_DERIVED)
- sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
+ snprintf (name, sizeof (name), "__tmp_type_%s_%s",
c->ts.u.derived->name,
+ var_name);
else if (c->ts.type == BT_CHARACTER)
{
HOST_WIDE_INT charlen = 0;
@@ -10898,12 +10902,13 @@ resolve_select_type (gfc_code *code, gfc_namespace
*old_ns)
&& c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
snprintf (name, sizeof (name),
- "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
- gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
+ "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s",
+ gfc_basic_typename (c->ts.type), charlen, c->ts.kind,
+ var_name);
}
else
- sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
- c->ts.kind);
+ snprintf (name, sizeof (name), "__tmp_%s_%d_%s",
+ gfc_basic_typename (c->ts.type), c->ts.kind, var_name);
st = gfc_find_symtree (ns->sym_root, name);
gcc_assert (st->n.sym->assoc);
diff --git a/gcc/testsuite/gfortran.dg/select_type_51.f90
b/gcc/testsuite/gfortran.dg/select_type_51.f90
new file mode 100644
index 000000000000..6099be1c7622
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_51.f90
@@ -0,0 +1,37 @@
+! { dg-do compile }
+!
+! Check the support by the compiler of very long symbol names in SELECT TYPE
+! and TYPE IS statements.
+!
+! Original testcase by Harald Anlauf.
+
+module m
+ implicit none
+ type t2345678901234567890123456789012345678901234567890123456789_123
+ integer :: i
+ end type t2345678901234567890123456789012345678901234567890123456789_123
+ class(*), allocatable :: a, &
+ c2345678901234567890123456789012345678901234567890123456789_123
+contains
+ subroutine check_type_is_intrinsic()
+ select type
(s2345678901234567890123456789012345678901234567890123456789_123 &
+ => c2345678901234567890123456789012345678901234567890123456789_123)
+ type is (integer(kind=4))
+ print *, s2345678901234567890123456789012345678901234567890123456789_123
+ end select
+ end subroutine
+ subroutine check_type_is_derived()
+ select type
(s2345678901234567890123456789012345678901234567890123456789_123 &
+ => c2345678901234567890123456789012345678901234567890123456789_123)
+ type is (t2345678901234567890123456789012345678901234567890123456789_123)
+ print *,
s2345678901234567890123456789012345678901234567890123456789_123%i
+ end select
+ end subroutine
+ subroutine check_type_is_class()
+ select type
(s2345678901234567890123456789012345678901234567890123456789_123 &
+ => c2345678901234567890123456789012345678901234567890123456789_123)
+ class is (t2345678901234567890123456789012345678901234567890123456789_123)
+ print *,
s2345678901234567890123456789012345678901234567890123456789_123%i
+ end select
+ end subroutine
+end module m
