re PR fortran/64787 (Invalid code on sourced allocation of class(*) character string)

gcc/fortran/ChangeLog

2015-03-24  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/64787
	PR fortran/57456
	PR fortran/63230
	* class.c (gfc_add_component_ref):  Free no longer needed
	ref-chains to prevent memory loss.
	(find_intrinsic_vtab): For deferred length char arrays or
	unlimited polymorphic objects, store the size in bytes of one
	character in the size component of the vtab.
	* gfortran.h: Added gfc_add_len_component () define.
	* trans-array.c (gfc_trans_create_temp_array): Switched to new
	function name for getting a class' vtab's field.
	(build_class_array_ref): Likewise.
	(gfc_array_init_size): Using the size information from allocate
	more consequently now, i.e., the typespec of the entity to
	allocate is no longer needed.  This is to address the last open
	comment in PR fortran/57456.
	(gfc_array_allocate): Likewise.
	(structure_alloc_comps): gfc_copy_class_to_class () needs to
	know whether the class is unlimited polymorphic.
	* trans-array.h: Changed interface of gfc_array_allocate () to
	reflect the no longer needed typespec.
	* trans-expr.c (gfc_find_and_cut_at_last_class_ref): New.
	(gfc_reset_len): New.
	(gfc_get_class_array_ref): Switch to new function name for
	getting a class' vtab's field.
	(gfc_copy_class_to_class):  Added flag to know whether the class
	to copy is unlimited polymorphic.  Adding _len dependent code
	then, which calls ->vptr->copy () with four arguments adding
	the length information ->vptr->copy(from, to, from_len, to_cap).
	(gfc_conv_procedure_call): Switch to new function name for
	getting a class' vtab's field.
	(alloc_scalar_allocatable_for_assignment): Use the string_length
	as computed by gfc_conv_expr and not the statically backend_decl
	which may be incorrect when ref-ing.
	(gfc_trans_assignment_1): Use the string_length variable and
	not the rse.string_length.  The former has been computed more
	generally.
	* trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Switch to new
	function name for getting a class' vtab's field.
	(gfc_conv_intrinsic_storage_size): Likewise.
	(gfc_conv_intrinsic_transfer): Likewise.
	* trans-stmt.c (gfc_trans_allocate): Restructured to evaluate
	source=expr3 only once before the loop over the objects to
	allocate, when the objects are not arrays. Doing correct _len
	initialization and calling of vptr->copy () fixing PR 64787.
	(gfc_trans_deallocate): Reseting _len to 0, preventing future
	errors.
	* trans.c (gfc_build_array_ref): Switch to new function name
	for getting a class' vtab's field.
	(gfc_add_comp_finalizer_call): Likewise.
	* trans.h: Define the prototypes for the gfc_class_vtab_*_get ()
	and gfc_vptr_*_get () functions.
	Added gfc_find_and_cut_at_last_class_ref () and
	gfc_reset_len () routine prototype.  Added flag to
	gfc_copy_class_to_class () prototype to signal an unlimited
	polymorphic entity to copy.

gcc/testsuite/ChangeLog

2015-03-24  Andre Vehreschild  <vehre@gmx.de>

	* gfortran.dg/allocate_alloc_opt_13.f90: Added tests for
	source= and mold= expressions functionality.
	* gfortran.dg/allocate_class_4.f90: New test.
	* gfortran.dg/unlimited_polymorphic_20.f90: Added test whether
	copying an unlimited polymorhpic object containing a char array
	to another unlimited polymorphic object respects the _len
	component.
	* gfortran.dg/unlimited_polymorphic_22.f90: Extended to check
	whether deferred length char array allocate works, unlimited
	polymorphic object allocation from a string works and if
	allocating an array of deferred length strings works.
	* gfortran.dg/unlimited_polymorphic_24.f03: New test.

From-SVN: r221621

gcc/fortran/ChangeLog

