re PR fortran/45648 (Unnecessary temporary for transpose calls as actual argument.)

2010-09-21  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/45648
	* trans-array.c (gfc_conv_expr_descriptor): Calculate dim out of n and
	info->dim.

	PR fortran/45648
	* trans-array.c (gfc_conv_expr_descriptor): Unset full if we are
	accessing dimensions in reversed order. 

	PR fortran/45648
	* trans-array.c (gfc_conv_expr_descriptor): Special case noncopying
	intrinsic function call. 

	* trans-array.c (gfc_conv_expr_descriptor): Remove ss lookup.
	Update asserts accordingly.

	PR fortran/45648
	* trans.h (gfc_se): New field force_tmp. 
	* trans-expr.c (gfc_conv_procedure_call): Check for argument alias
	and set parmse.force_tmp if some alias is found. 
	* trans-array.c (gfc_conv_expr_descriptor): Force a temporary creation
	if se->force_tmp is set. 

2010-09-21  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/45648
	* gfortran.dg/inline_transpose_1.f90: Update temporary's locations
	and counts. Add non-elemental function call check.

	PR fortran/45648
	* gfortran.dg/inline_transpose_1.f90: Add function calls with aliasing
	arguments checks. Update temporary counts.
	* gfortran.dg/transpose_optimization_1.f90: New.

From-SVN: r164494

7 files changed, 284 insertions, 53 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d9777bf..33eb639 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,27 @@
+2010-09-21  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/45648
+	* trans-array.c (gfc_conv_expr_descriptor): Calculate dim out of n and
+	info->dim.
+
+	PR fortran/45648
+	* trans-array.c (gfc_conv_expr_descriptor): Unset full if we are
+	accessing dimensions in reversed order. 
+
+	PR fortran/45648
+	* trans-array.c (gfc_conv_expr_descriptor): Special case noncopying
+	intrinsic function call. 
+
+	* trans-array.c (gfc_conv_expr_descriptor): Remove ss lookup.
+	Update asserts accordingly.
+
+	PR fortran/45648
+	* trans.h (gfc_se): New field force_tmp. 
+	* trans-expr.c (gfc_conv_procedure_call): Check for argument alias
+	and set parmse.force_tmp if some alias is found. 
+	* trans-array.c (gfc_conv_expr_descriptor): Force a temporary creation
+	if se->force_tmp is set. 
+
 2010-09-20  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/45438
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 7bce2ef..310a42b 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5136,7 +5136,6 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
 }
 
 
