re PR fortran/72832 ([OOP] ALLOCATE with SOURCE fails to allocate requested dimensions)

gcc/fortran/ChangeLog:

2016-09-01  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/72832
	* trans-expr.c (gfc_copy_class_to_class): Add generation of
	runtime array bounds check.
	* trans-intrinsic.c (gfc_conv_intrinsic_size): Add a crutch to
	get the descriptor of a function returning a class object.
	* trans-stmt.c (gfc_trans_allocate): Use the array spec on the
	array to allocate instead of the array spec from source=.

gcc/testsuite/ChangeLog:

2016-09-01  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/72832
	* gfortran.dg/allocate_with_source_22.f03: New test.
	* gfortran.dg/allocate_with_source_23.f03: New test.  Expected to
	fail.

From-SVN: r241088

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 437e53b..899e15e 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2016-10-13  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+       PR fortran/72832
+       * trans-expr.c (gfc_copy_class_to_class): Add generation of
+       runtime array bounds check.
+       * trans-intrinsic.c (gfc_conv_intrinsic_size): Add a crutch to
+       get the descriptor of a function returning a class object.
+       * trans-stmt.c (gfc_trans_allocate): Use the array spec on the
+       array to allocate instead of the array spec from source=.
+
 2016-10-12  Andre Vehreschild  <vehre@gcc.gnu.org>
 
        * trans-expr.c (gfc_find_and_cut_at_last_class_ref): Fixed style.

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 655399b..6b974db 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1235,6 +1235,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
       stmtblock_t body;
       stmtblock_t ifbody;
       gfc_loopinfo loop;
+      tree orig_nelems = nelems; /* Needed for bounds check.  */
 
       gfc_init_block (&body);
       tmp = fold_build2_loc (input_location, MINUS_EXPR,
@@ -1262,6 +1263,31 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
        }
       vec_safe_push (args, to_ref);
 
+      /* Add bounds check.  */
+      if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
+       {
+         char *msg;
+         const char *name = "<<unknown>>";
+         tree from_len;
+
+         if (DECL_P (to))
+           name = (const char *)(DECL_NAME (to)->identifier.id.str);
+
+         from_len = gfc_conv_descriptor_size (from_data, 1);
+         tmp = fold_build2_loc (input_location, NE_EXPR,
+                                 boolean_type_node, from_len, orig_nelems);
+         msg = xasprintf ("Array bound mismatch for dimension %d "
+                          "of array '%s' (%%ld/%%ld)",
+                          1, name);
+
+         gfc_trans_runtime_check (true, false, tmp, &body,
+                                  &gfc_current_locus, msg,
+                            fold_convert (long_integer_type_node, orig_nelems),
+                              fold_convert (long_integer_type_node, from_len));
+
+         free (msg);
+       }
+
       tmp = build_call_vec (fcn_type, fcn, args);
 
       /* Build the body of the loop.  */

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index a499c32..9d5e33c 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -6544,9 +6544,20 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
   if (actual->expr->ts.type == BT_CLASS)
     gfc_add_class_array_ref (actual->expr);
 
-  argse.want_pointer = 1;
   argse.data_not_needed = 1;
-  gfc_conv_expr_descriptor (&argse, actual->expr);
+  if (gfc_is_alloc_class_array_function (actual->expr))
+    {
+      /* For functions that return a class array conv_expr_descriptor is not
+        able to get the descriptor right.  Therefore this special case.  */
+      gfc_conv_expr_reference (&argse, actual->expr);
+      argse.expr = gfc_build_addr_expr (NULL_TREE,
+                                       gfc_class_data_get (argse.expr));
+    }
+  else
+    {
+      argse.want_pointer = 1;
+      gfc_conv_expr_descriptor (&argse, actual->expr);
+    }
   gfc_add_block_to_block (&se->pre, &argse.pre);
   gfc_add_block_to_block (&se->post, &argse.post);
   arg1 = gfc_evaluate_now (argse.expr, &se->pre);

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 67cd2b5..ef5153e 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5489,7 +5489,8 @@ gfc_trans_allocate (gfc_code * code)
                  desc = tmp;
                  tmp = gfc_class_data_get (tmp);
                }
