Hi all,
attached patch fixes an ICE in gfortran when an unlimited polymorphic entity
was used to store a char array of deferred/assumed length. The patch typedefs
the necessary type now copying the behavior from
trans-array.c::gfc_trans_create_temp_array().
Furthermore does the patch now consequently set the _vptr->_size to the
character kind of the char array and the _len component to the length of the
string independent of whether the char array was declared deferred or with a
len given.
Bootstraps and regtests ok on x86_64-linux/F23. Ok for trunk?
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
gcc/testsuite/ChangeLog:
2016-10-24 Andre Vehreschild <ve...@gcc.gnu.org>
PR fortran/78053
* gfortran.dg/alloc_comp_class_5.f03: Added test again that caused
this pr.
gcc/fortran/ChangeLog:
2016-10-24 Andre Vehreschild <ve...@gcc.gnu.org>
PR fortran/78053
* class.c (find_intrinsic_vtab): No longer encode the string length
into vtype's name and use the char's kind for the size instead of
the string_length time the size.
* trans-array.c (gfc_conv_ss_descriptor): For deferred length char
arrays the dynamically sized type needs to be declared.
(build_class_array_ref): Address the i-th array element by multiplying
it with the _vptr->_size and the _len to make sure char arrays are
addressed correctly.
* trans-expr.c (gfc_conv_intrinsic_to_class): Made comment more
precise.
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 6ac543c..549cc91 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -2515,11 +2515,6 @@ find_intrinsic_vtab (gfc_typespec *ts)
gfc_namespace *ns;
gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
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)
@@ -2530,12 +2525,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)
- 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);
-
+ /* Encode all type as TYPENAME_KIND_ including especially character
+ arrays, whose length is no consistently stored in the _len component
+ of the class-variable. */
+ sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
sprintf (name, "__vtab_%s", tname);
/* Look for the vtab symbol in the top-level namespace only. */
@@ -2600,9 +2593,8 @@ find_intrinsic_vtab (gfc_typespec *ts)
c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
NULL,
ts->type == BT_CHARACTER
- && charlen == 0 ?
- ts->kind :
- (int)gfc_element_size (e));
+ ? ts->kind
+ : (int)gfc_element_size (e));
gfc_free_expr (e);
/* Add component _extends. */
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index c59e872..0d0bc38 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2681,6 +2681,20 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
if (base)
{
+ if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
+ && ss_info->expr->ts.u.cl->length == NULL)
+ {
+ /* Emit a DECL_EXPR for the variable sized array type in
+ GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
+ sizes works correctly. */
+ tree arraytype = TREE_TYPE (
+ GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
+ if (! TYPE_NAME (arraytype))
+ TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
+ NULL_TREE, arraytype);
+ gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
+ TYPE_NAME (arraytype)));
+ }
/* Also the data pointer. */
tmp = gfc_conv_array_data (se.expr);
/* If this is a variable or address of a variable we use it directly.
@@ -3143,9 +3157,22 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
size = gfc_class_vtab_size_get (decl);
+ /* For unlimited polymorphic entities then _len component needs to be
+ multiplied with the size. If no _len component is present, then
+ gfc_class_len_or_zero_get () return a zero_node. */
+ tmp = gfc_class_len_or_zero_get (decl);
+ if (!integer_zerop (tmp))
+ size = fold_build2 (MULT_EXPR, TREE_TYPE (index),
+ fold_convert (TREE_TYPE (index), size),
+ fold_build2 (MAX_EXPR, TREE_TYPE (index),
+ fold_convert (TREE_TYPE (index), tmp),
+ fold_convert (TREE_TYPE (index),
+ integer_one_node)));
+ else
+ size = fold_convert (TREE_TYPE (index), size);
+
/* Build the address of the element. */
type = TREE_TYPE (TREE_TYPE (base));
- size = fold_convert (TREE_TYPE (index), size);
offset = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
index, size);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index f1849f5..aababab 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -861,7 +861,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
{
ctree = gfc_class_len_get (var);
/* When the actual arg is a char array, then set the _len component of the
- unlimited polymorphic entity, too. */
+ unlimited polymorphic entity to the length of the string. */
if (e->ts.type == BT_CHARACTER)
{
/* Start with parmse->string_length because this seems to be set to a
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03
index a2d7cce..f07ffa1 100644
--- a/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03
@@ -1,7 +1,7 @@
! { dg-do run }
!
! Contributed by Vladimir Fuka
-! Check that pr61337 is fixed.
+! Check that pr61337 and pr78053, which was caused by this testcase, is fixed.
module array_list
@@ -39,8 +39,9 @@ program test_pr61337
call add_item(a_list, [1, 2])
call add_item(a_list, [3.0_8, 4.0_8])
call add_item(a_list, [.true., .false.])
+ call add_item(a_list, ["foo", "bar", "baz"])
- if (size(a_list) /= 3) call abort()
+ if (size(a_list) /= 4) call abort()
do i = 1, size(a_list)
call checkarr(a_list(i))
end do
@@ -60,6 +61,9 @@ contains
if (any(x /= [3.0_8, 4.0_8])) call abort()
type is (logical)
if (any(x .neqv. [.true., .false.])) call abort()
+ type is (character(len=*))
+ if (len(x) /= 3) call abort()
+ if (any(x /= ["foo", "bar", "baz"])) call abort()
class default
call abort()
end select
