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

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- 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