+2015-03-24  Andre Vehreschild  <vehre@gmx.de>
+
+	PR fortran/64787
+	PR fortran/57456
+	PR fortran/63230
+	* class.c (gfc_add_component_ref):  Free no longer needed
+	ref-chains to prevent memory loss.
+	(find_intrinsic_vtab): For deferred length char arrays or
+	unlimited polymorphic objects, store the size in bytes of one
+	character in the size component of the vtab.
+	* gfortran.h: Added gfc_add_len_component () define.
+	* trans-array.c (gfc_trans_create_temp_array): Switched to new
+	function name for getting a class' vtab's field.
+	(build_class_array_ref): Likewise.
+	(gfc_array_init_size): Using the size information from allocate
+	more consequently now, i.e., the typespec of the entity to
+	allocate is no longer needed.  This is to address the last open
+	comment in PR fortran/57456.
+	(gfc_array_allocate): Likewise.
+	(structure_alloc_comps): gfc_copy_class_to_class () needs to
+	know whether the class is unlimited polymorphic.
+	* trans-array.h: Changed interface of gfc_array_allocate () to
+	reflect the no longer needed typespec.
+	* trans-expr.c (gfc_find_and_cut_at_last_class_ref): New.
+	(gfc_reset_len): New.
+	(gfc_get_class_array_ref): Switch to new function name for
+	getting a class' vtab's field.
+	(gfc_copy_class_to_class):  Added flag to know whether the class
+	to copy is unlimited polymorphic.  Adding _len dependent code
+	then, which calls ->vptr->copy () with four arguments adding
+	the length information ->vptr->copy(from, to, from_len, to_cap).
+	(gfc_conv_procedure_call): Switch to new function name for
+	getting a class' vtab's field. 
+	(alloc_scalar_allocatable_for_assignment): Use the string_length
+	as computed by gfc_conv_expr and not the statically backend_decl
+	which may be incorrect when ref-ing.
+	(gfc_trans_assignment_1): Use the string_length variable and
+	not the rse.string_length.  The former has been computed more
+	generally.
+	* trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Switch to new
+	function name for getting a class' vtab's field.
+	(gfc_conv_intrinsic_storage_size): Likewise.
+	(gfc_conv_intrinsic_transfer): Likewise.
+	* trans-stmt.c (gfc_trans_allocate): Restructured to evaluate
+	source=expr3 only once before the loop over the objects to
+	allocate, when the objects are not arrays. Doing correct _len
+	initialization and calling of vptr->copy () fixing PR 64787.
+	(gfc_trans_deallocate): Reseting _len to 0, preventing future
+	errors.
+	* trans.c (gfc_build_array_ref): Switch to new function name
+	for getting a class' vtab's field.
+	(gfc_add_comp_finalizer_call): Likewise.
+	* trans.h: Define the prototypes for the gfc_class_vtab_*_get ()
+	and gfc_vptr_*_get () functions.
+	Added gfc_find_and_cut_at_last_class_ref () and
+	gfc_reset_len () routine prototype.  Added flag to
+	gfc_copy_class_to_class () prototype to signal an unlimited
+	polymorphic entity to copy.    
+
 2015-03-24  Iain Sandoe  <iain@codesourcery.com>
 	    Tobias Burnus  <burnus@net-b.de>
 

gcc/fortran/class.c

@@ -234,6 +234,9 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
     }
   if (*tail != NULL && strcmp (name, "_data") == 0)
     next = *tail;
+  else
+    /* Avoid losing memory.  */
+    gfc_free_ref_list (*tail);
   (*tail) = gfc_get_ref();
   (*tail)->next = next;
   (*tail)->type = REF_COMPONENT;
@@ -2562,13 +2565,19 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	      c->attr.access = ACCESS_PRIVATE;
 
 	      /* Build a minimal expression to make use of
-		 target-memory.c/gfc_element_size for 'size'.  */
+		 target-memory.c/gfc_element_size for 'size'.  Special handling
+		 for character arrays, that are not constant sized: to support
+		 len (str) * kind, only the kind information is stored in the
+		 vtab.  */
 	      e = gfc_get_expr ();
 	      e->ts = *ts;
 	      e->expr_type = EXPR_VARIABLE;
 	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 						 NULL,
