Le 22/06/2025 à 21:09, Harald Anlauf a écrit :
Hi Mikael!
Am 20.06.25 um 12:08 schrieb Mikael Morin:
From: Mikael Morin <mik...@gcc.gnu.org>
Regression-tested on x86_64-pc-linux-gnu.
Ok for master?
-- >8 --
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 idea makes a lot of sense.
It's a purely convenience change, not a correctness issue.
While this is true, one needs to check whether all buffers used
to hold the new, longer artificial symbol name are big enough.
Skimming over the patch, I have the impression that at least
the following temporaries need to be check and likely adjusted.
Thanks for the review. Very good point indeed.
So we have a constant, GFC_MAX_SYMBOL_LEN, bounding the size of the
symbol name that a user is permitted to choose, making it possible to
use static buffers based on that upper limit.
But then there are internal/artificial symbols using names that are
built around the user-provided names, thus permitted to exceed
GFC_MAX_SYMBOL_LEN by a few units.
So in the end, I'm not sure that the various static buffers we have all
around are safe in the face of these artificial symbols. And what is
the actual true bound on symbol names. For what's worth gfc_get_string
uses a buffer of size 3*GFC_MAX_SYMBOL_LEN + 21.
Back to the patch, I've added a truncation to the buffers which I
haven't extended (except for one spot, see below). At least the
situation shouldn't be any worse than before.
Regression-tested on x86_64-pc-linux-gnu. I also checked the testcase
manually with valgrind.
Ok for master?
From ff3ca6ea6c1ee38fa419c3539febf1efba50b088 Mon Sep 17 00:00:00 2001
From: Mikael Morin <morin-mik...@orange.fr>
Date: Fri, 20 Jun 2025 12:08:02 +0200
Subject: [PATCH v2] 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.
---
gcc/fortran/gfortran.h | 2 ++
gcc/fortran/match.cc | 24 ++++++++-----
gcc/fortran/misc.cc | 21 +++++++++++
gcc/fortran/resolve.cc | 21 ++++++-----
gcc/testsuite/gfortran.dg/select_type_51.f90 | 37 ++++++++++++++++++++
5 files changed, 88 insertions(+), 17 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/select_type_51.f90
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index f73b5f9c23f..6848bd1762d 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 a99a757bede..aa0b04afd56 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -7171,9 +7171,11 @@ 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];
+ /* Keep size in sync with the buffer size in resolve_select_type as it
+ determines the final name through truncation. */
+ 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 +7194,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 +7241,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 +7251,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 b8bdf7578de..23393066fc7 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 5413d8f9c54..a4294647df5 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 00000000000..6099be1c762
--- /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
--
2.47.2
