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

gcc/fortran/ChangeLog

+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

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)

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);
 

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);
 }
 
 

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  */
 
 

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

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);

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:

gcc/testsuite/ChangeLog

+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.

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)"

gcc/testsuite/gfortran.dg/select_type_36.f03

+! { 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