-						 (int)gfc_element_size (e));
+						 ts->type == BT_CHARACTER
+						 && charlen == 0 ?
+						   ts->kind :
+						   (int)gfc_element_size (e));
 	      gfc_free_expr (e);
 
 	      /* Add component _extends.  */

gcc/fortran/gfortran.h

@@ -3175,6 +3175,7 @@ void gfc_add_component_ref (gfc_expr *, const char *);
 void gfc_add_class_array_ref (gfc_expr *);
 #define gfc_add_data_component(e)     gfc_add_component_ref(e,"_data")
 #define gfc_add_vptr_component(e)     gfc_add_component_ref(e,"_vptr")
+#define gfc_add_len_component(e)      gfc_add_component_ref(e,"_len")
 #define gfc_add_hash_component(e)     gfc_add_component_ref(e,"_hash")
 #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")

gcc/fortran/trans-array.c

@@ -1196,7 +1196,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
 	elemsize = fold_convert (gfc_array_index_type,
 			TYPE_SIZE_UNIT (gfc_get_element_type (type)));
       else
-	elemsize = gfc_vtable_size_get (class_expr);
+	elemsize = gfc_class_vtab_size_get (class_expr);
 
       size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			      size, elemsize);
@@ -3066,7 +3066,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
   if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
     return false;
 
-  size = gfc_vtable_size_get (decl);
+  size = gfc_class_vtab_size_get (decl);
 
   /* Build the address of the element.  */
   type = TREE_TYPE (TREE_TYPE (base));
@@ -4956,8 +4956,7 @@ static tree
 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
 		     stmtblock_t * descriptor_block, tree * overflow,
-		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
-		     gfc_typespec *ts)
+		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
 {
   tree type;
   tree tmp;
@@ -4983,7 +4982,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
   /* Set the dtype.  */
   tmp = gfc_conv_descriptor_dtype (descriptor);
-  gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
+  gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (type));
 
   or_expr = boolean_false_node;
 
@@ -5137,9 +5136,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 	  tmp = TYPE_SIZE_UNIT (tmp);
 	}
     }
-  else if (ts->type != BT_UNKNOWN && ts->type != BT_CHARACTER)
-    /* FIXME: Properly handle characters.  See PR 57456.  */
-    tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
   else
     tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
 
@@ -5211,7 +5207,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 bool
 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 		    tree errlen, tree label_finish, tree expr3_elem_size,
-		    tree *nelems, gfc_expr *expr3, gfc_typespec *ts)
+		    tree *nelems, gfc_expr *expr3)
 {
   tree tmp;
   tree pointer;
@@ -5296,7 +5292,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
 			      ref->u.ar.as->corank, &offset, lower, upper,
 			      &se->pre, &set_descriptor_block, &overflow,
-			      expr3_elem_size, nelems, expr3, ts);
+			      expr3_elem_size, nelems, expr3);
 
   if (dimension)
     {
@@ -7942,7 +7938,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
 	      dst_data = gfc_class_data_get (dcmp);
 	      src_data = gfc_class_data_get (comp);
-	      size = fold_convert (size_type_node, gfc_vtable_size_get (comp));
+	      size = fold_convert (size_type_node,
+				   gfc_class_vtab_size_get (comp));
 
 	      if (CLASS_DATA (c)->attr.dimension)
 		{
@@ -7977,7 +7974,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 				  fold_convert (TREE_TYPE (dst_data), tmp));
 		}
 
-	      tmp = gfc_copy_class_to_class (comp, dcmp, nelems);
+	      tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
+					     UNLIMITED_POLY (c));
 	      gfc_add_expr_to_block (&tmpblock, tmp);
 	      tmp = gfc_finish_block (&tmpblock);
 

