[Patch, fortran] PR69834 - Collision in derived type hashes

[Patch, fortran] PR69834 - Collision in derived type hashes

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 2647 bytes --]

Dear All,

What started out as a provisional kludge, when first working on OOP,
has come back to bite us after 7 years. A collision in derived type
has values has been reported on clf. In principle, as pointed out in
the clf thread, this could mean that existing code might be quietly
confusing dynamic types. Fortunately, this is unlikely because the
error in SELECT TYPE that flagged up this problem might appear or
incorrect fields might be accessed, giving rise to runtime errors.

The fix uses a new vtable field, '_name' that is loaded with the
value, "typename_scopename", which is used for the cases in SELECT
TYPE and for comparison in SAME_TYPE_AS. I have retained the '_hash'
field for compatibility with existing libraries. It could easily be
removed, if that is preferred, but would require a publicity campaign
to ensure that users recompile their code.

The changes are sufficiently well described in the ChangeLogs and the
comments in the patch to not warrant further comment.

I have to confess to not knowing quite what to propose here. My gut
feeling is that we should bite the bullet and the patch should be
applied to trunk and 5-branch. However, I am open, on the grounds
above, to wait until 7.0.0. It does bootstrap and regtest on trunk
with FC23/x86_64.

Thanks to Dominique for testing an early version of the test and to
Thomas for picking up on the clf thread.

Regards

Paul

2016-03-03  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/69834
    * class.c (gfc_select_type_name): New function.
    (gfc_find_derived_vtab, find_intrinsic_vtab): Add a new field
    to the vtable '_name'. Initialize using gfc_select_type_name.
    * expr.c : Clean up some trailing white space.
    * gfortran.h : Define 'gfc_add_name_component' and provide
    prototype for 'gfc_select_type_name'.
    * module.c (mio_component): Deal with the initializer for the
    '_name' field.
    * resolve.c (resolve_select_type): Use the name generated by
    'gfc_select_type_name' instead of the hash for the case labels.
    * trans-expr.c : Generate the access functions for the vtable
    '_name' field.
    * trans-intrinsic.c (gfc_conv_same_type_as): Rework to use the
    vtable '_name' field or, for derived types, the name produced
    by 'gfc_select_type_name' for comparison, instead of the hash.

2016-03-03  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/69834
    * gfortran.dg/finalize_21.f90 : Remove the right brace in the
    test for the tree dump to allow for the new field.
    * gfortran.dg/select_type_35.f90 : New test.


-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein

