[Bug fortran/55901] [OOP] type is (character(len=*)) misinterpreted as array
Paul Richard Thomas
paul.richard.thomas@gmail.com
Sun Jan 11 15:05:00 GMT 2015
Dear Andre,
Please find attached an extended version of your patch for PR60255. It
incorporates the patch for PR55901. Apart from this latter, the
differences occur (by line numbers in the attached) as follows:
trans-expr.c
328 to 337 set _len for expressions other than CHARACTER
385 to 396 -ditto-
406 to 416 -ditto- TODO these three additions should be
broken out into a function
TODO gfc_trans_pointer_assignment should have the _len component set
for all allowed assignments, using this function
trans-stmt.c
726 to 733 permits allocation of unlimited_polymorphic components
743 to 753 sets the _len field using memsz
770 to 780 copies unlimited_polymorphic SOURCE, using MEMCPY and the
allocated size
These changes, which extends setting _len for all dynamic types, came
about because the allocation from an unlimited_polymorphic source does
not readily allow the distinction between CHARACTER and other dynamic
types to be made at compile time. Also, the _copy function pointed to
in the vtable missed the string_length arguments for CHARACTER dynamic
types.
Although not essential, I would suggest changing gfc_get_len_component
to have the same API as the other functions like
gfc_add_vptr_component.
I have made no attempt to deal with the KIND business. I am assuming
that you have progressed that bit.
The upshot of all of this is that
ftp://ftp.numerical.rl.ac.uk/pub/MRandC/oo.f90 , pointed to in comment
#5 of PR59901 now runs correctly; or, rather, produces the same output
as ifort.
Either this, or the "test vehicle below" should be turned into a test
case. I am willing to do that. I have yet to test all of this on
unlimited_polymorphic arrays and have not checked the use of MOLD for
similar cases.
To my immense surprise, trunk with the attached patch bootstraps and
regtests with no problems :-)
What next? I propose that I commit the patch posted in comment #8 of
PR55901 to get it out of the way. Then we need to discuss who does
what to bring the whole lot to a conclusion. I have to attend to some
"daytime" work now and might not be able to get back to gfortran
tonight
I have been using this as the "test vehicle", whilst making the changes:
class (*), allocatable :: a
type :: mytype
integer :: i
class(*), allocatable :: c
end type
type(mytype) :: b
allocate (a, source = "hello")
select type (a)
type is (character(*))
print *, a, len (a)
end select
if (allocated (a)) deallocate (a)
allocate (a, source = "goodbye")
select type (a)
type is (character(*))
print *, a, len (a)
end select
call foo (b%c, a)
select type (z => b%c)
type is (character(*))
print *, z, len (z)
z = "it is nice to meet you"
end select
select type (z => b%c)
type is (character(*))
print *, z, len (z)
end select
if (allocated (b%c)) deallocate (b%c)
allocate (b%c, source = "goodbye")
select type (z => b%c)
type is (character(*))
print *, z, len (z)
end select
if (allocated (b%c)) deallocate (b%c)
call foo (b%c, 42)
select type (z => b%c)
type is (INTEGER)
print *, z
end select
contains
subroutine foo (dest, src)
class (*), allocatable :: dest
class (*) :: src
allocate (dest, source = src)
end subroutine
end
With best regards
Paul
On 8 January 2015 at 21:44, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi Paul,
>
> I am not mad at you. I am sorry, if I attacked you by my writing. That was
> not my intention. I am doing this patches for a living. The contract is:
> payment on patch in trunk. And it is already taking far to much time for the
> money I will get. May that was the frustration I have felt. Again my
> apologies.
>
> From Tobias I got the same idea of storing the elem_size* #elems in _Len. I
> will modify the patch tomorrow to mimick the new style, but then I will
> rename the _Len component, cause I believe it should then express, that it
> is storing the size of the datatype and not only the length in the array
> dimension. So how about renaming it to _dtsize to make it distinct from the
> size in vtype by name. I could also live with _asize for 'array size' . what
> would you prefer? Any other ideas?
>
> Regards,
> Andre
>
> Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
> Tel. +49 241.9291018 * vehre@gmx.de
>
>
> Paul Richard Thomas <paul.richard.thomas@gmail.com> schrieb:
>
>
> Dear Andre,
>
> From a quick look at the patch, I do not think that there is a bind_c issue,
> as Janus was suggesting. As long as the extra condition is added, it seems
> to me that all is well.
>
> By the way, I do not agree that BT_VOID has been "hijacked" :-) Its use has
> been extended.....
>
> Let's ignore this issue for now.
>
> Cheers
>
> Paul
>
> On 8 January 2015 at 20:32, Paul Richard Thomas
> <paul.richard.thomas@gmail.com> wrote:
>>
>> Dear Andre,
>>
>> Please do not get mad at me. I am very much on the edge of not being able
>> to contribute to gfortran at all :-(
>>
>> As for the bind_c issue, as I said I have no more expertise in this matter
>> than you do. I will take a look tonight but can offer no guarantees!
>>
>> My thinking on the storage of the length in bytes is that the performance
>> issue in array access is more important than the evaluation of LEN, even
>> though it is the latter that appears in your testcases. I am open to being
>> persuaded otherwise :-)
>>
>> If it is any consolation to you, I submitted my first gfortran patch 10
>> years ago. It took me some months to satisfy the then gfortran guru, Paul
>> Brooks. Even then, it was committed on the basis that, "If this is the best
>> that you can do, OK." I have to say that every time I look at it, I think
>> that I must put it right! Paul was really excellent and it is a pity that we
>> do not have his support now. We have a tradition, shared with gcc in
>> general, that we try to ensure a certain amount of QC. It can be a pain in
>> the ass but the result is a rather robust compiler.
>>
>> Back to work - you will hear from me later.
>>
>> Cheers
>>
>> Paul
>>
>> On 8 January 2015 at 10:33, Andre Vehreschild <vehre@gmx.de> wrote:
>>>
>>> Hi Paul,
>>>
>>> > The patch was only a draft and has not yet even been submitted, let
>>> > alone
>>> > committed. I wanted to see it working with your patch such that the
>>> > Metcalfe example works correctly :-)
>>>
>>> My published patches do not address the Metcalf example. I have a patch
>>> that
>>> addresses it, but I will not publish it before the patches it bases on
>>> are
>>> done. It is hard enough to get one patch reviewed at a time. Producing
>>> review
>>> overhead by publishing multiple dependent patches makes no sense to me.
>>>
>>> > I took a long look at your patch last night. It bootstraps and regtests
>>> > OK.
>>> > I think that there are some issues, which will not be difficult to put
>>> > right, concerning the vtables and the treatment of kind information. I
>>> > believe, and this is consistent with the standard, that there should be
>>> > a
>>> > unique vtable only for each kind. I suggest that the _size field
>>> > contain
>>> > the kind value and that the _len field that you have introduced contain
>>> > the
>>> > product of the kind and the string length; ie the string length in
>>> > bytes.
>>> > This allows the indexing of arrays to be done without repeating the
>>> > multiplication.
>>>
>>> But that would mean to do a division each time one executes
>>> len(chararray). IMHO
>>> divisions are far more expensive than a multiplication. Furthermore is a
>>> multiplication translated to a shift operation by the compiler, right?
>>>
>>> Anyhow, what about the bind_c issue I was asking about?
>>>
>>> - Andre
>>> --
>>> Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
>>> Tel.: +49 241 9291018 * Email: vehre@gmx.de
>>
>>
>>
>>
>> --
>> Outside of a dog, a book is a man's best friend. Inside of a dog it's too
>> dark to read.
>>
>> Groucho Marx
>
>
>
>
> --
> Outside of a dog, a book is a man's best friend. Inside of a dog it's too
> dark to read.
>
> Groucho Marx
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
-------------- next part --------------
Index: gcc/fortran/class.c
===================================================================
*** gcc/fortran/class.c (revision 219297)
--- gcc/fortran/class.c (working copy)
*************** along with GCC; see the file COPYING3.
*** 34,39 ****
--- 34,45 ----
(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.
*************** gfc_intrinsic_hash_value (gfc_typespec *
*** 544,553 ****
}
/* 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. */
bool
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
--- 550,597 ----
}
+ /* 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. 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,
*************** gfc_build_class_symbol (gfc_typespec *ts
*** 645,663 ****
if (!gfc_add_component (fclass, "_vptr", &c))
return false;
c->ts.type = BT_DERIVED;
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;
}
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)
--- 689,716 ----
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;
}
if (!ts->u.derived->attr.unlimited_polymorphic)
*************** find_intrinsic_vtab (gfc_typespec *ts)
*** 2415,2432 ****
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);
! }
/* Find the top-level namespace. */
for (ns = gfc_current_ns; ns; ns = ns->parent)
--- 2468,2476 ----
gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
int charlen = 0;
! 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)
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 219297)
--- gcc/fortran/gfortran.h (working copy)
*************** bool gfc_is_class_scalar_expr (gfc_expr
*** 3123,3128 ****
--- 3123,3129 ----
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 *);
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c (revision 219297)
--- gcc/fortran/primary.c (working copy)
*************** gfc_match_varspec (gfc_expr *primary, in
*** 1857,1863 ****
Thus if we have one and parentheses follow, we have to assume that it
actually is one for now. The final decision will be made at
resolution time, of course. */
! if (sym->assoc && gfc_peek_ascii_char () == '(')
sym->attr.dimension = 1;
if ((equiv_flag && gfc_peek_ascii_char () == '(')
--- 1857,1866 ----
Thus if we have one and parentheses follow, we have to assume that it
actually is one for now. The final decision will be made at
resolution time, of course. */
! if (sym->assoc && gfc_peek_ascii_char () == '('
! && !(sym->assoc->dangling && sym->assoc->st
! && sym->assoc->st->n.sym
! && sym->assoc->st->n.sym->attr.dimension == 0))
sym->attr.dimension = 1;
if ((equiv_flag && gfc_peek_ascii_char () == '(')
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 219297)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_assoc_var (gfc_symbol* sym, bool
*** 7935,7942 ****
/* Finally resolve if this is an array or not. */
if (sym->attr.dimension && target->rank == 0)
{
! gfc_error ("Associate-name %qs at %L is used as array",
! sym->name, &sym->declared_at);
sym->attr.dimension = 0;
return;
}
--- 7935,7945 ----
/* Finally resolve if this is an array or not. */
if (sym->attr.dimension && target->rank == 0)
{
! /* primary.c makes the assumption that a reference to an associate
! name followed by a left parenthesis is an array reference. */
! if (sym->ts.type != BT_CHARACTER)
! gfc_error ("Associate-name %qs at %L is used as array",
! sym->name, &sym->declared_at);
sym->attr.dimension = 0;
return;
}
Index: gcc/fortran/simplify.c
===================================================================
*** gcc/fortran/simplify.c (revision 219297)
--- gcc/fortran/simplify.c (working copy)
*************** gfc_simplify_len (gfc_expr *e, gfc_expr
*** 3713,3718 ****
--- 3713,3726 ----
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;
}
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 219297)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1452,1458 ****
/* Create string length decl first so that they can be used in the
type declaration. */
if (sym->ts.type == BT_CHARACTER)
! length = gfc_create_string_length (sym);
/* Create the decl for the variable. */
decl = build_decl (sym->declared_at.lb->location,
--- 1452,1465 ----
/* Create string length decl first so that they can be used in the
type declaration. */
if (sym->ts.type == BT_CHARACTER)
! {
! if (sym->attr.associate_var
! && sym->ts.u.cl->backend_decl
! && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
! length = gfc_index_zero_node;
! else
! length = gfc_create_string_length (sym);
! }
/* Create the decl for the variable. */
decl = build_decl (sym->declared_at.lb->location,
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1514,1519 ****
--- 1521,1528 ----
/* Character variables need special handling. */
gfc_allocate_lang_decl (decl);
+ /* Associate names can use the hidden string length variable
+ of their associated target. */
if (TREE_CODE (length) != INTEGER_CST)
{
gfc_finish_var_decl (length, sym);
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 219297)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_scalar_to_descriptor (gfc_se *s
*** 94,99 ****
--- 94,100 ----
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
*************** gfc_class_vptr_get (tree decl)
*** 148,153 ****
--- 149,168 ----
}
+ 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)
{
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 459,464 ****
--- 474,489 ----
}
}
+ /* Set the _len field. */
+ if (class_ts.u.derived->attr.unlimited_polymorphic)
+ {
+ tree type;
+ type = gfc_typenode_for_spec (&e->ts);
+ ctree = gfc_class_len_get (var);
+ tmp = fold_convert (TREE_TYPE (ctree), TYPE_SIZE_UNIT (type));
+ gfc_add_modify (&parmse->pre, ctree, tmp);
+ }
+
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
*************** gfc_conv_intrinsic_to_class (gfc_se *par
*** 617,622 ****
--- 642,697 ----
}
}
+ /* Set the _len component of the unlimited polymorphic entity. */
+ 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);
+ }
+ }
+ }
+ else
+ {
+ tree type;
+ if (e->rank)
+ type = gfc_get_element_type (TREE_TYPE (parmse->expr));
+ else
+ type = TREE_TYPE (parmse->expr);
+ ctree = gfc_class_len_get (var);
+ tmp = fold_convert (TREE_TYPE (ctree), TYPE_SIZE_UNIT (type));
+ gfc_add_modify (&parmse->pre, ctree, tmp);
+ }
+
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
}
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 4254,4259 ****
--- 4329,4345 ----
&& e->symtree->n.sym->attr.optional,
CLASS_DATA (fsym)->attr.class_pointer
|| CLASS_DATA (fsym)->attr.allocatable);
+
+ /* Set the _len field of unlimited polymorphic formal args. */
+ if (UNLIMITED_POLY (fsym))
+ {
+ tree type, ctree;
+ tmp = TREE_OPERAND (parmse.expr, 0);
+ type = gfc_typenode_for_spec (&e->ts);
+ ctree = gfc_class_len_get (tmp);
+ tmp = fold_convert (TREE_TYPE (ctree), TYPE_SIZE_UNIT (type));
+ gfc_add_modify (&parmse.pre, ctree, tmp);
+ }
}
else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
{
*************** gfc_conv_structure (gfc_se * se, gfc_exp
*** 6490,6495 ****
--- 6576,6589 ----
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,
*************** gfc_conv_expr (gfc_se * se, gfc_expr * e
*** 6566,6572 ****
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->expr_type == EXPR_VARIABLE
&& (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
--- 6660,6667 ----
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
! && expr->ts.u.derived->attr.is_bind_c)
{
if (expr->expr_type == EXPR_VARIABLE
&& (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 6834,6839 ****
--- 6929,6955 ----
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. */
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 219297)
--- gcc/fortran/trans.h (working copy)
*************** gfc_wrapped_block;
*** 348,353 ****
--- 348,354 ----
/* 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);
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 219297)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_critical (gfc_code *code)
*** 1143,1148 ****
--- 1143,1164 ----
}
+ /* 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
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1156,1161 ****
--- 1172,1179 ----
tree offset;
tree dim;
int n;
+ tree charlen;
+ bool need_len_assign;
gcc_assert (sym->assoc);
e = sym->assoc->target;
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1166,1171 ****
--- 1184,1203 ----
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. */
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1265,1272 ****
--- 1297,1307 ----
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);
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1286,1291 ****
--- 1321,1343 ----
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
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1300,1306 ****
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
}
else
! gfc_conv_expr (&se, e);
tmp = TREE_TYPE (sym->backend_decl);
tmp = gfc_build_addr_expr (tmp, se.expr);
--- 1352,1364 ----
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
}
else
! {
! /* 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);
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1321,1341 ****
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)
{
- 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);
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));
}
}
--- 1379,1408 ----
gfc_add_init_cleanup (block, tmp, NULL_TREE);
}
! /* Set the stringlength, when needed. */
! if (need_len_assign)
{
gfc_se se;
gfc_init_se (&se, NULL);
! 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.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));
! }
}
}
*************** gfc_trans_allocate (gfc_code * code)
*** 4941,4946 ****
--- 5008,5014 ----
&& al->expr->ts.type == BT_CLASS
&& code->expr3
&& code->expr3->ts.type == BT_CLASS
+ && !UNLIMITED_POLY (code->expr3)
&& code->expr3->expr_type != EXPR_VARIABLE)
{
gfc_init_se (&se_sz, NULL);
*************** gfc_trans_allocate (gfc_code * code)
*** 4979,4993 ****
&& code->expr3
&& memsz == NULL_TREE)
{
if (code->expr3->ts.type == BT_CLASS)
{
sz = gfc_copy_expr (code->expr3);
! gfc_add_vptr_component (sz);
! gfc_add_size_component (sz);
gfc_init_se (&se_sz, NULL);
gfc_conv_expr (&se_sz, sz);
gfc_free_expr (sz);
memsz = se_sz.expr;
}
else
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
--- 5047,5076 ----
&& code->expr3
&& memsz == NULL_TREE)
{
+ /* For an unlimited polymorphic source, use the _len component
+ for the size in memory, otherwise use the vtable _size. */
if (code->expr3->ts.type == BT_CLASS)
{
sz = gfc_copy_expr (code->expr3);
! if (UNLIMITED_POLY (code->expr3))
! sz = gfc_get_len_component (sz);
! else
! {
! gfc_add_vptr_component (sz);
! gfc_add_size_component (sz);
! }
gfc_init_se (&se_sz, NULL);
gfc_conv_expr (&se_sz, sz);
gfc_free_expr (sz);
memsz = se_sz.expr;
+ if (UNLIMITED_POLY (al->expr))
+ {
+ tmp = TREE_OPERAND (se.expr, 0);
+ tmp = gfc_class_len_get (tmp);
+ gfc_add_modify (&se.pre, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ memsz));
+ }
}
else
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
*************** gfc_trans_allocate (gfc_code * code)
*** 5050,5055 ****
--- 5133,5149 ----
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)
+ {
+ /* Roll back the _data reference to the CLASS object. */
+ tmp = TREE_OPERAND (se.expr, 0);
+ tmp = gfc_class_len_get (tmp);
+ gfc_add_modify (&se.pre, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ memsz));
+ }
/* Convert to size in bytes, using the character KIND. */
if (unlimited_char)
*************** gfc_trans_allocate (gfc_code * code)
*** 5237,5243 ****
/* Initialization via SOURCE block
(or static default initializer). */
gfc_expr *rhs = gfc_copy_expr (code->expr3);
! if (class_expr != NULL_TREE)
{
tree to;
to = TREE_OPERAND (se.expr, 0);
--- 5331,5347 ----
/* Initialization via SOURCE block
(or static default initializer). */
gfc_expr *rhs = gfc_copy_expr (code->expr3);
!
! if (UNLIMITED_POLY (code->expr3))
! {
! sz = gfc_copy_expr (code->expr3);
! gfc_add_data_component (sz);
! gfc_init_se (&se_sz, NULL);
! gfc_conv_expr (&se_sz, sz);
! gfc_free_expr (sz);
! tmp = gfc_build_memcpy_call (se.expr, se_sz.expr, memsz);
! }
! else if (class_expr != NULL_TREE)
{
tree to;
to = TREE_OPERAND (se.expr, 0);
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90
===================================================================
*** gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 (working copy)
***************
*** 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
+
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03
===================================================================
*** gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 (revision 219297)
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 (working copy)
***************
*** 5,11 ****
! 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
--- 5,11 ----
! 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
More information about the Fortran
mailing list