-             e3_is = E3_DESC;
+             if (code->ext.alloc.arr_spec_from_expr3)
+               e3_is = E3_DESC;
            }
          else
            desc = !is_coarray ? se.expr

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index bdf8b75..e5c3e63 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2016-10-13  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+       PR fortran/72832
+       * gfortran.dg/allocate_with_source_22.f03: New test.
+       * gfortran.dg/allocate_with_source_23.f03: New test.  Expected to
+       fail.
+
 2016-10-13  Thomas Preud'homme  <thomas.preudhomme@arm.com>
 
        * gcc.target/arm/movhi_movw.c: Enable test for ARM mode.

diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_22.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_22.f03
new file mode 100644 (file)
index 0000000..b8689f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_22.f03
@@ -0,0 +1,48 @@
+! { dg-do run }
+!
+! Test that pr72832 is fixed now.
+! Contributed by Daan van Vugt
+
+program allocate_source
+  type :: t
+    integer :: i
+  end type t
+  type, extends(t) :: tt
+  end type tt
+
+  call test_type()
+  call test_class()
+
+contains
+
+subroutine test_class()
+  class(t), allocatable, dimension(:) :: a, b
+  allocate(tt::a(1:2))
+  a(:)%i = [ 1,2 ]
+  if (size(a) /= 2) call abort()
+  if (any(a(:)%i /= [ 1,2])) call abort()
+
+  allocate(b(1:4), source=a)
+  ! b is incorrectly initialized here.  This only is diagnosed when compiled
+  ! with -fcheck=bounds.
+  if (size(b) /= 4) call abort()
+  if (any(b(1:2)%i /= [ 1,2])) call abort()
+  select type (b(1))
+    class is (tt)
+      continue
+    class default
+      call abort()
+  end select
+end subroutine
+
+subroutine test_type()
+  type(t), allocatable, dimension(:) :: a, b
+  allocate(a(1:2))
+  if (size(a) /= 2) call abort()
+
+  allocate(b(1:4), source=a)
+  if (size(b) /= 4) call abort()
+end subroutine
+end program allocate_source
+
+

diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_23.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_23.f03
new file mode 100644 (file)
index 0000000..cfe8bd8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_23.f03
@@ -0,0 +1,67 @@
+! { dg-do run }
+! { dg-options "-fcheck=bounds" }
+! { dg-shouldfail "Array bounds mismatch" }
+!
+! Test that pr72832 is fixed now.
+! Contributed by Daan van Vugt
+
+program allocate_source
+  type :: t
+    integer :: i
+  end type t
+  type, extends(t) :: tt
+  end type tt
+
+  call test_type()
+  call test_class_correct()
+  call test_class_fail()
+
+contains
+
+subroutine test_class_correct()
+  class(t), allocatable, dimension(:) :: a, b
+  allocate(tt::a(1:2))
+  a(:)%i = [ 1,2 ]
+  if (size(a) /= 2) call abort()
+  if (any(a(:)%i /= [ 1,2])) call abort()
+
+  allocate(b(1:4), source=a(1))
+  if (size(b) /= 4) call abort()
+  if (any(b(:)%i /= [ 1,1,1,1])) call abort()
+  select type (b(1))
+    class is (tt)
+      continue
+    class default
+      call abort()
+  end select
+end subroutine
+
+subroutine test_class_fail()
+  class(t), allocatable, dimension(:) :: a, b
+  allocate(tt::a(1:2))
+  a(:)%i = [ 1,2 ]
+  if (size(a) /= 2) call abort()
+  if (any(a(:)%i /= [ 1,2])) call abort()
+
+  allocate(b(1:4), source=a) ! Fail expected: sizes do not conform
+  if (size(b) /= 4) call abort()
+  if (any(b(1:2)%i /= [ 1,2])) call abort()
+  select type (b(1))
+    class is (tt)
+      continue
+    class default
+      call abort()
+  end select
+end subroutine
+
+subroutine test_type()
+  type(t), allocatable, dimension(:) :: a, b
+  allocate(a(1:2))
+  if (size(a) /= 2) call abort()
+
+  allocate(b(1:4), source=a)
+  if (size(b) /= 4) call abort()
+end subroutine
+end program allocate_source
+
+