re PR fortran/69834 ([OOP] Collision in derived type hashes)

2016-10-23  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): Modify select case dump to
	show 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-23  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.

From-SVN: r241450

11 files changed, 360 insertions, 34 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f5843bf..d057d0f 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,25 @@
+2016-10-23  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): Modify select case dump to
+	show 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  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/78021
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index e110f2c..6ac543c 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -2190,6 +2190,7 @@ 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;
+  gfc_gsymbol *gsym = NULL;
 
   /* Find the top-level namespace.  */
   for (ns = gfc_current_ns; ns; ns = ns->parent)
@@ -2200,6 +2201,20 @@ gfc_find_derived_vtab (gfc_symbol *derived)
   if (!derived->attr.unlimited_polymorphic && derived->attr.is_class)
     derived = gfc_get_derived_super_type (derived);
 
+  /* 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)
     {
       char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
@@ -2208,7 +2223,14 @@ gfc_find_derived_vtab (gfc_symbol *derived)
       sprintf (name, "__vtab_%s", tname);
 
       /* Look for the vtab symbol in various namespaces.  */
-      gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
+      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)
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 8c24074..33a2842 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -227,7 +227,7 @@ show_array_ref (gfc_array_ref * ar)
 	     print the start expression which contains the vector, in
 	     the latter case we have to print any of lower and upper
 	     bound and the stride, if they're present.  */
-  
+
 	  if (ar->start[i] != NULL)
 	    show_expr (ar->start[i]);
 
@@ -429,7 +429,7 @@ show_expr (gfc_expr *p)
 	  break;
 
 	case BT_CHARACTER:
-	  show_char_const (p->value.character.string, 
+	  show_char_const (p->value.character.string,
 			   p->value.character.length);
 	  break;
 
@@ -982,7 +982,7 @@ show_common (gfc_symtree *st)
 	fputs (", ", dumpfile);
     }
   fputc ('\n', dumpfile);
-}    
+}
 
 
 /* Worker function to display the symbol tree.  */
@@ -1238,7 +1238,7 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
       for (list = omp_clauses->tile_list; list; list = list->next)
 	{
 	  show_expr (list->expr);
-	  if (list->next) 
+	  if (list->next)
 	    fputs (", ", dumpfile);
 	}
       fputc (')', dumpfile);
@@ -1250,7 +1250,7 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
       for (list = omp_clauses->wait_list; list; list = list->next)
 	{
 	  show_expr (list->expr);
-	  if (list->next) 
+	  if (list->next)
 	    fputs (", ", dumpfile);
 	}
       fputc (')', dumpfile);
@@ -1815,8 +1815,12 @@ show_code_node (int level, gfc_code *c)
       break;
 
     case EXEC_SELECT:
+    case EXEC_SELECT_TYPE:
       d = c->block;
-      fputs ("SELECT CASE ", dumpfile);
+      if (c->op == EXEC_SELECT_TYPE)
+	fputs ("SELECT TYPE", dumpfile);
+      else
+	fputs ("SELECT CASE ", dumpfile);
       show_expr (c->expr1);
       fputc ('\n', dumpfile);
 
@@ -2628,7 +2632,7 @@ show_namespace (gfc_namespace *ns)
       fputs ("User operators:\n", dumpfile);
       gfc_traverse_user_op (ns, show_uop);
     }
-  
+
   for (eq = ns->equiv; eq; eq = eq->next)
     show_equiv (eq);
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6dae6fb..2a64ab7 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8369,6 +8369,25 @@ fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2,
 }
 
 
+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
@@ -8385,6 +8404,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
   int charlen = 0;
   int rank = 0;
   gfc_ref* ref = NULL;
+  gfc_expr *selector_expr = NULL;
 
   ns = code->ext.block.ns;
   gfc_resolve (ns);
@@ -8433,6 +8453,31 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
     {
       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.u.derived && d->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 ("TYPE IS at %L overlaps with TYPE IS 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
@@ -8460,7 +8505,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
 	}
 
       /* Check F03:C814.  */
-      if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length != NULL)
+      if (c->ts.type == BT_CHARACTER
+	  && (c->ts.u.cl->length != NULL || c->ts.deferred))
 	{
 	  gfc_error ("The type-spec at %L shall specify that each length "
 		     "type parameter is assumed", &c->where);
@@ -8549,31 +8595,47 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
   else
     ns->code->next = new_st;
   code = new_st;
-  code->op = EXEC_SELECT;
+  code->op = EXEC_SELECT_TYPE;
 
+  /* Use the intrinsic LOC function to generate 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);
-  gfc_add_hash_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;
 
-      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)
+      /* 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)
 	{
-	  gfc_symbol *ivtab;
-	  gfc_expr *e;
+	  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);
+	    }
 
-	  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);
+	  e = gfc_lval_expr_from_sym (vtab);
+	  c->low = build_loc_call (e);
 	}
-
-      else if (c->ts.type == BT_UNKNOWN)
+      else
 	continue;
 
       /* Associate temporary to selector.  This should only be done
@@ -8599,8 +8661,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
 
       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;
+      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);
@@ -8720,7 +8782,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
 	  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 = 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);
@@ -8748,8 +8810,6 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
 
   if (ref)
     free (ref);
-
-  resolve_select (code, true);
 }
 
 
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index fc03a23..f1849f5 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1508,6 +1508,27 @@ gfc_trans_class_init_assign (gfc_code *code)
 }
 
 
+/* 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).  */
+
+
 /* End of prototype trans-class.c  */
 
 
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 2cf41b9..c52066f 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -2331,6 +2331,125 @@ gfc_trans_do_while (gfc_code * code)
 }
 
 
+/* 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
@@ -2972,6 +3091,35 @@ gfc_trans_select (gfc_code * code)
   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
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index e4d4a67..0b4f713 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -52,6 +52,7 @@ tree gfc_trans_do (gfc_code *, tree);
 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);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index fba0d9a..df77fc9 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1820,10 +1820,7 @@ trans_code (gfc_code * code, tree cond)
 	  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;
+	  res = gfc_trans_select_type (code);
 	  break;
 
 	case EXEC_FLUSH:
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ca08945..8178f8d 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2016-10-23  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.
+
 2016-10-22  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gcc.dg/tree-ssa/pr71347.c: Remove XFAIL on SPARC.
diff --git a/gcc/testsuite/gfortran.dg/select_type_1.f03 b/gcc/testsuite/gfortran.dg/select_type_1.f03
index af0db3c..b92366d 100644
--- a/gcc/testsuite/gfortran.dg/select_type_1.f03
+++ b/gcc/testsuite/gfortran.dg/select_type_1.f03
@@ -60,9 +60,9 @@
 label: select type (a)
   type is (t1) label
     print *,"a is TYPE(t1)"
-  type is (t2)  ! { dg-error "overlaps with CASE label" }
+  type is (t2)  ! { dg-error "overlaps with TYPE IS" }
     print *,"a is TYPE(t2)"
-  type is (t2)  ! { dg-error "overlaps with CASE label" }
+  type is (t2)  ! { dg-error "overlaps with TYPE IS" }
     print *,"a is still TYPE(t2)"
   class is (t1) labe   ! { dg-error "Expected block name" }
     print *,"a is CLASS(t1)"
diff --git a/gcc/testsuite/gfortran.dg/select_type_36.f03 b/gcc/testsuite/gfortran.dg/select_type_36.f03
new file mode 100644
index 0000000..a667ece
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_36.f03
@@ -0,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