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 --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index f73b5f9c23f43db70e8205c17fdb48aaa366a7af..6848bd1762d33303330f1901a4d555183c2161cf 100644 (file)
--- 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 a99a757bede60886fe41d258c42e1494fcdea357..aa0b04afd563cb22b58112b5e9e418a60651e208 100644 (file)
--- 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 b8bdf7578de6225f4c41aa839911a88e2d73f976..23393066fc75d8bfae0ad3c3d5dba36c9c8d028f 100644 (file)
--- 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 5413d8f9c542f4887ee2f0d3f9b7e00696b00e62..7089e4f171d11432522695e26d34d155b10565df 100644 (file)
--- 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 (file)
index 0000000..6099be1
--- /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