https://gcc.gnu.org/g:f74c501c5c7714784b9738d15687de9f0290dc8a
commit f74c501c5c7714784b9738d15687de9f0290dc8a
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Wed Jun 18 18:07:54 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 used to have a name depending only on the type.
This could produce confusing dumps with code having multiple select type
statements, as it wasn't obvious with which select type construct the
variable were related. This was 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.
It's a purely convenience change, not a correctness issue.
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.
* match.cc (select_type_set_tmp): Likewise. Pass the
discriminating name...
(select_intrinsic_set_tmp): ... to this function. Use the
discriminating name likewise.
Diff:
---
gcc/fortran/gfortran.h | 2 ++
gcc/fortran/match.cc | 18 ++++++++++--------
gcc/fortran/misc.cc | 21 +++++++++++++++++++++
gcc/fortran/resolve.cc | 19 +++++++++++--------
4 files changed, 44 insertions(+), 16 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..4631791015fa 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -7171,7 +7171,7 @@ 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];
gfc_symtree *tmp;
@@ -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);
+ sprintf (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,9 @@ select_type_set_tmp (gfc_typespec *ts)
return;
if (ts->type == BT_CLASS)
- sprintf (name, "__tmp_class_%s", ts->u.derived->name);
+ sprintf (name, "__tmp_class_%s_%s", ts->u.derived->name, var_name);
else
- sprintf (name, "__tmp_type_%s", ts->u.derived->name);
+ sprintf (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..bf72e1f62ea9 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,11 @@ 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);
+ sprintf (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);
+ sprintf (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 +10900,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);
+ sprintf (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);
