https://gcc.gnu.org/g:7a9396443bd81b27d61a99eefe1a29f832fc1434
commit 7a9396443bd81b27d61a99eefe1a29f832fc1434
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Wed Jun 18 18:07:54 2025 +0200
Ajout nom de variable au variables temporaires select type
Diff:
---
gcc/fortran/match.cc | 35 +++++++++++++++++++++++++++--------
gcc/fortran/resolve.cc | 27 ++++++++++++++++++++-------
2 files changed, 47 insertions(+), 15 deletions(-)
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index a99a757bede6..09082db8b24c 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;
@@ -7222,6 +7222,22 @@ select_intrinsic_set_tmp (gfc_typespec *ts)
}
+static const char *
+get_select_type_var_name ()
+{
+ const char *name = "";
+ gfc_expr *e = gfc_state_stack->construct->expr1;
+ 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)
+ name = r->u.c.component->name;
+
+ return name;
+}
+
+
/* Set up a temporary for the current TYPE IS / CLASS IS branch . */
static void
@@ -7239,7 +7255,10 @@ select_type_set_tmp (gfc_typespec *ts)
return;
}
- tmp = select_intrinsic_set_tmp (ts);
+
+ const char *var_name = get_select_type_var_name ();
+
+ tmp = select_intrinsic_set_tmp (ts, var_name);
if (tmp == NULL)
{
@@ -7247,9 +7266,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/resolve.cc b/gcc/fortran/resolve.cc
index 5413d8f9c542..0070e8c170d2 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,22 @@ 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 = "";
+ if (orig_expr1->symtree)
+ var_name = orig_expr1->symtree->name;
+ if (orig_expr1->ref)
+ {
+ for (gfc_ref *r = orig_expr1->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))
+ var_name = r->u.c.component->name;
+ }
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 +10911,12 @@ 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);
