[Patch, fortran] PR84074 Incorrect indexing of array when actual argument is an array expression and dummy is polymorphic

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 577 bytes --]

Hi All,

This patch makes sure that offsets and bounds are correct in passing
derived types to class formal arrays. It is straightforward enough as
not to require explanation.

Bootstraps and regtests on FC25/x86_64 - OK for trunk?

Paul

2018-02-11  Paul Thomas  <pault@gcc.gnu.org>

PR fortran/84074
* trans-expr.c (gfc_conv_derived_to_class): Set the use_offset
flag. If the is a vector subscript or the expression is not a
variable, make the descriptor one-based.

2018-02-11  Paul Thomas  <pault@gcc.gnu.org>

PR fortran/84074
* gfortran.dg/type_to_class_5.f03: New test.

[-- Attachment #2: submit.diff --]
[-- Type: text/plain, Size: 3114 bytes --]

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 257549)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 547,552 ****
--- 547,553 ----
    tree ctree;
    tree var;
    tree tmp;
+   int dim;
  
    /* The derived type needs to be converted to a temporary
       CLASS object.  */
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 636,645 ****
--- 637,670 ----
  	{
  	  stmtblock_t block;
  	  gfc_init_block (&block);
+ 	  gfc_ref *ref;
  
  	  parmse->ss = ss;
+ 	  parmse->use_offset = 1;
  	  gfc_conv_expr_descriptor (parmse, e);
  
+ 	  /* Detect any vector array references.  */
+ 	  for (ref = e->ref; ref; ref = ref->next)
+ 	    if (ref->type == REF_ARRAY
+ 		&& ref->u.ar.type != AR_ELEMENT
+ 		&& ref->u.ar.type != AR_FULL)
+ 	      {
+ 		for (dim = 0; dim < ref->u.ar.dimen; dim++)
+ 		  if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+ 		    break;
+ 		if (dim < ref->u.ar.dimen)
+ 		  break;
+ 	      }
+ 
+ 	  /* Vector array references and non-variable expressions need be
+ 	     coverted to one-based descriptors.  */
+ 	  if (ref || e->expr_type != EXPR_VARIABLE)
+ 	    {
+ 	      for (dim = 0; dim < e->rank; ++dim)
+ 		gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
+ 						  gfc_index_one_node);
+ 	    }
+ 
  	  if (e->rank != class_ts.u.derived->components->as->rank)
  	    {
  	      gcc_assert (class_ts.u.derived->components->as->type
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 10105,10111 ****
  				   &expr1->where, msg);
  	}
  
!       /* Deallocate the lhs parameterized components if required.  */ 
        if (dealloc && expr2->expr_type == EXPR_FUNCTION
  	  && !expr1->symtree->n.sym->attr.associate_var)
  	{
--- 10130,10136 ----
  				   &expr1->where, msg);
  	}
  
!       /* Deallocate the lhs parameterized components if required.  */
        if (dealloc && expr2->expr_type == EXPR_FUNCTION
  	  && !expr1->symtree->n.sym->attr.associate_var)
  	{
Index: gcc/testsuite/gfortran.dg/type_to_class_5.f03
===================================================================
*** gcc/testsuite/gfortran.dg/type_to_class_5.f03	(nonexistent)
--- gcc/testsuite/gfortran.dg/type_to_class_5.f03	(working copy)
***************
*** 0 ****
--- 1,29 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR84074
+ !
+ ! Contributed by Vladimir Fuka  <vladimir.fuka@gmail.com>
+ !
+   type :: t
+       integer :: n
+   end type
+ 
+   type(t) :: array(4) = [t(1),t(2),t(3),t(4)]
+ 
+   call sub(array((/3,1/)), [3,1,0,0]) ! Does not increment any elements of 'array'.
+   call sub(array(1:3:2), [1,3,0,0])
+   call sub(array(3:1:-2), [4,2,0,0])
+   call sub(array, [3,2,5,4])          ! Elements 1 and 3 should have been incremented twice.
+ 
+ contains
+ 
+   subroutine sub(a, iarray)
+     class(t) :: a(:)
+     integer :: iarray(4)
+     integer :: i
+     do i=1,size(a)
+         if (a(i)%n .ne. iarray(i)) call abort
+         a(i)%n = a(i)%n+1
+     enddo
+   end subroutine
+ end program