public inbox for fortran@gcc.gnu.org
 help / color / mirror / Atom feed
* Re: [Patch, fortran] PR69834 - Collision in derived type hashes
@ 2016-11-05 14:24 Dominique d'Humières
  2016-11-05 14:55 ` Janus Weil
  0 siblings, 1 reply; 17+ messages in thread
From: Dominique d'Humières @ 2016-11-05 14:24 UTC (permalink / raw)
  To: Paul Richard Thomas; +Cc: fortran, gcc-patches List

> 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

^ permalink raw reply	[flat|nested] 17+ messages in thread
[parent not found: <CAGkQGi+S-4qf+ifgVvKHRu=TEj4pRmMCCJrLxBJOLoZDZ1QP2Q@mail.gmail.com>]
* [Patch, fortran] PR69834 - Collision in derived type hashes
@ 2016-10-21 12:52 Paul Richard Thomas
  0 siblings, 0 replies; 17+ messages in thread
From: Paul Richard Thomas @ 2016-10-21 12:52 UTC (permalink / raw)
  To: fortran, gcc-patches

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

^ permalink raw reply	[flat|nested] 17+ messages in thread
* [Patch, fortran] PR69834 - Collision in derived type hashes
@ 2016-09-27  8:27 Paul Richard Thomas
  2016-09-27 12:42 ` Paul Richard Thomas
  0 siblings, 1 reply; 17+ messages in thread
From: Paul Richard Thomas @ 2016-09-27  8:27 UTC (permalink / raw)
  To: fortran, gcc-patches

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

^ permalink raw reply	[flat|nested] 17+ messages in thread
* [Patch, fortran] PR69834 - Collision in derived type hashes
@ 2016-03-03 15:59 Paul Richard Thomas
  2016-03-03 20:31 ` Jerry DeLisle
  0 siblings, 1 reply; 17+ messages in thread
From: Paul Richard Thomas @ 2016-03-03 15:59 UTC (permalink / raw)
  To: fortran, gcc-patches, Dominique Dhumieres, Thomas Koenig

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

^ permalink raw reply	[flat|nested] 17+ messages in thread
end of thread, other threads:[~2016-11-05 14:55 UTC | newest]

Thread overview: 17+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
     [not found] <F8D03D98-0E54-4994-B7D4-23E757BE9A08@lps.ens.fr>
2016-10-22  0:22 ` Fwd: [Patch, fortran] PR69834 - Collision in derived type hashes Dominique d'Humières
2016-10-22  8:21 ` Paul Richard Thomas
2016-10-22  8:51   ` Dominique d'Humières
2016-10-22 10:41     ` Paul Richard Thomas
2016-11-05 14:24 Dominique d'Humières
2016-11-05 14:55 ` Janus Weil
     [not found] <CAGkQGi+S-4qf+ifgVvKHRu=TEj4pRmMCCJrLxBJOLoZDZ1QP2Q@mail.gmail.com>
2016-10-23 18:14 ` Andre Vehreschild
2016-10-23 21:30   ` Paul Richard Thomas
2016-10-24 10:18     ` Andre Vehreschild
2016-10-24 11:53       ` Paul Richard Thomas
2016-11-05 10:51         ` Paul Richard Thomas
  -- strict thread matches above, loose matches on Subject: below --
2016-10-21 12:52 Paul Richard Thomas
2016-09-27  8:27 Paul Richard Thomas
2016-09-27 12:42 ` Paul Richard Thomas
2016-03-03 15:59 Paul Richard Thomas
2016-03-03 20:31 ` Jerry DeLisle
2016-03-13 17:31   ` Paul Richard Thomas

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).