gfortran.h (gfc_expr): Remove inline_noncopying_intrinsic attribute.

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

	* gfortran.h (gfc_expr): Remove inline_noncopying_intrinsic attribute.
	* dependency.c (gfc_check_dependency): Don't depend on
	expr's inline_noncopying_intrinsic_attribute.
	* dependency.c (gfc_check_argument_var_dependency,
	gfc_check_argument_dependency): Ditto. Recursively check dependency
	as NOT_ELEMENTAL in the non-copying (=transpose) case.
	* trans-intrinsic.c (gfc_conv_intrinsic_function): Ditto.
	* resolve.c (find_noncopying_intrinsics): Remove.
	(resolve_function, resolve_call): Remove call to
	find_noncopying_intrinsics.

	* trans-array.c (gfc_conv_array_transpose): Remove.
	(gfc_walk_subexpr): Make non-static. Move prototype...
	* trans-array.h (gfc_walk_subexpr): ... here.
	* trans-intrinsic.c (gfc_conv_intrinsic_function): Update transpose
	handling.
	(walk_inline_intrinsic_transpose, walk_inline_intrinsic_function,
	gfc_inline_intrinsic_function_p): New.
	(gfc_is_intrinsic_libcall): Return early in inline intrinsic case.
	Remove transpose from the libcall list.
	(gfc_walk_intrinsic_function): Special case inline intrinsic.
	* trans.h (gfc_inline_intrinsic_function_p): New prototype.

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

	* gfortran.dg/inline_transpose_1.f90: Update temporary's locations
	and counts. Check that transpose is not called.
	* gfortran.dg/transpose_2.f90: Update error message.

From-SVN: r164205

gcc/fortran/ChangeLog

+2010-09-11  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* gfortran.h (gfc_expr): Remove inline_noncopying_intrinsic attribute.
+	* dependency.c (gfc_check_dependency): Don't depend on
+	expr's inline_noncopying_intrinsic_attribute.
+	* dependency.c (gfc_check_argument_var_dependency,
+	gfc_check_argument_dependency): Ditto. Recursively check dependency
+	as NOT_ELEMENTAL in the non-copying (=transpose) case.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Ditto.
+	* resolve.c (find_noncopying_intrinsics): Remove.
+	(resolve_function, resolve_call): Remove call to
+	find_noncopying_intrinsics.
+
+	* trans-array.c (gfc_conv_array_transpose): Remove.
+	(gfc_walk_subexpr): Make non-static. Move prototype...
+	* trans-array.h (gfc_walk_subexpr): ... here.
+	* trans-intrinsic.c (gfc_conv_intrinsic_function): Update transpose
+	handling.
+	(walk_inline_intrinsic_transpose, walk_inline_intrinsic_function,
+	gfc_inline_intrinsic_function_p): New.
+	(gfc_is_intrinsic_libcall): Return early in inline intrinsic case.
+	Remove transpose from the libcall list.
+	(gfc_walk_intrinsic_function): Special case inline intrinsic.
+	* trans.h (gfc_inline_intrinsic_function_p): New prototype.
+
 2010-09-10  Mikael Morin  <mikael@gcc.gnu.org>
 
 	* trans-expr.c (expr_is_variable): New function taking non-copying

gcc/fortran/dependency.c

@@ -627,11 +627,15 @@ gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
       return gfc_check_dependency (var, expr, 1);
 
     case EXPR_FUNCTION:
-      if (intent != INTENT_IN && expr->inline_noncopying_intrinsic
-	  && (arg = gfc_get_noncopying_intrinsic_argument (expr))
-	  && gfc_check_argument_var_dependency (var, intent, arg, elemental))
-	return 1;
-      if (elemental)
+      if (intent != INTENT_IN)
+	{
+	  arg = gfc_get_noncopying_intrinsic_argument (expr);
+	  if (arg != NULL)
+	    return gfc_check_argument_var_dependency (var, intent, arg,
+						      NOT_ELEMENTAL);
+	}
+
+      if (elemental != NOT_ELEMENTAL)
 	{
 	  if ((expr->value.function.esym
 	       && expr->value.function.esym->attr.elemental)
@@ -683,12 +687,11 @@ gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
       return gfc_check_argument_var_dependency (other, intent, expr, elemental);
 
     case EXPR_FUNCTION:
-      if (other->inline_noncopying_intrinsic)
-	{
-	  other = gfc_get_noncopying_intrinsic_argument (other);
-	  return gfc_check_argument_dependency (other, INTENT_IN, expr, 
-						elemental);
-	}
+      other = gfc_get_noncopying_intrinsic_argument (other);
+      if (other != NULL)
+	return gfc_check_argument_dependency (other, INTENT_IN, expr,
+					      NOT_ELEMENTAL);
+
       return 0;
 
     default:
@@ -962,8 +965,9 @@ gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
       return 1;
 
     case EXPR_FUNCTION:
-      if (expr2->inline_noncopying_intrinsic)
+      if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL)
 	identical = 1;
+
       /* Remember possible differences between elemental and
 	 transformational functions.  All functions inside a FORALL
 	 will be pure.  */

gcc/fortran/gfortran.h

@@ -1695,11 +1695,9 @@ typedef struct gfc_expr
 
   locus where;
 
-  /* True if the expression is a call to a function that returns an array,
-     and if we have decided not to allocate temporary data for that array.
-     is_boz is true if the integer is regarded as BOZ bitpatten and is_snan
+  /* is_boz is true if the integer is regarded as BOZ bitpatten and is_snan
      denotes a signalling not-a-number.  */
-  unsigned int inline_noncopying_intrinsic : 1, is_boz : 1, is_snan : 1;
+  unsigned int is_boz : 1, is_snan : 1;
 
   /* Sometimes, when an error has been emitted, it is necessary to prevent
       it from recurring.  */

gcc/fortran/resolve.c

@@ -1916,25 +1916,6 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
 }
 
 
-/* Go through each actual argument in ACTUAL and see if it can be
-   implemented as an inlined, non-copying intrinsic.  FNSYM is the
-   function being called, or NULL if not known.  */
-
-static void
-find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
-{
-  gfc_actual_arglist *ap;
-  gfc_expr *expr;
-
-  for (ap = actual; ap; ap = ap->next)
-    if (ap->expr
-	&& (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
-	&& !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
-					 NOT_ELEMENTAL))
-      ap->expr->inline_noncopying_intrinsic = 1;
-}
-
-
 /* This function does the checking of references to global procedures
    as defined in sections 18.1 and 14.1, respectively, of the Fortran
    77 and 95 standards.  It checks for a gsymbol for the name, making
@@ -3115,15 +3096,6 @@ resolve_function (gfc_expr *expr)
       gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
     }
 
-  if (t == SUCCESS
-	&& !((expr->value.function.esym
-		&& expr->value.function.esym->attr.elemental)
-			||
-	     (expr->value.function.isym
-		&& expr->value.function.isym->elemental)))
-    find_noncopying_intrinsics (expr->value.function.esym,
-				expr->value.function.actual);
-
   /* Make sure that the expression has a typespec that works.  */
   if (expr->ts.type == BT_UNKNOWN)
     {
@@ -3602,8 +3574,6 @@ resolve_call (gfc_code *c)
   if (resolve_elemental_actual (NULL, c) == FAILURE)
     return FAILURE;
 
-  if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
-    find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
   return t;
 }
 

gcc/fortran/trans-array.c

@@ -91,7 +91,6 @@ along with GCC; see the file COPYING3.  If not see
 #include "trans-const.h"
 #include "dependency.h"
 
-static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
 
 /* The contents of this structure aren't actually used, just the address.  */
@@ -917,96 +916,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
 }
 
 