gcc/fortran/trans-array.h

@@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*);
 /* Generate code to initialize and allocate an array.  Statements are added to
    se, which should contain an expression for the array descriptor.  */
 bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
-			 tree, tree *, gfc_expr *, gfc_typespec *);
+			 tree, tree *, gfc_expr *);
 
 /* Allow the bounds of a loop to be set from a callee's array spec.  */
 void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,

gcc/fortran/trans-intrinsic.c

@@ -2755,7 +2755,7 @@ if (least <= 2)
 	arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
 	       : null_pointer_node;
       }
-  
+
     if (least == 2)
       {
 	arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
@@ -5922,9 +5922,9 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
   else if (arg->ts.type == BT_CLASS)
     {
       if (arg->rank)
-	byte_size = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0));
+	byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
       else
-	byte_size = gfc_vtable_size_get (argse.expr);
+	byte_size = gfc_class_vtab_size_get (argse.expr);
     }
   else
     {
@@ -6053,7 +6053,7 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
       gfc_conv_expr_descriptor (&argse, arg);
       if (arg->ts.type == BT_CLASS)
 	{
-	  tmp = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0));
+	  tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
 	  tmp = fold_convert (result_type, tmp);
 	  goto done;
 	}
@@ -6198,7 +6198,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 					 argse.string_length);
 	  break;
 	case BT_CLASS:
-	  tmp = gfc_vtable_size_get (argse.expr);
+	  tmp = gfc_class_vtab_size_get (argse.expr);
 	  break;
 	default:
 	  source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
@@ -6322,7 +6322,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
       break;
     case BT_CLASS:
-      tmp = gfc_vtable_size_get (argse.expr);
+      tmp = gfc_class_vtab_size_get (argse.expr);
       break;
     default:
       tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));

gcc/fortran/trans.c

@@ -373,7 +373,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl)
 	    return build4_loc (input_location, ARRAY_REF, type, base,
 			       offset, NULL_TREE, NULL_TREE);
 
-	  span = gfc_vtable_size_get (decl);
+	  span = gfc_class_vtab_size_get (decl);
 	}
       else if (GFC_DECL_SUBREF_ARRAY_P (decl))
 	span = GFC_DECL_SPAN(decl);
@@ -1015,8 +1015,8 @@ gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp,
 	return false;
 
       gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
-      final_fndecl = gfc_vtable_final_get (decl);
-      size = gfc_vtable_size_get (decl);
+      final_fndecl = gfc_class_vtab_final_get (decl);
+      size = gfc_class_vtab_size_get (decl);
       array = gfc_class_data_get (decl);
     }
 

gcc/fortran/trans.h

@@ -350,20 +350,31 @@ typedef struct
 gfc_wrapped_block;
 
 /* Class API functions.  */
+tree gfc_class_set_static_fields (tree, tree, tree);
 tree gfc_class_data_get (tree);
 tree gfc_class_vptr_get (tree);
 tree gfc_class_len_get (tree);
+gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *);
+/* Get an accessor to the class' vtab's * field, when a class handle is
+   available.  */
+tree gfc_class_vtab_hash_get (tree);
+tree gfc_class_vtab_size_get (tree);
+tree gfc_class_vtab_extends_get (tree);
+tree gfc_class_vtab_def_init_get (tree);
+tree gfc_class_vtab_copy_get (tree);
+tree gfc_class_vtab_final_get (tree);
+/* Get an accessor to the vtab's * field, when a vptr handle is present.  */
+tree gfc_vtpr_hash_get (tree);
+tree gfc_vptr_size_get (tree);
+tree gfc_vptr_extends_get (tree);
+tree gfc_vptr_def_init_get (tree);
+tree gfc_vptr_copy_get (tree);
+tree gfc_vptr_final_get (tree);
 void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
