Hi all, commited as r221591 to gcc_4.9-branch. Okayed by Paul via IRC on 2015-03-22. Thanks, Paul.
gcc/fortran/ChangeLog 2015-03-23 Andre Vehreschild <ve...@gmx.de> Janus Weil <ja...@gcc.gnu.org> Backported from mainline PR fortran/60255 Initial patch version: Janus Weil * class.c (gfc_get_len_component): New. (gfc_build_class_symbol): Add _len component to unlimited polymorphic entities. (find_intrinsic_vtab): Removed emitting of error message. * gfortran.h: Added prototype for gfc_get_len_component. * simplify.c (gfc_simplify_len): Use _len component where available. * trans-expr.c (gfc_class_len_get): New. (gfc_conv_intrinsic_to_class): Add handling for deferred character arrays. (gfc_conv_structure): Treat _len component correctly. (gfc_conv_expr): Prevent bind_c handling when not required. (gfc_trans_pointer_assignment): Propagate _len component. * trans-stmt.c (class_has_len_component): New. (trans_associate_var): _len component treatement for associate context. (gfc_trans_allocate): Same as for trans_associate_var() * trans.h: Add prototype for gfc_class_len_get. gcc/testsuite/ChangeLog 2015-03-20 Andre Vehreschild <ve...@gmx.de> Backport from mainline PR fortran/60255 * gfortran.dg/unlimited_polymorphic_2.f03: Removed error. Converted from dos to unix line endings. * gfortran.dg/unlimited_polymorphic_20.f03: New test. Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de
Index: gcc/testsuite/ChangeLog =================================================================== --- gcc/testsuite/ChangeLog (Revision 221590) +++ gcc/testsuite/ChangeLog (Arbeitskopie) @@ -1,3 +1,11 @@ +2015-03-20 Andre Vehreschild <ve...@gmx.de> + + Backport from mainline + PR fortran/60255 + * gfortran.dg/unlimited_polymorphic_2.f03: Removed error. + Converted from dos to unix line endings. + * gfortran.dg/unlimited_polymorphic_20.f03: New test. + 2015-03-23 Yvan Roux <yvan.r...@linaro.org> Backport from trunk r216841. Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 =================================================================== --- gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 (Revision 221590) +++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 (Arbeitskopie) @@ -1,80 +1,80 @@ -! { dg-do compile } -! -! Test the most important constraints unlimited polymorphic entities -! -! Contributed by Paul Thomas <pa...@gcc.gnu.org> -! and Tobias Burnus <bur...@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 <pa...@gcc.gnu.org> +! and Tobias Burnus <bur...@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 Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03 =================================================================== --- gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03 (Revision 0) +++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f03 (Revision 221591) @@ -0,0 +1,104 @@ +! { dg-do run } +! +! Testing fix for PR fortran/60255 +! +! Author: Andre Vehreschild <ve...@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/fortran/simplify.c =================================================================== --- gcc/fortran/simplify.c (Revision 221590) +++ gcc/fortran/simplify.c (Arbeitskopie) @@ -3690,6 +3690,14 @@ 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-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 221590) +++ gcc/fortran/trans-expr.c (Arbeitskopie) @@ -92,6 +92,7 @@ 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 @@ } +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 @@ } } + /* 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 @@ 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 @@ 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 @@ 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 @@ 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); Index: gcc/fortran/class.c =================================================================== --- gcc/fortran/class.c (Revision 221590) +++ gcc/fortran/class.c (Arbeitskopie) @@ -34,6 +34,12 @@ (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 @@ } +/* 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 traverses 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,6 +689,8 @@ 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) { @@ -651,13 +697,20 @@ 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 @@ 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) Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (Revision 221590) +++ gcc/fortran/gfortran.h (Arbeitskopie) @@ -3173,6 +3173,7 @@ 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/ChangeLog =================================================================== --- gcc/fortran/ChangeLog (Revision 221590) +++ gcc/fortran/ChangeLog (Arbeitskopie) @@ -1,3 +1,28 @@ +2015-03-23 Andre Vehreschild <ve...@gmx.de> + Janus Weil <ja...@gcc.gnu.org> + + Backported from mainline + PR fortran/60255 + Initial patch version: Janus Weil + * class.c (gfc_get_len_component): New. + (gfc_build_class_symbol): Add _len component to unlimited + polymorphic entities. + (find_intrinsic_vtab): Removed emitting of error message. + * gfortran.h: Added prototype for gfc_get_len_component. + * simplify.c (gfc_simplify_len): Use _len component where + available. + * trans-expr.c (gfc_class_len_get): New. + (gfc_conv_intrinsic_to_class): Add handling for deferred + character arrays. + (gfc_conv_structure): Treat _len component correctly. + (gfc_conv_expr): Prevent bind_c handling when not required. + (gfc_trans_pointer_assignment): Propagate _len component. + * trans-stmt.c (class_has_len_component): New. + (trans_associate_var): _len component treatement for associate + context. + (gfc_trans_allocate): Same as for trans_associate_var() + * trans.h: Add prototype for gfc_class_len_get. + 2015-03-21 Mikael Morin <mik...@gcc.gnu.org> PR fortran/61138 Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (Revision 221590) +++ gcc/fortran/trans-stmt.c (Arbeitskopie) @@ -1133,6 +1133,22 @@ } +/* 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 @@ tree offset; tree dim; int n; + tree charlen; + bool need_len_assign; gcc_assert (sym->assoc); e = sym->assoc->target; @@ -1156,6 +1174,20 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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_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) Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (Revision 221590) +++ gcc/fortran/trans.h (Arbeitskopie) @@ -347,6 +347,7 @@ /* 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);