[Fortran, Patch, PR72832, v1] [6/7 Regression] [OOP] ALLOCATE with SOURCE fails to allocate requested dimensions

[Andre Vehreschild <vehre at gmx dot de>]

Hi all,

attached patch fixes the issue raised by PR72832. The issue was that
the array descriptor of the SOURCE= in an ALLOCATE () was used to
allocate an array object although an explicit array spec had been
given.

The initial test showed a second issue when a class array was copied.
Compiling the code with -fcheck=bounds showed that no boundary check
was generated for class array copying using gfc_copy_class_to_class().
I have added the generation of a runtime boundary check when the
-fcheck=bounds flag is set to locate the current issue. The test
allocate_with_source_23 is compiled with fcheck=bounds and fails as
expected ({ xfail *-*-* } set).

Fixing the both issues unfortunately raised the next one, when trying
to get the size of a class array returned from a function (testcase:
allocate_with_source_11.f08). Here the issue was that for functions
returning class arrays gfc_conv_expr_descriptor () relied on the
descriptor being magicked into the scalarizer, which did not work in
this use case. Due to the first issue this bug did not raise beforehand.
Because I could not figure how to do it right in
gfc_conv_expr_descriptor (), I found a way to circumvent the issue by
getting the reference of the result of the function returning a class
array and massaging it to be ok for size (). This works quite neatly,
but may be someone with better knowledge of conv_expr_descriptor and
the scalarizer might want to fix it there. I suppose there are more
locations in the code, that work around this issue.

Bootstrapped and regtests ok on x86_64-linux-gnu/F23 for trunk and
gcc-6. Ok for both?

- Andre
-- 
Andre Vehreschild * Email: vehre ad gmx dot de

Attachment: pr72832_1.clog
Description: Text document

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 19239fb..4d2fd33 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1180,6 +1180,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,
@@ -1207,6 +1208,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 8167842..d4ff85c 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -5845,9 +5845,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 5884e7a..8e5428a 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5485,7 +5485,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/gfortran.dg/allocate_with_source_22.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_22.f03
new file mode 100644
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
index 0000000..e36b5ce
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_23.f03
@@ -0,0 +1,65 @@
+! { dg-do run { xfail *-*-* } }
+! { dg-options "-fcheck=bounds" }
+! 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
+
+