@@ -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)
@@ -2434,18 +2487,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)
@@ -3173,6 +3173,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 *);
@@ -3690,6 +3690,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;
}
@@ -92,6 +92,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
@@ -146,6 +147,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)
{
@@ -599,6 +614,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, 4,
+ &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);
}
@@ -6193,7 +6247,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
of EXPR_NULL,... by default, the static nullify is not needed
since this is done every time we come into scope. */
if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
- continue;
+ continue;
if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
&& strcmp (cm->name, "_extends") == 0
@@ -6211,6 +6265,10 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
}
+ else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
+ fold_convert (TREE_TYPE (cm->backend_decl),
+ integer_zero_node));
else
{
val = gfc_conv_initializer (c->expr, &cm->ts,
@@ -6287,7 +6345,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
@@ -6552,6 +6611,27 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
rse.expr = build_fold_indirect_ref_loc (input_location,
rse.expr);
+ /* 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);
+ }
+
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
@@ -1133,6 +1133,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
@@ -1146,6 +1162,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;
@@ -1156,6 +1174,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. */
@@ -1255,8 +1287,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);
@@ -1276,6 +1311,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
@@ -1290,7 +1342,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);
@@ -1311,21 +1369,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));
+ }
}
}
@@ -5038,6 +5105,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)
@@ -347,6 +347,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);
@@ -1,80 +1,80 @@
-! { dg-do compile }
-!
-! Test the most important constraints unlimited polymorphic entities
-!
-! 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" }
-! F2008: C5100
- integer :: i(2)
- logical :: flag
- class(*), pointer :: u1, u2(:) ! { dg-error "cannot appear in COMMON" }
- common u1
- u1 => chr
-! F2003: C625
- allocate (u1) ! { dg-error "requires either a type-spec or SOURCE tag" }
- allocate (real :: u1)
- Allocate (u1, source = 1.0)
-
-! F2008: C4106
- u2 = [u1] ! { dg-error "shall not be unlimited polymorphic" }
-
- i = u2 ! { dg-error "Can\\'t convert CLASS\\(\\*\\)" }
-
-! Repeats same_type_as_1.f03 for unlimited polymorphic u2
- flag = same_type_as (i, u2) ! { dg-error "cannot be of type INTEGER" }
- flag = extends_type_of (i, u2) ! { dg-error "cannot be of type INTEGER" }
-
-contains
-
-! C717 (R735) If data-target is unlimited polymorphic,
-! data-pointer-object shall be unlimited polymorphic, of a sequence
-! derived type, or of a type with the BIND attribute.
-!
- subroutine bar
-
- type sq
- sequence
- integer :: i
- end type sq
-
- type(sq), target :: x
- class(*), pointer :: y
- integer, pointer :: tgt
-
- x%i = 42
- y => x
- call foo (y)
-
- y => tgt ! This is OK, of course.
- tgt => y ! { dg-error "must be unlimited polymorphic" }
-
- select type (y) ! This is the correct way to accomplish the previous
- type is (integer)
- tgt => y
- end select
-
- end subroutine bar
-
-
- subroutine foo(tgt)
- class(*), pointer, intent(in) :: tgt
- type t
- sequence
- integer :: k
- end type t
-
- type(t), pointer :: ptr
-
- ptr => tgt ! C717 allows this.
-
- select type (tgt)
-! F03:C815 or F08:C839
- type is (t) ! { dg-error "shall not specify a sequence derived type" }
- ptr => tgt ! { dg-error "Expected TYPE IS" }
- end select
-
- print *, ptr%k
- end subroutine foo
-END
+! { dg-do compile }
+!
+! Test the most important constraints unlimited polymorphic entities
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+! and Tobias Burnus <burnus@gcc.gnu.org>
+!
+ CHARACTER(:), allocatable, target :: chr
+! F2008: C5100
+ integer :: i(2)
+ logical :: flag
+ class(*), pointer :: u1, u2(:) ! { dg-error "cannot appear in COMMON" }
+ common u1
+ u1 => chr
+! F2003: C625
+ allocate (u1) ! { dg-error "requires either a type-spec or SOURCE tag" }
+ allocate (real :: u1)
+ Allocate (u1, source = 1.0)
+
+! F2008: C4106
+ u2 = [u1] ! { dg-error "shall not be unlimited polymorphic" }
+
+ i = u2 ! { dg-error "Can\\'t convert CLASS\\(\\*\\)" }
+
+! Repeats same_type_as_1.f03 for unlimited polymorphic u2
+ flag = same_type_as (i, u2) ! { dg-error "cannot be of type INTEGER" }
+ flag = extends_type_of (i, u2) ! { dg-error "cannot be of type INTEGER" }
+
+contains
+
+! C717 (R735) If data-target is unlimited polymorphic,
+! data-pointer-object shall be unlimited polymorphic, of a sequence
+! derived type, or of a type with the BIND attribute.
+!
+ subroutine bar
+
+ type sq
+ sequence
+ integer :: i
+ end type sq
+
+ type(sq), target :: x
+ class(*), pointer :: y
+ integer, pointer :: tgt
+
+ x%i = 42
+ y => x
+ call foo (y)
+
+ y => tgt ! This is OK, of course.
+ tgt => y ! { dg-error "must be unlimited polymorphic" }
+
+ select type (y) ! This is the correct way to accomplish the previous
+ type is (integer)
+ tgt => y
+ end select
+
+ end subroutine bar
+
+
+ subroutine foo(tgt)
+ class(*), pointer, intent(in) :: tgt
+ type t
+ sequence
+ integer :: k
+ end type t
+
+ type(t), pointer :: ptr
+
+ ptr => tgt ! C717 allows this.
+
+ select type (tgt)
+! F03:C815 or F08:C839
+ type is (t) ! { dg-error "shall not specify a sequence derived type" }
+ ptr => tgt ! { dg-error "Expected TYPE IS" }
+ end select
+
+ print *, ptr%k
+ end subroutine foo
+END
new file mode 100644
@@ -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
+