[multiple changes]

2015-01-18  Andre Vehreschild  <vehre@gmx.de>
	    Janus Weil <janus@gcc.gnu.org>

	PR fortran/60255
	* class.c (gfc_get_len_component): New.
	(gfc_build_class_symbol): Add _len component to unlimited
	polymorphic entities.
	(find_intrinsic_vtab): Removed emitting of error message.
	* gfortran.h: Added prototype for gfc_get_len_component.
	* simplify.c (gfc_simplify_len): Use _len component where
	available.
	* trans-expr.c (gfc_class_len_get): New.
	(gfc_conv_intrinsic_to_class): Add handling for deferred
	character arrays.
	(gfc_conv_structure): Treat _len component correctly.
	(gfc_conv_expr): Prevent bind_c handling when not required.
	(gfc_trans_pointer_assignment): Propagate _len component.
	* trans-stmt.c (class_has_len_component): New.
	(trans_associate_var): _len component treatment for associate
	context.
	(gfc_trans_allocate): Same as for trans_associate_var()
	* trans.h: Added prototype for gfc_class_len_get.

2015-01-18  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/60255
	* gfortran.dg/unlimited_polymorphic_2.f03: Removed error.
	* gfortran.dg/unlimited_polymorphic_20.f03: New test.

2015-01-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/64578
	* gfortran.dg/unlimited_polymorphic_21.f90: New test

From-SVN: r219827

gcc/fortran/ChangeLog

+2015-01-18  Andre Vehreschild  <vehre@gmx.de>
+	    Janus Weil <janus@gcc.gnu.org>
+
+	PR fortran/60255
+	* class.c (gfc_get_len_component): New.
+	(gfc_build_class_symbol): Add _len component to unlimited
+	polymorphic entities.
+	(find_intrinsic_vtab): Removed emitting of error message.
+	* gfortran.h: Added prototype for gfc_get_len_component.
+	* simplify.c (gfc_simplify_len): Use _len component where
+	available.
+	* trans-expr.c (gfc_class_len_get): New.
+	(gfc_conv_intrinsic_to_class): Add handling for deferred
+	character arrays.
+	(gfc_conv_structure): Treat _len component correctly.
+	(gfc_conv_expr): Prevent bind_c handling when not required.
+	(gfc_trans_pointer_assignment): Propagate _len component.
+	* trans-stmt.c (class_has_len_component): New.
+	(trans_associate_var): _len component treatment for associate
+	context.
+	(gfc_trans_allocate): Same as for trans_associate_var()
+	* trans.h: Added prototype for gfc_class_len_get.
+
 2015-01-18  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/57959

gcc/fortran/class.c

@@ -34,6 +34,12 @@ along with GCC; see the file COPYING3.  If not see
              (pointer/allocatable/dimension/...).
     * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
 
+    Only for unlimited polymorphic classes:
+    * _len:  An integer(4) to store the string length when the unlimited
+             polymorphic pointer is used to point to a char array.  The '_len'
+             component will be zero when no character array is stored in
+             '_data'.
+
    For each derived type we set up a "vtable" entry, i.e. a structure with the
    following fields:
     * _hash:     A hash value serving as a unique identifier for this type.
@@ -544,10 +550,48 @@ gfc_intrinsic_hash_value (gfc_typespec *ts)
 }
 
 