-tree gfc_class_set_static_fields (tree, tree, tree);
-tree gfc_vtable_hash_get (tree);
-tree gfc_vtable_size_get (tree);
-tree gfc_vtable_extends_get (tree);
-tree gfc_vtable_def_init_get (tree);
-tree gfc_vtable_copy_get (tree);
-tree gfc_vtable_final_get (tree);
+void gfc_reset_len (stmtblock_t *, gfc_expr *);
 tree gfc_get_vptr_from_expr (tree);
 tree gfc_get_class_array_ref (tree, tree);
-tree gfc_copy_class_to_class (tree, tree, tree);
+tree gfc_copy_class_to_class (tree, tree, tree, bool);
 bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
 bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
 

gcc/testsuite/ChangeLog

+2015-03-24  Andre Vehreschild  <vehre@gmx.de>
+
+	* gfortran.dg/allocate_alloc_opt_13.f90: Added tests for
+	source= and mold= expressions functionality.
+	* gfortran.dg/allocate_class_4.f90: New test.
+	* gfortran.dg/unlimited_polymorphic_20.f90: Added test whether
+	copying an unlimited polymorhpic object containing a char array
+	to another unlimited polymorphic object respects the _len
+	component.
+	* gfortran.dg/unlimited_polymorphic_22.f90: Extended to check
+	whether deferred length char array allocate works, unlimited
+	polymorphic object allocation from a string works and if
+	allocating an array of deferred length strings works.
+	* gfortran.dg/unlimited_polymorphic_24.f03: New test.
+
 2015-03-24  Paolo Carlini  <paolo.carlini@oracle.com>
 
 	PR c++/65513

gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90

@@ -12,6 +12,9 @@ class(t), pointer :: b, d(:)
 allocate (a, b, source=c(1))
 allocate (c(4), d(6), source=e)
 
+allocate (a, b, mold=f())
+allocate (c(1), d(6), mold=g())
+
 allocate (a, b, source=f())
 allocate (c(1), d(6), source=g())
 

gcc/testsuite/gfortran.dg/allocate_class_4.f90

+! { dg-do compile }
+!
+! Part of PR 51946, but breaks easily, therefore introduce its own test
+! Authors: Damian Rouson  <damian@sourceryinstitute.org>,
+!          Dominique Pelletier  <dominique.pelletier@polymtl.ca>
+! Contributed by: Andre Vehreschild  <vehre@gcc.gnu.org>
+
+module integrable_model_module
+
+   implicit none
+
+   type, abstract, public :: integrable_model
+      contains
+         procedure(default_constructor), deferred :: empty_instance
+   end type
+
+   abstract interface
+      function default_constructor(this) result(blank_slate)
+         import :: integrable_model
+         class(integrable_model), intent(in)  :: this
+         class(integrable_model), allocatable :: blank_slate
+      end function
+   end interface
+
+   contains
+
+      subroutine integrate(this)
+         class(integrable_model), intent(inout) :: this
+         class(integrable_model), allocatable   :: residual
+         allocate(residual, source=this%empty_instance())
+      end subroutine
+
+end module integrable_model_module
+
+! { dg-final { cleanup-modules "integrable_model_module" } }
+ 

gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90

@@ -23,12 +23,14 @@ program test
     implicit none
     character(LEN=:), allocatable, target :: S
     character(LEN=100) :: res
-    class(*), pointer :: ucp
+    class(*), pointer :: ucp, ucp2
     call sub1 ("long test string", 16)
     call sub2 ()
     S = "test"
     ucp => S
     call sub3 (ucp)
+    allocate (ucp2, source=ucp)
+    call sub3 (ucp2)
     call sub4 (S, 4)
     call sub4 ("This is a longer string.", 24)
     call bar (S, res)

gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90

@@ -5,52 +5,211 @@
 program test
     implicit none
 
-    class(*), pointer :: P
+    class(*), pointer :: P1, P2, P3
+    class(*), pointer, dimension(:) :: PA1
+    class(*), allocatable :: A1, A2
     integer :: string_len = 10 *2
