Hi all,
here is my next try on proposing a patch for the issue in pr60255. It took me
quite some time to understand the intricacies with handling variables
associated in a select type. I think I got most of the issues fixed now:
- Added generation of _len component for each unlimited polymorphic pointer.
- Removed (my own) _len component creation routine.
- Removed the double underscore in get_len_component().
- Associating an unlimited polymorphic entity to a deferred char array now lets
the deferred char array use the actual string length from the '_len'
component of the unlimited polymorphic entity for the charlen instead of the
size component of the vptr.
- Removed: Generating a special vtab name for deferred strings. A deferred
string assigned to the unlimited polymorphic entity is now stored as having
charlen zero again.
- Basic support for char array arrays (No stuttering here) in u-poly variables.
Bootstraps ok on x86_64-linux-gnu. Comparing regtests I get a difference in
unlimited_polymorphic_2.f90 that I don't understand yet. May be that is only,
because one error message disappeared.
Attached is the full patch for trunk and a delta patch for those of you who
already have my pr60255_3 added.
I don't provide a changelog entry yet, because I think review will find some
issues still to fix. So, comments welcome!
Regards,
Andre
On Tue, 9 Dec 2014 14:16:05 +0100
Dominique d'Humières <[email protected]> wrote:
> Dear Andre,
>
> The patch causes an ICE for the test gfortran.dg/unlimited_polymorphic_1.f03:
>
> f951: internal compiler error: in gfc_add_component_ref, at
> fortran/class.c:236
>
> f951: internal compiler error: Abort trap: 6
> gfc: internal compiler error: Abort trap: 6 (program f951)
> Abort
>
> Reduced test for which the ICE is triggered by ‘len(w)'
>
> 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
>
> Note that with your patch at
> https://gcc.gnu.org/ml/fortran/2014-08/msg00022.html, I get the same ICE for
> the Mikael’s test at https://gcc.gnu.org/ml/fortran/2014-08/msg00055.html
> (before your patch for pr60255, it used to give a wrong length: 80 instead of
> 20 AFAICR).
>
> Note that the assert at fortran/class.c:236 is also triggered for pr61115.
>
> Thanks for working on these issues,
>
> Dominique
>
> >> On 8 December 2014 at 18:38, Andre Vehreschild <[email protected]> wrote:
> >> Hi all,
> >>
> >> please find attached a more elaborate patch for pr60255. I totally agree
> >> that my first attempt was just scratching the surface of the work needed.
> >>
> >> This patch also is *not* complete, but because I am really new to gfortran
> >> patching, I don't want to present a final patch only to learn then, that I
> >> have violated design rules, common practice or the like. Therefore please
> >> comment and direct me to any sources/ideas to improve the patch.
> >>
> >> Topic:
> >> The pr 60255 is about assigning a char array to an unlimited polymorphic
> >> entity. In the comments the concern about the lost length information is
> >> raised. The patch adds a _len component to the unlimited polymorphic entity
> >> (after _data and _vtab) and adds an assignment of the string length to _len
> >> when a string is pointer assigned to the unlimited poly entity.
> >> Furthermore is the intrinsic len(unlimited poly pointing to a string)
> >> resolved to give the _len component.
> >>
> >> Yet missing:
> >> - assign _len component back to deferred char array length component
> >> - transport length along chains of unlimited poly entities, i.e., a => b;
> >> c => a where all objects are unlimited poly and b is a string.
> >> - allocate() in this context
> >>
> >> Patch dependencies:
> >> none
> >>
> >> Comments, concerns, candy welcome!
> >>
> >> Regards,
> >> Andre
>
>
--
Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
Tel.: +49 241 9291018 * Email: [email protected]
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 29e31e1..f5a815c 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,41 @@ 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 +682,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)
@@ -2403,38 +2457,6 @@ yes:
return true;
}
-/* Add the component _len to the class-type variable in c->expr1. */
-
-void
-gfc_add_len_component (gfc_code *c)
-{
- /* Just make sure input is correct. This is already at the calling site,
- but may be this routine is called from somewhere else in the furure. */
- gcc_assert (UNLIMITED_POLY(c->expr1)
- && c->expr2
- && c->expr2->ts.type== BT_CHARACTER);
-
- gfc_component *len;
- gfc_expr *e;
- /* Check that _len is not present already. */
- if ((len= gfc_find_component (c->expr1->ts.u.derived, "_len", true, true)))
- return;
- /* Create the new component. */
- if (!gfc_add_component (c->expr1->ts.u.derived, "_len", &len))
- // Possible errors are already reported in add_component
- return;
- len->ts.type = BT_INTEGER;
- len->ts.kind = 4;
- len->attr.access = ACCESS_PRIVATE;
-
- /* Build minimal expression to initialize component with zero. */
- e = gfc_get_expr();
- e->ts = c->expr1->ts;
- e->expr_type = EXPR_VARIABLE;
- len->initializer = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, 0);
- gfc_free_expr (e);
-}
/* Find (or generate) the symbol for an intrinsic type's vtab. This is
needed to support unlimited polymorphism. */
@@ -2460,16 +2482,10 @@ find_intrinsic_vtab (gfc_typespec *ts)
{
char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
- if (ts->type == BT_CHARACTER) {
- if (!ts->deferred)
- sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
- charlen, ts->kind);
- else
- /* The type is deferred here. Ensure that this is easily seen in the
- vtable. */
- sprintf (tname, "%s_DEFERRED_%d", gfc_basic_typename (ts->type),
- ts->kind);
- } else
+ if (ts->type == BT_CHARACTER)
+ 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);
sprintf (name, "__vtab_%s", tname);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index f99c3f8..07de61b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3190,9 +3190,9 @@ 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_add_len_component(gfc_code *);
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 *);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6e14e74..9d7d3c2 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10081,11 +10081,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
if (!t)
break;
- if (gfc_check_pointer_assign (code->expr1, code->expr2)
- && UNLIMITED_POLY(code->expr1)
- && code->expr2->ts.type== BT_CHARACTER)
- gfc_add_len_component (code);
-
+ gfc_check_pointer_assign (code->expr1, code->expr2);
break;
}
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 88cd8e7..ed6c057 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3687,32 +3687,6 @@ gfc_simplify_leadz (gfc_expr *e)
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
}
-static gfc_expr *
-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;
-}
-
gfc_expr *
gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
{
@@ -3741,7 +3715,7 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
&& e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
&& e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED)
{
- return get__len_component (e);
+ return gfc_get_len_component (e);
}
else
return NULL;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 713f969..cb2c656 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -550,15 +550,15 @@ static void
gfc_finish_var_decl (tree decl, gfc_symbol * sym)
{
tree new_type;
- /* TREE_ADDRESSABLE means the address of this variable is actually needed.
- This is the equivalent of the TARGET variables.
- We also need to set this if the variable is passed by reference in a
- CALL statement. */
/* Set DECL_VALUE_EXPR for Cray Pointees. */
if (sym->attr.cray_pointee)
gfc_finish_cray_pointee (decl, sym);
+ /* TREE_ADDRESSABLE means the address of this variable is actually needed.
+ This is the equivalent of the TARGET variables.
+ We also need to set this if the variable is passed by reference in a
+ CALL statement. */
if (sym->attr.target)
TREE_ADDRESSABLE (decl) = 1;
/* If it wasn't used we wouldn't be getting it. */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9a08bde..d52f3cc 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,40 @@ 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);
}
@@ -6415,6 +6464,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,
@@ -6491,7 +6548,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
@@ -6798,9 +6857,12 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
/* 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_DERIVED
+ 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_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);
}
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index d17b075..7c8974e 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,22 @@ 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 +1250,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 +1279,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));
}
@@ -1286,6 +1317,22 @@ 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. */
+ tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
+ /* 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 +1347,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 = sym->ts.type == BT_CHARACTER;
+ }
tmp = TREE_TYPE (sym->backend_decl);
tmp = gfc_build_addr_expr (tmp, se.expr);
@@ -1321,19 +1374,17 @@ 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);
+ 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;
+ charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl
+ : gfc_class_len_get (sym->backend_decl);
gfc_add_modify (&se.pre, charlen,
- fold_convert (TREE_TYPE (charlen), tmp));
+ fold_convert (TREE_TYPE (charlen), tmp));
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
gfc_finish_block (&se.post));
}
@@ -5048,12 +5099,21 @@ 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)
tmp = TREE_TYPE (gfc_typenode_for_spec (&code->expr3->ts));
else
- tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
+ tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
tmp = TYPE_SIZE_UNIT (tmp);
memsz = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), tmp,
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/fortran/class.c b/gcc/fortran/class.c
index 0286c9e..f5a815c 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,41 @@ 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 +682,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 +2469,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 +2483,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 1058502..07de61b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3190,8 +3190,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 7ccabc7..ed6c057 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3687,7 +3687,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)
{
@@ -3711,6 +3710,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-decl.c b/gcc/fortran/trans-decl.c
index 713f969..cb2c656 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -550,15 +550,15 @@ static void
gfc_finish_var_decl (tree decl, gfc_symbol * sym)
{
tree new_type;
- /* TREE_ADDRESSABLE means the address of this variable is actually needed.
- This is the equivalent of the TARGET variables.
- We also need to set this if the variable is passed by reference in a
- CALL statement. */
/* Set DECL_VALUE_EXPR for Cray Pointees. */
if (sym->attr.cray_pointee)
gfc_finish_cray_pointee (decl, sym);
+ /* TREE_ADDRESSABLE means the address of this variable is actually needed.
+ This is the equivalent of the TARGET variables.
+ We also need to set this if the variable is passed by reference in a
+ CALL statement. */
if (sym->attr.target)
TREE_ADDRESSABLE (decl) = 1;
/* If it wasn't used we wouldn't be getting it. */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index f8e4df8..d52f3cc 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,40 @@ 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);
}
@@ -1034,11 +1083,11 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
gfc_add_vptr_component (lhs);
if (UNLIMITED_POLY (expr1)
- && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN)
- {
- rhs = gfc_get_null_expr (&expr2->where);
- goto assign_vptr;
- }
+ && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN)
+ {
+ rhs = gfc_get_null_expr (&expr2->where);
+ goto assign_vptr;
+ }
if (expr2->expr_type == EXPR_NULL)
vtab = gfc_find_vtab (&expr1->ts);
@@ -6415,6 +6464,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,
@@ -6491,7 +6548,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
@@ -6695,6 +6754,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)
{
@@ -6759,6 +6855,18 @@ 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 d17b075..7c8974e 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,22 @@ 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 +1250,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 +1279,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));
}
@@ -1286,6 +1317,22 @@ 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. */
+ tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
+ /* 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 +1347,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 = sym->ts.type == BT_CHARACTER;
+ }
tmp = TREE_TYPE (sym->backend_decl);
tmp = gfc_build_addr_expr (tmp, se.expr);
@@ -1321,19 +1374,17 @@ 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);
+ 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;
+ charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl
+ : gfc_class_len_get (sym->backend_decl);
gfc_add_modify (&se.pre, charlen,
- fold_convert (TREE_TYPE (charlen), tmp));
+ fold_convert (TREE_TYPE (charlen), tmp));
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
gfc_finish_block (&se.post));
}
@@ -5048,12 +5099,21 @@ 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)
tmp = TREE_TYPE (gfc_typenode_for_spec (&code->expr3->ts));
else
- tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
+ tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
tmp = TYPE_SIZE_UNIT (tmp);
memsz = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), tmp,
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_18.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90
index 7a0df1a..9044199 100644
--- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90
@@ -1,6 +1,6 @@
! { dg-do compile }
-! Testing fix for
-! PR fortran/60414
+! Testing fix for
+! PR fortran/60414
!
module m
implicit none
@@ -23,7 +23,7 @@ contains
if ( abs (X - this%expectedScalar) > 0.0001 ) then
call abort()
end if
- class default
+ class default
call abort ()
end select
end subroutine FCheck
@@ -62,8 +62,8 @@ end module
program test
use :: m
implicit none
-
+
real :: vec(1:6) = (/ 0, 1, 2, 3, 4, 5 /)
call checktextvector(vec, 6, 5.0)
-end program test
+end program test
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03
new file mode 100644
index 0000000..6042882
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03
@@ -0,0 +1,57 @@
+! { dg-do run }
+! Testing fix for
+! PR fortran/60255
+!
+program test
+ implicit none
+ character(LEN=:), allocatable :: S
+ call subP(S)
+ call sub2()
+ call sub1("test")
+
+contains
+
+ subroutine sub1(dcl)
+ character(len=*), target :: dcl
+ class(*), pointer :: ucp
+! character(len=:), allocatable ::def
+
+ ucp => dcl
+
+ select type (ucp)
+ type is (character(len=*))
+ if (len(ucp) .NE. 4) then
+ call abort()
+! else
+! def = ucp
+! if (len(def) .NE. 4) then
+! call abort() ! This abort is expected currently
+! end if
+ end if
+ 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) then
+ call abort()
+ end if
+ class default
+ call abort()
+ end select
+ end subroutine
+
+ subroutine subP(P)
+ class(*) :: P
+ end subroutine
+
+end program
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 <[email protected]>
! and Tobias Burnus <[email protected]>
!
- CHARACTER(:), allocatable, target :: chr ! { dg-error "TODO: Deferred character length variable" }
+ CHARACTER(:), allocatable, target :: chr
! F2008: C5100
integer :: i(2)
logical :: flag
