re PR fortran/88685 (pointer class array argument indexing)

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

	PR fortran/88685
	* expr.c (is_subref_array): Move the check for class pointer
	dummy arrays to after the reference check. If we haven't seen
	an array reference other than an element and a component is not
	class or derived, return false.

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

	PR fortran/88685
	* gfortran.dg/pointer_array_component_3.f90 : New test.

From-SVN: r268472

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0a5da36a601041783326281e2423123aa6c40dc5..1dc007d1a2e9b0afc8f88a1681350d26767b0dbc 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2019-02-02  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/88685
+       * expr.c (is_subref_array): Move the check for class pointer
+       dummy arrays to after the reference check. If we haven't seen
+       an array reference other than an element and a component is not
+       class or derived, return false.
+
 2019-02-01  Jakub Jelinek  <jakub@redhat.com>
 
        PR fortran/83246

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index a9e7f36c491a7179d31261c70aac8da325ec173a..a0eb94fbbccffe4f25fbf7d1b529c1b6ec687913 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1072,15 +1072,17 @@ is_subref_array (gfc_expr * e)
   if (e->symtree->n.sym->attr.subref_array_pointer)
     return true;
 
-  if (e->symtree->n.sym->ts.type == BT_CLASS
-      && e->symtree->n.sym->attr.dummy
-      && CLASS_DATA (e->symtree->n.sym)->attr.dimension
-      && CLASS_DATA (e->symtree->n.sym)->attr.class_pointer)
-    return true;
-
   seen_array = false;
+
   for (ref = e->ref; ref; ref = ref->next)
     {
+      /* If we haven't seen the array reference and this is an intrinsic,
+        what follows cannot be a subreference array.  */
+      if (!seen_array && ref->type == REF_COMPONENT
+         && ref->u.c.component->ts.type != BT_CLASS
+         && !gfc_bt_struct (ref->u.c.component->ts.type))
+       return false;
+
       if (ref->type == REF_ARRAY
            && ref->u.ar.type != AR_ELEMENT)
        seen_array = true;
@@ -1089,6 +1091,13 @@ is_subref_array (gfc_expr * e)
            && ref->type != REF_ARRAY)
        return seen_array;
     }
+
+  if (e->symtree->n.sym->ts.type == BT_CLASS
+      && e->symtree->n.sym->attr.dummy
+      && CLASS_DATA (e->symtree->n.sym)->attr.dimension
+      && CLASS_DATA (e->symtree->n.sym)->attr.class_pointer)
+    return true;
+
   return false;
 }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4687a662dfb548747d70fe8244dc90568e68b0fd..bc9ca4c289ce9314ad4ac480296c5b2f0c80bf9d 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2019-02-02  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/88685
+       * gfortran.dg/pointer_array_component_3.f90 : New test.
+
 2019-02-02  Jakub Jelinek  <jakub@redhat.com>
 
        PR middle-end/87887

diff --git a/gcc/testsuite/gfortran.dg/pointer_array_component_3.f90 b/gcc/testsuite/gfortran.dg/pointer_array_component_3.f90
new file mode 100644 (file)
index 0000000..8ef205b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_array_component_3.f90
@@ -0,0 +1,36 @@
+! { dg-do run }
+!
+! Test the fix for PR88685, in which the component array references in 'doit'
+! were being ascribed to the class pointer 'Cls' itself so that the stride
+! measure between elements was wrong.
+!
+! Contributed by Antony Lewis  <antony@cosmologist.info>
+!
+program tester
+  implicit none
+  Type TArr
+    integer, allocatable :: CL(:)
+  end Type TArr
+
+  type(TArr), allocatable, target :: arr(:,:)
+  class(TArr), pointer:: Cls(:,:)
+  integer i
+
+  allocate(arr(1,1))
+  allocate(arr(1,1)%CL(3))
+  arr(1,1)%CL=-1
+  cls => arr
+  call doit(cls)
+  if (any (arr(1,1)%cl .ne. [3,2,1])) stop 3
+contains
+  subroutine doit(cls)
+    class(TArr), pointer :: Cls(:,:)
+
+    cls(1,1)%CL(1) = 3
+    cls(1,1)%CL(2:3) = [2,1]
+
+    if (any (Cls(1,1)%CL .ne. [3,2,1])) stop 1
+    if (Cls(1,1)%CL(2) .ne. 2) stop 2
+
+  end subroutine doit
+end program tester