[-- Attachment #2: submit.diff --]
[-- Type: text/plain, Size: 19147 bytes --]

Index: gcc/fortran/class.c
===================================================================
*** gcc/fortran/class.c	(revision 233626)
--- gcc/fortran/class.c	(working copy)
*************** gfc_intrinsic_hash_value (gfc_typespec *
*** 552,557 ****
--- 552,589 ----
    return (hash % 100000000);
  }
  
+ /* Provide a full name for any arbitrary type that can be used in
+    SELECT TYPE and the SAME_TYPE_AS intrinsic. This is loaded into the
+    vtable '_name' field and is used for the case label in SELECT TYPE
+    and for derived types in SAME_TYPE_AS. Unlike get_unique_type_string
+    the derived type name is put before the scope name on the grounds
+    that this will, most of the time, make distinguishing the names more
+    efficient.  */
+ void
+ gfc_select_type_name (char *name, gfc_typespec *ts, gfc_symbol *type)
+ {
+   if (ts != NULL && (ts->type == BT_DERIVED || ts->type == BT_CLASS))
+     type = ts->u.derived;
+   else if (!type)
+     {
+       sprintf (name, "%s_%d", gfc_basic_typename (ts->type), ts->kind);
+       return;
+     }
+   gcc_assert (type);
+ 
+   if (type->attr.unlimited_polymorphic)
+     {
+       sprintf (name, "STAR");
+       return;
+     }
+ 
+   if (type->module)
+     sprintf (name, "%s_%s", type->name, type->module);
+   else if (type->ns->proc_name)
+     sprintf (name, "%s_%s", type->name, type->ns->proc_name->name);
+   else
+     sprintf (name, "%s", type->name);
+ }
  
  /* 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
*** 2203,2208 ****
--- 2235,2241 ----
    if (ns)
      {
        char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
+       char *cname;
  
        get_unique_hashed_string (tname, derived);
        sprintf (name, "__vtab_%s", tname);
*************** gfc_find_derived_vtab (gfc_symbol *deriv
*** 2405,2410 ****
--- 2438,2458 ----
  	      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();
+ 	      c->ts.u.cl->next = ns->cl_list;
+ 	      ns->cl_list = c->ts.u.cl;
+ 	      cname = XCNEWVEC (char, 2*GFC_MAX_SYMBOL_LEN + 2);
+ 	      gfc_select_type_name (cname, NULL, derived);
+ 	      c->ts.u.cl->length = gfc_get_int_expr (4, &derived->declared_at,
+ 						     2*GFC_MAX_SYMBOL_LEN+1);
+ 	      c->initializer = gfc_get_character_expr (c->ts.kind, NULL,
+ 						       cname, strlen (cname));
+ 	      free (cname);
  	      /* 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)
*** 2507,2512 ****
--- 2555,2561 ----
    if (ns)
      {
        char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
+       char *cname;
  
        if (ts->type == BT_CHARACTER)
  	sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
*************** find_intrinsic_vtab (gfc_typespec *ts)
*** 2678,2683 ****
--- 2727,2749 ----
  	      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();
+ 	      c->ts.u.cl->next = ns->cl_list;
+ 	      ns->cl_list = c->ts.u.cl;
+ 	      cname = XCNEWVEC (char, 2*GFC_MAX_SYMBOL_LEN + 2);
+ 	      gfc_select_type_name (cname, ts, NULL);
+ 	      c->ts.u.cl->length = gfc_get_int_expr (gfc_index_integer_kind,
+ 						     &gfc_current_locus,
+ 						     2*GFC_MAX_SYMBOL_LEN+1);
+ 	      c->initializer = gfc_get_character_expr (gfc_default_character_kind, NULL,
+ 						       cname, strlen (cname));
+ 	      free (cname);
  	    }
  	  vtab->ts.u.derived = vtype;
  	  vtab->value = gfc_default_initializer (&vtab->ts);
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c	(revision 233626)
--- gcc/fortran/expr.c	(working copy)
*************** gfc_check_assign (gfc_expr *lvalue, gfc_
*** 3245,3251 ****
    if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
        && lvalue->symtree->n.sym->attr.data
        && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to "
! 			  "initialize non-integer variable %qs", 
  			  &rvalue->where, lvalue->symtree->n.sym->name))
      return false;
    else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
--- 3245,3251 ----
    if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
        && lvalue->symtree->n.sym->attr.data
        && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to "
! 			  "initialize non-integer variable %qs",
  			  &rvalue->where, lvalue->symtree->n.sym->name))
      return false;
    else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
*************** gfc_check_pointer_assign (gfc_expr *lval
*** 3371,3377 ****
  	    }
  
  	  if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification "
! 			       "for %qs in pointer assignment at %L", 
  			       lvalue->symtree->n.sym->name, &lvalue->where))
  	    return false;
  
--- 3371,3377 ----
  	    }
  
  	  if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification "
! 			       "for %qs in pointer assignment at %L",
  			       lvalue->symtree->n.sym->name, &lvalue->where))
  	    return false;
  
*************** gfc_check_vardef_context (gfc_expr* e, b
*** 5035,5047 ****
  		{
  		  gfc_constructor *c, *n;
  		  gfc_expr *ec, *en;
! 		  
  		  for (c = gfc_constructor_first (arr->value.constructor);
  		       c != NULL; c = gfc_constructor_next (c))
  		    {
  		      if (c == NULL || c->iterator != NULL)
  			continue;
! 		      
  		      ec = c->expr;
  
  		      for (n = gfc_constructor_next (c); n != NULL;
--- 5035,5047 ----
  		{
  		  gfc_constructor *c, *n;
  		  gfc_expr *ec, *en;
! 
  		  for (c = gfc_constructor_first (arr->value.constructor);
  		       c != NULL; c = gfc_constructor_next (c))
  		    {
  		      if (c == NULL || c->iterator != NULL)
  			continue;
! 
  		      ec = c->expr;
  
  		      for (n = gfc_constructor_next (c); n != NULL;
*************** gfc_check_vardef_context (gfc_expr* e, b
*** 5049,5055 ****
  			{
  			  if (n->iterator != NULL)
  			    continue;
! 			  
  			  en = n->expr;
  			  if (gfc_dep_compare_expr (ec, en) == 0)
  			    {
--- 5049,5055 ----
  			{
  			  if (n->iterator != NULL)
  			    continue;
! 
  			  en = n->expr;
  			  if (gfc_dep_compare_expr (ec, en) == 0)
  			    {
*************** gfc_check_vardef_context (gfc_expr* e, b
*** 5066,5071 ****
  		    }
  		}
  	    }
!   
    return true;
  }
--- 5066,5071 ----
  		    }
  		}
  	    }
! 
    return true;
  }
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 233626)
--- gcc/fortran/gfortran.h	(working copy)
*************** void gfc_add_class_array_ref (gfc_expr *
*** 3227,3237 ****
--- 3227,3239 ----
  #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_select_type_name (char *, gfc_typespec *,  gfc_symbol *);
  gfc_expr *gfc_get_len_component (gfc_expr *e);
  bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
  			     gfc_array_spec **);
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c	(revision 233626)
--- gcc/fortran/module.c	(working copy)
*************** mio_component (gfc_component *c, int vty
*** 2771,2777 ****
    c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
  
    if (!vtype || strcmp (c->name, "_final") == 0
!       || strcmp (c->name, "_hash") == 0)
      mio_expr (&c->initializer);
  
    if (c->attr.proc_pointer)
--- 2771,2778 ----
    c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
  
    if (!vtype || strcmp (c->name, "_final") == 0
!       || strcmp (c->name, "_hash") == 0
!       || strcmp (c->name, "_name") == 0)
      mio_expr (&c->initializer);
  
    if (c->attr.proc_pointer)
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 233626)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_select_type (gfc_code *code, gfc
*** 8392,8420 ****
    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)
! 	{
! 	  gfc_symbol *ivtab;
! 	  gfc_expr *e;
  
! 	  ivtab = gfc_find_vtab (&c->ts);
! 	  gcc_assert (ivtab && CLASS_DATA (ivtab)->initializer);
! 	  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
--- 8392,8421 ----
    code->op = EXEC_SELECT;
  
    gfc_add_vptr_component (code->expr1);
!   gfc_add_name_component (code->expr1);
  
    /* Loop over TYPE IS / CLASS IS cases.  */
    for (body = code->block; body; body = body->block)
      {
!       char *cname;
  
!       c = body->ext.block.case_list;
  
+       cname = XCNEWVEC (char, 2*GFC_MAX_SYMBOL_LEN + 2);
+       if (c->ts.type != BT_UNKNOWN)
+ 	gfc_select_type_name (&cname[0], &c->ts, NULL);
        else if (c->ts.type == BT_UNKNOWN)
  	continue;
+       c->low = gfc_get_character_expr (gfc_default_character_kind, NULL,
+ 				       cname, strlen (cname));
+       c->low->ts.u.cl = gfc_get_charlen();
+       c->low->ts.u.cl->next = gfc_current_ns->cl_list;
+       gfc_current_ns->cl_list = c->low->ts.u.cl;
+       c->low->ts.u.cl->length = gfc_get_int_expr (gfc_index_integer_kind,
+ 						  &code->expr1->where,
+ 						  2*GFC_MAX_SYMBOL_LEN+1);
+       free (cname);
+       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/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 233626)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_scalar_to_descriptor (gfc_se *s
*** 101,106 ****
--- 101,107 ----
  #define VTABLE_DEF_INIT_FIELD 3
  #define VTABLE_COPY_FIELD 4
  #define VTABLE_FINAL_FIELD 5
+ #define VTABLE_NAME_FIELD 6
  
  
  tree
*************** VTAB_GET_FIELD_GEN (extends, VTABLE_EXTE
*** 220,225 ****
--- 221,227 ----
  VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
  VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
  VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
+ VTAB_GET_FIELD_GEN (name, VTABLE_NAME_FIELD)
  
  
  /* The size field is returned as an array index type.  Therefore treat
*************** gfc_vptr_size_get (tree vptr)
*** 256,261 ****
--- 258,264 ----
  #undef VTABLE_DEF_INIT_FIELD
  #undef VTABLE_COPY_FIELD
  #undef VTABLE_FINAL_FIELD
+ #undef VTABLE_NAME_FIELD
  
  
  /* Search for the last _class ref in the chain of references of this
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c	(revision 233626)
--- gcc/fortran/trans-intrinsic.c	(working copy)
*************** gfc_conv_associated (gfc_se *se, gfc_exp
*** 6775,6781 ****
  
  
  /* Generate code for the SAME_TYPE_AS intrinsic.
!    Generate inline code that directly checks the vindices.  */
  
  static void
  gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
--- 6775,6781 ----
  
  
  /* Generate code for the SAME_TYPE_AS intrinsic.
!    Generate inline code that directly checks the full names.  */
  
  static void
  gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
*************** gfc_conv_same_type_as (gfc_se *se, gfc_e
*** 6784,6789 ****
--- 6784,6790 ----
    gfc_se se1, se2;
    tree tmp;
    tree conda = NULL_TREE, condb = NULL_TREE;
+   char *c;
  
    gfc_init_se (&se1, NULL);
    gfc_init_se (&se2, NULL);
*************** gfc_conv_same_type_as (gfc_se *se, gfc_e
*** 6808,6834 ****
    if (a->ts.type == BT_CLASS)
      {
        gfc_add_vptr_component (a);
!       gfc_add_hash_component (a);
      }
    else if (a->ts.type == BT_DERIVED)
!     a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
! 			  a->ts.u.derived->hash_value);
  
    if (b->ts.type == BT_CLASS)
      {
        gfc_add_vptr_component (b);
!       gfc_add_hash_component (b);
      }
    else if (b->ts.type == BT_DERIVED)
!     b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
! 			  b->ts.u.derived->hash_value);
  
    gfc_conv_expr (&se1, a);
    gfc_conv_expr (&se2, b);
  
    tmp = fold_build2_loc (input_location, EQ_EXPR,
! 			 boolean_type_node, se1.expr,
! 			 fold_convert (TREE_TYPE (se1.expr), se2.expr));
  
    if (conda)
      tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
--- 6809,6868 ----
    if (a->ts.type == BT_CLASS)
      {
        gfc_add_vptr_component (a);
!       gfc_add_name_component (a);
      }
    else if (a->ts.type == BT_DERIVED)
!     {
!       c = XCNEWVEC (char, 2*GFC_MAX_SYMBOL_LEN + 2);
!       gfc_select_type_name (c, NULL, a->ts.u.derived);
!       a = gfc_get_character_expr (gfc_default_character_kind, NULL,
! 				  c, strlen (c));
!       free (c);
!     }
  
    if (b->ts.type == BT_CLASS)
      {
        gfc_add_vptr_component (b);
!       gfc_add_name_component (b);
      }
    else if (b->ts.type == BT_DERIVED)
!     {
!       c = XCNEWVEC (char, 2*GFC_MAX_SYMBOL_LEN + 2);
!       gfc_select_type_name (c, NULL, b->ts.u.derived);
!       b = gfc_get_character_expr (gfc_default_character_kind, NULL,
! 				  c, strlen (c));
!       free (c);
!     }
  
    gfc_conv_expr (&se1, a);
    gfc_conv_expr (&se2, b);
  
+   gfc_add_block_to_block (&se->pre, &se1.pre);
+   gfc_add_block_to_block (&se->pre, &se2.pre);
+ 
+   gfc_conv_string_parameter (&se1);
+   gfc_conv_string_parameter (&se2);
+ 
+   /* The string length of the '_name' field in the vtables is fixed
+      at 2*GFC_MAX_SYMBOL_LEN + 1, whereas the constant expressions
+      for derived types have whatever length the name itself is. Use
+      the minimum of the two lengths for memcmp.  */
+   tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ 			 se1.string_length, se2.string_length);
+   tmp = fold_build3_loc (input_location, COND_EXPR,
+ 			 TREE_TYPE (se1.string_length),
+ 			 tmp, se1.string_length, se2.string_length);
+ 
+   /* Use memcmp to compare the strings.  */
+   tmp = build_call_expr_loc (input_location,
+ 			     builtin_decl_explicit (BUILT_IN_MEMCMP),
+ 			     3, se1.expr, se2.expr, tmp);
    tmp = fold_build2_loc (input_location, EQ_EXPR,
! 			 boolean_type_node,
! 			 tmp, build_int_cst (TREE_TYPE (tmp), 0));
! 
!   gfc_add_block_to_block (&se->post, &se1.post);
!   gfc_add_block_to_block (&se->post, &se2.post);
  
    if (conda)
      tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
Index: gcc/testsuite/gfortran.dg/finalize_21.f90
===================================================================
*** gcc/testsuite/gfortran.dg/finalize_21.f90	(revision 233626)
--- 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_35.f90
===================================================================
*** gcc/testsuite/gfortran.dg/select_type_35.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/select_type_35.f90	(working copy)
***************
*** 0 ****
--- 1,64 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for pr69834, in which the hash values for the
+ ! derived types 'CS5SS' and 'SQS3C' are the same thereby
+ ! generating the error:
+ ! "CASE label at (1) overlaps with CASE label at (2)" in 'sub'.
+ !
+ ! Since the fix involves replacing the hash by a full name
+ ! 'typename_scopename', SELECT TYPE and SAME_TYPE_AS have to
+ ! be tested. Whilst the tests below probably occur elsewhere
+ ! in the testsuite, they are worth repeating because they
+ ! represent sticking points during the development of the fix.
+ !
+ module types
+    implicit none
+    type CS5SS
+       integer x
+       real y
+    end type CS5SS
+    type SQS3C
+       logical u
+       character(7) v
+    end type SQS3C
+    contains
+       integer function sub(x)
+          class(*), intent(in) :: x
+          select type(x)
+             class default
+                sub = 0
+                select type (x)
+                  type is (real(4))
+                    sub = -1
+                end select
+             type is(CS5SS)
+                sub = 1
+             type is(SQS3C)
+                sub = 2
+          end select
+       end function sub
+ end module types
+ 
+ program test
+    use types
+    implicit none
+    class(*), allocatable :: u1, u2
+    real(4) :: z
+    type (CS5SS) :: w
+    type (SQS3C) :: u
+    allocate(u1,source = CS5SS(5,1.414))
+    allocate(u2,source = SQS3C(.TRUE.,'Message'))
+    if (sub(u1) .ne. 1) call abort
+    if (sub(u2) .ne. 2) call abort
+    if (sub(z) .ne. -1) call abort
+    if (sub(0_4) .ne. 0) call abort
+ 
+    if (same_type_as (u1, u2)) call abort
+    deallocate (u2)
+    allocate(u2,source = CS5SS(5,1.414))
+    if (.not.same_type_as (u1, u2)) call abort
+    if (same_type_as (w, u)) call abort
+    if (.not.same_type_as (CS5SS(5,1.414), w)) call abort
+    if (same_type_as (u2, u)) call abort
+    if (.not.same_type_as (u2, w)) call abort
+ end program test

Re: [Patch, fortran] PR69834 - Collision in derived type hashes

[Jerry DeLisle]

On 03/03/2016 07:59 AM, Paul Richard Thomas wrote:
> Dear All,
> 
> What started out as a provisional kludge, when first working on OOP,
> has come back to bite us after 7 years. A collision in derived type
> has values has been reported on clf. In principle, as pointed out in
> the clf thread, this could mean that existing code might be quietly
> confusing dynamic types. Fortunately, this is unlikely because the
> error in SELECT TYPE that flagged up this problem might appear or
> incorrect fields might be accessed, giving rise to runtime errors.
> 
> The fix uses a new vtable field, '_name' that is loaded with the
> value, "typename_scopename", which is used for the cases in SELECT
> TYPE and for comparison in SAME_TYPE_AS. I have retained the '_hash'
> field for compatibility with existing libraries. It could easily be
> removed, if that is preferred, but would require a publicity campaign
> to ensure that users recompile their code.
> 
> The changes are sufficiently well described in the ChangeLogs and the
> comments in the patch to not warrant further comment.
> 
> I have to confess to not knowing quite what to propose here. My gut
> feeling is that we should bite the bullet and the patch should be
> applied to trunk and 5-branch. However, I am open, on the grounds
> above, to wait until 7.0.0. It does bootstrap and regtest on trunk
> with FC23/x86_64.
> 
> Thanks to Dominique for testing an early version of the test and to
> Thomas for picking up on the clf thread.
> 

In my very humble opinion, I think you should commit the patch now before
release. As I have said before, people know major releases are bleeding edge,
bugs if any will be flushed out and can be fixed at 6.2 or 6.3.  It is the open
nature of our software and the user feedback that makes this all work. (also we
know Fortran is not release critical)

I tested with my own OOP code which is an adaptation of Metcalf's linked anylist
and it works fine.  Thats the best I can do and it is fairly complex code.  I
can send it to you if you would like to have it in your test pile.

Regards,

Jerry

Re: [Patch, fortran] PR69834 - Collision in derived type hashes

[Paul Richard Thomas]

Dear Jerry,

I have been distracted by other matters and will not be able to do
anything about this for a couple of weeks. I will try to get over the
problem with submodules with the alternative patch, which uses the
pointer to the vtable as a type identifier. It must be possible to do
this and would be much neater, since the comparison in select type and
same_type_as would be a long integer, rather than a long string!

Please send me the Metcalfe testcase. I already have it somewhere but
don't seem able to lay hands on it.

Best regards

Paul

On 3 March 2016 at 21:31, Jerry DeLisle <jvdelisle@charter.net> wrote:
> On 03/03/2016 07:59 AM, Paul Richard Thomas wrote:
>> Dear All,
>>
>> What started out as a provisional kludge, when first working on OOP,
>> has come back to bite us after 7 years. A collision in derived type
>> has values has been reported on clf. In principle, as pointed out in
>> the clf thread, this could mean that existing code might be quietly
>> confusing dynamic types. Fortunately, this is unlikely because the
>> error in SELECT TYPE that flagged up this problem might appear or
>> incorrect fields might be accessed, giving rise to runtime errors.
>>
>> The fix uses a new vtable field, '_name' that is loaded with the
>> value, "typename_scopename", which is used for the cases in SELECT
>> TYPE and for comparison in SAME_TYPE_AS. I have retained the '_hash'
>> field for compatibility with existing libraries. It could easily be
>> removed, if that is preferred, but would require a publicity campaign
>> to ensure that users recompile their code.
>>
>> The changes are sufficiently well described in the ChangeLogs and the
>> comments in the patch to not warrant further comment.
>>
>> I have to confess to not knowing quite what to propose here. My gut
>> feeling is that we should bite the bullet and the patch should be
>> applied to trunk and 5-branch. However, I am open, on the grounds
>> above, to wait until 7.0.0. It does bootstrap and regtest on trunk
>> with FC23/x86_64.
>>
>> Thanks to Dominique for testing an early version of the test and to
>> Thomas for picking up on the clf thread.
>>
>
> In my very humble opinion, I think you should commit the patch now before
> release. As I have said before, people know major releases are bleeding edge,
> bugs if any will be flushed out and can be fixed at 6.2 or 6.3.  It is the open
> nature of our software and the user feedback that makes this all work. (also we
> know Fortran is not release critical)
>
> I tested with my own OOP code which is an adaptation of Metcalf's linked anylist
> and it works fine.  Thats the best I can do and it is fairly complex code.  I
> can send it to you if you would like to have it in your test pile.
>
> Regards,
>
> Jerry



-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein

Re: [Patch, fortran] PR69834 - Collision in derived type hashes

[Janus Weil]

Hi guys,

>> I will set aside the patch and wait for the release of 6.2 unless there
>> is demand for it to be applied now. I am somewhat nervous about doing
>> this, however, since it is a rather radical change to select type and
>> has been in trunk for less than two weeks.
>
> This is the usual egg and chicken dilemma which can only be solved by tester(s).
> IMO, as usual, the sooner the better. Note that any commit can be reverted if the
> exposed problem cannot be fixed quickly.

I'd actually vote to wait for the 6.3 release (6.2 is out already,
right?). This is quite an invasive patch, and I'm afraid it could
potentially break all kinds of stuff (even though I believe that Paul
has prepared it very carefully).

I think it's kind of important to have the release branches in a
stable state and not risk too much there. Whoever wants a
bleeding-edge gfortran, with all the latest features and fixes, should
get a trunk build.

Cheers,
Janus

Re: [Patch, fortran] PR69834 - Collision in derived type hashes

[Dominique d'Humières]

> Dear All,
>
> I was intending to backport this patch to 6-branch. However, I see
> that this is closed to all but regressions and documentation at
> present.
>
> The patch applies cleanly, except for two small chunks in resolve.c
> which were easily inserted by hand, and bootstraps and regtests OK.
> I will set aside the patch and wait for the release of 6.2 unless there
> is demand for it to be applied now. I am somewhat nervous about doing
> this, however, since it is a rather radical change to select type and
> has been in trunk for less than two weeks.
>
> Cheers
>
> Paul 

This is the usual egg and chicken dilemma which can only be solved by tester(s).
IMO, as usual, the sooner the better. Note that any commit can be reverted if the
exposed problem cannot be fixed quickly.

Cheers,

Dominique

Re: [Patch, fortran] PR69834 - Collision in derived type hashes

[Paul Richard Thomas]

Dear All,

I was intending to backport this patch to 6-branch. However, I see
that this is closed to all but regressions and documentation at
present.

The patch applies cleanly, except for two small chunks in resolve.c
which were easily inserted by hand, and bootstraps and regtests OK. I
will set aside the patch and wait for the release of 6.2 unless there
is demand for it to be applied now. I am somewhat nervous about doing
this, however, since it is a rather radical change to select type and
has been in trunk for less than two weeks.

Cheers

Paul

On 24 October 2016 at 12:18, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Hi Andre,
>
> It was the comment for the function that you eliminated. I'll get rid
> of the comment. I was in a bit of a hurry and did indeed only look
> where you suggested. Sorry about that.
>
> Thanks
>
> Paul
>
> On 24 October 2016 at 11:07, Andre Vehreschild <vehre@gmx.de> wrote:
>> Hi Paul,
>>
>> concerning this:
>>
>>> >> Index: gcc/fortran/trans-stmt.c
>>> >> ===================================================================
>>> >> *** gcc/fortran/trans-stmt.c    (revision 241439)
>>> >> --- gcc/fortran/trans-stmt.c    (working copy)
>>> >> *************** gfc_trans_do_while (gfc_code * code)
>>> >> *** 2331,2336 ****
>>> >> --- 2331,2455 ----
>>> > <snipp>
>>> >> +
>>> >> +   /* Translate an assignment to a CLASS object
>>> >> +      (pointer or ordinary assignment).  */
>>> >> +
>>> >> +
>>> >
>>> > Here is no routine the above comment could document. Left over from prior
>>> > version?
>>>
>>> This is in your tree, not mine :-)
>>
>> Well, now it is in everyone's tree. But I am guilty of pasting the wrong
>> location. The correct one is:
>>
>>> Index: gcc/fortran/trans-expr.c
>>> ===================================================================
>>> *** gcc/fortran/trans-expr.c  (revision 241439)
>>> --- gcc/fortran/trans-expr.c  (working copy)
>>> *************** gfc_trans_class_init_assign (gfc_code *c
>>> *** 1508,1513 ****
>>>   }
>>>
>>>
>>> + /* Return the backend_decl for the vtable of an arbitrary typespec
>>> +    and the vtable symbol.  */
>>> +
>>> + tree
>>> + gfc_get_vtable_decl (gfc_typespec *ts, gfc_symbol **vtab)
>>> + {
>>> +   gfc_symbol *vtable = gfc_find_vtab (ts);
>>> +   gcc_assert (vtable != NULL);
>>> +   if (vtab != NULL)
>>> +     *vtab = vtable;
>>> +   if (vtable->backend_decl == NULL_TREE)
>>> +     return gfc_get_symbol_decl (vtable);
>>> +   else
>>> +     return vtable->backend_decl;
>>> + }
>>> +
>>> +
>>> +   /* Translate an assignment to a CLASS object
>>> +      (pointer or ordinary assignment).  */
>>> +
>>
>> Still I do not see what the above documents. The next function is
>> realloc_lhs_warning () and the comment makes no sense to it.
>>
>>> +
>>>   /* End of prototype trans-class.c  */
>>
>> Regards,
>>         Andre
>> --
>> Andre Vehreschild * Email: vehre ad gmx dot de
>
>
>
> --
> The difference between genius and stupidity is; genius has its limits.
>
> Albert Einstein



-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein

Re: [Patch, fortran] PR69834 - Collision in derived type hashes

[Paul Richard Thomas]

Hi Andre,

It was the comment for the function that you eliminated. I'll get rid
of the comment. I was in a bit of a hurry and did indeed only look
where you suggested. Sorry about that.

Thanks

Paul

On 24 October 2016 at 11:07, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi Paul,
>
> concerning this:
>
>> >> Index: gcc/fortran/trans-stmt.c
>> >> ===================================================================
>> >> *** gcc/fortran/trans-stmt.c    (revision 241439)
>> >> --- gcc/fortran/trans-stmt.c    (working copy)
>> >> *************** gfc_trans_do_while (gfc_code * code)
>> >> *** 2331,2336 ****
>> >> --- 2331,2455 ----
>> > <snipp>
>> >> +
>> >> +   /* Translate an assignment to a CLASS object
>> >> +      (pointer or ordinary assignment).  */
>> >> +
>> >> +
>> >
>> > Here is no routine the above comment could document. Left over from prior
>> > version?
>>
>> This is in your tree, not mine :-)
>
> Well, now it is in everyone's tree. But I am guilty of pasting the wrong
> location. The correct one is:
>
>> Index: gcc/fortran/trans-expr.c
>> ===================================================================
>> *** gcc/fortran/trans-expr.c  (revision 241439)
>> --- gcc/fortran/trans-expr.c  (working copy)
>> *************** gfc_trans_class_init_assign (gfc_code *c
>> *** 1508,1513 ****
>>   }
>>
>>
>> + /* Return the backend_decl for the vtable of an arbitrary typespec
>> +    and the vtable symbol.  */
>> +
>> + tree
>> + gfc_get_vtable_decl (gfc_typespec *ts, gfc_symbol **vtab)
>> + {
>> +   gfc_symbol *vtable = gfc_find_vtab (ts);
>> +   gcc_assert (vtable != NULL);
>> +   if (vtab != NULL)
>> +     *vtab = vtable;
>> +   if (vtable->backend_decl == NULL_TREE)
>> +     return gfc_get_symbol_decl (vtable);
>> +   else
>> +     return vtable->backend_decl;
>> + }
>> +
>> +
>> +   /* Translate an assignment to a CLASS object
>> +      (pointer or ordinary assignment).  */
>> +
>
> Still I do not see what the above documents. The next function is
> realloc_lhs_warning () and the comment makes no sense to it.
>
>> +
>>   /* End of prototype trans-class.c  */
>
> Regards,
>         Andre
> --
> Andre Vehreschild * Email: vehre ad gmx dot de



