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

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

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