-/* Generate code to transpose array EXPR by creating a new descriptor
-   in which the dimension specifications have been reversed.  */
-
-void
-gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
-{
-  tree dest, src, dest_index, src_index;
-  gfc_loopinfo *loop;
-  gfc_ss_info *dest_info;
-  gfc_ss *dest_ss, *src_ss;
-  gfc_se src_se;
-  int n;
-
-  loop = se->loop;
-
-  src_ss = gfc_walk_expr (expr);
-  dest_ss = se->ss;
-
-  dest_info = &dest_ss->data.info;
-  gcc_assert (dest_info->dimen == 2);
-
-  /* Get a descriptor for EXPR.  */
-  gfc_init_se (&src_se, NULL);
-  gfc_conv_expr_descriptor (&src_se, expr, src_ss);
-  gfc_add_block_to_block (&se->pre, &src_se.pre);
-  gfc_add_block_to_block (&se->post, &src_se.post);
-  src = src_se.expr;
-
-  /* Allocate a new descriptor for the return value.  */
-  dest = gfc_create_var (TREE_TYPE (src), "transp");
-  dest_info->descriptor = dest;
-  se->expr = dest;
-
-  /* Copy across the dtype field.  */
-  gfc_add_modify (&se->pre,
-		       gfc_conv_descriptor_dtype (dest),
-		       gfc_conv_descriptor_dtype (src));
-
-  /* Copy the dimension information, renumbering dimension 1 to 0 and
-     0 to 1.  */
-  for (n = 0; n < 2; n++)
-    {
-      dest_info->delta[n] = gfc_index_zero_node;
-      dest_info->start[n] = gfc_index_zero_node;
-      dest_info->end[n] = gfc_index_zero_node;
-      dest_info->stride[n] = gfc_index_one_node;
-      dest_info->dim[n] = n;
-
-      dest_index = gfc_rank_cst[n];
-      src_index = gfc_rank_cst[1 - n];
-
-      gfc_conv_descriptor_stride_set (&se->pre, dest, dest_index,
-			   gfc_conv_descriptor_stride_get (src, src_index));
-
-      gfc_conv_descriptor_lbound_set (&se->pre, dest, dest_index,
-			   gfc_conv_descriptor_lbound_get (src, src_index));
-
-      gfc_conv_descriptor_ubound_set (&se->pre, dest, dest_index,
-			   gfc_conv_descriptor_ubound_get (src, src_index));
-
-      if (!loop->to[n])
-        {
-	  gcc_assert (integer_zerop (loop->from[n]));
-	  loop->to[n] =
-	    fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-			 gfc_conv_descriptor_ubound_get (dest, dest_index),
-			 gfc_conv_descriptor_lbound_get (dest, dest_index));
-        }
-    }
-
-  /* Copy the data pointer.  */
-  dest_info->data = gfc_conv_descriptor_data_get (src);
-  gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
-
-  /* Copy the offset.  This is not changed by transposition; the top-left
-     element is still at the same offset as before, except where the loop
-     starts at zero.  */
-  if (!integer_zerop (loop->from[0]))
-    dest_info->offset = gfc_conv_descriptor_offset_get (src);
-  else
-    dest_info->offset = gfc_index_zero_node;
-
-  gfc_conv_descriptor_offset_set (&se->pre, dest,
-				  dest_info->offset);
-	  
-  if (dest_info->dimen > loop->temp_dim)
-    loop->temp_dim = dest_info->dimen;
-}
-
-
 /* Return the number of iterations in a loop that starts at START,
    ends at END, and has step STEP.  */
 
@@ -6989,7 +6898,7 @@ gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
 /* Walk an expression.  Add walked expressions to the head of the SS chain.
    A wholly scalar expression will not be added.  */
 
-static gfc_ss *
+gfc_ss *
 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
 {
   gfc_ss *head;

gcc/fortran/trans-array.h

@@ -64,6 +64,8 @@ void gfc_trans_static_array_pointer (gfc_symbol *);
 
 /* Generate scalarization information for an expression.  */
 gfc_ss *gfc_walk_expr (gfc_expr *);
+/* Workhorse for gfc_walk_expr.  */
+gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
 /* Walk the arguments of an elemental function.  */
 gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *,
 					  gfc_ss_type);

gcc/fortran/trans-intrinsic.c

@@ -5583,7 +5583,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
 
   name = &expr->value.function.name[2];
 
-  if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
+  if (expr->rank > 0)
     {
       lib = gfc_is_intrinsic_libcall (expr);
       if (lib != 0)
@@ -5957,13 +5957,9 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_TRANSPOSE:
-      if (se->ss && se->ss->useflags)
-	{
-	  gfc_conv_tmp_array_ref (se);
-	  gfc_advance_se_ss_chain (se);
-	}
-      else
-	gfc_conv_array_transpose (se, expr->value.function.actual->expr);
+      /* The scalarizer has already been set up for reversed dimension access
+	 order ; now we just get the argument value normally.  */
+      gfc_conv_expr (se, expr->value.function.actual->expr);
       break;
 
     case GFC_ISYM_LEN:
@@ -6188,6 +6184,64 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
 }
 
 