-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein

Re: [Patch, fortran] PR69834 - Collision in derived type hashes

[Andre Vehreschild]

Hi Paul,

concerning this:

> >> Index: gcc/fortran/trans-stmt.c
> >> ===================================================================
> >> *** gcc/fortran/trans-stmt.c    (revision 241439)
> >> --- gcc/fortran/trans-stmt.c    (working copy)
> >> *************** gfc_trans_do_while (gfc_code * code)
> >> *** 2331,2336 ****
> >> --- 2331,2455 ----  
> > <snipp>  
> >> +
> >> +   /* Translate an assignment to a CLASS object
> >> +      (pointer or ordinary assignment).  */
> >> +
> >> +  
> >
> > Here is no routine the above comment could document. Left over from prior
> > version?  
> 
> This is in your tree, not mine :-)

Well, now it is in everyone's tree. But I am guilty of pasting the wrong
location. The correct one is:

> Index: gcc/fortran/trans-expr.c
> ===================================================================
> *** gcc/fortran/trans-expr.c	(revision 241439)
> --- gcc/fortran/trans-expr.c	(working copy)
> *************** gfc_trans_class_init_assign (gfc_code *c
> *** 1508,1513 ****
>   }
> 
> 
> + /* Return the backend_decl for the vtable of an arbitrary typespec
> +    and the vtable symbol.  */
> +
> + tree
> + gfc_get_vtable_decl (gfc_typespec *ts, gfc_symbol **vtab)
> + {
> +   gfc_symbol *vtable = gfc_find_vtab (ts);
> +   gcc_assert (vtable != NULL);
> +   if (vtab != NULL)
> +     *vtab = vtable;
> +   if (vtable->backend_decl == NULL_TREE)
> +     return gfc_get_symbol_decl (vtable);
> +   else
> +     return vtable->backend_decl;
> + }
> +
> +
> +   /* Translate an assignment to a CLASS object
> +      (pointer or ordinary assignment).  */
> +

Still I do not see what the above documents. The next function is
realloc_lhs_warning () and the comment makes no sense to it.

> +
>   /* End of prototype trans-class.c  */

Regards,
	Andre
-- 
Andre Vehreschild * Email: vehre ad gmx dot de 

Re: [Patch, fortran] PR69834 - Collision in derived type hashes

[Paul Richard Thomas]

Hi Andre,

Thanks for the review.  I have partially responded to your comments - see below.

Committed as revision 241450.

Cheers

Paul