+    character(len=:), allocatable, target :: str
+    character(len=:,kind=4), allocatable :: str4
+    type T
+        class(*), pointer :: content
+    end type
+    type(T) :: o1, o2
+
+    str = "string for test"
+    str4 = 4_"string for test"
+
+    allocate(character(string_len)::P1)
+
+    select type(P1)
+        type is (character(*))
+            P1 ="some test string"
+            if (P1 .ne. "some test string") call abort ()
+            if (len(P1) .ne. 20) call abort ()
+            if (len(P1) .eq. len("some test string")) call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(A1, source = P1)
 
-    allocate(character(string_len)::P)
+    select type(A1)
+        type is (character(*))
+            if (A1 .ne. "some test string") call abort ()
+            if (len(A1) .ne. 20) call abort ()
+            if (len(A1) .eq. len("some test string")) call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(A2, source = convertType(P1))
 
-    select type(P)
+    select type(A2)
         type is (character(*))
-            P ="some test string"
-            if (P .ne. "some test string") then
-                call abort ()
-            end if
-            if (len(P) .ne. 20) then
-                call abort ()
-            end if
-            if (len(P) .eq. len("some test string")) then
-                call abort ()
-            end if
+            if (A2 .ne. "some test string") call abort ()
+            if (len(A2) .ne. 20) call abort ()
+            if (len(A2) .eq. len("some test string")) call abort ()
         class default
             call abort ()
     end select
 
-    deallocate(P)
+    allocate(P2, source = str)
+
+    select type(P2)
+        type is (character(*))
+            if (P2 .ne. "string for test") call abort ()
+            if (len(P2) .eq. 20) call abort ()
+            if (len(P2) .ne. len("string for test")) call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(P3, source = "string for test")
+
+    select type(P3)
+        type is (character(*))
+            if (P3 .ne. "string for test") call abort ()
+            if (len(P3) .eq. 20) call abort ()
+            if (len(P3) .ne. len("string for test")) call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(character(len=10)::PA1(3))
+
+    select type(PA1)
+        type is (character(*))
+            PA1(1) = "string 10 "
+            if (PA1(1) .ne. "string 10 ") call abort ()
+            if (any(len(PA1(:)) .ne. [10,10,10])) call abort ()
+        class default
+            call abort ()
+    end select
+
+    deallocate(PA1)
+    deallocate(P3)
+!   if (len(P3) .ne. 0) call abort() ! Can't check, because select
+!     type would be needed, which needs the vptr, which is 0 now.
+    deallocate(P2)
+    deallocate(A2)
+    deallocate(A1)
+    deallocate(P1)
 
     ! Now for kind=4 chars.
 
-    allocate(character(len=20,kind=4)::P)
+    allocate(character(len=20,kind=4)::P1)
+
+    select type(P1)
+        type is (character(len=*,kind=4))
+            P1 ="some test string"
+            if (P1 .ne. 4_"some test string") call abort ()
+            if (len(P1) .ne. 20) call abort ()
+            if (len(P1) .eq. len("some test string")) call abort ()
+        type is (character(len=*,kind=1))
+            call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(A1, source=P1)
 
-    select type(P)
+    select type(A1)
         type is (character(len=*,kind=4))
-            P ="some test string"
-            if (P .ne. 4_"some test string") then
-                call abort ()
-            end if
-            if (len(P) .ne. 20) then
-                call abort ()
-            end if
-            if (len(P) .eq. len("some test string")) then
-                call abort ()
-            end if
+            if (A1 .ne. 4_"some test string") call abort ()
+            if (len(A1) .ne. 20) call abort ()
+            if (len(A1) .eq. len("some test string")) call abort ()
         type is (character(len=*,kind=1))
             call abort ()
         class default
             call abort ()
     end select
 