+/* Get the _len component from a class/derived object storing a string.
+   For unlimited polymorphic entities a ref to the _data component is available
+   while a ref to the _len component is needed.  This routine traverese the
+   ref-chain and strips the last ref to a _data from it replacing it with a
+   ref to the _len component.  */
+
+gfc_expr *
+gfc_get_len_component (gfc_expr *e)
+{
+  gfc_expr *ptr;
+  gfc_ref *ref, **last;
+
+  ptr = gfc_copy_expr (e);
+
+  /* We need to remove the last _data component ref from ptr.  */
+  last = &(ptr->ref);
+  ref = ptr->ref;
+  while (ref)
+    {
+      if (!ref->next
+	  && ref->type == REF_COMPONENT
+	  && strcmp ("_data", ref->u.c.component->name)== 0)
+	{
+	  gfc_free_ref_list (ref);
+	  *last = NULL;
+	  break;
+	}
+      last = &(ref->next);
+      ref = ref->next;
+    }
+  /* And replace if with a ref to the _len component.  */
+  gfc_add_component_ref (ptr, "_len");
+  return ptr;
+}
+
+
 /* Build a polymorphic CLASS entity, using the symbol that comes from
    build_sym. A CLASS entity is represented by an encapsulating type,
    which contains the declared type as '_data' component, plus a pointer
-   component '_vptr' which determines the dynamic type.  */
+   component '_vptr' which determines the dynamic type.  When this CLASS
+   entity is unlimited polymorphic, then also add a component '_len' to
+   store the length of string when that is stored in it.  */
 
 bool
 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
@@ -645,19 +689,28 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       if (!gfc_add_component (fclass, "_vptr", &c))
 	return false;
       c->ts.type = BT_DERIVED;
+      c->attr.access = ACCESS_PRIVATE;
+      c->attr.pointer = 1;
 
       if (ts->u.derived->attr.unlimited_polymorphic)
 	{
 	  vtab = gfc_find_derived_vtab (ts->u.derived);
 	  gcc_assert (vtab);
 	  c->ts.u.derived = vtab->ts.u.derived;
+
+	  /* Add component '_len'.  Only unlimited polymorphic pointers may
+             have a string assigned to them, i.e., only those need the _len
+             component.  */
+	  if (!gfc_add_component (fclass, "_len", &c))
+	    return false;
+	  c->ts.type = BT_INTEGER;
+	  c->ts.kind = 4;
+	  c->attr.access = ACCESS_PRIVATE;
+	  c->attr.artificial = 1;
 	}
       else
 	/* Build vtab later.  */
 	c->ts.u.derived = NULL;
-
-      c->attr.access = ACCESS_PRIVATE;
-      c->attr.pointer = 1;
     }
 
   if (!ts->u.derived->attr.unlimited_polymorphic)
@@ -2415,18 +2468,9 @@ find_intrinsic_vtab (gfc_typespec *ts)
   gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
   int charlen = 0;
 
-  if (ts->type == BT_CHARACTER)
-    {
-      if (ts->deferred)
-	{
-	  gfc_error ("TODO: Deferred character length variable at %C cannot "
-		     "yet be associated with unlimited polymorphic entities");
-	  return NULL;
-	}
-      else if (ts->u.cl && ts->u.cl->length
-	       && ts->u.cl->length->expr_type == EXPR_CONSTANT)
-	charlen = mpz_get_si (ts->u.cl->length->value.integer);
-    }
+  if (ts->type == BT_CHARACTER && !ts->deferred && ts->u.cl && ts->u.cl->length
+      && ts->u.cl->length->expr_type == EXPR_CONSTANT)
+    charlen = mpz_get_si (ts->u.cl->length->value.integer);
 
   /* Find the top-level namespace.  */
   for (ns = gfc_current_ns; ns; ns = ns->parent)

gcc/fortran/gfortran.h

@@ -3174,6 +3174,7 @@ 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 *);
+gfc_expr *gfc_get_len_component (gfc_expr *e);
 bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
 			     gfc_array_spec **);
 gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);

gcc/fortran/simplify.c

@@ -3713,6 +3713,14 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
       mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
       return range_check (result, "LEN");
     }
+  else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
+	   && e->symtree->n.sym
+	   && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
+	   && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED)
+    /* The expression in assoc->target points to a ref to the _data component
+       of the unlimited polymorphic entity.  To get the _len component the last
+       _data ref needs to be stripped and a ref to the _len component added.  */
+    return gfc_get_len_component (e->symtree->n.sym->assoc->target);
   else
     return NULL;
 }

