re PR fortran/67451 ([F08] ICE with sourced allocation from coarray.)

gcc/testsuite/ChangeLog:

2016-02-03  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/67451
	PR fortran/69418
	* gfortran.dg/coarray_allocate_2.f08: New test.
	* gfortran.dg/coarray_allocate_3.f08: New test.
	* gfortran.dg/coarray_allocate_4.f08: New test.

gcc/fortran/ChangeLog:

2016-02-03  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/67451
	PR fortran/69418
	* trans-expr.c (gfc_copy_class_to_class): For coarrays just the
	pointer is passed.  Take it as is without trying to deref the
	_data component.
	* trans-stmt.c (gfc_trans_allocate): Take care of coarrays as
	argument to source=-expression.

From-SVN: r233101

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 36b4ddb..dc0b8f2 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2016-02-03  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+       PR fortran/67451
+       PR fortran/69418
+       * trans-expr.c (gfc_copy_class_to_class): For coarrays just the
+       pointer is passed.  Take it as is without trying to deref the
+       _data component.
+       * trans-stmt.c (gfc_trans_allocate): Take care of coarrays as
+       argument to source=-expression.
+
 2016-02-02  Nathan Sidwell  <nathan@codesourcery.com>
 
        * lang.opt (fopenacc-dim=): New option.

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 08b20e6..87af7ac 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1103,7 +1103,14 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
        }
       else
        {
-         from_data = gfc_class_data_get (from);
+         /* Check that from is a class.  When the class is part of a coarray,
+            then from is a common pointer and is to be used as is.  */
+         tmp = POINTER_TYPE_P (TREE_TYPE (from))
+             ? build_fold_indirect_ref (from) : from;
+         from_data =
+             (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+              || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
+             ? gfc_class_data_get (from) : from;
          is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
        }
      }

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 310d2cd..5143c31 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5358,7 +5358,8 @@ gfc_trans_allocate (gfc_code * code)
      expression.  */
   if (code->expr3)
     {
-      bool vtab_needed = false, temp_var_needed = false;
+      bool vtab_needed = false, temp_var_needed = false,
+         is_coarray = gfc_is_coarray (code->expr3);
 
       /* Figure whether we need the vtab from expr3.  */
       for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
@@ -5392,9 +5393,9 @@ gfc_trans_allocate (gfc_code * code)
                     with the POINTER_PLUS_EXPR in this case.  */
                  if (code->expr3->ts.type == BT_CLASS
                      && TREE_CODE (se.expr) == NOP_EXPR
-                     && TREE_CODE (TREE_OPERAND (se.expr, 0))
-                                                          == POINTER_PLUS_EXPR)
-                     //&& ! GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
+                     && (TREE_CODE (TREE_OPERAND (se.expr, 0))
+                                                           == POINTER_PLUS_EXPR
+                         || is_coarray))
                    se.expr = TREE_OPERAND (se.expr, 0);
                }
              /* Create a temp variable only for component refs to prevent
@@ -5435,7 +5436,7 @@ gfc_trans_allocate (gfc_code * code)
       if (se.expr != NULL_TREE && temp_var_needed)
        {
          tree var, desc;
-         tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ?
+         tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) || is_coarray ?
                se.expr
              : build_fold_indirect_ref_loc (input_location, se.expr);
 
@@ -5448,7 +5449,7 @@ gfc_trans_allocate (gfc_code * code)
            {
              /* When an array_ref was in expr3, then the descriptor is the
                 first operand.  */
-             if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+             if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray)
                {
                  desc = TREE_OPERAND (tmp, 0);
                }
@@ -5460,11 +5461,12 @@ gfc_trans_allocate (gfc_code * code)
              e3_is = E3_DESC;
            }
          else
-           desc = se.expr;
+           desc = !is_coarray ? se.expr
+                              : TREE_OPERAND (TREE_OPERAND (se.expr, 0), 0);
          /* We need a regular (non-UID) symbol here, therefore give a
             prefix.  */
          var = gfc_create_var (TREE_TYPE (tmp), "source");
