Dear All,
The first attempts at fixing this bug were posted to the PR in
February of this year. Since then, real life has intervened and I have
not been able to get back to it until now.
The first patch used the address of the vtable to perform the
switching in SELECT_TYPE. Unfortunately, it failed in submodule_6.f90
and I have not been able to find a way to fix this without breaking
the ABI and having to bump up the module version number.
The second patch uses a string for the switching, which comprises a
concatenation of the type name and the module or procedure name.
Clearly, there is a performance penalty associated with this. My
recent efforts have been focussed on making this version detect
incoming selectors and associates that are use associated with
libraries that were compiled before this patch was applied and the
result is this submission. By the way, I was unable to find a way of
testing this feature as part of the testsuite but have done so 'by
hand'.
If the performance penalty is considered to be a show stopper, I could
develop further the version based on the vtable addresses but will
have to postpone any further work on this for a few weeks.
Otherwise, this patch does bootstrap and regtest on FC21/x86_64 - OK for trunk?
Cheers
Paul
2016-09-27 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/69834
* class.c (get_unique_type_string): Add an extra argument
'icase' that defaults to false but, when true, switches the
order of type name and module or procedure name.
(get_unique_hashed_string): New argument 'icase' switches
bewteen the old form and a new one in which the string length
is limited to GFC_MAX_SYMBOL_LEN and, in case of this limit
being exceeded, the hash string is followed by as much of the
composite name as possible.
(gfc_case_name): New function.
(gfc_find_derived_vtab): Add '_name' field to vtable. This is
initialized by 'get_unique_type_string' with 'icase' true.
(find_intrinsic_vtab): Ditto with initialization performed by a
call to 'gfc_case_name'.
* gfortran.h : Add macro 'gfc_add_name_component' and prototype
for 'gfc_case_name'.
* resolve.c (vtable_old_style): New function to determine if a
use associated vtable is missing the '_name' field.
(resolve_select_type): Call 'vtable_old_style' to determine if
any of the derived types or vtables come from a library that
was compiled before this patch. If this is the case, the old
form of SELECT TYPE is activated, in which the cases are set by
the hash value. Otherwise, the 'unique_type_string' is used.
2016-09-27 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/69834
* gfortran.dg/finalize_21.f90: Remove semi colon from the tree
scan.
* gfortran.dg/select_type_36.f03: New test.
* gfortran.dg/select_type_37.f03: New test.
Index: gcc/fortran/class.c
===================================================================
*** gcc/fortran/class.c (revision 240492)
--- gcc/fortran/class.c (working copy)
*************** gfc_class_initializer (gfc_typespec *ts,
*** 472,492 ****
containers and vtab symbols. */
static void
! get_unique_type_string (char *string, gfc_symbol *derived)
{
char dt_name[GFC_MAX_SYMBOL_LEN+1];
if (derived->attr.unlimited_polymorphic)
strcpy (dt_name, "STAR");
else
strcpy (dt_name, gfc_dt_upper_string (derived->name));
! if (derived->attr.unlimited_polymorphic)
! sprintf (string, "_%s", dt_name);
! else if (derived->module)
! sprintf (string, "%s_%s", derived->module, dt_name);
! else if (derived->ns->proc_name)
! sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name);
else
! sprintf (string, "_%s", dt_name);
}
--- 472,508 ----
containers and vtab symbols. */
static void
! get_unique_type_string (char *string, gfc_symbol *derived, bool iscase =
false)
{
char dt_name[GFC_MAX_SYMBOL_LEN+1];
if (derived->attr.unlimited_polymorphic)
strcpy (dt_name, "STAR");
else
strcpy (dt_name, gfc_dt_upper_string (derived->name));
!
! /* The new style SELECT TYPE requires the type name to appear first. */
! if (iscase)
! {
! if (derived->attr.unlimited_polymorphic)
! sprintf (string, "_%s", dt_name);
! else if (derived->module)
! sprintf (string, "%s_%s", dt_name, derived->module);
! else if (derived->ns->proc_name)
! sprintf (string, "%s_%s", dt_name, derived->ns->proc_name->name);
! else
! sprintf (string, "_%s", dt_name);
! }
else
! {
! if (derived->attr.unlimited_polymorphic)
! sprintf (string, "_%s", dt_name);
! else if (derived->module)
! sprintf (string, "%s_%s", derived->module, dt_name);
! else if (derived->ns->proc_name)
! sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name);
! else
! sprintf (string, "_%s", dt_name);
! }
}
*************** get_unique_type_string (char *string, gf
*** 494,512 ****
string will not be too long (replacing it by a hash string if needed). */
static void
! get_unique_hashed_string (char *string, gfc_symbol *derived)
{
char tmp[2*GFC_MAX_SYMBOL_LEN+2];
! get_unique_type_string (&tmp[0], derived);
! /* If string is too long, use hash value in hex representation (allow for
! extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
! We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
! where %d is the (co)rank which can be up to n = 15. */
! if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15)
! {
! int h = gfc_hash_value (derived);
sprintf (string, "%X", h);
}
else
strcpy (string, tmp);
}
--- 510,543 ----
string will not be too long (replacing it by a hash string if needed). */
static void
! get_unique_hashed_string (char *string, gfc_symbol *derived, bool iscase =
false)
{
char tmp[2*GFC_MAX_SYMBOL_LEN+2];
! int h;
!
! get_unique_type_string (&tmp[0], derived, iscase);
!
! /* Whether this function is called by 'gfc_case_name' or
! 'gfc_find_derived_vtab' makes a big difference as to what is written to
! 'string' in the event that the unique type string is over long. */
! if (!iscase && strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15)
! {
! /* If string is too long, use hash value in hex representation (allow
for
! extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
! We need space for 15 characters "__class_" + symbol name + "_%d_%da",
! where %d is the (co)rank which can be up to n = 15. */
! h = gfc_hash_value (derived);
sprintf (string, "%X", h);
}
+ else if (iscase && strlen (tmp) > GFC_MAX_SYMBOL_LEN)
+ {
+ /* If string is too long, use hash value in hex representation followed
+ by as much of the unique name as possible. */
+ char str[GFC_MAX_SYMBOL_LEN-8];
+ h = gfc_hash_value (derived);
+ strncpy (str, tmp, (size_t)(GFC_MAX_SYMBOL_LEN - 8));
+ sprintf (string, "%X%s", h, str);
+ }
else
strcpy (string, tmp);
}
*************** gfc_intrinsic_hash_value (gfc_typespec *
*** 552,557 ****
--- 583,596 ----
return (hash % 100000000);
}
+ void
+ gfc_case_name (char *name, gfc_typespec *ts)
+ {
+ if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
+ get_unique_hashed_string (name, ts->u.derived, true);
+ else
+ sprintf (name, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
+ }
/* Get the _len component from a class/derived object storing a string.
For unlimited polymorphic entities a ref to the _data component is
available
*************** gfc_find_derived_vtab (gfc_symbol *deriv
*** 2405,2410 ****
--- 2444,2460 ----
c->tb->ppc = 1;
generate_finalization_wrapper (derived, ns, tname, c);
+ if (!gfc_add_component (vtype, "_name", &c))
+ goto cleanup;
+ c->ts.type = BT_CHARACTER;
+ c->ts.kind = gfc_default_character_kind;
+ c->attr.access = ACCESS_PRIVATE;
+ c->ts.u.cl = gfc_get_charlen();
+ get_unique_hashed_string (tname, derived, true);
+ c->ts.u.cl->length = gfc_get_int_expr (4, &derived->declared_at,
+ GFC_MAX_SYMBOL_LEN+1);
+ c->initializer = gfc_get_character_expr (c->ts.kind, NULL,
+ tname, strlen (tname));
/* Add procedure pointers for type-bound procedures. */
if (!derived->attr.unlimited_polymorphic)
add_procs_to_declared_vtab (derived, vtype);
*************** find_intrinsic_vtab (gfc_typespec *ts)
*** 2678,2683 ****
--- 2728,2746 ----
c->tb = XCNEW (gfc_typebound_proc);
c->tb->ppc = 1;
c->initializer = gfc_get_null_expr (NULL);
+
+ if (!gfc_add_component (vtype, "_name", &c))
+ goto cleanup;
+ c->ts.type = BT_CHARACTER;
+ c->ts.kind = gfc_default_character_kind;
+ c->attr.access = ACCESS_PRIVATE;
+ c->ts.u.cl = gfc_get_charlen();
+ gfc_case_name (tname, ts);
+ c->ts.u.cl->length = gfc_get_int_expr (gfc_index_integer_kind,
+ &gfc_current_locus,
+ GFC_MAX_SYMBOL_LEN+1);
+ c->initializer = gfc_get_character_expr
(gfc_default_character_kind, NULL,
+ tname, strlen (tname));
}
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 240492)
--- gcc/fortran/gfortran.h (working copy)
*************** void gfc_add_class_array_ref (gfc_expr *
*** 3266,3276 ****
--- 3266,3278 ----
#define gfc_add_size_component(e) gfc_add_component_ref(e,"_size")
#define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init")
#define gfc_add_final_component(e) gfc_add_component_ref(e,"_final")
+ #define gfc_add_name_component(e) gfc_add_component_ref(e,"_name")
bool gfc_is_class_array_ref (gfc_expr *, bool *);
bool gfc_is_class_scalar_expr (gfc_expr *);
bool gfc_is_class_container_ref (gfc_expr *e);
gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
unsigned int gfc_hash_value (gfc_symbol *);
+ void gfc_case_name (char *, gfc_typespec *);
gfc_expr *gfc_get_len_component (gfc_expr *e);
bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **);
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 240492)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_assoc_var (gfc_symbol* sym, bool
*** 8310,8315 ****
--- 8310,8348 ----
}
+ /* See if the 'name' field appears in the vtable. If so, SELECT TYPE can
+ proceed with the comparison of composite names. Otherwise, the hash
+ values are used. */
+
+ static bool
+ vtable_old_style (gfc_typespec ts)
+ {
+ gfc_symbol *vtab;
+
+ if (ts.u.derived == NULL
+ || !ts.u.derived->attr.use_assoc
+ || ts.u.derived->components == NULL)
+ return false;
+
+ if (ts.u.derived->attr.vtype)
+ return gfc_find_component (ts.u.derived, "_name", true, true, NULL)
+ ? false : true;
+
+ if (ts.type == BT_CLASS
+ && (ts.u.derived->components == NULL
+ || ts.u.derived->components->ts.u.derived == NULL
+ || !ts.u.derived->components->ts.u.derived->attr.use_assoc))
+ return false;
+
+ vtab = gfc_find_vtab (&ts);
+ if (gfc_find_component (vtab->ts.u.derived, "_name", true, true, NULL))
+ return false;
+
+ /* This is an old style vtable. */
+ return true;
+ }
+
+
/* Resolve a SELECT TYPE statement. */
static void
*************** resolve_select_type (gfc_code *code, gfc
*** 8324,8329 ****
--- 8357,8363 ----
gfc_namespace *ns;
int error = 0;
int charlen = 0;
+ bool old_style_vtable = false;
ns = code->ext.block.ns;
gfc_resolve (ns);
*************** resolve_select_type (gfc_code *code, gfc
*** 8372,8377 ****
--- 8406,8414 ----
{
c = body->ext.block.case_list;
+ if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ old_style_vtable = vtable_old_style (c->ts);
+
/* Check F03:C815. */
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
&& !selector_type->attr.unlimited_polymorphic
*************** resolve_select_type (gfc_code *code, gfc
*** 8465,8480 ****
code = new_st;
code->op = EXEC_SELECT;
gfc_add_vptr_component (code->expr1);
gfc_add_hash_component (code->expr1);
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
c = body->ext.block.case_list;
if (c->ts.type == BT_DERIVED)
! c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
c->ts.u.derived->hash_value);
else if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
{
--- 8502,8531 ----
code = new_st;
code->op = EXEC_SELECT;
+
gfc_add_vptr_component (code->expr1);
+ old_style_vtable = vtable_old_style (code->expr1->ts);
+
+ if (old_style_vtable)
gfc_add_hash_component (code->expr1);
+ else
+ gfc_add_name_component (code->expr1);
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
+ char tname[GFC_MAX_SYMBOL_LEN+1];
+
c = body->ext.block.case_list;
+ if (old_style_vtable)
+ {
+ /* At least one old style vtable has been detected. Use the
+ hash value for the SELECT CASE. Note that this will remain
+ prone to clashes as in PR69834. */
if (c->ts.type == BT_DERIVED)
! c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind,
! NULL,
c->ts.u.derived->hash_value);
else if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
{
*************** resolve_select_type (gfc_code *code, gfc
*** 8486,8494 ****
e = CLASS_DATA (ivtab)->initializer;
c->low = c->high = gfc_copy_expr (e);
}
-
else if (c->ts.type == BT_UNKNOWN)
continue;
/* Associate temporary to selector. This should only be done
when this case is actually true, so build a new ASSOCIATE
--- 8537,8562 ----
e = CLASS_DATA (ivtab)->initializer;
c->low = c->high = gfc_copy_expr (e);
}
else if (c->ts.type == BT_UNKNOWN)
continue;
+ }
+ else
+ {
+ /* New style selection using a composite name generated in
+ class.c (gfc_case_name). */
+ if (c->ts.type != BT_UNKNOWN)
+ gfc_case_name (&tname[0], &c->ts);
+ else if (c->ts.type == BT_UNKNOWN)
+ continue;
+
+ c->low = gfc_get_character_expr (gfc_default_character_kind, NULL,
+ tname, strlen (tname));
+ c->low->ts.u.cl = gfc_get_charlen();
+ c->low->ts.u.cl->length = gfc_get_int_expr (gfc_index_integer_kind,
+ &code->expr1->where,
+ GFC_MAX_SYMBOL_LEN+1);
+ c->high = c->low;
+ }
/* Associate temporary to selector. This should only be done
when this case is actually true, so build a new ASSOCIATE
Index: gcc/testsuite/gfortran.dg/finalize_21.f90
===================================================================
*** gcc/testsuite/gfortran.dg/finalize_21.f90 (revision 240492)
--- gcc/testsuite/gfortran.dg/finalize_21.f90 (working copy)
***************
*** 8,11 ****
class(*), allocatable :: var
end
! ! { dg-final { scan-tree-dump "static struct __vtype__STAR __vtab__STAR =
{._hash=0, ._size=., ._extends=0B, ._def_init=0B, ._copy=0B, ._final=0B};"
"original" } }
--- 8,11 ----
class(*), allocatable :: var
end
! ! { dg-final { scan-tree-dump "static struct __vtype__STAR __vtab__STAR =
{._hash=0, ._size=., ._extends=0B, ._def_init=0B, ._copy=0B, ._final=0B,"
"original" } }
Index: gcc/testsuite/gfortran.dg/select_type_36.f03
===================================================================
*** gcc/testsuite/gfortran.dg/select_type_36.f03 (revision 0)
--- gcc/testsuite/gfortran.dg/select_type_36.f03 (working copy)
***************
*** 0 ****
--- 1,44 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR69834 in which the two derived types below
+ ! had the same hash value and so generated an error in the resolution
+ ! of SELECT TYPE.
+ !
+ ! Reported by James van Buskirk on clf:
+ ! https://groups.google.com/forum/#!topic/comp.lang.fortran/0bm3E5xJpkM
+ !
+ module types
+ implicit none
+ type CS5SS
+ integer x
+ real y
+ end type CS5SS
+ type SQS3C
+ logical u
+ character(7) v
+ end type SQS3C
+ contains
+ subroutine sub(x, switch)
+ class(*), allocatable :: x
+ integer :: switch
+ select type(x)
+ type is(CS5SS)
+ if (switch .ne. 1) call abort
+ type is(SQS3C)
+ if (switch .ne. 2) call abort
+ class default
+ call abort
+ end select
+ end subroutine sub
+ end module types
+
+ program test
+ use types
+ implicit none
+ class(*), allocatable :: u1, u2
+
+ allocate(u1,source = CS5SS(2,1.414))
+ allocate(u2,source = SQS3C(.TRUE.,'Message'))
+ call sub(u1, 1)
+ call sub(u2, 2)
+ end program test
Index: gcc/testsuite/gfortran.dg/select_type_37.f03
===================================================================
*** gcc/testsuite/gfortran.dg/select_type_37.f03 (revision 0)
--- gcc/testsuite/gfortran.dg/select_type_37.f03 (working copy)
***************
*** 0 ****
--- 1,30 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR69834 in which the hash value was insufficient to
+ ! prevent type clashes. This test exercises that cases where the combined
+ ! name is longer than GFC_MAX_SYMBOL_LEN, so that the hash is rolled into
+ ! the composite name used in SELECT TYPE.
+ !
+ module extreme_and_very_silly_module_named_brian
+ type :: daft_type_name_that_sounds_like_blue_parrot
+ integer :: i
+ end type
+ type, extends(daft_type_name_that_sounds_like_blue_parrot) :: &
+ daft_type_name_that_sounds_that_is_spam_spam
+ real :: r
+ end type
+ end module
+
+ use extreme_and_very_silly_module_named_brian
+
+ class (daft_type_name_that_sounds_like_blue_parrot), allocatable ::c
+
+ allocate (c, source = daft_type_name_that_sounds_that_is_spam_spam (22,
3.0))
+
+ select type (c)
+ type is (daft_type_name_that_sounds_like_blue_parrot)
+ call abort
+ type is (daft_type_name_that_sounds_that_is_spam_spam)
+ print *, c%i, c%r
+ end select
+ end