-    deallocate(P)
+    allocate(A2, source = convertType(P1))
+
+    select type(A2)
+        type is (character(len=*, kind=4))
+            if (A2 .ne. 4_"some test string") call abort ()
+            if (len(A2) .ne. 20) call abort ()
+            if (len(A2) .eq. len("some test string")) call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(P2, source = str4)
+
+    select type(P2)
+        type is (character(len=*,kind=4))
+            if (P2 .ne. 4_"string for test") call abort ()
+            if (len(P2) .eq. 20) call abort ()
+            if (len(P2) .ne. len("string for test")) call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(P3, source = convertType(P2))
 
+    select type(P3)
+        type is (character(len=*, kind=4))
+            if (P3 .ne. 4_"string for test") call abort ()
+            if (len(P3) .eq. 20) call abort ()
+            if (len(P3) .ne. len("string for test")) call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(character(kind=4, len=10)::PA1(3))
+
+    select type(PA1)
+        type is (character(len=*, kind=4))
+            PA1(1) = 4_"string 10 "
+            if (PA1(1) .ne. 4_"string 10 ") call abort ()
+            if (any(len(PA1(:)) .ne. [10,10,10])) call abort ()
+        class default
+            call abort ()
+    end select
+
+    deallocate(PA1)
+    deallocate(P3)
+    deallocate(P2)
+    deallocate(A2)
+    deallocate(P1)
+    deallocate(A1)
+
+    allocate(o1%content, source='test string')
+    allocate(o2%content, source=o1%content)
+    select type (c => o1%content)
+      type is (character(*))
+        if (c /= 'test string') call abort ()
+      class default
+        call abort()
+    end select
+    select type (d => o2%content)
+      type is (character(*))
+        if (d /= 'test string') call abort ()
+      class default
+    end select
+
+    call AddCopy ('test string')
+
+contains
+
+  function convertType(in)
+    class(*), pointer, intent(in) :: in
+    class(*), pointer :: convertType
+
+    convertType => in
+  end function
+
+  subroutine AddCopy(C)
+    class(*), intent(in) :: C
+    class(*), pointer :: P
+    allocate(P, source=C)
+    select type (P)
+      type is (character(*))
+        if (P /= 'test string') call abort()
+      class default
+        call abort()
+    end select
+  end subroutine
 
 end program test

gcc/testsuite/gfortran.dg/unlimited_polymorphic_24.f03