On 23 October 2016 at 14:45, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi Paul,
>
> here are my comments to your patch:
>
>> Index: gcc/fortran/class.c
>> ===================================================================
>> *** gcc/fortran/class.c (revision 241439)
>> --- gcc/fortran/class.c (working copy)
>> *************** add_procs_to_declared_vtab (gfc_symbol *
>> --- 2187,2219 ----
>>   gfc_symbol *
>>   gfc_find_derived_vtab (gfc_symbol *derived)
>>   {
>> !   gfc_namespace *ns = NULL;
>
> Setting this to NULL for consistency?

Indeed - =NULL eliminated. It was needed in one incarnation of the patch.


>
>> Index: gcc/fortran/dump-parse-tree.c
>> ===================================================================
>> *** gcc/fortran/dump-parse-tree.c       (revision 241439)
>> --- gcc/fortran/dump-parse-tree.c       (working copy)
>> *************** show_code_node (int level, gfc_code *c)
>> *** 1843,1848 ****
>> --- 1843,1877 ----
>
> Well, the code in this chunk is identical to the one of EXEC_SELECT, besides
> two lines where the statement's name is printed. I propose to do something like:
>
> case EXEC_SELECT:
> case EXEC_SELECT_TYPE:
>   d= ..
>   fputs ("SELECT", dumpfile);
>   if (c->op == EXEC_SELECT_TYPE)
>     fputs (" TYPE", dumpfile);
>  ...
>   // and the same for "END SELECT..."
>
> This would reduce the amount of copied code. An improvement in one
> EXEC_SELECT-dump-handler would then automagically available in the other, too.

Have done this, except for the end, where I have retained "END SELECT" for both.

>
>> Index: gcc/fortran/resolve.c
>> ===================================================================
>> *** gcc/fortran/resolve.c       (revision 241439)
>> --- gcc/fortran/resolve.c       (working copy)
> <snipp>
>> *************** resolve_select_type (gfc_code *code, gfc
> <snipp>
>> --- 8595,8641 ----
>>     else
>>       ns->code->next = new_st;
>>     code = new_st;
>> !   code->op = EXEC_SELECT_TYPE;
>>
>> +   /* Use the intrinsic LOC function to generate the an integer expression
>> +      for the vtable of the selector.  Note that the rank of the selector
>> +      expression has to be set to zero.  */
>
> double article:                                    _the an_  !!!

Corrected - thanks.

>
>> Index: gcc/fortran/trans-stmt.c
>> ===================================================================
>> *** gcc/fortran/trans-stmt.c    (revision 241439)
>> --- gcc/fortran/trans-stmt.c    (working copy)
>> *************** gfc_trans_do_while (gfc_code * code)
>> *** 2331,2336 ****
>> --- 2331,2455 ----
> <snipp>
>> +
>> +   /* Translate an assignment to a CLASS object
>> +      (pointer or ordinary assignment).  */
>> +
>> +
>
> Here is no routine the above comment could document. Left over from prior
> version?

This is in your tree, not mine :-)

>
>>   /* End of prototype trans-class.c  */
>
>
>> Index: gcc/fortran/trans-stmt.c
>> ===================================================================
>> *** gcc/fortran/trans-stmt.c    (revision 241439)
>> --- gcc/fortran/trans-stmt.c    (working copy)
>> *************** gfc_trans_do_while (gfc_code * code)
>> *** 2331,2336 ****
>> --- 2331,2455 ----
>
> Can one optimize this by using the "old style" for intrinsic types, i.e. a
> computed goto (switch-case) for them? And in the default case the if-chain on
> the derived types/classes? Would we gain any speed by this? What is your
> opinion on this?

Maybe this would gain something but I suspect that it would not amount to much.

>
>> Please find attached a revised version of the patch that corrects one
>> or two tiny wrinkles. I have removed the tidy up of vtable retrieval
>
> I haven't understood yet, what you need to do for this. Looking forward to that
> patch.

OK will submit this separately.

>
> With the above small changes the patch is ok for trunk given that Dominique
> doesn't find any issues.
>
> Beware, that my big patch on polymorphic assignment will *not* be backported
> to gcc-6. I.e., this version of your patch will most probably not be applyable.
> You rather will need to apply the old version.
>
> Thanks for the work.
>
> Regards,
>         Andre
>
>> Functionally, the patch is as described in the original submission.
>>
>> As attached, it bootstraps and regtests on FC21/x86_64.  OK for trunk
>> and, after a decent interval for 6-branch?
>>
>> Cheers
>>
>> Paul
>>
>> 2016-10-22  Paul Thomas  <pault@gcc.gnu.org>
>>
>>     PR fortran/69834
>>     * class.c (gfc_find_derived_vtab): Obtain the gsymbol for the
>>     derived type's module. If the gsymbol is present and the top
>>     level namespace corresponds to a module, use the gsymbol name
>>     space. In the search to see if the vtable exists, try the gsym
>>     namespace first.
>>     * dump-parse-tree (show_code_node): Add explicit dump for the
>>     select type construct.
>>     * resolve.c (build_loc_call): New function.
>>     (resolve_select_type): Add check for repeated type is cases.
>>     Retain selector expression and use it later instead of expr1.
>>     Exclude deferred length TYPE IS cases and emit error message.
>>     Store the address for the vtable in the 'low' expression and
>>     the hash value in the 'high' expression, for each case. Do not
>>     call resolve_select.
>>     * trans.c(trans_code) : Call gfc_trans_select_type.
>>     * trans-stmt.c (gfc_trans_select_type_cases): New function.
>>     (gfc_trans_select_type): New function.
>>     * trans-stmt.h : Add prototype for gfc_trans_select_type.
>>
>> 2016-10-22  Paul Thomas  <pault@gcc.gnu.org>
>>
>>     PR fortran/69834
>>     * gfortran.dg/select_type_1.f03: Change error for overlapping
>>     TYPE IS cases.
>>     * gfortran.dg/select_type_36.f03: New test.
>
>
> --
> Andre Vehreschild * Email: vehre ad gmx dot de



-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein

Re: [Patch, fortran] PR69834 - Collision in derived type hashes

[Andre Vehreschild]

Hi Paul,

here are my comments to your patch:

> Index: gcc/fortran/class.c
> ===================================================================
> *** gcc/fortran/class.c (revision 241439)
> --- gcc/fortran/class.c (working copy)
> *************** add_procs_to_declared_vtab (gfc_symbol *
> --- 2187,2219 ----
>   gfc_symbol *
>   gfc_find_derived_vtab (gfc_symbol *derived)
>   {
> !   gfc_namespace *ns = NULL;

Setting this to NULL for consistency?

> Index: gcc/fortran/dump-parse-tree.c
> ===================================================================
> *** gcc/fortran/dump-parse-tree.c       (revision 241439)
> --- gcc/fortran/dump-parse-tree.c       (working copy)
> *************** show_code_node (int level, gfc_code *c)
> *** 1843,1848 ****
> --- 1843,1877 ----

Well, the code in this chunk is identical to the one of EXEC_SELECT, besides
two lines where the statement's name is printed. I propose to do something like:

case EXEC_SELECT:
case EXEC_SELECT_TYPE:
  d= ..
  fputs ("SELECT", dumpfile);
  if (c->op == EXEC_SELECT_TYPE)
    fputs (" TYPE", dumpfile);
 ...
  // and the same for "END SELECT..."

This would reduce the amount of copied code. An improvement in one
EXEC_SELECT-dump-handler would then automagically available in the other, too.

> Index: gcc/fortran/resolve.c
> ===================================================================
> *** gcc/fortran/resolve.c       (revision 241439)
> --- gcc/fortran/resolve.c       (working copy)
<snipp>
> *************** resolve_select_type (gfc_code *code, gfc
<snipp>
> --- 8595,8641 ----
>     else
>       ns->code->next = new_st;
>     code = new_st;
> !   code->op = EXEC_SELECT_TYPE;
> 
> +   /* Use the intrinsic LOC function to generate the an integer expression
> +      for the vtable of the selector.  Note that the rank of the selector
> +      expression has to be set to zero.  */

double article:                                    _the an_  !!!

> Index: gcc/fortran/trans-stmt.c
> ===================================================================
> *** gcc/fortran/trans-stmt.c    (revision 241439)
> --- gcc/fortran/trans-stmt.c    (working copy)
> *************** gfc_trans_do_while (gfc_code * code)
> *** 2331,2336 ****
> --- 2331,2455 ----
<snipp>
> +
> +   /* Translate an assignment to a CLASS object
> +      (pointer or ordinary assignment).  */
> +
> +

Here is no routine the above comment could document. Left over from prior
version?

>   /* End of prototype trans-class.c  */


> Index: gcc/fortran/trans-stmt.c
> ===================================================================
> *** gcc/fortran/trans-stmt.c    (revision 241439)
> --- gcc/fortran/trans-stmt.c    (working copy)
> *************** gfc_trans_do_while (gfc_code * code)
> *** 2331,2336 ****
> --- 2331,2455 ----

Can one optimize this by using the "old style" for intrinsic types, i.e. a
computed goto (switch-case) for them? And in the default case the if-chain on
the derived types/classes? Would we gain any speed by this? What is your
opinion on this?

> Please find attached a revised version of the patch that corrects one
> or two tiny wrinkles. I have removed the tidy up of vtable retrieval

I haven't understood yet, what you need to do for this. Looking forward to that
patch.

With the above small changes the patch is ok for trunk given that Dominique
doesn't find any issues.

Beware, that my big patch on polymorphic assignment will *not* be backported
to gcc-6. I.e., this version of your patch will most probably not be applyable.
You rather will need to apply the old version.

Thanks for the work.

Regards,
	Andre

> Functionally, the patch is as described in the original submission.
> 
> As attached, it bootstraps and regtests on FC21/x86_64.  OK for trunk
> and, after a decent interval for 6-branch?
> 
> Cheers
> 
> Paul
> 
> 2016-10-22  Paul Thomas  <pault@gcc.gnu.org>
> 
>     PR fortran/69834
>     * class.c (gfc_find_derived_vtab): Obtain the gsymbol for the
>     derived type's module. If the gsymbol is present and the top
>     level namespace corresponds to a module, use the gsymbol name
>     space. In the search to see if the vtable exists, try the gsym
>     namespace first.
>     * dump-parse-tree (show_code_node): Add explicit dump for the
>     select type construct.
>     * resolve.c (build_loc_call): New function.
>     (resolve_select_type): Add check for repeated type is cases.
>     Retain selector expression and use it later instead of expr1.
>     Exclude deferred length TYPE IS cases and emit error message.
>     Store the address for the vtable in the 'low' expression and
>     the hash value in the 'high' expression, for each case. Do not
>     call resolve_select.
>     * trans.c(trans_code) : Call gfc_trans_select_type.
>     * trans-stmt.c (gfc_trans_select_type_cases): New function.
>     (gfc_trans_select_type): New function.
>     * trans-stmt.h : Add prototype for gfc_trans_select_type.
> 
> 2016-10-22  Paul Thomas  <pault@gcc.gnu.org>
> 
>     PR fortran/69834
>     * gfortran.dg/select_type_1.f03: Change error for overlapping
>     TYPE IS cases.
>     * gfortran.dg/select_type_36.f03: New test.


-- 
Andre Vehreschild * Email: vehre ad gmx dot de 

Re: [Patch, fortran] PR69834 - Collision in derived type hashes

[Paul Richard Thomas]

Hi Dominique,

I forgot to include the change to select_type_9.f03 in the diff. Since
I was going to improve the logic in detecting repeated type is/class
is, I might as well change the error messages too.

Andre's class assign patch regtests OK, as advertised.

Thanks

Paul

On 22 October 2016 at 10:21, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> I also see
>
> FAIL: gfortran.dg/select_type_9.f03   -O   (test for errors, line 16)
> FAIL: gfortran.dg/select_type_9.f03   -O  (test for excess errors)
>
> The errors emitted by the test have changed from
>
> /opt/gcc/_clean/gcc/testsuite/gfortran.dg/select_type_9.f03:16:11:
>
>   class is (t)  ! { dg-error "Double CLASS IS block" }
>            1
> Error: Double CLASS IS block in SELECT TYPE statement at (1)
>
> to
>
> /opt/gcc/_clean/gcc/testsuite/gfortran.dg/select_type_9.f03:16:11:
>
> /opt/gcc/_clean/gcc/testsuite/gfortran.dg/select_type_9.f03:14:11:
>
>   class is (t)
>            2
> /opt/gcc/_clean/gcc/testsuite/gfortran.dg/select_type_9.f03:16:11:
>
>   class is (t)  ! { dg-error "Double CLASS IS block" }
>            1
> Error: CASE label at (1) overlaps with CASE label at (2)
>
> Dominique
>
>> Le 22 oct. 2016 à 09:11, Paul Richard Thomas <paul.richard.thomas@gmail.com> a écrit :
>>
>> Hi Dominique,
>>
>> Thanks for the heads up!
>>
>> I was going to review Andre's patch this morning, so I will clean my
>> tree, apply it, confirm that it is regression free and then will
>> generate a compatible version of my patch for PR69834. I strongly
>> suspect that the core of the patch is OK and that it is the clean-up
>> element that is failing to apply.
>>
>> Best regards
>>
>> Paul
>>
>>
>> On 22 October 2016 at 01:04, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
>>> Dear Paul,
>>>
>>> If I did not do any mistake, this patch conflicts seriously with Andre’s one
>>> at https://gcc.gnu.org/ml/fortran/2016-10/msg00141.html.
>>>
>>> Cheers,
>>>
>>> Dominique
>>>
>>
>>
>>
>> --
>> The difference between genius and stupidity is; genius has its limits.
>>
>> Albert Einstein
>



-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein

Re: [Patch, fortran] PR69834 - Collision in derived type hashes

[Dominique d'Humières]

I also see

FAIL: gfortran.dg/select_type_9.f03   -O   (test for errors, line 16)
FAIL: gfortran.dg/select_type_9.f03   -O  (test for excess errors)

The errors emitted by the test have changed from

/opt/gcc/_clean/gcc/testsuite/gfortran.dg/select_type_9.f03:16:11:

  class is (t)  ! { dg-error "Double CLASS IS block" }
           1
Error: Double CLASS IS block in SELECT TYPE statement at (1)

to

/opt/gcc/_clean/gcc/testsuite/gfortran.dg/select_type_9.f03:16:11:

/opt/gcc/_clean/gcc/testsuite/gfortran.dg/select_type_9.f03:14:11:

  class is (t)
           2
/opt/gcc/_clean/gcc/testsuite/gfortran.dg/select_type_9.f03:16:11:

  class is (t)  ! { dg-error "Double CLASS IS block" }
           1
Error: CASE label at (1) overlaps with CASE label at (2)

Dominique

> Le 22 oct. 2016 à 09:11, Paul Richard Thomas <paul.richard.thomas@gmail.com> a écrit :
> 
> Hi Dominique,
> 
> Thanks for the heads up!
> 
> I was going to review Andre's patch this morning, so I will clean my
> tree, apply it, confirm that it is regression free and then will
> generate a compatible version of my patch for PR69834. I strongly
> suspect that the core of the patch is OK and that it is the clean-up
> element that is failing to apply.
> 
> Best regards
> 
> Paul
> 
> 
> On 22 October 2016 at 01:04, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
>> Dear Paul,
>> 
>> If I did not do any mistake, this patch conflicts seriously with Andre’s one
>> at https://gcc.gnu.org/ml/fortran/2016-10/msg00141.html.
>> 
>> Cheers,
>> 
>> Dominique
>> 
> 
> 
> 
> -- 
> The difference between genius and stupidity is; genius has its limits.
> 
> Albert Einstein

Re: [Patch, fortran] PR69834 - Collision in derived type hashes

[Paul Richard Thomas]

Hi Dominique,

Thanks for the heads up!

I was going to review Andre's patch this morning, so I will clean my
tree, apply it, confirm that it is regression free and then will
generate a compatible version of my patch for PR69834. I strongly
suspect that the core of the patch is OK and that it is the clean-up
element that is failing to apply.

Best regards

Paul


On 22 October 2016 at 01:04, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> Dear Paul,
>
> If I did not do any mistake, this patch conflicts seriously with Andre’s one
> at https://gcc.gnu.org/ml/fortran/2016-10/msg00141.html.
>
> Cheers,
>
> Dominique
>



-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein

[Patch, fortran] PR69834 - Collision in derived type hashes

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 4322 bytes --]

Dear All,

I had the attached patch more or less working at the end of January.
However, there was a regression with submodule_6.f03, which I had
quite a struggle with and only resolved yesterday.

Until now, select type used the hash value to do the type selection
with the inevitable consequence that a collision occurred; albeit a
good number of years after the introduction of OOP. The new testcase
is that of the reporter.

I had developed a fix that used the full, composite string containing
the type name and its module. This works fine but the string length is
such that there is a significant performance hit.

Mikael suggested to use the address of the vtable for type selection
and, apart from the regression mentioned above, this was pretty easy
to get going and causes no measurable performance hit.

The problem with submodule_6.f08 was that of multiple versions of the
vtable for derived type 't_b'. The modifications to
class.c(gfc_find_derived_vtab) provide the solution to this issue and
ensure that the vtable is unique. See the comments in the patch to
understand the mechanism.

I have retained the use of the hash value for intrinsic types, since I
know that there are no collisions there. For classes and derived
types, the addresses of the corresponding vtables are used.
resolve_select_type has been modified accordingly. Note that since
select type is no longer translated into select case, a test for
repeated cases had to be introduced. I retained the original message.
If desired the logic could be broken out into a separate function and
the message modified to reflect the source being select type rather
than select case.

The translation now occurs in two functions in trans-stmt.c. The
implementation is straight forward. Note that I have used a series of
if (condition) {block;goto end_label;} rather than stacked if () {}
else {}'s. This reduces the complexity somewhat and should not lead to
any significant performance problems.

I took the opportunity to eliminate the repeated code chunks that
obtain the symbol for the vtable and then obtain the backend_decl by
packing this into a new function. This constitutes the second block in
the fortran ChangeLog.

Bootstrapped and regtested on FC21/x86_64 - OK for trunk?

It crosses my mind that although this is not a regression, it might be
a good idea to port the patch to 6-branch in a month or two, since it
constitutes a potentially silent gotcha.

Cheers

Paul

2016-10-21  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/69834
    * class.c (gfc_find_derived_vtab): Obtain the gsymbol for the
    derived type's module. If the gsymbol is present and the top
    level namespace corresponds to a module, use the gsymbol name
    space. In the search to see if the vtable exists, try the gsym
    namespace first.
    * dump-parse-tree (show_code_node): Add explicit dump for the
    select type construct.
    * resolve.c (build_loc_call): New function.
    (resolve_select_type): Add check for repeated type is cases.
    Retain selector expression and use it later instead of expr1.
    Store the address for the vtable in the 'low' expression and
    the hash value in the 'high' expression, for each case. Do not
    call resolve_select.
    * trans.c(trans_code) : Call gfc_trans_select_type.
    * trans-stmt.c (gfc_trans_select_type_cases): New function.
    (gfc_trans_select_type): New function.
    * trans-stmt.h : Add prototype for gfc_trans_select_type.

    Tidy up retrieval of vtable backend decl.
    * trans.h : Add prototype for gfc_get_vtable_decl.
    * trans-array.c (structure_alloc_comps): Use it.
    * trans-decl.c (gfc_get_symbol_decl, gfc_trans_deferred_vars,
    gfc_trans_deferred_vars): The same.
    * trans-expr.c (gfc_get_vtable_decl): New function to obtain
    the vtable symbol and its backend decl for any typespec.
    (gfc_reset_vptr, gfc_conv_derived_to_class,
    gfc_conv_intrinsic_to_class, gfc_trans_class_assign,
    gfc_conv_procedure_call,gfc_trans_subcomponent_assign): Use it.
    trans-intrinsic.c (scalar_transfer, conv_intrinsic_move_alloc):
    The same.
    trans-io.c (transfer_namelist_element): The same.
    trans-stmt.c (gfc_trans_allocate): The same.

2016-10-21  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/69834
    * gfortran.dg/select_type_36.f03: New test.

[-- Attachment #2: submit.diff --]
[-- Type: text/plain, Size: 38065 bytes --]

Index: gcc/fortran/class.c
===================================================================
*** gcc/fortran/class.c	(revision 241393)
--- gcc/fortran/class.c	(working copy)
*************** add_procs_to_declared_vtab (gfc_symbol *
*** 2187,2204 ****
  gfc_symbol *
  gfc_find_derived_vtab (gfc_symbol *derived)
  {
!   gfc_namespace *ns;
    gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
    gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
  
    /* Find the top-level namespace.  */
    for (ns = gfc_current_ns; ns; ns = ns->parent)
      if (!ns->parent)
        break;
  
!   /* If the type is a class container, use the underlying derived type.  */
!   if (!derived->attr.unlimited_polymorphic && derived->attr.is_class)
!     derived = gfc_get_derived_super_type (derived);
  
    if (ns)
      {
--- 2187,2219 ----
  gfc_symbol *
  gfc_find_derived_vtab (gfc_symbol *derived)
  {
!   gfc_namespace *ns = NULL;
    gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
    gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
+   gfc_gsymbol *gsym = NULL;
+ 
+   /* If the type is a class container, use the underlying derived type.  */
+   if (!derived->attr.unlimited_polymorphic && derived->attr.is_class)
+     derived = gfc_get_derived_super_type (derived);
  
    /* Find the top-level namespace.  */
    for (ns = gfc_current_ns; ns; ns = ns->parent)
      if (!ns->parent)
        break;
  
!   /* Find the gsymbol for the module of use associated derived types.  */
!   if ((derived->attr.use_assoc || derived->attr.used_in_submodule)
!        && !derived->attr.vtype && !derived->attr.is_class)
!     gsym =  gfc_find_gsymbol (gfc_gsym_root, derived->module);
!   else
!     gsym = NULL;
! 
!   /* Work in the gsymbol namespace if the top-level namespace is a module.
!      This ensures that the vtable is unique, which is required since we use
!      its address in SELECT TYPE.  */
!   if (gsym && gsym->ns && ns && ns->proc_name
!       && ns->proc_name->attr.flavor == FL_MODULE)
!     ns = gsym->ns;
  
    if (ns)
      {
*************** gfc_find_derived_vtab (gfc_symbol *deriv
*** 2208,2214 ****
        sprintf (name, "__vtab_%s", tname);
  
        /* Look for the vtab symbol in various namespaces.  */
!       gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
        if (vtab == NULL)
  	gfc_find_symbol (name, ns, 0, &vtab);
        if (vtab == NULL)
--- 2223,2236 ----
        sprintf (name, "__vtab_%s", tname);
  
        /* Look for the vtab symbol in various namespaces.  */
!       if (gsym && gsym->ns)
! 	{
! 	  gfc_find_symbol (name, gsym->ns, 0, &vtab);
! 	  if (vtab)
! 	    ns = gsym->ns;
! 	}
!       if (vtab == NULL)
! 	gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
        if (vtab == NULL)
  	gfc_find_symbol (name, ns, 0, &vtab);
        if (vtab == NULL)
Index: gcc/fortran/dump-parse-tree.c
===================================================================
*** gcc/fortran/dump-parse-tree.c	(revision 241393)
--- gcc/fortran/dump-parse-tree.c	(working copy)
*************** show_code_node (int level, gfc_code *c)
*** 1843,1848 ****
--- 1843,1877 ----
        fputs ("END SELECT", dumpfile);
        break;
  
+     case EXEC_SELECT_TYPE:
+       d = c->block;
+       fputs ("SELECT TYPE ", dumpfile);
+       show_expr (c->expr1);
+       fputc ('\n', dumpfile);
+ 
+       for (; d; d = d->block)
+ 	{
+ 	  code_indent (level, 0);
+ 
+ 	  fputs ("CASE ", dumpfile);
+ 	  for (cp = d->ext.block.case_list; cp; cp = cp->next)
+ 	    {
+ 	      fputc ('(', dumpfile);
+ 	      show_expr (cp->low);
+ 	      fputc (' ', dumpfile);
+ 	      show_expr (cp->high);
+ 	      fputc (')', dumpfile);
+ 	      fputc (' ', dumpfile);
+ 	    }
+ 	  fputc ('\n', dumpfile);
+ 
+ 	  show_code (level + 1, d->next);
+ 	}
+ 
+       code_indent (level, c->label1);
+       fputs ("END SELECT TYPE", dumpfile);
+       break;
+ 
      case EXEC_WHERE:
        fputs ("WHERE ", dumpfile);
  
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c	(revision 241393)
--- gcc/fortran/parse.c	(working copy)
*************** check_component (gfc_symbol *sym, gfc_co
*** 2824,2830 ****
        coarray = true;
        sym->attr.coarray_comp = 1;
      }
!  
    if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
        && !c->attr.pointer)
      {
--- 2824,2830 ----
        coarray = true;
        sym->attr.coarray_comp = 1;
      }
! 
    if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
        && !c->attr.pointer)
      {
*************** parse_union (void)
*** 2988,2994 ****
            /* Add a component to the union for each map. */
            if (!gfc_add_component (un, gfc_new_block->name, &c))
              {
!               gfc_internal_error ("failed to create map component '%s'", 
                    gfc_new_block->name);
                reject_statement ();
                return;
--- 2988,2994 ----
            /* Add a component to the union for each map. */
            if (!gfc_add_component (un, gfc_new_block->name, &c))
              {
!               gfc_internal_error ("failed to create map component '%s'",
                    gfc_new_block->name);
                reject_statement ();
                return;
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 241393)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_assoc_var (gfc_symbol* sym, bool
*** 8327,8332 ****
--- 8327,8351 ----
  }
  
  
+ static gfc_expr *
+ build_loc_call (gfc_expr *sym_expr)
+ {
+   gfc_expr *loc_call;
+   loc_call = gfc_get_expr ();
+   loc_call->expr_type = EXPR_FUNCTION;
+   gfc_get_sym_tree ("loc", gfc_current_ns, &loc_call->symtree, false);
+   loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+   loc_call->symtree->n.sym->attr.intrinsic = 1;
+   loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
+   gfc_commit_symbol (loc_call->symtree->n.sym);
+   loc_call->ts.type = BT_INTEGER;
+   loc_call->ts.kind = gfc_index_integer_kind;
+   loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC);
+   loc_call->value.function.actual = gfc_get_actual_arglist ();
+   loc_call->value.function.actual->expr = sym_expr;
+   return loc_call;
+ }
+ 
  /* Resolve a SELECT TYPE statement.  */
  
  static void
*************** resolve_select_type (gfc_code *code, gfc
*** 8341,8346 ****
--- 8360,8366 ----
    gfc_namespace *ns;
    int error = 0;
    int charlen = 0;
+   gfc_expr *selector_expr = NULL;
  
    ns = code->ext.block.ns;
    gfc_resolve (ns);
*************** resolve_select_type (gfc_code *code, gfc
*** 8389,8394 ****
--- 8409,8441 ----
      {
        c = body->ext.block.case_list;
  
+       if (!error)
+ 	{
+ 	  /* Check for repeated cases.  */
+ 	  for (tail = code->block; tail; tail = tail->block)
+ 	    {
+ 	      gfc_case *d = tail->ext.block.case_list;
+ 	      if (tail == body)
+ 		break;
+ 
+ 	      if (c->ts.type == d->ts.type
+ 		  && (((c->ts.type == BT_DERIVED
+ 			|| c->ts.type == BT_CLASS)
+ 		       && c->ts.u.derived
+ 		       && !strcmp (c->ts.u.derived->name,
+ 				   d->ts.u.derived->name))
+ 		      || c->ts.type == BT_UNKNOWN
+ 		      || (!(c->ts.type == BT_DERIVED
+ 			    || c->ts.type == BT_CLASS)
+ 			  && c->ts.kind == d->ts.kind)))
+ 		{
+ 		  gfc_error ("CASE label at %L overlaps with CASE label at %L",
+ 			     &c->where, &d->where);
+ 		  return;
+ 		}
+ 	    }
+ 	}
+ 
        /* 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
*** 8480,8510 ****
    else
      ns->code->next = new_st;
    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)
  	{
! 	  gfc_symbol *ivtab;
! 	  gfc_expr *e;
  
! 	  ivtab = gfc_find_vtab (&c->ts);
! 	  gcc_assert (ivtab && CLASS_DATA (ivtab)->initializer);
! 	  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
--- 8527,8573 ----
    else
      ns->code->next = new_st;
    code = new_st;
!   code->op = EXEC_SELECT_TYPE;
  
+   /* Use the intrinsic LOC function to generate the an integer expression
+      for the vtable of the selector.  Note that the rank of the selector
+      expression has to be set to zero.  */
    gfc_add_vptr_component (code->expr1);
!   code->expr1->rank = 0;
!   code->expr1 = build_loc_call (code->expr1);
!   selector_expr = code->expr1->value.function.actual->expr;
  
    /* Loop over TYPE IS / CLASS IS cases.  */
    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
! 	 TYPE/CLASS vtable and store it in c->low.  The hash expression
! 	 is stored in c->high and is used to resolve intrinsic cases.  */
!       if (c->ts.type != BT_UNKNOWN)
  	{
! 	  if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
! 	    {
! 	      vtab = gfc_find_derived_vtab (c->ts.u.derived);
! 	      gcc_assert (vtab);
! 	      c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
! 					  c->ts.u.derived->hash_value);
! 	    }
! 	  else
! 	    {
! 	      vtab = gfc_find_vtab (&c->ts);
! 	      gcc_assert (vtab && CLASS_DATA (vtab)->initializer);
! 	      e = CLASS_DATA (vtab)->initializer;
! 	      c->high = gfc_copy_expr (e);
! 	    }
  
! 	  e = gfc_lval_expr_from_sym (vtab);
! 	  c->low = build_loc_call (e);
  	}
!       else
  	continue;
  
        /* Associate temporary to selector.  This should only be done
*************** resolve_select_type (gfc_code *code, gfc
*** 8530,8537 ****
  
        st = gfc_find_symtree (ns->sym_root, name);
        gcc_assert (st->n.sym->assoc);
!       st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
!       st->n.sym->assoc->target->where = code->expr1->where;
        if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
  	gfc_add_data_component (st->n.sym->assoc->target);
  
--- 8593,8600 ----
  
        st = gfc_find_symtree (ns->sym_root, name);
        gcc_assert (st->n.sym->assoc);
!       st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
!       st->n.sym->assoc->target->where = selector_expr->where;
        if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
  	gfc_add_data_component (st->n.sym->assoc->target);
  
*************** resolve_select_type (gfc_code *code, gfc
*** 8646,8652 ****
  	  new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
  	  /* Set up arguments.  */
  	  new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
! 	  new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
  	  new_st->expr1->value.function.actual->expr->where = code->loc;
  	  gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
  	  vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
--- 8709,8715 ----
  	  new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
  	  /* Set up arguments.  */
  	  new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
! 	  new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree);
  	  new_st->expr1->value.function.actual->expr->where = code->loc;
  	  gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
  	  vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
*************** resolve_select_type (gfc_code *code, gfc
*** 8671,8678 ****
    gfc_current_ns = ns;
    gfc_resolve_blocks (code->block, gfc_current_ns);
    gfc_current_ns = old_ns;
- 
-   resolve_select (code, true);
  }
  
  
--- 8734,8739 ----
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 241393)
--- gcc/fortran/trans-array.c	(working copy)
*************** structure_alloc_comps (gfc_symbol * der_
*** 8135,8145 ****
  		{
  		  /* Build the vtable address and set the vptr with it.  */
  		  tree vtab;
! 		  gfc_symbol *vtable;
! 		  vtable = gfc_find_derived_vtab (c->ts.u.derived);
! 		  vtab = vtable->backend_decl;
! 		  if (vtab == NULL_TREE)
! 		    vtab = gfc_get_symbol_decl (vtable);
  		  vtab = gfc_build_addr_expr (NULL, vtab);
  		  vtab = fold_convert (TREE_TYPE (tmp), vtab);
  		  gfc_add_modify (&tmpblock, tmp, vtab);
--- 8135,8141 ----
  		{
  		  /* Build the vtable address and set the vptr with it.  */
  		  tree vtab;
! 		  vtab = gfc_get_vtable_decl (&c->ts, NULL);
  		  vtab = gfc_build_addr_expr (NULL, vtab);
  		  vtab = fold_convert (TREE_TYPE (tmp), vtab);
  		  gfc_add_modify (&tmpblock, tmp, vtab);
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c	(revision 241393)
--- gcc/fortran/trans.c	(working copy)
*************** trans_code (gfc_code * code, tree cond)
*** 1832,1841 ****
  	  break;
  
  	case EXEC_SELECT_TYPE:
! 	  /* Do nothing. SELECT TYPE statements should be transformed into
! 	  an ordinary SELECT CASE at resolution stage.
! 	  TODO: Add an error message here once this is done.  */
! 	  res = NULL_TREE;
  	  break;
  
  	case EXEC_FLUSH:
--- 1832,1838 ----
  	  break;
  
  	case EXEC_SELECT_TYPE:
! 	  res = gfc_trans_select_type (code);
  	  break;
  
  	case EXEC_FLUSH:
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c	(revision 241393)
--- gcc/fortran/trans-decl.c	(working copy)
*************** gfc_finish_var_decl (tree decl, gfc_symb
*** 617,623 ****
    else if (sym->module && !sym->attr.result && !sym->attr.dummy)
      {
        /* TODO: Don't set sym->module for result or dummy variables.  */
-       gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
  
        TREE_PUBLIC (decl) = 1;
        TREE_STATIC (decl) = 1;
--- 617,622 ----
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1429,1435 ****
        gfc_component *c = CLASS_DATA (sym);
        if (!c->ts.u.derived->backend_decl)
  	{
! 	  gfc_find_derived_vtab (c->ts.u.derived);
  	  gfc_get_derived_type (sym->ts.u.derived);
  	}
      }
--- 1428,1434 ----
        gfc_component *c = CLASS_DATA (sym);
        if (!c->ts.u.derived->backend_decl)
  	{
! 	  gfc_get_vtable_decl (&c->ts, NULL);
  	  gfc_get_derived_type (sym->ts.u.derived);
  	}
      }
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4221,4229 ****
  	    vptr = null_pointer_node;
  	  else
  	    {
! 	      gfc_symbol *vsym;
! 	      vsym = gfc_find_derived_vtab (sym->ts.u.derived);
! 	      vptr = gfc_get_symbol_decl (vsym);
  	      vptr = gfc_build_addr_expr (NULL, vptr);
  	    }
  
--- 4220,4226 ----
  	    vptr = null_pointer_node;
  	  else
  	    {
! 	      vptr = gfc_get_vtable_decl (&sym->ts, NULL);
  	      vptr = gfc_build_addr_expr (NULL, vptr);
  	    }
  
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4455,4461 ****
  	      if (sym->ts.type == BT_CLASS)
  		{
  		  /* Initialize _vptr to declared type.  */
- 		  gfc_symbol *vtab;
  		  tree rhs;
  
  		  gfc_save_backend_locus (&loc);
--- 4452,4457 ----
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4470,4478 ****
  		    rhs = build_int_cst (TREE_TYPE (se.expr), 0);
  		  else
  		    {
! 		      vtab = gfc_find_derived_vtab (sym->ts.u.derived);
! 		      rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
! 						gfc_get_symbol_decl (vtab));
  		    }
  		  gfc_add_modify (&init, se.expr, rhs);
  		  gfc_restore_backend_locus (&loc);
--- 4466,4473 ----
  		    rhs = build_int_cst (TREE_TYPE (se.expr), 0);
  		  else
  		    {
! 		      rhs = gfc_get_vtable_decl (&sym->ts, NULL);
! 		      rhs = gfc_build_addr_expr (TREE_TYPE (se.expr), rhs);
  		    }
  		  gfc_add_modify (&init, se.expr, rhs);
  		  gfc_restore_backend_locus (&loc);
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 241393)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_find_and_cut_at_last_class_ref (gfc_
*** 411,417 ****
  void
  gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
  {
-   gfc_symbol *vtab;
    tree vptr;
    tree vtable;
    gfc_se se;
--- 411,416 ----
*************** gfc_reset_vptr (stmtblock_t *block, gfc_
*** 434,443 ****
    else
      {
        /* Return the vptr to the address of the declared type.  */
!       vtab = gfc_find_derived_vtab (e->ts.u.derived);
!       vtable = vtab->backend_decl;
!       if (vtable == NULL_TREE)
! 	vtable = gfc_get_symbol_decl (vtab);
        vtable = gfc_build_addr_expr (NULL, vtable);
        vtable = fold_convert (TREE_TYPE (vptr), vtable);
        gfc_add_modify (block, vptr, vtable);
--- 433,439 ----
    else
      {
        /* Return the vptr to the address of the declared type.  */
!       vtable = gfc_get_vtable_decl (&e->ts, NULL);
        vtable = gfc_build_addr_expr (NULL, vtable);
        vtable = fold_convert (TREE_TYPE (vptr), vtable);
        gfc_add_modify (block, vptr, vtable);
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 537,543 ****
  			   gfc_typespec class_ts, tree vptr, bool optional,
  			   bool optional_alloc_ptr)
  {
-   gfc_symbol *vtab;
    tree cond_optional = NULL_TREE;
    gfc_ss *ss;
    tree ctree;
--- 533,538 ----
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 561,569 ****
      {
        /* In this case the vtab corresponds to the derived type and the
  	 vptr must point to it.  */
!       vtab = gfc_find_derived_vtab (e->ts.u.derived);
!       gcc_assert (vtab);
!       tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
      }
    gfc_add_modify (&parmse->pre, ctree,
  		  fold_convert (TREE_TYPE (ctree), tmp));
--- 556,563 ----
      {
        /* In this case the vtab corresponds to the derived type and the
  	 vptr must point to it.  */
!       tmp = gfc_get_vtable_decl (&e->ts, NULL);
!       tmp = gfc_build_addr_expr (NULL_TREE, tmp);
      }
    gfc_add_modify (&parmse->pre, ctree,
  		  fold_convert (TREE_TYPE (ctree), tmp));
*************** void
*** 789,795 ****
  gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
  			     gfc_typespec class_ts)
  {
-   gfc_symbol *vtab;
    gfc_ss *ss;
    tree ctree;
    tree var;
--- 783,788 ----
*************** gfc_conv_intrinsic_to_class (gfc_se *par
*** 803,811 ****
    /* Set the vptr.  */
    ctree = gfc_class_vptr_get (var);
  
!   vtab = gfc_find_vtab (&e->ts);
!   gcc_assert (vtab);
!   tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
    gfc_add_modify (&parmse->pre, ctree,
  		  fold_convert (TREE_TYPE (ctree), tmp));
  
--- 796,803 ----
    /* Set the vptr.  */
    ctree = gfc_class_vptr_get (var);
  
!   tmp = gfc_get_vtable_decl (&e->ts, NULL);
!   tmp = gfc_build_addr_expr (NULL_TREE, tmp);
    gfc_add_modify (&parmse->pre, ctree,
  		  fold_convert (TREE_TYPE (ctree), tmp));
  
*************** gfc_trans_class_assign (gfc_expr *expr1,
*** 1542,1552 ****
  	}
  
        if (expr2->expr_type == EXPR_NULL)
! 	vtab = gfc_find_vtab (&expr1->ts);
        else
! 	vtab = gfc_find_vtab (&expr2->ts);
!       gcc_assert (vtab);
! 
        rhs = gfc_get_expr ();
        rhs->expr_type = EXPR_VARIABLE;
        gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
--- 1534,1542 ----
  	}
  
        if (expr2->expr_type == EXPR_NULL)
! 	gfc_get_vtable_decl (&expr1->ts, &vtab);
        else
! 	gfc_get_vtable_decl (&expr2->ts, &vtab);
        rhs = gfc_get_expr ();
        rhs->expr_type = EXPR_VARIABLE;
        gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
*************** assign:
*** 1606,1611 ****
--- 1596,1617 ----
  }
  
  
+ /* Return the backend_decl for the vtable of an arbitrary typespec
+    and the vtable symbol.  */
+ 
+ tree
+ gfc_get_vtable_decl (gfc_typespec *ts, gfc_symbol **vtab)
+ {
+   gfc_symbol *vtable = gfc_find_vtab (ts);
+   gcc_assert (vtable != NULL);
+   if (vtab != NULL)
+     *vtab = vtable;
+   if (vtable->backend_decl == NULL_TREE)
+     return gfc_get_symbol_decl (vtable);
+   else
+     return vtable->backend_decl;
+ }
+ 
  /* End of prototype trans-class.c  */
  
  
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5317,5325 ****
  			}
  		      else if (fsym->ts.type == BT_CLASS)
  			{
! 			  gfc_symbol *vtab;
! 			  vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
! 			  tmp = gfc_get_symbol_decl (vtab);
  			  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
  			  ptr = gfc_class_vptr_get (parmse.expr);
  			  gfc_add_modify (&block, ptr,
--- 5323,5329 ----
  			}
  		      else if (fsym->ts.type == BT_CLASS)
  			{
! 			  tmp = gfc_get_vtable_decl (&fsym->ts, NULL);
  			  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
  			  ptr = gfc_class_vptr_get (parmse.expr);
  			  gfc_add_modify (&block, ptr,
*************** gfc_trans_subcomponent_assign (tree dest
*** 7327,7333 ****
  	   && CLASS_DATA (cm)->attr.allocatable
  	   && expr->ts.type == BT_DERIVED)
      {
!       vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
        vtab = gfc_build_addr_expr (NULL_TREE, vtab);
        tmp = gfc_class_vptr_get (dest);
        gfc_add_modify (&block, tmp,
--- 7331,7337 ----
  	   && CLASS_DATA (cm)->attr.allocatable
  	   && expr->ts.type == BT_DERIVED)
      {
!       vtab = gfc_get_vtable_decl (&expr->ts, NULL);
        vtab = gfc_build_addr_expr (NULL_TREE, vtab);
        tmp = gfc_class_vptr_get (dest);
        gfc_add_modify (&block, tmp,
*************** gfc_trans_subcomponent_assign (tree dest
*** 7369,7375 ****
  	{
  	  tmp = gfc_class_data_get (dest);
  	  tmp = build_fold_indirect_ref_loc (input_location, tmp);
! 	  vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
  	  vtab = gfc_build_addr_expr (NULL_TREE, vtab);
  	  gfc_add_modify (&block, gfc_class_vptr_get (dest),
  		 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
--- 7373,7379 ----
  	{
  	  tmp = gfc_class_data_get (dest);
  	  tmp = build_fold_indirect_ref_loc (input_location, tmp);
! 	  vtab = gfc_get_vtable_decl (&expr->ts, NULL);
  	  vtab = gfc_build_addr_expr (NULL_TREE, vtab);
  	  gfc_add_modify (&block, gfc_class_vptr_get (dest),
  		 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 241393)
--- gcc/fortran/trans.h	(working copy)
*************** void gfc_conv_derived_to_class (gfc_se *
*** 415,420 ****
--- 415,421 ----
  				bool);
  void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
  			      bool, bool);
+ tree gfc_get_vtable_decl (gfc_typespec *, gfc_symbol **);
  
  /* Initialize an init/cleanup block.  */
  void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c	(revision 241393)
--- gcc/fortran/trans-intrinsic.c	(working copy)
*************** scalar_transfer:
*** 7303,7313 ****
        if (mold_expr->ts.type == BT_CLASS)
  	{
  	  tree vptr;
- 	  gfc_symbol *vtab;
  	  vptr = gfc_class_vptr_get (tmpdecl);
! 	  vtab = gfc_find_derived_vtab (source_expr->ts.u.derived);
! 	  gcc_assert (vtab);
! 	  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
  	  gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp));
  	}
  
--- 7303,7311 ----
        if (mold_expr->ts.type == BT_CLASS)
  	{
  	  tree vptr;
  	  vptr = gfc_class_vptr_get (tmpdecl);
! 	  tmp = gfc_get_vtable_decl (&source_expr->ts, NULL);
! 	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
  	  gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp));
  	}
  
*************** conv_intrinsic_move_alloc (gfc_code *cod
*** 10299,10308 ****
  	      if (UNLIMITED_POLY (from_expr))
  		vtab = NULL;
  	      else
! 		{
! 		  vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
! 		  gcc_assert (vtab);
! 		}
  
  	      gfc_free_expr (from_expr2);
  	      gfc_init_se (&from_se, NULL);
--- 10297,10303 ----
  	      if (UNLIMITED_POLY (from_expr))
  		vtab = NULL;
  	      else
! 		tmp = gfc_get_vtable_decl (&from_expr->ts, &vtab);
  
  	      gfc_free_expr (from_expr2);
  	      gfc_init_se (&from_se, NULL);
*************** conv_intrinsic_move_alloc (gfc_code *cod
*** 10321,10336 ****
  						  null_pointer_node));
  	      else
  		{
! 		  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
  		  gfc_add_modify_loc (input_location, &block, from_se.expr,
  				      fold_convert (TREE_TYPE (from_se.expr), tmp));
  		}
  	    }
  	  else
  	    {
! 	      vtab = gfc_find_vtab (&from_expr->ts);
! 	      gcc_assert (vtab);
! 	      tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
  	      gfc_add_modify_loc (input_location, &block, to_se.expr,
  				  fold_convert (TREE_TYPE (to_se.expr), tmp));
  	    }
--- 10316,10330 ----
  						  null_pointer_node));
  	      else
  		{
! 		  tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
  		  gfc_add_modify_loc (input_location, &block, from_se.expr,
  				      fold_convert (TREE_TYPE (from_se.expr), tmp));
  		}
  	    }
  	  else
  	    {
! 	      tmp = gfc_get_vtable_decl (&from_expr->ts, &vtab);
! 	      tmp = gfc_build_addr_expr (NULL_TREE, tmp);
  	      gfc_add_modify_loc (input_location, &block, to_se.expr,
  				  fold_convert (TREE_TYPE (to_se.expr), tmp));
  	    }
*************** conv_intrinsic_move_alloc (gfc_code *cod
*** 10353,10359 ****
    if (to_expr->ts.type == BT_CLASS)
      {
        gfc_symbol *vtab;
- 
        to_se.want_pointer = 1;
        to_expr2 = gfc_copy_expr (to_expr);
        gfc_add_vptr_component (to_expr2);
--- 10347,10352 ----
*************** conv_intrinsic_move_alloc (gfc_code *cod
*** 10362,10373 ****
        if (from_expr->ts.type == BT_CLASS)
  	{
  	  if (UNLIMITED_POLY (from_expr))
- 	    vtab = NULL;
- 	  else
  	    {
! 	      vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
! 	      gcc_assert (vtab);
  	    }
  
  	  from_se.want_pointer = 1;
  	  from_expr2 = gfc_copy_expr (from_expr);
--- 10355,10366 ----
        if (from_expr->ts.type == BT_CLASS)
  	{
  	  if (UNLIMITED_POLY (from_expr))
  	    {
! 	      vtab = NULL;
! 	      tmp = NULL_TREE;
  	    }
+ 	  else
+ 	    tmp = gfc_get_vtable_decl (&from_expr->ts, &vtab);
  
  	  from_se.want_pointer = 1;
  	  from_expr2 = gfc_copy_expr (from_expr);
*************** conv_intrinsic_move_alloc (gfc_code *cod
*** 10385,10400 ****
  					      null_pointer_node));
  	  else
  	    {
! 	      tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
  	      gfc_add_modify_loc (input_location, &block, from_se.expr,
  				  fold_convert (TREE_TYPE (from_se.expr), tmp));
  	    }
  	}
        else
  	{
! 	  vtab = gfc_find_vtab (&from_expr->ts);
! 	  gcc_assert (vtab);
! 	  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
  	  gfc_add_modify_loc (input_location, &block, to_se.expr,
  			      fold_convert (TREE_TYPE (to_se.expr), tmp));
  	}
--- 10378,10392 ----
  					      null_pointer_node));
  	  else
  	    {
! 	      tmp = gfc_build_addr_expr (NULL_TREE, tmp);
  	      gfc_add_modify_loc (input_location, &block, from_se.expr,
  				  fold_convert (TREE_TYPE (from_se.expr), tmp));
  	    }
  	}
        else
  	{
! 	  tmp = gfc_get_vtable_decl (&from_expr->ts, NULL);
! 	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
  	  gfc_add_modify_loc (input_location, &block, to_se.expr,
  			      fold_convert (TREE_TYPE (to_se.expr), tmp));
  	}
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c	(revision 241393)
--- gcc/fortran/trans-io.c	(working copy)
*************** transfer_namelist_element (stmtblock_t *
*** 1683,1689 ****
    if (ts->type == BT_DERIVED)
      {
        gfc_symbol *dtio_sub = NULL;
-       gfc_symbol *vtab;
        dtio_sub = gfc_find_specific_dtio_proc (ts->u.derived,
  					      last_dt == WRITE,
  					      true);
--- 1683,1688 ----
*************** transfer_namelist_element (stmtblock_t *
*** 1691,1700 ****
  	{
  	  dtio_proc = gfc_get_symbol_decl (dtio_sub);
  	  dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
! 	  vtab = gfc_find_derived_vtab (ts->u.derived);
! 	  vtable = vtab->backend_decl;
! 	  if (vtable == NULL_TREE)
! 	    vtable = gfc_get_symbol_decl (vtab);
  	  vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
  	}
      }
--- 1690,1696 ----
  	{
  	  dtio_proc = gfc_get_symbol_decl (dtio_sub);
  	  dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
! 	  vtable = gfc_get_vtable_decl (&c->ts, NULL);
  	  vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
  	}
      }
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 241393)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** gfc_trans_do_while (gfc_code * code)
*** 2331,2336 ****
--- 2331,2455 ----
  }
  
  
+ /* Deal with the particular case of SELECT_TYPE, where the vtable
+    addresses are used for the selection. Since these are not sorted,
+    the selection has to be made by a series of if statements.  */
+ 
+ static tree
+ gfc_trans_select_type_cases (gfc_code * code)
+ {
+   gfc_code *c;
+   gfc_case *cp;
+   tree tmp;
+   tree cond;
+   tree low;
+   tree high;
+   gfc_se se;
+   gfc_se cse;
+   stmtblock_t block;
+   stmtblock_t body;
+   bool def = false;
+   gfc_expr *e;
+   gfc_start_block (&block);
+ 
+   /* Calculate the switch expression.  */
+   gfc_init_se (&se, NULL);
+   gfc_conv_expr_val (&se, code->expr1);
+   gfc_add_block_to_block (&block, &se.pre);
+ 
+   /* Generate an expression for the selector hash value, for
+      use to resolve character cases.  */
+   e = gfc_copy_expr (code->expr1->value.function.actual->expr);
+   gfc_add_hash_component (e);
+ 
+   TREE_USED (code->exit_label) = 0;
+ 
+ repeat:
+   for (c = code->block; c; c = c->block)
+     {
+       cp = c->ext.block.case_list;
+ 
+       /* Assume it's the default case.  */
+       low = NULL_TREE;
+       high = NULL_TREE;
+       tmp = NULL_TREE;
+ 
+       /* Put the default case at the end.  */
+       if ((!def && !cp->low) || (def && cp->low))
+ 	continue;
+ 
+       if (cp->low && (cp->ts.type == BT_CLASS
+ 		      || cp->ts.type == BT_DERIVED))
+ 	{
+ 	  gfc_init_se (&cse, NULL);
+ 	  gfc_conv_expr_val (&cse, cp->low);
+ 	  gfc_add_block_to_block (&block, &cse.pre);
+ 	  low = cse.expr;
+ 	}
+       else if (cp->ts.type != BT_UNKNOWN)
+ 	{
+ 	  gcc_assert (cp->high);
+ 	  gfc_init_se (&cse, NULL);
+ 	  gfc_conv_expr_val (&cse, cp->high);
+ 	  gfc_add_block_to_block (&block, &cse.pre);
+ 	  high = cse.expr;
+ 	}
+ 
+       gfc_init_block (&body);
+ 
+       /* Add the statements for this case.  */
+       tmp = gfc_trans_code (c->next);
+       gfc_add_expr_to_block (&body, tmp);
+ 
+       /* Break to the end of the SELECT TYPE construct.  The default
+ 	 case just falls through.  */
+       if (!def)
+ 	{
+ 	  TREE_USED (code->exit_label) = 1;
+ 	  tmp = build1_v (GOTO_EXPR, code->exit_label);
+ 	  gfc_add_expr_to_block (&body, tmp);
+ 	}
+ 
+       tmp = gfc_finish_block (&body);
+ 
+       if (low != NULL_TREE)
+ 	{
+ 	  /* Compare vtable pointers.  */
+ 	  cond = fold_build2_loc (input_location, EQ_EXPR,
+ 				  TREE_TYPE (se.expr), se.expr, low);
+ 	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ 				 cond, tmp,
+ 				 build_empty_stmt (input_location));
+ 	}
+       else if (high != NULL_TREE)
+ 	{
+ 	  /* Compare hash values for character cases.  */
+ 	  gfc_init_se (&cse, NULL);
+ 	  gfc_conv_expr_val (&cse, e);
+ 	  gfc_add_block_to_block (&block, &cse.pre);
+ 
+ 	  cond = fold_build2_loc (input_location, EQ_EXPR,
+ 				  TREE_TYPE (se.expr), high, cse.expr);
+ 	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ 				 cond, tmp,
+ 				 build_empty_stmt (input_location));
+ 	}
+ 
+       gfc_add_expr_to_block (&block, tmp);
+     }
+ 
+   if (!def)
+     {
+       def = true;
+       goto repeat;
+     }
+ 
+   gfc_free_expr (e);
+ 
+   return gfc_finish_block (&block);
+ }
+ 
+ 
  /* Translate the SELECT CASE construct for INTEGER case expressions,
     without killing all potential optimizations.  The problem is that
     Fortran allows unbounded cases, but the back-end does not, so we
*************** gfc_trans_select (gfc_code * code)
*** 2972,2977 ****
--- 3091,3125 ----
    return gfc_finish_block (&block);
  }
  
+ tree
+ gfc_trans_select_type (gfc_code * code)
+ {
+   stmtblock_t block;
+   tree body;
+   tree exit_label;
+ 
+   gcc_assert (code && code->expr1);
+   gfc_init_block (&block);
+ 
+   /* Build the exit label and hang it in.  */
+   exit_label = gfc_build_label_decl (NULL_TREE);
+   code->exit_label = exit_label;
+ 
+   /* Empty SELECT constructs are legal.  */
+   if (code->block == NULL)
+     body = build_empty_stmt (input_location);
+   else
+     body = gfc_trans_select_type_cases (code);
+ 
+   /* Build everything together.  */
+   gfc_add_expr_to_block (&block, body);
+ 
+   if (TREE_USED (exit_label))
+     gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
+ 
+   return gfc_finish_block (&block);
+ }
+ 
  
  /* Traversal function to substitute a replacement symtree if the symbol
     in the expression is the same as that passed.  f == 2 signals that
*************** gfc_trans_allocate (gfc_code * code)
*** 5591,5603 ****
  	  if (vtab_needed)
  	    {
  	      /* VPTR is fixed at compile time.  */
! 	      gfc_symbol *vtab;
! 
! 	      vtab = gfc_find_vtab (&code->expr3->ts);
! 	      gcc_assert (vtab);
! 	      expr3_vptr = gfc_get_symbol_decl (vtab);
! 	      expr3_vptr = gfc_build_addr_expr (NULL_TREE,
! 						expr3_vptr);
  	    }
  	  /* _len component needs to be set, when ts is a character
  	     array.  */
--- 5739,5746 ----
  	  if (vtab_needed)
  	    {
  	      /* VPTR is fixed at compile time.  */
! 	      expr3_vptr = gfc_get_vtable_decl (&code->expr3->ts, NULL);
! 	      expr3_vptr = gfc_build_addr_expr (NULL_TREE, expr3_vptr);
  	    }
  	  /* _len component needs to be set, when ts is a character
  	     array.  */
*************** gfc_trans_allocate (gfc_code * code)
*** 5970,5976 ****
  	  else
  	    {
  	      /* VPTR is fixed at compile time.  */
- 	      gfc_symbol *vtab;
  	      gfc_typespec *ts;
  
  	      if (code->expr3)
--- 6113,6118 ----
*************** gfc_trans_allocate (gfc_code * code)
*** 5988,5997 ****
  		/* Prepare for setting the vtab as declared.  */
  		ts = &expr->ts;
  
! 	      vtab = gfc_find_vtab (ts);
! 	      gcc_assert (vtab);
! 	      tmp = gfc_build_addr_expr (NULL_TREE,
! 					 gfc_get_symbol_decl (vtab));
  	      gfc_add_modify (&block, al_vptr,
  			      fold_convert (TREE_TYPE (al_vptr), tmp));
  	    }
--- 6130,6137 ----
  		/* Prepare for setting the vtab as declared.  */
  		ts = &expr->ts;
  
! 	      tmp = gfc_get_vtable_decl (ts, NULL);
! 	      tmp = gfc_build_addr_expr (NULL_TREE, tmp);
  	      gfc_add_modify (&block, al_vptr,
  			      fold_convert (TREE_TYPE (al_vptr), tmp));
  	    }
Index: gcc/fortran/trans-stmt.h
===================================================================
*** gcc/fortran/trans-stmt.h	(revision 241393)
--- gcc/fortran/trans-stmt.h	(working copy)
*************** tree gfc_trans_do (gfc_code *, tree);
*** 53,58 ****
--- 53,59 ----
  tree gfc_trans_do_concurrent (gfc_code *);
  tree gfc_trans_do_while (gfc_code *);
  tree gfc_trans_select (gfc_code *);
+ tree gfc_trans_select_type (gfc_code *);
  tree gfc_trans_sync (gfc_code *, gfc_exec_op);
  tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op);
  tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op);
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

Re: [Patch, fortran] PR69834 - Collision in derived type hashes

[Paul Richard Thomas]

Dear All,

After submitting the patch, I did something that I should have done a
long time ago: some timing tests :-)

I used actual_array_offset_1.f90, which is based on Arjen Markus's
implementation of quicksort using unlimited polymorphic entities as
carriers of the objects to be sorted.

With 10^5 elements in the array and -O3, without the patch, the
execution time is 49ms. With the patch it climbs to 315ms

Dominique repeated the test with 10^7 elements and got 4.4s before the
patch and 46.5 after.

In light of this, I withdraw the submission and will concentrate on
making the pointer version work in all circumstances with submodules.

Best regards

Paul

On 27 September 2016 at 10:27, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> 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  <pault@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  <pault@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.



-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein

[Patch, fortran] PR69834 - Collision in derived type hashes

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 2860 bytes --]

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  <pault@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  <pault@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.

[-- Attachment #2: submit.diff --]
[-- Type: text/plain, Size: 15724 bytes --]

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