This patch fixes PR97045 - unlimited polymorphic array element selectors.

2020-30-09  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/97045
	* trans-array.c (gfc_conv_array_ref): Make sure that the class
	decl is passed to build_array_ref in the case of unlimited
	polymorphic entities.
	* trans-expr.c (gfc_conv_derived_to_class): Ensure that array
	refs do not preceed the _len component. Free the _len expr.
	* trans-stmt.c (trans_associate_var): Reset 'need_len_assign'
	for polymorphic scalars.
	* trans.c (gfc_build_array_ref): When the vptr size is used for
	span, multiply by the _len field of unlimited polymorphic
	entities, when non-zero.

gcc/testsuite/
	PR fortran/97045
	* gfortran.dg/select_type_50.f90 : New test.

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 6566c47d4ae36505eb10c4847952514f1f2f043c..998d4d4ed9be9cd77bbf93aafb382f77dd70d539 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3787,7 +3787,20 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
        decl = sym->backend_decl;
     }
   else if (sym->ts.type == BT_CLASS)
-    decl = NULL_TREE;
+    {
+      if (UNLIMITED_POLY (sym))
+       {
+         gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
+         gfc_init_se (&tmpse, NULL);
+         gfc_conv_expr (&tmpse, class_expr);
+         if (!se->class_vptr)
+           se->class_vptr = gfc_class_vptr_get (tmpse.expr);
+         gfc_free_expr (class_expr);
+         decl = tmpse.expr;
+       }
+      else
+       decl = NULL_TREE;
+    }
 
   se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
 }

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index a690839f591f794c0d215a4617ff3baae2a89d8b..2c31ec9bf019f9699f0482daeaa9aa7ab0ce3625 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -728,7 +728,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
          gfc_expr *len;
          gfc_se se;
 
-         len = gfc_copy_expr (e);
+         len = gfc_find_and_cut_at_last_class_ref (e);
          gfc_add_len_component (len);
          gfc_init_se (&se, NULL);
          gfc_conv_expr (&se, len);
@@ -739,6 +739,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
                                            integer_zero_node));
          else
            tmp = se.expr;
+         gfc_free_expr (len);
        }
       else
        tmp = integer_zero_node;

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 389fec7227e5804a33a186381939920b75d8bbf3..adc6b8fefb56d09d4862c7f428a8f3bb10d24ff1 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -2091,6 +2091,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
          /* Obtain a temporary class container for the result.  */
          gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false);
          se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+         need_len_assign = false;
        }
       else
        {

diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index ed05426145236ddd74e90c2cb564f25c70bd6e3b..8caa625ab0e878bf0daf9fd5f62a72348c48f393 100644 (file)
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -429,7 +429,28 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
   /* If decl or vptr are non-null, pointer arithmetic for the array reference
      is likely. Generate the 'span' for the array reference.  */
   if (vptr)
-    span = gfc_vptr_size_get (vptr);
+    {
+      span = gfc_vptr_size_get (vptr);
+
+      /* Check if this is an unlimited polymorphic object carrying a character
+        payload. In this case, the 'len' field is non-zero.  */
+      if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
+       {
+         tmp = gfc_class_len_or_zero_get (decl);
+         if (!integer_zerop (tmp))
+           {
+             tree cond;
+             tree stype = TREE_TYPE (span);
+             tmp = fold_convert (stype, tmp);
+             cond = fold_build2_loc (input_location, EQ_EXPR,
+                                     logical_type_node, tmp,
+                                     build_int_cst (stype, 0));
+             tmp = fold_build2 (MULT_EXPR, stype, span, tmp);
+             span = fold_build3_loc (input_location, COND_EXPR, stype,
+                                     cond, span, tmp);
+           }
+       }
+    }
   else if (decl)
     span = get_array_span (type, decl);
 

diff --git a/gcc/testsuite/gfortran.dg/select_type_50.f90 b/gcc/testsuite/gfortran.dg/select_type_50.f90
new file mode 100644 (file)
index 0000000..aea1c81
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_50.f90
@@ -0,0 +1,52 @@
+! { dg-do run }
+!
+! Test the fix for PR97045. The report was for the INTEGER version. Testing
+! revealed a further bug with the character versions.
+!
+! Contributed by Igor Gayday  <igor.gayday@mu.edu>
+!
+program test_prg
+  implicit none
+  integer :: i
+  integer, allocatable :: arr(:, :)
+  character(kind = 1, len = 2), allocatable :: chr(:, :)
+  character(kind = 4, len = 2), allocatable :: chr4(:, :)
+
+  arr = reshape ([(i, i = 1, 9)], [3, 3])
+  do i = 1, 3
+    call write_array(arr(1:2, i), i)
+  end do
+
+  chr = reshape([(char (i)//char (i+1), i = 65, 83, 2)], [3, 3])
+  do i = 1, 3
+    call write_array (chr(1:2, i), i)
+  end do
+
+  chr4 = reshape([(char (i, kind = 4)//char (i+1, kind = 4), i = 65, 83, 2)], &
+                 [3, 3])
+  do i = 1, 3
+    call write_array (chr4(1:2, i), i)
+  end do
+
+contains
+
+  subroutine write_array(array, j)
+    class(*), intent(in) :: array(:)
+    integer :: i = 2
+    integer :: j, k
+
+    select type (elem => array(i))
+      type is (integer)
+        k = 3*(j-1)+i
+        if (elem .ne. k) stop 1
+      type is (character(kind = 1, len = *))
+        k = 63 + 2*(3*(j-1)+i)
+        if (elem .ne. char (k)//char (k+1)) print *, elem, "   ", char (k)//char (k+1)
+      type is (character(kind = 4, len = *))
+        k = 63 + 2*(3*(j-1)+i)
+        if (elem .ne. char (k, kind = 4)//char (k+1, kind = 4)) stop 3
+    end select
+
+  end subroutine
+
+end program