+static gfc_ss *
+walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
+{
+  gfc_ss *arg_ss, *tmp_ss;
+  gfc_actual_arglist *arg;
+
+  arg = expr->value.function.actual;
+
+  gcc_assert (arg->expr);
+
+  arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
+  gcc_assert (arg_ss != gfc_ss_terminator);
+
+  for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
+    {
+      if (tmp_ss->type != GFC_SS_SCALAR
+	  && tmp_ss->type != GFC_SS_REFERENCE)
+	{
+	  int tmp_dim;
+	  gfc_ss_info *info;
+
+	  info = &tmp_ss->data.info;
+	  gcc_assert (info->dimen == 2);
+
+	  /* We just invert dimensions.  */
+	  tmp_dim = info->dim[0];
+	  info->dim[0] = info->dim[1];
+	  info->dim[1] = tmp_dim;
+	}
+
+      /* Stop when tmp_ss points to the last valid element of the chain...  */
+      if (tmp_ss->next == gfc_ss_terminator)
+	break;
+    }
+
+  /* ... so that we can attach the rest of the chain to it.  */
+  tmp_ss->next = ss;
+
+  return arg_ss;
+}
+
+
+static gfc_ss *
+walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
+{
+
+  switch (expr->value.function.isym->id)
+    {
+      case GFC_ISYM_TRANSPOSE:
+	return walk_inline_intrinsic_transpose (ss, expr);
+
+      default:
+	gcc_unreachable ();
+    }
+  gcc_unreachable ();
+}
+
+
 /* This generates code to execute before entering the scalarization loop.
    Currently does nothing.  */
 
@@ -6250,6 +6304,26 @@ gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
 }
 
 
+/* Return whether the function call expression EXPR will be expanded
+   inline by gfc_conv_intrinsic_function.  */
+
+bool
+gfc_inline_intrinsic_function_p (gfc_expr *expr)
+{
+  if (!expr->value.function.isym)
+    return false;
+
+  switch (expr->value.function.isym->id)
+    {
+    case GFC_ISYM_TRANSPOSE:
+      return true;
+
+    default:
+      return false;
+    }
+}
+
+
 /* Returns nonzero if the specified intrinsic function call maps directly to
    an external library call.  Should only be used for functions that return
    arrays.  */
@@ -6260,6 +6334,9 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
   gcc_assert (expr->rank > 0);
 
+  if (gfc_inline_intrinsic_function_p (expr))
+    return 0;
+
   switch (expr->value.function.isym->id)
     {
     case GFC_ISYM_ALL:
@@ -6280,7 +6357,6 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
     case GFC_ISYM_SUM:
     case GFC_ISYM_SHAPE:
     case GFC_ISYM_SPREAD:
-    case GFC_ISYM_TRANSPOSE:
     case GFC_ISYM_YN2:
       /* Ignore absent optional parameters.  */
       return 1;
@@ -6306,11 +6382,15 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
   gcc_assert (isym);
 
   if (isym->elemental)
-    return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
+    return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
+					     GFC_SS_SCALAR);
 
   if (expr->rank == 0)
     return ss;
 
+  if (gfc_inline_intrinsic_function_p (expr))
+    return walk_inline_intrinsic_function (ss, expr);
+
   if (gfc_is_intrinsic_libcall (expr))
     return gfc_walk_intrinsic_libfunc (ss, expr);
 

gcc/fortran/trans.h

@@ -345,7 +345,12 @@ tree gfc_builtin_decl_for_float_kind (enum built_in_function, int);
 /* Intrinsic function handling.  */
 void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *);
 
-/* Does an intrinsic map directly to an external library call.  */
+/* Is the intrinsic expanded inline.  */
+bool gfc_inline_intrinsic_function_p (gfc_expr *);
+
+/* Does an intrinsic map directly to an external library call
+   This is true for array-returning intrinsics, unless
+   gfc_inline_intrinsic_function_p returns true.  */
 int gfc_is_intrinsic_libcall (gfc_expr *);
 
 tree gfc_conv_intrinsic_move_alloc (gfc_code *);

gcc/testsuite/ChangeLog

+2010-09-11  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* gfortran.dg/inline_transpose_1.f90: Update temporary's locations
+	and counts. Check that transpose is not called.
+	* gfortran.dg/transpose_2.f90: Update error message.
+
 2010-09-10  Rodrigo Rivas Costa <rodrigorivascosta@gmail.com>
 
 	PR c++/43824

gcc/testsuite/gfortran.dg/inline_transpose_1.f90

 ! { dg-do run }
-! { dg-options "-fdump-tree-original -Warray-temporaries" }
+! { dg-options "-fdump-tree-original -fdump-tree-optimized -Warray-temporaries -fbounds-check" }
 
   implicit none
 
@@ -29,7 +29,7 @@
   c = transpose(a)
   if (any(c /= q)) call abort
 