+! { dg-do run }
+!
+! Test case for unlimited polymorphism that is derived from the article
+! by Mark Leair, in the 'PGI Insider':
+! https://www.pgroup.com/lit/articles/insider/v3n2a2.htm
+! Note that 'getValue' has been removed from the generic 'add' becuse
+! gfortran asserts that this is ambiguous. See
+! https://gcc.gnu.org/ml/fortran/2015-03/msg00002.html for a discussion.
+!
+module link_mod
+  private
+  public :: link, output, index
+  character(6) :: output (14)
+  integer :: index = 0
+  type link
+     private
+     class(*), pointer :: value => null() ! value stored in link
+     type(link), pointer :: next => null()! next link in list
+     contains
+     procedure :: getValue    ! return value pointer
+     procedure :: printLinks  ! print linked list starting with this link
+     procedure :: nextLink    ! return next pointer
+     procedure :: setNextLink ! set next pointer
+  end type link
+
+  interface link
+   procedure constructor ! construct/initialize a link
+  end interface
+
+contains
+
+  function nextLink(this)
+  class(link) :: this
+  class(link), pointer :: nextLink
+    nextLink => this%next
+  end function nextLink
+
+  subroutine setNextLink(this,next)
+  class(link) :: this
+  class(link), pointer :: next
+     this%next => next
+  end subroutine setNextLink
+
+  function getValue(this)
+  class(link) :: this
+  class(*), pointer :: getValue
+  getValue => this%value
+  end function getValue
+
+  subroutine printLink(this)
+  class(link) :: this
+
+  index = index + 1
+
+  select type(v => this%value)
+  type is (integer)
+    write (output(index), '(i6)') v
+  type is (character(*))
+    write (output(index), '(a6)') v
+  type is (real)
+    write (output(index), '(f6.2)') v
+  class default
+    stop 'printLink: unexepected type for link'
+  end select
+
+  end subroutine printLink
+
+  subroutine printLinks(this)
+  class(link) :: this
+  class(link), pointer :: curr
+
+  call printLink(this)
+  curr => this%next
+  do while(associated(curr))
+    call printLink(curr)
+    curr => curr%next
+  end do
+
+  end subroutine
+
+  function constructor(value, next)
+    class(link),pointer :: constructor
+    class(*) :: value
+    class(link), pointer :: next
+    allocate(constructor)
+    constructor%next => next
+    allocate(constructor%value, source=value)
+  end function constructor
+
+end module link_mod
+
+module list_mod
+  use link_mod
+  private
+  public :: list
+  type list
+     private
+     class(link),pointer :: firstLink => null() ! first link in list
+     class(link),pointer :: lastLink => null()  ! last link in list
+   contains
+     procedure :: printValues ! print linked list
+     procedure :: addInteger  ! add integer to linked list
+     procedure :: addChar     ! add character to linked list
+     procedure :: addReal     ! add real to linked list
+     procedure :: addValue    ! add class(*) to linked list
+     procedure :: firstValue  ! return value associated with firstLink
+     procedure :: isEmpty     ! return true if list is empty
+     generic :: add => addInteger, addChar, addReal
+  end type list
+
+contains
+
+  subroutine printValues(this)
+    class(list) :: this
+
+    if (.not.this%isEmpty()) then
+       call this%firstLink%printLinks()
+    endif
+  end subroutine printValues
+
+  subroutine addValue(this, value)
+    class(list) :: this
+    class(*) :: value
+    class(link), pointer :: newLink
+
+    if (.not. associated(this%firstLink)) then
+       this%firstLink => link(value, this%firstLink)
+       this%lastLink => this%firstLink
+    else
+       newLink => link(value, this%lastLink%nextLink())
+       call this%lastLink%setNextLink(newLink)
+       this%lastLink => newLink
+    end if
+
+  end subroutine addValue
+
+  subroutine addInteger(this, value)
+   class(list) :: this
+    integer value
+    class(*), allocatable :: v
+    allocate(v,source=value)
+    call this%addValue(v)
+  end subroutine addInteger
+
+  subroutine addChar(this, value)
+    class(list) :: this
+    character(*) :: value
+    class(*), allocatable :: v
+
+    allocate(v,source=value)
+    call this%addValue(v)
+  end subroutine addChar
+
+  subroutine addReal(this, value)
+    class(list) :: this
+    real value
+    class(*), allocatable :: v
+
+    allocate(v,source=value)
+    call this%addValue(v)
+  end subroutine addReal
+
+  function firstValue(this)
+    class(list) :: this
+    class(*), pointer :: firstValue
+
+    firstValue => this%firstLink%getValue()
+
+  end function firstValue
+
+  function isEmpty(this)
+    class(list) :: this
+    logical isEmpty
+
+    if (associated(this%firstLink)) then
+       isEmpty = .false.
+    else
+       isEmpty = .true.
+    endif
+  end function isEmpty
+
+end module list_mod
+
+program main
+  use link_mod, only : output
+  use list_mod
+  implicit none
+  integer i, j
+  type(list) :: my_list
+
+  do i=1, 10
+     call my_list%add(i)
+  enddo
+  call my_list%add(1.23)
+  call my_list%add('A')
+  call my_list%add('BC')
+  call my_list%add('DEF')
+  call my_list%printvalues()
+  do i = 1, 14
+    select case (i)
+      case (1:10)
+        read (output(i), '(i6)') j
+        if (j .ne. i) call abort
+      case (11)
+        if (output(i) .ne. "  1.23") call abort
+      case (12)
+        if (output(i) .ne. "     A") call abort
+      case (13)
+        if (output(i) .ne. "    BC") call abort
+      case (14)
+        if (output(i) .ne. "   DEF") call abort
+    end select
+  end do
+end program main
+