re PR fortran/31692 (Wrong code when passing function name as result to procedures)

2007-05-08  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31692
	* trans-array.c (gfc_conv_array_parameter): Convert full array
	references to the result of the procedure enclusing the call.

2007-05-08  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31692
	* gfortran.dg/actual_array_result_1.f90: New test.

From-SVN: r124546

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7a145fa2d4947163fd201b44bfe193332090584f..3fc67d70405035953540753e740d16686a52aa83 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2007-05-08  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/31692
+       * trans-array.c (gfc_conv_array_parameter): Convert full array
+       references to the result of the procedure enclusing the call.
+
 2007-05-08  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/29397

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 92fd67cccf5074ba9ba3009b1ee996fc35445f4d..4997673904f798eb6e5fa7c097c4ef3b3e450cd4 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4748,14 +4748,25 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
   tree desc;
   tree tmp;
   tree stmt;
+  tree parent = DECL_CONTEXT (current_function_decl);
+  bool full_array_var, this_array_result;
   gfc_symbol *sym;
   stmtblock_t block;
 
+  full_array_var = (expr->expr_type == EXPR_VARIABLE
+                     && expr->ref->u.ar.type == AR_FULL);
+  sym = full_array_var ? expr->symtree->n.sym : NULL;
+
+  /* Is this the result of the enclosing procedure?  */
+  this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
+  if (this_array_result
+       && (sym->backend_decl != current_function_decl)
+       && (sym->backend_decl != parent))
+    this_array_result = false;
+
   /* Passing address of the array if it is not pointer or assumed-shape.  */
-  if (expr->expr_type == EXPR_VARIABLE
-       && expr->ref->u.ar.type == AR_FULL && g77)
+  if (full_array_var && g77 && !this_array_result)
     {
-      sym = expr->symtree->n.sym;
       tmp = gfc_get_symbol_decl (sym);
 
       if (sym->ts.type == BT_CHARACTER)
@@ -4784,8 +4795,25 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
         }
     }
 
-  se->want_pointer = 1;
-  gfc_conv_expr_descriptor (se, expr, ss);
+  if (this_array_result)
+    {
+      /* Result of the enclosing function.  */
+      gfc_conv_expr_descriptor (se, expr, ss);
+      se->expr = build_fold_addr_expr (se->expr);
+
+      if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
+             && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
+       se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
+
+      return;
+    }
+  else
+    {
+      /* Every other type of array.  */
+      se->want_pointer = 1;
+      gfc_conv_expr_descriptor (se, expr, ss);
+    }
+
 
   /* Deallocate the allocatable components of structures that are
      not variable.  */

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3c6d9c49bd9a48fe1f8a646508c2c51681e47a23..1542977acedb7f34dd664d2f36cc9563c8129e80 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2007-05-08  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/31692
+       * gfortran.dg/actual_array_result_1.f90: New test.
+
 2007-05-08  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/29397

diff --git a/gcc/testsuite/gfortran.dg/actual_array_result_1.f90 b/gcc/testsuite/gfortran.dg/actual_array_result_1.f90
new file mode 100644 (file)
index 0000000..cf79315
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/actual_array_result_1.f90
@@ -0,0 +1,71 @@
+! { dg-do run }
+! PR fortan/31692
+! Passing array valued results to procedures
+!
+! Test case contributed by rakuen_himawari@yahoo.co.jp
+module one
+  integer :: flag = 0
+contains
+  function foo1 (n)
+    integer :: n
+    integer :: foo1(n)
+    if (flag == 0) then
+      call bar1 (n, foo1)
+    else
+      call bar2 (n, foo1)
+    end if
+  end function
+
+  function foo2 (n)
+    implicit none
+    integer :: n
+    integer,ALLOCATABLE :: foo2(:)
+    allocate (foo2(n))
+    if (flag == 0) then
+      call bar1 (n, foo2)
+    else
+      call bar2 (n, foo2)
+    end if
+  end function
+
+  function foo3 (n)
+    implicit none
+    integer :: n
+    integer,ALLOCATABLE :: foo3(:)
+    allocate (foo3(n))
+    foo3 = 0
+    call bar2(n, foo3(2:(n-1)))  ! Check that sections are OK
+  end function
+
+  subroutine bar1 (n, array)     ! Checks assumed size formal arg.
+    integer :: n
+    integer :: array(*)
+    integer :: i
+    do i = 1, n
+      array(i) = i
+    enddo
+  end subroutine
+
+  subroutine bar2(n, array)     ! Checks assumed shape formal arg.
+    integer :: n
+    integer :: array(:)
+    integer :: i
+    do i = 1, size (array, 1)
+      array(i) = i
+    enddo
+   end subroutine
+end module
+
+program main
+  use one
+  integer :: n
+  n = 3
+  if(any (foo1(n) /= [ 1,2,3 ])) call abort()
+  if(any (foo2(n) /= [ 1,2,3 ])) call abort()
+  flag = 1
+  if(any (foo1(n) /= [ 1,2,3 ])) call abort()
+  if(any (foo2(n) /= [ 1,2,3 ])) call abort()
+  n = 5
+  if(any (foo3(n) /= [ 0,1,2,3,0 ])) call abort()
+end program
+! { dg-final { cleanup-modules "one" } }