-  write(u,*) transpose(a)       ! Unnecessary { dg-warning "Creating array temporary" }
+  write(u,*) transpose(a)
   write(v,*) q
   if (u /= v) call abort
 
@@ -37,10 +37,10 @@
   e = r
   f = s
 
-  g = transpose(e+f)            ! Unnecessary { dg-warning "Creating array temporary" }
+  g = transpose(e+f)
   if (any(g /= r + s)) call abort
 
-  write(u,*) transpose(e+f)     ! 2 Unnecessary temps { dg-warning "Creating array temporary" }
+  write(u,*) transpose(e+f)
   write(v,*) r + s
   if (u /= v) call abort
 
@@ -48,7 +48,7 @@
   e = transpose(e)      ! { dg-warning "Creating array temporary" }
   if (any(e /= s)) call abort
 
-  write(u,*) transpose(transpose(e))    ! Unnecessary { dg-warning "Creating array temporary" }
+  write(u,*) transpose(transpose(e))
   write(v,*) s
   if (u /= v) call abort
 
@@ -56,15 +56,15 @@
   e = transpose(e+f)     ! { dg-warning "Creating array temporary" }
   if (any(e /= 2*r)) call abort
 
-  write(u,*) transpose(transpose(e+f))-f        ! 2 Unnecessary temps { dg-warning "Creating array temporary" }
+  write(u,*) transpose(transpose(e+f))-f
   write(v,*) 2*r
   if (u /= v) call abort
 
 
-  a = foo(transpose(c))
+  a = foo(transpose(c)) ! Unnecessary { dg-warning "Creating array temporary" }
   if (any(a /= p+1)) call abort
 
-  write(u,*) foo(transpose(c))    ! { dg-warning "Creating array temporary" }
+  write(u,*) foo(transpose(c))    ! 2 temps, should be 1 { dg-warning "Creating array temporary" }
   write(v,*) p+1
   if (u /= v) call abort
 
@@ -72,15 +72,15 @@
   c = transpose(foo(a))      ! Unnecessary { dg-warning "Creating array temporary" }
   if (any(c /= q+2)) call abort
 
-  write(u,*) transpose(foo(a))     ! 2 temps, should be 1 { dg-warning "Creating array temporary" }
+  write(u,*) transpose(foo(a))     ! { dg-warning "Creating array temporary" }
   write(v,*) q+2
   if (u /= v) call abort
 
 
-  e = foo(transpose(e))     ! { dg-warning "Creating array temporary" }
+  e = foo(transpose(e))     ! 2 temps, should be 1 { dg-warning "Creating array temporary" }
   if (any(e /= 2*s+1)) call abort
 
-  write(u,*) transpose(foo(transpose(e))-1)     ! 3 temps, should be 1 { dg-warning "Creating array temporary" }
+  write(u,*) transpose(foo(transpose(e))-1)     ! 2 temps, should be 1 { dg-warning "Creating array temporary" }
   write(v,*) 2*s+1
   if (u /= v) call abort
 
@@ -88,23 +88,23 @@
   e = transpose(foo(e))     ! { dg-warning "Creating array temporary" }
   if (any(e /= 2*r+2)) call abort
 
-  write(u,*) transpose(foo(transpose(e)-1))     ! 4 temps, should be 2 { dg-warning "Creating array temporary" }
+  write(u,*) transpose(foo(transpose(e)-1))     ! 2 temps { dg-warning "Creating array temporary" }
   write(v,*) 2*r+2
   if (u /= v) call abort
 
 
-  a = bar(transpose(c))         ! Unnecessary { dg-warning "Creating array temporary" }
+  a = bar(transpose(c))
   if (any(a /= p+4)) call abort
 
-  write(u,*) bar(transpose(c))  ! Unnecessary { dg-warning "Creating array temporary" }
+  write(u,*) bar(transpose(c))
   write(v,*) p+4
   if (u /= v) call abort
 
 
-  c = transpose(bar(a))         ! Unnecessary { dg-warning "Creating array temporary" }
+  c = transpose(bar(a))
   if (any(c /= q+6)) call abort
 
-  write(u,*) transpose(bar(a))  ! 2 Unnecessary temps { dg-warning "Creating array temporary" }
+  write(u,*) transpose(bar(a))
   write(v,*) q+6
   if (u /= v) call abort
 
@@ -112,7 +112,7 @@
   e = bar(transpose(e))     ! { dg-warning "Creating array temporary" }
   if (any(e /= 2*s+4)) call abort
 