gcc/fortran/trans-expr.c

@@ -104,6 +104,7 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
    in future implementations.  Use the corresponding APIs.  */
 #define CLASS_DATA_FIELD 0
 #define CLASS_VPTR_FIELD 1
+#define CLASS_LEN_FIELD 2
 #define VTABLE_HASH_FIELD 0
 #define VTABLE_SIZE_FIELD 1
 #define VTABLE_EXTENDS_FIELD 2
@@ -158,6 +159,20 @@ gfc_class_vptr_get (tree decl)
 }
 
 
+tree
+gfc_class_len_get (tree decl)
+{
+  tree len;
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+  len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
+			    CLASS_LEN_FIELD);
+  return fold_build3_loc (input_location, COMPONENT_REF,
+			  TREE_TYPE (len), decl, len,
+			  NULL_TREE);
+}
+
+
 static tree
 gfc_vtable_field_get (tree decl, int field)
 {
@@ -627,6 +642,45 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
 	}
     }
 
+  /* When the actual arg is a char array, then set the _len component of the
+     unlimited polymorphic entity, too.  */
+  if (e->ts.type == BT_CHARACTER)
+    {
+      ctree = gfc_class_len_get (var);
+      /* Start with parmse->string_length because this seems to be set to a
+	 correct value more often.  */
+      if (parmse->string_length)
+	  gfc_add_modify (&parmse->pre, ctree, parmse->string_length);
+      /* When the string_length is not yet set, then try the backend_decl of
+	 the cl.  */
+      else if (e->ts.u.cl->backend_decl)
+          gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
+      /* If both of the above approaches fail, then try to generate an
+	 expression from the input, which is only feasible currently, when the
+	 expression can be evaluated to a constant one.  */
+      else
+        {
+          /* Try to simplify the expression.  */
+          gfc_simplify_expr (e, 0);
+          if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
+            {
+              /* Amazingly all data is present to compute the length of a
+                 constant string, but the expression is not yet there.  */
+              e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 1,
+                                                          &e->where);
+              mpz_set_ui (e->ts.u.cl->length->value.integer,
+                          e->value.character.length);
+              gfc_conv_const_charlen (e->ts.u.cl);
+              e->ts.u.cl->resolved = 1;
+              gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
+            }
+          else
+            {
+              gfc_error ("Can't compute the length of the char array at %L.",
+                         &e->where);
+            }
+        }
+    }
   /* Pass the address of the class object.  */
   parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
 }
@@ -6656,6 +6710,14 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 				  fold_convert (TREE_TYPE (cm->backend_decl),
 						val));
 	}
+      else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
+        {
+          gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+          val = gfc_conv_constant_to_tree (e);
+          CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
+                                  fold_convert (TREE_TYPE (cm->backend_decl),
+                                                val));
+        }
       else
 	{
 	  val = gfc_conv_initializer (c->expr, &cm->ts,
@@ -6732,7 +6794,8 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
      null_pointer_node.  C_PTR and C_FUNPTR are converted to match the
      typespec for the C_PTR and C_FUNPTR symbols, which has already been
      updated to be an integer with a kind equal to the size of a (void *).  */
-  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID)
+  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
+      && expr->ts.u.derived->attr.is_bind_c)
     {
       if (expr->expr_type == EXPR_VARIABLE
 	  && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
@@ -7000,6 +7063,27 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       gfc_add_block_to_block (&block, &lse.pre);
       gfc_add_block_to_block (&block, &rse.pre);
 
+      /* For string assignments to unlimited polymorphic pointers add an
+	 assignment of the string_length to the _len component of the
+	 pointer.  */
+      if ((expr1->ts.type == BT_CLASS || expr1->ts.type == BT_DERIVED)
+	  && expr1->ts.u.derived->attr.unlimited_polymorphic
+	  && (expr2->ts.type == BT_CHARACTER ||
+	      ((expr2->ts.type == BT_DERIVED || expr2->ts.type == BT_CLASS)
+	       && expr2->ts.u.derived->attr.unlimited_polymorphic)))
+	{
+	  gfc_expr *len_comp;
+	  gfc_se se;
+	  len_comp = gfc_get_len_component (expr1);
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr (&se, len_comp);
+
+	  /* ptr % _len = len (str)  */
+	  gfc_add_modify (&block, se.expr, rse.string_length);
+	  lse.string_length = se.expr;
+	  gfc_free_expr (len_comp);
+	}
+
       /* Check character lengths if character expression.  The test is only
 	 really added if -fbounds-check is enabled.  Exclude deferred
 	 character length lefthand sides.  */

gcc/fortran/trans-stmt.c

@@ -1154,6 +1154,22 @@ gfc_trans_critical (gfc_code *code)
 }
 
 
+/* Return true, when the class has a _len component.  */
+
+static bool
+class_has_len_component (gfc_symbol *sym)
+{
+  gfc_component *comp = sym->ts.u.derived->components;
+  while (comp)
+    {
+      if (strcmp (comp->name, "_len") == 0)
+	return true;
+      comp = comp->next;
+    }
+  return false;
+}
+
+
 /* Do proper initialization for ASSOCIATE names.  */
 
 static void
@@ -1167,6 +1183,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   tree offset;
   tree dim;
   int n;
+  tree charlen;
+  bool need_len_assign;
 
   gcc_assert (sym->assoc);
   e = sym->assoc->target;
@@ -1177,6 +1195,20 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 
   unlimited = UNLIMITED_POLY (e);
 
+  /* Assignments to the string length need to be generated, when
+     ( sym is a char array or
+       sym has a _len component)
+     and the associated expression is unlimited polymorphic, which is
+     not (yet) correctly in 'unlimited', because for an already associated
+     BT_DERIVED the u-poly flag is not set, i.e.,
+      __tmp_CHARACTER_0_1 => w => arg
+       ^ generated temp      ^ from code, the w does not have the u-poly
+     flag set, where UNLIMITED_POLY(e) expects it.  */
+  need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED
+                     && e->ts.u.derived->attr.unlimited_polymorphic))
+      && (sym->ts.type == BT_CHARACTER
+          || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)
+              && class_has_len_component (sym))));
   /* Do a `pointer assignment' with updated descriptor (or assign descriptor
      to array temporary) for arrays with either unknown shape or if associating
      to a variable.  */
@@ -1276,8 +1308,11 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	 unconditionally associate pointers and the symbol is scalar.  */
       if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
 	{
+	  tree target_expr;
 	  /* For a class array we need a descriptor for the selector.  */
 	  gfc_conv_expr_descriptor (&se, e);
+	  /* Needed to get/set the _len component below.  */
+	  target_expr = se.expr;
 
 	  /* Obtain a temporary class container for the result.  */
 	  gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
@@ -1297,6 +1332,23 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 				        gfc_array_index_type,
 				        offset, tmp);
 	    }
+	  if (need_len_assign)
+	    {
+	      /* Get the _len comp from the target expr by stripping _data
+		 from it and adding component-ref to _len.  */
+	      tmp = gfc_class_len_get (TREE_OPERAND (target_expr, 0));
+	      /* Get the component-ref for the temp structure's _len comp.  */
+	      charlen = gfc_class_len_get (se.expr);
+	      /* Add the assign to the beginning of the the block...  */
+	      gfc_add_modify (&se.pre, charlen,
+			      fold_convert (TREE_TYPE (charlen), tmp));
+	      /* and the oposite way at the end of the block, to hand changes
+		 on the string length back.  */
+	      gfc_add_modify (&se.post, tmp,
+			      fold_convert (TREE_TYPE (tmp), charlen));
+	      /* Length assignment done, prevent adding it again below.  */
+	      need_len_assign = false;
+	    }
 	  gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
 	}
       else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
@@ -1311,7 +1363,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
 	}
       else
