re PR fortran/72770 (ICE in make_ssa_name_fn, at tree-ssanames.c:263)

gcc/testsuite/ChangeLog:

2016-10-25  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/72770
	* gfortran.dg/alloc_comp_class_5.f03: Added test again that caused
	this pr.

gcc/fortran/ChangeLog:

2016-10-25  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/72770
	* 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.

From-SVN: r241528

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 115e39c..2e7c293 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2016-10-25  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+       PR fortran/72770
+       * 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.
+
 2016-10-25  Cesar Philippidis  <cesar@codesourcery.com>
 
        * intrinsic.texi (cosd): New mathop.

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 6ac543c..be1ddf8 100644 (file)
--- 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 types as TYPENAME_KIND_ including especially character
+        arrays, whose length is now 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 117349e..de21cc0 100644 (file)
--- 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 525bb67..e57d3b9 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -860,7 +860,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/ChangeLog b/gcc/testsuite/ChangeLog
index f985dba..35b366a 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2016-10-25  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+       PR fortran/72770
+       * gfortran.dg/alloc_comp_class_5.f03: Added test again that caused
+       this pr.
+
 2016-10-25  Jakub Jelinek  <jakub@redhat.com>
 
        PR target/78102

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 (file)
--- 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