1 files changed, 198 insertions, 0 deletions

diff --git a/meta/recipes-devtools/gcc/gcc-4.6.0/gcc-4_6-branch-backports/0202-2011-04-30-Paul-Thomas-pault-gcc.gnu.org.patch b/meta/recipes-devtools/gcc/gcc-4.6.0/gcc-4_6-branch-backports/0202-2011-04-30-Paul-Thomas-pault-gcc.gnu.org.patch
new file mode 100644
index 0000000000..59380b0492
--- /dev/null
+++ b/meta/recipes-devtools/gcc/gcc-4.6.0/gcc-4_6-branch-backports/0202-2011-04-30-Paul-Thomas-pault-gcc.gnu.org.patch
@@ -0,0 +1,198 @@
+From f90642b60dbe411df162174646348f4a7d5e1a63 Mon Sep 17 00:00:00 2001
+From: pault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
+Date: Sat, 30 Apr 2011 12:00:50 +0000
+Subject: [PATCH] 2011-04-30  Paul Thomas  <pault@gcc.gnu.org>
+
+        PR fortran/48462
+        PR fortran/48746
+        * trans-expr.c ( arrayfunc_assign_needs_temporary): Need a temp
+        if automatic reallocation on assignement is active, the lhs is a
+        target and the rhs an intrinsic function.
+        (realloc_lhs_bounds_for_intrinsic_call): Rename as next.
+        (fcncall_realloc_result): Renamed version of above function.
+        Free the original descriptor data after the function call.Set the bounds and the
+        offset so that the lbounds are one.
+        (gfc_trans_arrayfunc_assign): Call renamed function.
+
+2011-04-30  Paul Thomas  <pault@gcc.gnu.org>
+
+        PR fortran/48462
+        PR fortran/48746
+        * gfortran.dg/realloc_on_assign_7.f03: New test.
+
+
+
+git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-4_6-branch@173214 138bc75d-0d04-0410-961f-82ee72b054a4
+
+index da7cfba..1d678e6 100644
+--- a/gcc/fortran/trans-expr.c
++++ b/gcc/fortran/trans-expr.c
+@@ -5444,9 +5444,12 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
+     return true;
+ 
+   /* If we have reached here with an intrinsic function, we do not
+-     need a temporary.  */
++     need a temporary except in the particular case that reallocation
++     on assignment is active and the lhs is allocatable and a target.  */
+   if (expr2->value.function.isym)
+-    return false;
++    return (gfc_option.flag_realloc_lhs
++             && sym->attr.allocatable
++             && sym->attr.target);
+ 
+   /* If the LHS is a dummy, we need a temporary if it is not
+      INTENT(OUT).  */
+@@ -5528,23 +5531,38 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss)
+ }
+ 
+ 
++/* For Assignment to a reallocatable lhs from intrinsic functions,
++   replace the se.expr (ie. the result) with a temporary descriptor.
++   Null the data field so that the library allocates space for the
++   result. Free the data of the original descriptor after the function,
++   in case it appears in an argument expression and transfer the
++   result to the original descriptor.  */
++
+ static void
+-realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
++fcncall_realloc_result (gfc_se *se, int rank)
+ {
+   tree desc;
++  tree res_desc;
+   tree tmp;
+   tree offset;
+   int n;
+ 
+-  /* Use the allocation done by the library.  */
++  /* Use the allocation done by the library.  Substitute the lhs
++     descriptor with a copy, whose data field is nulled.*/
+   desc = build_fold_indirect_ref_loc (input_location, se->expr);
+-  tmp = gfc_conv_descriptor_data_get (desc);
+-  tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
+-  gfc_add_expr_to_block (&se->pre, tmp);
+-  gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
+   /* Unallocated, the descriptor does not have a dtype.  */
+   tmp = gfc_conv_descriptor_dtype (desc);
+   gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
++  res_desc = gfc_evaluate_now (desc, &se->pre);
++  gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
++  se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
++
++  /* Free the lhs after the function call and copy the result to
++     the lhs descriptor.  */
++  tmp = gfc_conv_descriptor_data_get (desc);
++  tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
++  gfc_add_expr_to_block (&se->post, tmp);
++  gfc_add_modify (&se->post, desc, res_desc);
+ 
+   offset = gfc_index_zero_node;
+   tmp = gfc_index_one_node;
+@@ -5580,7 +5598,6 @@ realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
+ }
+ 
+ 
+-
+ /* Try to translate array(:) = func (...), where func is a transformational
+    array function, without using a temporary.  Returns NULL if this isn't the
+    case.  */
+@@ -5645,7 +5662,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
+          ss->is_alloc_lhs = 1;
+        }
+       else
+-       realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
++       fcncall_realloc_result (&se, expr1->rank);
+     }
+ 
+   gfc_conv_function_expr (&se, expr2);
+new file mode 100644
+index 0000000..f871d27
+--- /dev/null
++++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03
+@@ -0,0 +1,84 @@
++! { dg-do run }
++! Check the fix for PR48462 in which the assignments involving matmul
++! seg faulted because a was automatically freed before the assignment.
++! Since it is related, the test for the fix of PR48746 has been added
++! as a subroutine by that name.
++!
++! Contributed by John Nedney  <ortp21@gmail.com>
++!
++program main
++  implicit none
++  integer, parameter :: dp = kind(0.0d0)
++  real(kind=dp), allocatable :: delta(:,:)
++  real(kind=dp), allocatable, target :: a(:,:)
++  real(kind=dp), pointer :: aptr(:,:)
++
++  allocate(a(3,3))
++  aptr => a
++  
++  call foo
++  if (.not. associated (aptr, a)) call abort () ! reallocated to same size - remains associated
++  call bar
++  if (.not. associated (aptr, a)) call abort () ! reallocated to smaller size - remains associated
++  call foobar
++  if (associated (aptr, a)) call abort () ! reallocated to larger size - disassociates
++
++  call pr48746
++contains
++!
++! Original reduced version from comment #2
++  subroutine foo
++    implicit none
++    real(kind=dp), allocatable :: b(:,:)
++
++    allocate(b(3,3))
++    allocate(delta(3,3))
++
++    a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])
++    b = reshape ([1d0, 0d0, 0d0, 0d0, 1d0, 0d0, 0d0, 0d0, 1d0], [3,3])
++
++    a = matmul( matmul( a, b ), b )
++    delta = (a - reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]))**2
++    if (any (delta > 1d-12)) call abort
++    if (any (lbound (a) .ne. [1, 1])) call abort
++  end subroutine
++!
++! Check that all is well when the shape of 'a' changes.
++  subroutine bar
++    implicit none
++    real(kind=dp), allocatable :: a(:,:)
++    real(kind=dp), allocatable :: b(:,:)
++
++    b = reshape ([1d0, 1d0, 1d0], [3,1])
++    a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])
++
++    a = matmul( a, matmul( a, b ) )
++
++    delta = (a - reshape ([198d0, 243d0, 288d0], [3,1]))**2
++    if (any (delta > 1d-12)) call abort
++    if (any (lbound (a) .ne. [1, 1])) call abort
++  end subroutine
++  subroutine foobar
++    integer :: i
++    a = reshape ([(real(i, dp), i = 1, 100)],[10,10])
++  end subroutine
++  subroutine pr48746
++! This is a further wrinkle on the original problem and came about
++! because the dtype field of the result argument, passed to matmul,
++! was not being set. This is needed by matmul for the rank.
++!
++! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
++!
++    implicit none
++    integer, parameter :: m=10, n=12, count=4
++    real :: optmatmul(m, n)
++    real :: a(m, count), b(count, n), c(m, n)
++    real, dimension(:,:), allocatable :: tmp
++    call random_number(a)
++    call random_number(b)
++    tmp = matmul(a,b)
++    if (any (lbound (tmp) .ne. [1,1])) call abort
++    if (any (ubound (tmp) .ne. [10,12])) call abort
++  end subroutine
++end program main
++
+-- 
+1.7.0.4
+