-         if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+         if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray)
            {
              gfc_allocate_lang_decl (var);
              GFC_DECL_SAVED_DESCRIPTOR (var) = desc;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 28a5a85..03376d5 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2016-02-03  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+       PR fortran/67451
+       PR fortran/69418
+       * gfortran.dg/coarray_allocate_2.f08: New test.
+       * gfortran.dg/coarray_allocate_3.f08: New test.
+       * gfortran.dg/coarray_allocate_4.f08: New test.
+
 2016-02-03  Alan Lawrence  <alan.lawrence@arm.com>
 
        * gcc.dg/vect/vect-outer-1-big-array.c: Drop vect_multiple_sizes;

diff --git a/gcc/testsuite/gfortran.dg/coarray_allocate_2.f08 b/gcc/testsuite/gfortran.dg/coarray_allocate_2.f08
new file mode 100644 (file)
index 0000000..7a712a9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_allocate_2.f08
@@ -0,0 +1,26 @@
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! Contributed by Ian Harvey  <ian_harvey@bigpond.com>
+! Extended by Andre Vehreschild  <vehre@gcc.gnu.org>
+! to test that coarray references in allocate work now
+! PR fortran/67451
+
+  program main
+    implicit none
+    type foo
+      integer :: bar = 99
+    end type
+    class(foo), allocatable :: foobar[:]
+    class(foo), allocatable :: some_local_object
+    allocate(foobar[*])
+
+    allocate(some_local_object, source=foobar)
+
+    if (.not. allocated(foobar)) call abort()
+    if (.not. allocated(some_local_object)) call abort()
+
+    deallocate(some_local_object)
+    deallocate(foobar)
+  end program
+

diff --git a/gcc/testsuite/gfortran.dg/coarray_allocate_3.f08 b/gcc/testsuite/gfortran.dg/coarray_allocate_3.f08
new file mode 100644 (file)
index 0000000..46f34c0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_allocate_3.f08
@@ -0,0 +1,28 @@
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! Contributed by Ian Harvey  <ian_harvey@bigpond.com>
+! Extended by Andre Vehreschild  <vehre@gcc.gnu.org>
+! to test that coarray references in allocate work now
+! PR fortran/67451
+
+  program main
+    implicit none
+    type foo
+      integer :: bar = 99
+    end type
+    class(foo), dimension(:), allocatable :: foobar[:]
+    class(foo), dimension(:), allocatable :: some_local_object
+    allocate(foobar(10)[*])
+
+    allocate(some_local_object, source=foobar)
+
+    if (.not. allocated(foobar)) call abort()
+    if (lbound(foobar, 1) /= 1 .OR. ubound(foobar, 1) /= 10) call abort()
+    if (.not. allocated(some_local_object)) call abort()
+    if (any(some_local_object(:)%bar /= [99, 99,  99, 99, 99, 99, 99, 99, 99, 99])) call abort()
+
+    deallocate(some_local_object)
+    deallocate(foobar)
+  end program
+

diff --git a/gcc/testsuite/gfortran.dg/coarray_allocate_4.f08 b/gcc/testsuite/gfortran.dg/coarray_allocate_4.f08
new file mode 100644 (file)
index 0000000..a36d796
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_allocate_4.f08
@@ -0,0 +1,43 @@
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! Contributed by Gerhard Steinmetz  <gerhard.steinmetz.fortran@t-online.de>
+!               Andre Vehreschild <vehre@gcc.gnu.org>
+! Check that PR fortran/69451 is fixed.
+
+program main
+
+implicit none
+
+type foo
+end type
+
+class(foo), allocatable :: p[:]
+class(foo), pointer :: r
+class(*), allocatable, target :: z
+
+allocate(p[*])
+
+call s(p, z)
+select type (z)
+  class is (foo) 
+        r => z
+  class default
+     call abort()
+end select
+
+if (.not. associated(r)) call abort()
+
+deallocate(r)
+deallocate(p)
+
+contains
+
+subroutine s(x, z) 
+   class(*) :: x[*]
+   class(*), allocatable:: z
+   allocate (z, source=x)
+end
+
+end
+