-  write(u,*) transpose(bar(transpose(e)))-2     ! 3 Unnecessary temps { dg-warning "Creating array temporary" }
+  write(u,*) transpose(bar(transpose(e)))-2
   write(v,*) 2*s+4
   if (u /= v) call abort
 
@@ -120,44 +120,44 @@
   e = transpose(bar(e))     ! { dg-warning "Creating array temporary" }
   if (any(e /= 2*r+6)) call abort
 
-  write(u,*) transpose(transpose(bar(e))-2)     ! 4 Unnecessary temps { dg-warning "Creating array temporary" }
+  write(u,*) transpose(transpose(bar(e))-2)
   write(v,*) 2*r+6
   if (u /= v) call abort
 
 
-  if (any(a /= transpose(transpose(a)))) call abort     ! Unnecessary { dg-warning "Creating array temporary" }
+  if (any(a /= transpose(transpose(a)))) call abort     ! optimized away
 
   write(u,*) a
-  write(v,*) transpose(transpose(a))    ! Unnecessary { dg-warning "Creating array temporary" }
+  write(v,*) transpose(transpose(a))
   if (u /= v) call abort
 
 
   b = a * a
 
-  if (any(transpose(a+b) /= transpose(a)+transpose(b))) call abort      ! 4 unnecessary temps { dg-warning "Creating array temporary" }
+  if (any(transpose(a+b) /= transpose(a)+transpose(b))) call abort      ! optimized away
 
-  write(u,*) transpose(a+b)     ! 2 unnecessary temps { dg-warning "Creating array temporary" }
-  write(v,*) transpose(a) + transpose(b)        ! 2 unnecessary temps { dg-warning "Creating array temporary" }
+  write(u,*) transpose(a+b)
+  write(v,*) transpose(a) + transpose(b)
   if (u /= v) call abort
 
 
-  if (any(transpose(matmul(a,c)) /= matmul(transpose(c), transpose(a)))) call abort      ! 3 temps, should be 2 { dg-warning "Creating array temporary" }
+  if (any(transpose(matmul(a,c)) /= matmul(transpose(c), transpose(a)))) call abort      ! 4 temps, should be 2 { dg-warning "Creating array temporary" }
 
-  write(u,*) transpose(matmul(a,c))     ! 2 temps, should be 1 { dg-warning "Creating array temporary" }
-  write(v,*) matmul(transpose(c), transpose(a))     ! { 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" }
   if (u /= v) call abort
 
 
-  if (any(transpose(matmul(e,a)) /= matmul(transpose(a), transpose(e)))) call abort     ! 3 temps, should be 2 { dg-warning "Creating array temporary" }
+  if (any(transpose(matmul(e,a)) /= matmul(transpose(a), transpose(e)))) call abort     ! 4 temps, should be 2 { dg-warning "Creating array temporary" }
 
-  write(u,*) transpose(matmul(e,a))     ! 2 temps, should be 1 { dg-warning "Creating array temporary" }
-  write(v,*) matmul(transpose(a), transpose(e))     ! { 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" }
   if (u /= v) call abort
 
 
-  call baz (transpose(a))
+  call baz (transpose(a))       ! Unnecessary { dg-warning "Creating array temporary" }
 
-  call toto (f, transpose (e))          ! Unnecessary { dg-warning "Creating array temporary" }
+  call toto (f, transpose (e))
   if (any (f /= 4 * s + 12)) call abort
 
   call toto (f, transpose (f))          ! { dg-warning "Creating array temporary" }
@@ -189,5 +189,16 @@
   end subroutine toto
 
 end
-! { dg-final { scan-tree-dump-times "struct\[^\\n\]*atmp" 60 "original" } }
-! { dg-final { cleanup-tree-dump "original" } }
+! 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" } }
+!
+! 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" } }
+!
+! cleanup
+! { #dg-final { cleanup-tree-dump "original" } }
+! { dg-final { cleanup-tree-dump "optimized" } }

gcc/testsuite/gfortran.dg/transpose_2.f90

@@ -15,4 +15,5 @@ program main
   b = 2.1
   b = transpose(a)
 end program main
-! { dg-output "Fortran runtime error: Incorrect extent in return value of TRANSPOSE intrinsic in dimension 1: is 2, should be 3" }
+! { dg-output "Fortran runtime error: Array bound mismatch for dimension 1 of
+! array 'b' (3/2)" }