-	gfc_conv_expr (&se, e);
+	{
+	  /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
+	     which has the string length included.  For CHARACTERS it is still
+	     needed and will be done at the end of this routine.  */
+	  gfc_conv_expr (&se, e);
+	  need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER;
+	}
 
       tmp = TREE_TYPE (sym->backend_decl);
       tmp = gfc_build_addr_expr (tmp, se.expr);
@@ -1332,21 +1390,30 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
       gfc_add_init_cleanup (block, tmp, NULL_TREE);
     }
 
-  /* Set the stringlength from the vtable size.  */
-  if (sym->ts.type == BT_CHARACTER && sym->attr.select_type_temporary)
+  /* Set the stringlength, when needed.  */
+  if (need_len_assign)
     {
-      tree charlen;
       gfc_se se;
       gfc_init_se (&se, NULL);
-      gcc_assert (UNLIMITED_POLY (e->symtree->n.sym));
-      tmp = gfc_get_symbol_decl (e->symtree->n.sym);
-      tmp = gfc_vtable_size_get (tmp);
+      if (e->symtree->n.sym->ts.type == BT_CHARACTER)
+	{
+	  /* What about deferred strings?  */
+	  gcc_assert (!e->symtree->n.sym->ts.deferred);
+	  tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
+	}
+      else
+	tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
       gfc_get_symbol_decl (sym);
-      charlen = sym->ts.u.cl->backend_decl;
-      gfc_add_modify (&se.pre, charlen,
-		      fold_convert (TREE_TYPE (charlen), tmp));
-      gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
-			    gfc_finish_block (&se.post));
+      charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl
+					: gfc_class_len_get (sym->backend_decl);
+      /* Prevent adding a noop len= len.  */
+      if (tmp != charlen)
+	{
+	  gfc_add_modify (&se.pre, charlen,
+			  fold_convert (TREE_TYPE (charlen), tmp));
+	  gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
+				gfc_finish_block (&se.post));
+	}
     }
 }
 
@@ -5069,6 +5136,15 @@ gfc_trans_allocate (gfc_code * code)
 		gfc_add_modify (&se.pre, se.string_length,
 				fold_convert (TREE_TYPE (se.string_length),
 				memsz));
+	      else if ((al->expr->ts.type == BT_DERIVED
+			|| al->expr->ts.type == BT_CLASS)
+		       && expr->ts.u.derived->attr.unlimited_polymorphic)
+		{
+		  tmp = gfc_class_len_get (al->expr->symtree->n.sym->backend_decl);
+		  gfc_add_modify (&se.pre, tmp,
+				  fold_convert (TREE_TYPE (tmp),
+						memsz));
+		}
 
 	      /* Convert to size in bytes, using the character KIND.  */
 	      if (unlimited_char)

gcc/fortran/trans.h

@@ -348,6 +348,7 @@ gfc_wrapped_block;
 /* Class API functions.  */
 tree gfc_class_data_get (tree);
 tree gfc_class_vptr_get (tree);
+tree gfc_class_len_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);

gcc/testsuite/ChangeLog

+2015-01-18  Andre Vehreschild  <vehre@gmx.de>
+
+	PR fortran/60255
+	* gfortran.dg/unlimited_polymorphic_2.f03: Removed error.
+	* gfortran.dg/unlimited_polymorphic_20.f03: New test.
+
+2015-01-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/64578
+	* gfortran.dg/unlimited_polymorphic_21.f90: New test
+
 2015-01-18  Oleg Endo  <olegendo@gcc.gnu.org>
 
 	PR target/64652

gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03

@@ -5,7 +5,7 @@
 ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
 !            and Tobias Burnus <burnus@gcc.gnu.org>
 !
-  CHARACTER(:), allocatable, target :: chr ! { dg-error "TODO: Deferred character length variable" }
+  CHARACTER(:), allocatable, target :: chr
 ! F2008: C5100
   integer :: i(2)
   logical :: flag

gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90

+! { dg-do run }
+!
+! Testing fix for PR fortran/60255
+!
+! Author: Andre Vehreschild <vehre@gmx.de>
+!
+MODULE m
+
+contains
+  subroutine bar (arg, res)
+    class(*) :: arg
+    character(100) :: res
+    select type (w => arg)
+      type is (character(*))
+        write (res, '(I2)') len(w)
+    end select
+  end subroutine
+
+END MODULE
+
+program test
+    use m;
+    implicit none
+    character(LEN=:), allocatable, target :: S
+    character(LEN=100) :: res
+    class(*), pointer :: ucp
+    call sub1 ("long test string", 16)
+    call sub2 ()
+    S = "test"
+    ucp => S
+    call sub3 (ucp)
+    call sub4 (S, 4)
+    call sub4 ("This is a longer string.", 24)
+    call bar (S, res)
+    if (trim (res) .NE. " 4") call abort ()
+    call bar(ucp, res)
+    if (trim (res) .NE. " 4") call abort ()
+
+contains
+
+    subroutine sub1(dcl, ilen)
+        character(len=*), target :: dcl
+        integer(4) :: ilen
+        character(len=:), allocatable :: hlp
+        class(*), pointer :: ucp
+
+        ucp => dcl
+
+        select type (ucp)
+        type is (character(len=*))
+            if (len(dcl) .NE. ilen) call abort ()
+            if (len(ucp) .NE. ilen) call abort ()
+            hlp = ucp
+            if (len(hlp) .NE. ilen) call abort ()
+        class default
+            call abort()
+        end select
+    end subroutine
+
+    subroutine sub2
+        character(len=:), allocatable, target :: dcl
+        class(*), pointer :: ucp
+
+        dcl = "ttt"
+        ucp => dcl
+
+        select type (ucp)
+        type is (character(len=*))
+            if (len(ucp) .ne. 3) call abort ()
+        class default
+            call abort()
+        end select
+    end subroutine
+
+    subroutine sub3(ucp)
+        character(len=:), allocatable :: hlp
+        class(*), pointer :: ucp
+
+        select type (ucp)
+        type is (character(len=*))
+            if (len(ucp) .ne. 4) call abort ()
+            hlp = ucp
+            if (len(hlp) .ne. 4) call abort ()
+        class default
+            call abort()
+        end select
+    end subroutine
+
+    subroutine sub4(ucp, ilen)
+        character(len=:), allocatable :: hlp
+        integer(4) :: ilen
+        class(*) :: ucp
+
+        select type (ucp)
+        type is (character(len=*))
+            if (len(ucp) .ne. ilen) call abort ()
+            hlp = ucp
+            if (len(hlp) .ne. ilen) call abort ()
+        class default
+            call abort()
+        end select
+    end subroutine
+end program
+

gcc/testsuite/gfortran.dg/unlimited_polymorphic_21.f90

+! { dg-do run }
+! Tests the fix for PR64578.
+!
+! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
+!
+  type foo
+     real, allocatable :: component(:)
+  end type
+  type (foo), target :: f
+  class(*), pointer :: ptr(:)
+  allocate(f%component(1),source=[0.99])
+  call associate_pointer(f,ptr)
+  select type (ptr)
+    type is (real)
+      if (abs (ptr(1) - 0.99) > 1e-5) call abort
+  end select
+  ptr => return_pointer(f)  ! runtime segmentation fault
+  if (associated(return_pointer(f)) .neqv. .true.) call abort
+  select type (ptr)
+    type is (real)
+      if (abs (ptr(1) - 0.99) > 1e-5) call abort
+  end select
+contains
+  subroutine associate_pointer(this, item)
+    class(foo), target :: this
+    class(*), pointer :: item(:)
+    item => this%component
+  end subroutine
+  function return_pointer(this)
+    class(foo), target :: this
+    class(*), pointer :: return_pointer(:)
+    return_pointer => this%component
+  end function
+end
+