-
 /* Convert an array for passing as an actual argument.  Expressions and
    vector subscripts are evaluated and stored in a temporary, which is then
    passed.  For whole arrays the descriptor is passed.  For array sections
@@ -5158,13 +5157,18 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
 	 EXPR is the right-hand side of a pointer assignment and
 	 se->expr is the descriptor for the previously-evaluated
 	 left-hand side.  The function creates an assignment from
-	 EXPR to se->expr.  */
+	 EXPR to se->expr.  
+
+
+   The se->force_tmp flag disables the non-copying descriptor optimization
+   that is used for transpose. It may be used in cases where there is an
+   alias between the transpose argument and another argument in the same
+   function call.  */
 
 void
 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 {
   gfc_loopinfo loop;
-  gfc_ss *secss;
   gfc_ss_info *info;
   int need_tmp;
   int n;
@@ -5175,7 +5179,9 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
   tree offset;
   int full;
   bool subref_array_target = false;
+  gfc_expr *arg;
 
+  gcc_assert (ss != NULL);
   gcc_assert (ss != gfc_ss_terminator);
 
   /* Special case things we know we can pass easily.  */
@@ -5185,22 +5191,21 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       /* If we have a linear array section, we can pass it directly.
 	 Otherwise we need to copy it into a temporary.  */
 
-      /* Find the SS for the array section.  */
-      secss = ss;
-      while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
-	secss = secss->next;
-
-      gcc_assert (secss != gfc_ss_terminator);
-      info = &secss->data.info;
+      gcc_assert (ss->type == GFC_SS_SECTION);
+      gcc_assert (ss->expr == expr);
+      info = &ss->data.info;
 
       /* Get the descriptor for the array.  */
-      gfc_conv_ss_descriptor (&se->pre, secss, 0);
+      gfc_conv_ss_descriptor (&se->pre, ss, 0);
       desc = info->descriptor;
 
       subref_array_target = se->direct_byref && is_subref_array (expr);
       need_tmp = gfc_ref_needs_temporary_p (expr->ref)
 			&& !subref_array_target;
 
+      if (se->force_tmp)
+	need_tmp = 1;
+
       if (need_tmp)
 	full = 0;
       else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
@@ -5216,6 +5221,14 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	full = gfc_full_array_ref_p (info->ref, NULL);
 
       if (full)
+	for (n = 0; n < info->dimen; n++)
+	  if (info->dim[n] != n)
+	    {
+	      full = 0;
+	      break;
+	    }
+
+      if (full)
 	{
 	  if (se->direct_byref && !se->byref_noassign)
 	    {
@@ -5245,30 +5258,45 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       break;
       
     case EXPR_FUNCTION:
+
+      /* We don't need to copy data in some cases.  */
+      arg = gfc_get_noncopying_intrinsic_argument (expr);
+      if (arg)
+	{
+	  /* This is a call to transpose...  */
+	  gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
+	  /* ... which has already been handled by the scalarizer, so
+	     that we just need to get its argument's descriptor.  */
+	  gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
+	  return;
+	}
+
       /* A transformational function return value will be a temporary
 	 array descriptor.  We still need to go through the scalarizer
 	 to create the descriptor.  Elemental functions ar handled as
 	 arbitrary expressions, i.e. copy to a temporary.  */
-      secss = ss;
-      /* Look for the SS for this function.  */
-      while (secss != gfc_ss_terminator
-	     && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
-      	secss = secss->next;
 
       if (se->direct_byref)
 	{
-	  gcc_assert (secss != gfc_ss_terminator);
+	  gcc_assert (ss->type == GFC_SS_FUNCTION && ss->expr == expr);
 
 	  /* For pointer assignments pass the descriptor directly.  */
-	  se->ss = secss;
+	  if (se->ss == NULL)
+	    se->ss = ss;
+	  else
+	    gcc_assert (se->ss == ss);
 	  se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
 	  gfc_conv_expr (se, expr);
 	  return;
 	}
 
-      if (secss == gfc_ss_terminator)
+      if (ss->expr != expr)
 	{
 	  /* Elemental function.  */
+	  gcc_assert ((expr->value.function.esym != NULL
+		       && expr->value.function.esym->attr.elemental)
+		      || (expr->value.function.isym != NULL
+			  && expr->value.function.isym->elemental));
 	  need_tmp = 1;
 	  if (expr->ts.type == BT_CHARACTER
 		&& expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
@@ -5279,7 +5307,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       else
 	{
 	  /* Transformational function.  */
-	  info = &secss->data.info;
+	  info = &ss->data.info;
 	  need_tmp = 0;
 	}
       break;
@@ -5292,12 +5320,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	{
 	  need_tmp = 0;
 	  info = &ss->data.info;
-	  secss = ss;
 	}
       else
 	{
 	  need_tmp = 1;
-	  secss = NULL;
 	  info = NULL;
 	}
       break;
@@ -5305,11 +5331,15 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
     default:
       /* Something complicated.  Copy it into a temporary.  */
       need_tmp = 1;
-      secss = NULL;
       info = NULL;
       break;
     }
 
+  /* If we are creating a temporary, we don't need to bother about aliases
+     anymore.  */
+  if (need_tmp)
+    se->force_tmp = 0;
+
   gfc_init_loopinfo (&loop);
 
   /* Associate the SS with the loop.  */
@@ -5421,7 +5451,6 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	se->string_length =  gfc_get_expr_charlen (expr);
 
       desc = info->descriptor;
-      gcc_assert (secss && secss != gfc_ss_terminator);
       if (se->direct_byref && !se->byref_noassign)
 	{
 	  /* For pointer assignments we fill in the destination.  */
@@ -5439,12 +5468,11 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	}
 
       offset = gfc_index_zero_node;
-      dim = 0;
 
       /* The following can be somewhat confusing.  We have two
          descriptors, a new one and the original array.
          {parm, parmtype, dim} refer to the new one.
-         {desc, type, n, secss, loop} refer to the original, which maybe
+         {desc, type, n, loop} refer to the original, which maybe
          a descriptorless array.
          The bounds of the scalarization are the bounds of the section.
          We don't have to worry about numeric overflows when calculating
@@ -5479,9 +5507,6 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	    }
 	  else
 	    {
-	      /* Check we haven't somehow got out of sync.  */
-	      gcc_assert (info->dim[dim] == n);
-
 	      /* Evaluate and remember the start of the section.  */
 	      start = info->start[n];
 	      stride = gfc_evaluate_now (stride, &loop.pre);
@@ -5505,6 +5530,14 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	  /* Vector subscripts need copying and are handled elsewhere.  */
 	  if (info->ref)
 	    gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
+ 
+	  /* look for the corresponding scalarizer dimension: dim.  */
+	  for (dim = 0; dim < ndim; dim++)
+	    if (info->dim[dim] == n)
+	      break;
+
+	  /* loop exited early: the DIM being looked for has been found.  */
+	  gcc_assert (dim < ndim);
 
 	  /* Set the new lower bound.  */
 	  from = loop.from[dim];
@@ -5559,8 +5592,6 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	  /* Store the new stride.  */
 	  gfc_conv_descriptor_stride_set (&loop.pre, parm,
 					  gfc_rank_cst[dim], stride);
-
-	  dim++;
 	}
 
       if (se->data_not_needed)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9b24cad..a6837c9 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2770,7 +2770,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
 
 int
 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
-			 gfc_actual_arglist * arg, gfc_expr * expr,
+			 gfc_actual_arglist * args, gfc_expr * expr,
 			 VEC(tree,gc) *append_args)
 {
   gfc_interface_mapping mapping;
@@ -2789,6 +2789,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   VEC(tree,gc) *stringargs;
   tree result = NULL;
   gfc_formal_arglist *formal;
+  gfc_actual_arglist *arg;
   int has_alternate_specifier = 0;
   bool need_interface_mapping;
   bool callee_alloc;
@@ -2809,7 +2810,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   gfc_clear_ts (&ts);
 
   if (sym->from_intmod == INTMOD_ISO_C_BINDING
-      && conv_isocbinding_procedure (se, sym, arg))
+      && conv_isocbinding_procedure (se, sym, args))
     return 0;
 
   gfc_is_proc_ptr_comp (expr, &comp);
@@ -2859,7 +2860,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
     }
 
   /* Evaluate the arguments.  */
-  for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
+  for (arg = args; arg != NULL;
+       arg = arg->next, formal = formal ? formal->next : NULL)
     {
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
@@ -3040,6 +3042,24 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      else
 		f = f || !sym->attr.always_explicit;
 
+	      /* If the argument is a function call that may not create
+		 a temporary for the result, we have to check that we
+		 can do it, i.e. that there is no alias between this 
+		 argument and another one.  */
+	      if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
+		{
+		  sym_intent intent;
+
+		  if (fsym != NULL)
+		    intent = fsym->attr.intent;
+		  else
+		    intent = INTENT_UNKNOWN;
+
+		  if (gfc_check_fncall_dependency (e, intent, sym, args,
+						   NOT_ELEMENTAL))
+		    parmse.force_tmp = 1;
+		}
+
 	      if (e->expr_type == EXPR_VARIABLE
 		    && is_subref_array (e))
 		/* The actual argument is a component reference to an
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index acdd3e3..a883cf5 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -81,6 +81,11 @@ typedef struct gfc_se
   /* If set, gfc_conv_procedure_call does not put byref calls into se->pre.  */
   unsigned no_function_call:1;
 
+  /* If set, we will force the creation of a temporary. Useful to disable
+     non-copying procedure argument passing optimizations, when some function
+     args alias.  */
+  unsigned force_tmp:1;
+
   /* Scalarization parameters.  */
   struct gfc_se *parent;
   struct gfc_ss *ss;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b9ca99d..a1d8eb0 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+2010-09-21  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/45648
+	* gfortran.dg/inline_transpose_1.f90: Update temporary's locations
+	and counts. Add non-elemental function call check.
+
+	PR fortran/45648
+	* gfortran.dg/inline_transpose_1.f90: Add function calls with aliasing
+	arguments checks. Update temporary counts.
+	* gfortran.dg/transpose_optimization_1.f90: New.
+
 2010-09-21  Nicola Pero  <nicola.pero@meta-innovation.com>
 
 	Merge from 'apple/trunk' branch on FSF servers.
diff --git a/gcc/testsuite/gfortran.dg/inline_transpose_1.f90 b/gcc/testsuite/gfortran.dg/inline_transpose_1.f90
index 4995c49..a364842 100644
--- a/gcc/testsuite/gfortran.dg/inline_transpose_1.f90
+++ b/gcc/testsuite/gfortran.dg/inline_transpose_1.f90
@@ -61,10 +61,10 @@
   if (u /= v) call abort
 
 
-  a = foo(transpose(c)) ! Unnecessary { dg-warning "Creating array temporary" }
+  a = foo(transpose(c))
   if (any(a /= p+1)) call abort
 
-  write(u,*) foo(transpose(c))    ! 2 temps, should be 1 { dg-warning "Creating array temporary" }
+  write(u,*) foo(transpose(c))    ! { dg-warning "Creating array temporary" }
   write(v,*) p+1
   if (u /= v) call abort
 
@@ -77,10 +77,10 @@
   if (u /= v) call abort
 
 
-  e = foo(transpose(e))     ! 2 temps, should be 1 { dg-warning "Creating array temporary" }
+  e = foo(transpose(e))     ! { dg-warning "Creating array temporary" }
   if (any(e /= 2*s+1)) call abort
 
-  write(u,*) transpose(foo(transpose(e))-1)     ! 2 temps, should be 1 { dg-warning "Creating array temporary" }
+  write(u,*) transpose(foo(transpose(e))-1)     ! { dg-warning "Creating array temporary" }
   write(v,*) 2*s+1
   if (u /= v) call abort
 
@@ -141,28 +141,46 @@
   if (u /= v) call abort
 
 
-  if (any(transpose(matmul(a,c)) /= matmul(transpose(c), transpose(a)))) call abort      ! 4 temps, should be 2 { dg-warning "Creating array temporary" }
+  if (any(transpose(matmul(a,c)) /= matmul(transpose(c), transpose(a)))) call abort      ! 2 temps { dg-warning "Creating array temporary" }
 
   write(u,*) transpose(matmul(a,c))     ! { dg-warning "Creating array temporary" }
-  write(v,*) matmul(transpose(c), transpose(a))     ! 3 temps, should be 1 { dg-warning "Creating array temporary" }
+  write(v,*) matmul(transpose(c), transpose(a))     ! { dg-warning "Creating array temporary" }
   if (u /= v) call abort
 
 
-  if (any(transpose(matmul(e,a)) /= matmul(transpose(a), transpose(e)))) call abort     ! 4 temps, should be 2 { dg-warning "Creating array temporary" }
+  if (any(transpose(matmul(e,a)) /= matmul(transpose(a), transpose(e)))) call abort     ! 2 temps { dg-warning "Creating array temporary" }
 
   write(u,*) transpose(matmul(e,a))     ! { dg-warning "Creating array temporary" }
-  write(v,*) matmul(transpose(a), transpose(e))     ! 3 temps, should be 1 { dg-warning "Creating array temporary" }
+  write(v,*) matmul(transpose(a), transpose(e))     ! { dg-warning "Creating array temporary" }
   if (u /= v) call abort
 
 
-  call baz (transpose(a))       ! Unnecessary { dg-warning "Creating array temporary" }
+  call baz (transpose(a))
 
-  call toto (f, transpose (e))
-  if (any (f /= 4 * s + 12)) call abort
 
-  call toto (f, transpose (f))          ! { dg-warning "Creating array temporary" }
-  if (any (f /= 8 * r + 24)) call abort
+  call toto1 (a, transpose (c))
+  if (any (a /= 2 * p + 12)) call abort
 
+  call toto1 (e, transpose (e))          ! { dg-warning "Creating array temporary" }
+  if (any (e /= 4 * s + 12)) call abort
+
+
+  call toto2 (c, transpose (a))
+  if (any (c /= 2 * q + 13)) call abort
+
+  call toto2 (e, transpose(e))           ! { dg-warning "Creating array temporary" }
+  if (any (e /= 4 * r + 13)) call abort
+
+  call toto2 (e, transpose(transpose(e)))           ! { dg-warning "Creating array temporary" }
+  if (any (e /= 4 * r + 14)) call abort
+
+
+  call toto3 (e, transpose(e))
+  if (any (e /= 4 * r + 14)) call abort
+
+
+  call titi (nx, e, transpose(e))           ! { dg-warning "Creating array temporary" }
+  if (any (e /= 4 * s + 17)) call abort
 
   contains
 
@@ -182,22 +200,38 @@
     integer, intent(in) :: x(:,:)
   end subroutine baz
 
-  elemental subroutine toto (x, y)
+  elemental subroutine toto1 (x, y)
     integer, intent(out) :: x
     integer, intent(in)  :: y
     x = y + y
-  end subroutine toto
+  end subroutine toto1
+
+  subroutine toto2 (x, y)
+    integer, dimension(:,:), intent(out) :: x
+    integer, dimension(:,:), intent(in)  :: y
+    x = y + 1
+  end subroutine toto2
+
+  subroutine toto3 (x, y)
+    integer, dimension(:,:), intent(in) :: x, y
+  end subroutine toto3
 
 end
+
+subroutine titi (n, x, y)
+  integer :: n, x(n,n), y(n,n)
+  x = y + 3
+end subroutine titi
+
 ! No call to transpose
 ! { dg-final { scan-tree-dump-times "_gfortran_transpose" 0 "original" } }
 !
-! 34 temporaries
-! { dg-final { scan-tree-dump-times "struct\[^\\n\]*atmp" 34 "original" } }
+! 24 temporaries
+! { dg-final { scan-tree-dump-times "struct\[^\\n\]*atmp" 24 "original" } }
 !
 ! 2 tests optimized out
-! { dg-final { scan-tree-dump-times "_gfortran_abort" 34 "original" } }
-! { # Commented out as failing at -O0: dg-final { scan-tree-dump-times "_gfortran_abort" 32 "optimized" } }
+! { dg-final { scan-tree-dump-times "_gfortran_abort" 39 "original" } }
+! { # Commented out as failing at -O0: dg-final { scan-tree-dump-times "_gfortran_abort" 37 "optimized" } }
 !
 ! cleanup
 ! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/transpose_optimization_1.f90 b/gcc/testsuite/gfortran.dg/transpose_optimization_1.f90
new file mode 100644
index 0000000..885ff7c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/transpose_optimization_1.f90
@@ -0,0 +1,106 @@
+! { dg-do compile }
+! { dg-options "-Warray-temporaries -fdump-tree-original" }
+!
+! PR fortran/45648
+! Non-copying descriptor transpose optimization (for function call args).
+!
+! Contributed by Richard Sandiford <richard@codesourcery.com>
+
+module foo
+  interface
+    subroutine ext1 (a, b)
+      real, intent (in), dimension (:, :) :: a, b
+    end subroutine ext1
+    subroutine ext2 (a, b)
+      real, intent (in), dimension (:, :) :: a
+      real, intent (out), dimension (:, :) :: b
+    end subroutine ext2
+    subroutine ext3 (a, b)
+      real, dimension (:, :) :: a, b
+    end subroutine ext3
+  end interface
+contains
+  ! No temporary needed here.
+  subroutine test1 (n, a, b, c)
+    integer :: n
+    real, dimension (n, n) :: a, b, c
+    a = matmul (transpose (b), c)
+  end subroutine test1
+
+  ! No temporary either, as we know the arguments to matmul are intent(in)
+  subroutine test2 (n, a, b)
+    integer :: n
+    real, dimension (n, n) :: a, b
+    a = matmul (transpose (b), b)
+  end subroutine test2
+
+  ! No temporary needed.
+  subroutine test3 (n, a, b, c)
+    integer :: n
+    real, dimension (n, n) :: a, c
+    real, dimension (n+4, n+4) :: b
+    a = matmul (transpose (b (2:n+1, 3:n+2)), c)
+  end subroutine test3
+
+  ! A temporary is needed for the result of either the transpose or matmul.
+  subroutine test4 (n, a, b)
+    integer :: n
+    real, dimension (n, n) :: a, b
+    a = matmul (transpose (a), b)       ! { dg-warning "Creating array temporary" }
+  end subroutine test4
+
+  ! The temporary is needed here since the second argument to imp1
+  ! has unknown intent.
+  subroutine test5 (n, a)
+    integer :: n
+    real, dimension (n, n) :: a
+    call imp1 (transpose (a), a)        ! { dg-warning "Creating array temporary" }
+  end subroutine test5
+
+  ! No temporaries are needed here; imp1 can't modify either argument.
+  ! We have to pack the arguments, however. 
+  subroutine test6 (n, a, b)
+    integer :: n
+    real, dimension (n, n) :: a, b
+    call imp1 (transpose (a), transpose (b))    ! { dg-warning "Creating array temporary" }
+  end subroutine test6
+
+  ! No temporaries are needed here; imp1 can't modify either argument.
+  ! We don't have to pack the arguments. 
+  subroutine test6_bis (n, a, b)
+    integer :: n
+    real, dimension (n, n) :: a, b
+    call ext3 (transpose (a), transpose (b))
+  end subroutine test6_bis
+
+  ! No temporary is neede here; the second argument is intent(in).
+  subroutine test7 (n, a)
+    integer :: n
+    real, dimension (n, n) :: a
+    call ext1 (transpose (a), a)
+  end subroutine test7
+
+  ! The temporary is needed here though.
+  subroutine test8 (n, a)
+    integer :: n
+    real, dimension (n, n) :: a
+    call ext2 (transpose (a), a)        ! { dg-warning "Creating array temporary" } 
+  end subroutine test8
+
+  ! Silly, but we don't need any temporaries here.
+  subroutine test9 (n, a)
+    integer :: n
+    real, dimension (n, n) :: a
+    call ext1 (transpose (transpose (a)), a)
+  end subroutine test9
+
+  ! The outer transpose needs a temporary; the inner one doesn't.
+  subroutine test10 (n, a)
+    integer :: n
+    real, dimension (n, n) :: a
+    call ext2 (transpose (transpose (a)), a)    ! { dg-warning "Creating array temporary" }
+  end subroutine test10
+end module foo
+
+! { dg-final { scan-tree-dump-times "struct\[^\\n\]*atmp" 4 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }