[Patc, fortran] PR22146 - ICE on elemental subroutine calls with array-valued actual arguments.

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

:ADDPATCH fortran:

This patch fixes pr22146, in which elemental subroutines with array 
arguments would ICE in gfc_conv_function_call.  The reason is that 
trans-stmt.c (gfc_trans_call) did not even attempt to scalarize the 
function call.  The patch provides the required scalarization.

Note that gfc_walk_elemental_function_args had to be modified by 
replacing the gfc_expr, for the function call, with the 
gfc_actual_arglist because the former does not apply to a subroutine call.

Also, since the ss chain produced by gfc_walk_elemental_function_args is 
in the reverse order to the actual arglist, gfc_reverse_ss had its 
static attribute removed and a prototype was put in trans-array.h.  I am 
open to the suggestion that the scalarization be moved from trans-stmt.c 
to trans-array.c but, myself, could only see it as being six of one and 
half-a-dozen of the other, as far as code structure and prototypes are 
concerned.

The standard does indeed explicitly forbid alternate return arguments 
for elemental procedures.  This is caught in resolve_formal_arglist and 
the right error produced but the compiler continues on to trans-xxx.c, 
where it ICEs.  Since the error is trapped, I consider the ICE to be of 
secondary importance in what is, after all, a rather unusual error 
condition.  As soon as this patch is committed, I will raise a PR on 
this and will add it to my TODO list.

Another TODO concerns the requirements of the standard in respect of 
actual arguments:  For an elemental subroutine all actual arguments must 
be scalar or those associated with INTENT(OUT) and INTENT(INOUT) dummy 
arguments shall be conforming arrays.  For the present, I propose that 
the extension of the functionality should be committed and the standard 
conditional error can come later.  I will raise a PR on this too, unless 
Joost has already beaten me to it!

The line   "call foobar (cos (x) + u, y)"   in the test case produces:

   {
     int4 S.12;

     S.12 = 1;
     while (1)
       {
         if (S.12 > 2) goto L.10; else (void) 0;
         {
           real4 D.861;

           D.861 = __builtin_cosf (x[NON_LVALUE_EXPR <S.12> + -1]) + D.859;
           foobar (&D.861, &y[NON_LVALUE_EXPR <S.12> + -1]);
         }
         S.12 = S.12 + 1;
       }
     L.10:;
   }

which seems to be entirely as it ought to be.

The testcase contains the original example, furnished by Erik Edelmann, 
and adds a functional test of different mixes of scalar, array end 
expression actual arguments.  Once the application of the standard, in 
respect of actual arguments, is applied, dg-warnings will have to be 
added to the mixed scalar/array cases.

Bootstrapped and regtested on FC3/Athlon and Cygwin/Pentium

OK for trunk and 4.1?

Paul

2006-01-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/22146
	* trans-array.c (gfc_reverse_ss): Remove static attribute.
	(gfc_walk_elemental_function_args): Replace gfc_expr * argument for
	the function call with the corresponding gfc_actual_arglist*.  Change
	code accordingly.
	(gfc_walk_function_expr): Call to gfc_walk_elemental_function_args
	now requires the actual argument list instead of the expression for
	the function call.
	* trans-array.h: Modify the prototype for gfc_walk_elemental_function_args
	and provide a prototype for gfc_reverse_ss.
	* trans-stmt.h (gfc_trans_call): Add the scalarization code for the case
	where an elemental subroutine has array valued actual arguments.

2006-01-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/22146
	* gfortran.dg/elemental_subroutine_1.f90: New test.

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 109168)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_walk_op_expr (gfc_ss * ss, gfc_expr 
*** 4529,4535 ****
  
  /* Reverse a SS chain.  */
  
! static gfc_ss *
  gfc_reverse_ss (gfc_ss * ss)
  {
    gfc_ss *next;
--- 4529,4535 ----
  
  /* Reverse a SS chain.  */
  
! gfc_ss *
  gfc_reverse_ss (gfc_ss * ss)
  {
    gfc_ss *next;
*************** gfc_reverse_ss (gfc_ss * ss)
*** 4555,4564 ****
  /* Walk the arguments of an elemental function.  */
  
  gfc_ss *
! gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr,
  				  gfc_ss_type type)
  {
-   gfc_actual_arglist *arg;
    int scalar;
    gfc_ss *head;
    gfc_ss *tail;
--- 4555,4563 ----
  /* Walk the arguments of an elemental function.  */
  
  gfc_ss *
! gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
  				  gfc_ss_type type)
  {
    int scalar;
    gfc_ss *head;
    gfc_ss *tail;
*************** gfc_walk_elemental_function_args (gfc_ss
*** 4567,4573 ****
    head = gfc_ss_terminator;
    tail = NULL;
    scalar = 1;
!   for (arg = expr->value.function.actual; arg; arg = arg->next)
      {
        if (!arg->expr)
  	continue;
--- 4566,4572 ----
    head = gfc_ss_terminator;
    tail = NULL;
    scalar = 1;
!   for (; arg; arg = arg->next)
      {
        if (!arg->expr)
  	continue;
*************** gfc_walk_function_expr (gfc_ss * ss, gfc
*** 4644,4650 ****
    /* Walk the parameters of an elemental function.  For now we always pass
       by reference.  */
    if (sym->attr.elemental)
!     return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE);
  
    /* Scalar functions are OK as these are evaluated outside the scalarization
       loop.  Pass back and let the caller deal with it.  */
--- 4643,4650 ----
    /* Walk the parameters of an elemental function.  For now we always pass
       by reference.  */
    if (sym->attr.elemental)
!     return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
! 					     GFC_SS_REFERENCE);
  
    /* Scalar functions are OK as these are evaluated outside the scalarization
       loop.  Pass back and let the caller deal with it.  */
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h	(revision 109168)
--- gcc/fortran/trans-array.h	(working copy)
*************** void gfc_trans_static_array_pointer (gfc
*** 49,58 ****
  /* Generate scalarization information for an expression.  */
  gfc_ss *gfc_walk_expr (gfc_expr *);
  /* Walk the arguments of an intrinsic function.  */
! gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_expr *, gfc_ss_type);
  /* Walk an intrinsic function.  */
  gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *,
  				     gfc_intrinsic_sym *);
  
  /* Free the SS associated with a loop.  */
  void gfc_cleanup_loop (gfc_loopinfo *);
--- 49,60 ----
  /* Generate scalarization information for an expression.  */
  gfc_ss *gfc_walk_expr (gfc_expr *);
  /* Walk the arguments of an intrinsic function.  */
! gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *, gfc_ss_type);
  /* Walk an intrinsic function.  */
  gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *,
  				     gfc_intrinsic_sym *);
+ /* Reverse the order of an SS chain.  */
+ gfc_ss *gfc_reverse_ss (gfc_ss *);
  
  /* Free the SS associated with a loop.  */
  void gfc_cleanup_loop (gfc_loopinfo *);
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 109168)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** tree
*** 209,214 ****
--- 209,215 ----
  gfc_trans_call (gfc_code * code)
  {
    gfc_se se;
+   gfc_ss * ss;
    int has_alternate_specifier;
  
    /* A CALL starts a new block because the actual arguments may have to
*************** gfc_trans_call (gfc_code * code)
*** 218,245 ****
  
    gcc_assert (code->resolved_sym);
  
!   /* Translate the call.  */
!   has_alternate_specifier
!     = gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);
! 
!   /* A subroutine without side-effect, by definition, does nothing!  */
!   TREE_SIDE_EFFECTS (se.expr) = 1;
! 
!   /* Chain the pieces together and return the block.  */
!   if (has_alternate_specifier)
!     {
!       gfc_code *select_code;
!       gfc_symbol *sym;
!       select_code = code->next;
!       gcc_assert(select_code->op == EXEC_SELECT);
!       sym = select_code->expr->symtree->n.sym;
!       se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
!       gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr);
      }
    else
!     gfc_add_expr_to_block (&se.pre, se.expr);
  
-   gfc_add_block_to_block (&se.pre, &se.post);
    return gfc_finish_block (&se.pre);
  }
  
--- 219,302 ----
  
    gcc_assert (code->resolved_sym);
  
!   ss = gfc_ss_terminator;
!   if (code->resolved_sym->attr.elemental)
!     ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
! 
!   /* Is not an elemental subroutine call with array valued arguments.  */
!   if (ss == gfc_ss_terminator)
!     {
! 
!       /* Translate the call.  */
!       has_alternate_specifier
! 	= gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);
! 
!       /* A subroutine without side-effect, by definition, does nothing!  */
!       TREE_SIDE_EFFECTS (se.expr) = 1;
! 
!       /* Chain the pieces together and return the block.  */
!       if (has_alternate_specifier)
! 	{
! 	  gfc_code *select_code;
! 	  gfc_symbol *sym;
! 	  select_code = code->next;
! 	  gcc_assert(select_code->op == EXEC_SELECT);
! 	  sym = select_code->expr->symtree->n.sym;
! 	  se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
! 	  gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr);
! 	}
!       else
! 	gfc_add_expr_to_block (&se.pre, se.expr);
! 
!       gfc_add_block_to_block (&se.pre, &se.post);
      }
+ 
+   /* An elemental subroutine call with array valued arguments has
+      to be scalarized.  */
    else
!     {
!       gfc_loopinfo loop;
!       stmtblock_t body;
!       stmtblock_t block;
!       gfc_se loopse;
! 
!       /* gfc_walk_elemental_function_args renders the ss chain in the
!          reverse order to the actual argument order.  */
!       ss = gfc_reverse_ss (ss);
! 
!       /* Initialize the loop.  */
!       gfc_init_se (&loopse, NULL);
!       gfc_init_loopinfo (&loop);
!       gfc_add_ss_to_loop (&loop, ss);
! 
!       gfc_conv_ss_startstride (&loop);
!       gfc_conv_loop_setup (&loop);
!       gfc_mark_ss_chain_used (ss, 1);
! 
!       /* Generate the loop body.  */
!       gfc_start_scalarized_body (&loop, &body);
!       gfc_init_block (&block);
!       gfc_copy_loopinfo_to_se (&loopse, &loop);
!       loopse.ss = ss;
! 
!       /* Add the subroutine call to the block.  Alternate return arguments
! 	 have already been eliminated (12.7.1).  */
!       gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual);
! 
!       TREE_SIDE_EFFECTS (loopse.expr) = 1;
!       gfc_add_expr_to_block (&loopse.pre, loopse.expr);
! 
!       gfc_add_block_to_block (&block, &loopse.pre);
!       gfc_add_block_to_block (&block, &loopse.post);
! 
!       /* Finish up the loop block and the loop.  */
!       gfc_add_expr_to_block (&body, gfc_finish_block (&block));
!       gfc_trans_scalarizing_loops (&loop, &body);
!       gfc_add_block_to_block (&se.pre, &loop.pre);
!       gfc_add_block_to_block (&se.pre, &loop.post);
!       gfc_cleanup_loop (&loop);
!     }
  
    return gfc_finish_block (&se.pre);
  }
  

! { dg-do run }
! Test the fix for pr22146, where and elemental subroutine with
! array actual arguments would cause an ICE in gfc_conv_function_call.
! The module is the original test case and the rest is a basic
! functional test of the scalarization of the function call.
!
! Contributed by Erik Edelmann  <erik.edelmann@iki.fi>
!             and Paul Thomas   <pault@gcc.gnu.org>

  module pr22146

contains

    elemental subroutine foo(a)
      integer, intent(out) :: a
      a = 0
    end subroutine foo

    subroutine bar()
      integer :: a(10)
      call foo(a)
    end subroutine bar

end module pr22146

  use pr22146
  real, dimension (2)  :: x, y
  real :: u, v
  x = (/1.0, 2.0/)
  u = 42.0

  call bar ()

! Check the various combinations of scalar and array.
  call foobar (x, y)
  if (any(y.ne.-x)) call abort ()

  call foobar (u, y)
  if (any(y.ne.-42.0)) call abort ()

  call foobar (u, v)
  if (v.ne.-42.0) call abort ()

  call foobar (x, v)
  if (v.ne.-2.0) call abort ()

! Test an expression in the INTENT(IN) argument
  call foobar (cos (x) + u, y)
  if (any(abs (y + cos (x) + u) .gt. 2.0e-6)) call abort ()

contains

  elemental subroutine foobar (a, b)
    real, intent(IN) :: a
    real, intent(out) :: b
    b = -a
  end subroutine foobar
end