Commit 858b288d by Thomas Koenig

Use CHARACTER(kind) string for calculating the type hash.

This regression came about because of a change in the way
types are displayed in error messages.  The character
representation is also used to calculate the hashes for
our types, so this patch restores the old behavior if
we are indeed calculating a hash.

The test case also checks for the specific hash value because
changing that would be an ABI change, which we should not
be doing unintentionally.

gcc/fortran/ChangeLog:

2020-06-30  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/95366
	* gfortran.h (gfc_typename): Add optional argument for_hash.
	* misc.c (gfc_typename): When for_hash is true, just retur
	  CHARACTER(kind).
	* class.c (gfc_intrinsic_hash_value): Call gfc_typename with
	  for_hash = true.

(cherry picked from commit 5958b926dcc3332aec0a2e34653c4394d2613401)
parent 7ec7198f
...@@ -564,7 +564,7 @@ unsigned int ...@@ -564,7 +564,7 @@ unsigned int
gfc_intrinsic_hash_value (gfc_typespec *ts) gfc_intrinsic_hash_value (gfc_typespec *ts)
{ {
unsigned int hash = 0; unsigned int hash = 0;
const char *c = gfc_typename (ts); const char *c = gfc_typename (ts, true);
int i, len; int i, len;
len = strlen (c); len = strlen (c);
......
...@@ -2931,7 +2931,7 @@ void gfc_clear_ts (gfc_typespec *); ...@@ -2931,7 +2931,7 @@ void gfc_clear_ts (gfc_typespec *);
FILE *gfc_open_file (const char *); FILE *gfc_open_file (const char *);
const char *gfc_basic_typename (bt); const char *gfc_basic_typename (bt);
const char *gfc_dummy_typename (gfc_typespec *); const char *gfc_dummy_typename (gfc_typespec *);
const char *gfc_typename (gfc_typespec *); const char *gfc_typename (gfc_typespec *, bool for_hash = false);
const char *gfc_typename (gfc_expr *); const char *gfc_typename (gfc_expr *);
const char *gfc_op2string (gfc_intrinsic_op); const char *gfc_op2string (gfc_intrinsic_op);
const char *gfc_code2string (const mstring *, int); const char *gfc_code2string (const mstring *, int);
......
...@@ -122,7 +122,7 @@ gfc_basic_typename (bt type) ...@@ -122,7 +122,7 @@ gfc_basic_typename (bt type)
the argument list of a single statement. */ the argument list of a single statement. */
const char * const char *
gfc_typename (gfc_typespec *ts) gfc_typename (gfc_typespec *ts, bool for_hash)
{ {
static char buffer1[GFC_MAX_SYMBOL_LEN + 7]; /* 7 for "TYPE()" + '\0'. */ static char buffer1[GFC_MAX_SYMBOL_LEN + 7]; /* 7 for "TYPE()" + '\0'. */
static char buffer2[GFC_MAX_SYMBOL_LEN + 7]; static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
...@@ -149,6 +149,12 @@ gfc_typename (gfc_typespec *ts) ...@@ -149,6 +149,12 @@ gfc_typename (gfc_typespec *ts)
sprintf (buffer, "LOGICAL(%d)", ts->kind); sprintf (buffer, "LOGICAL(%d)", ts->kind);
break; break;
case BT_CHARACTER: case BT_CHARACTER:
if (for_hash)
{
sprintf (buffer, "CHARACTER(%d)", ts->kind);
break;
}
if (ts->u.cl && ts->u.cl->length) if (ts->u.cl && ts->u.cl->length)
length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
if (ts->kind == gfc_default_character_kind) if (ts->kind == gfc_default_character_kind)
......
! { dg-do run }
! { dg-additional-options "-fdump-tree-original" }
! PR 95366 - this did not work due the wrong hashes
! being generated for CHARACTER variables.
MODULE mod1
implicit none
integer :: tst(3)
CONTAINS
subroutine showpoly(poly)
CLASS(*), INTENT(IN) :: poly(:)
SELECT TYPE (poly)
TYPE IS(INTEGER)
tst(1) = tst(1) + 1
TYPE IS(character(*))
tst(2) = tst(2) + 1
class default
tst(3) = tst(3) + 1
end select
end subroutine showpoly
END MODULE mod1
MODULE mod2
implicit none
CONTAINS
subroutine polytest2()
use mod1
integer :: a(1)
character(len=42) :: c(1)
call showpoly(a)
if (any(tst /= [1,0,0])) stop 1
call showpoly(c)
if (any(tst /= [1,1,0])) stop 2
end subroutine polytest2
END MODULE mod2
PROGRAM testpoly
use mod2
CALL polytest2()
END PROGRAM testpoly
! The value of the hashes are also checked. If you get
! a failure here, be aware that changing that value is
! an ABI change.
! { dg-final { scan-tree-dump-times "== 17759" 1 "original" } }
! { dg-final { scan-tree-dump-times "== 85893463" 1 "original" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment