[fortran,final] PR fortran/60255 Deferred character length

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 5130022..3438826 100644
--- a/gcc/fortran/class.c
+++ b/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,42 @@  gfc_intrinsic_hash_value (gfc_typespec *ts)
 }
 
 
+/* Get the _len component from a class/derived object storing a string.  */
+
+gfc_expr *
+gfc_get_len_component (gfc_expr *e)
+{
+  gfc_expr *len_comp;
+  gfc_ref *ref, **last;
+  len_comp = gfc_copy_expr (e->symtree->n.sym->assoc->target);
+
+  /* We need to remove the last _data component ref from ptr.  */
+  last = &(len_comp->ref);
+  ref = len_comp->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;
+    }
+  gfc_add_component_ref (len_comp, "_len");
+  return len_comp;
+}
+
+
 /* 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 +683,36 @@  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;
+
+	  /* Build minimal expression to initialize component with zero.
+	     TODO: When doing this, one goes to hell in the select type
+		   id association something in generating the constructor
+		   code really goes wrong.  Not using an initializer here
+		   needs extra code in the alloc statements.  */
+//	  c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+//					     NULL, 0);
 	}
       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 +2470,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)
@@ -2438,8 +2484,8 @@  find_intrinsic_vtab (gfc_typespec *ts)
       char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
 
       if (ts->type == BT_CHARACTER)
-	sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
-		 charlen, ts->kind);
+        sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
+                 charlen, ts->kind);
       else
 	sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 41c6c57..20c86b7 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3123,8 +3123,10 @@  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 *);
 bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
 			     gfc_array_spec **);
+void gfc_assign_charlen_to_unlimited_poly (gfc_code *c);
 gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
 gfc_symbol *gfc_find_vtab (gfc_typespec *);
 gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*,
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index d46c5db..f4436ab 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3689,7 +3689,6 @@  gfc_simplify_leadz (gfc_expr *e)
   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
 }
 
-
 gfc_expr *
 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
 {
@@ -3713,6 +3712,13 @@  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)
+    {
+      return gfc_get_len_component (e);
+    }
   else
     return NULL;
 }
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 3793cfb..d5a49af 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -94,6 +94,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
@@ -148,6 +149,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)
 {
@@ -617,6 +632,42 @@  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);
+      if (e->ts.u.cl->backend_decl)
+        {
+          gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl);
+        }
+      else if (parmse->string_length)
+        {
+          gfc_add_modify (&parmse->pre, ctree, parmse->string_length);
+        }
+      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);
 }
@@ -6489,6 +6540,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,
@@ -6565,7 +6624,9 @@  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
+      /* TODO: Need to check, if this is correctly working for all cases.  */
+      && expr->ts.u.derived->attr.is_bind_c)
     {
       if (expr->expr_type == EXPR_VARIABLE
 	  && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
@@ -6769,6 +6830,43 @@  gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
 }
 
 
+/* Create the character length assignment to the _len component.  */
+
+void
+add_assignment_of_string_len_to_len_component (stmtblock_t *block,
+                                               gfc_expr *ptr, gfc_se *ptr_se,
+                                               gfc_se *str)
+{
+  gfc_expr *len_comp;
+  gfc_ref *ref, **last;
+  gfc_se lse;
+  len_comp = gfc_copy_expr (ptr);
+  /* We need to remove the last _data component ref from ptr.  */
+  last = &(len_comp->ref);
+  ref = len_comp->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;
+    }
+  gfc_add_component_ref (len_comp, "_len");
+  gfc_init_se (&lse, NULL);
+  gfc_conv_expr (&lse, len_comp);
+
+  /* ptr % _len = len (str)  */
+  gfc_add_modify (block, lse.expr, str->string_length);
+  ptr_se->string_length = lse.expr;
+  gfc_free_expr (len_comp);
+}
+
 tree
 gfc_trans_pointer_assign (gfc_code * code)
 {
@@ -6833,6 +6931,19 @@  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)))
+        {
+          add_assignment_of_string_len_to_len_component (&block, expr1, &lse,
+                                                         &rse);
+        }
+
       /* Check character lengths if character expression.  The test is only
 	 really added if -fbounds-check is enabled.  Exclude deferred
 	 character length lefthand sides.  */
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 24e47f2..78d11c1 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1143,6 +1143,21 @@  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
@@ -1156,6 +1171,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;
@@ -1166,6 +1183,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.  */
@@ -1217,7 +1248,6 @@  trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
 	  gfc_add_modify (&se.pre, GFC_DECL_SPAN(desc), tmp);
 	}
-
       /* Done, register stuff as init / cleanup code.  */
       gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
 			    gfc_finish_block (&se.post));
@@ -1247,7 +1277,6 @@  trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  gfc_add_modify (&se.pre, tmp,
 			  gfc_get_dtype (TREE_TYPE (sym->backend_decl)));
 	}
-
       gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
 			    gfc_finish_block (&se.post));
     }
@@ -1265,8 +1294,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);
@@ -1286,6 +1318,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
@@ -1300,7 +1349,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);
@@ -1321,21 +1376,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));
+        }
     }
 }
 
@@ -5050,6 +5114,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)
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 51ad910..3926c2a 100644
--- a/gcc/fortran/trans.h
+++ b/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);
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03
index 8e80386..30e4797 100644
--- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03
new file mode 100644
index 0000000..c6c6d29
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03
@@ -0,0 +1,104 @@ 
+! { 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
+