re PR fortran/22146 (ICE when calling ELEMENTAL subroutines)

2006-01-07  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.

	PR fortran/25029
	PR fortran/21256
	PR fortran/20868
	PR fortran/20870
	* resolve.c (check_assumed_size_reference): New function to check for upper
	bound in assumed size array references.
	(resolve_assumed_size_actual): New function to do a very restricted scan
	of actual argument expressions of those procedures for which incomplete
	assumed size array references are not allowed.
	(resolve_function, resolve_call): Switch off assumed size checking of
	actual arguments, except for elemental procedures and intrinsic
	inquiry functions, in some circumstances.
	(resolve_variable): Call check_assumed_size_reference.

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

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

	PR fortran/25029
	PR fortran/21256
	* gfortran.dg/assumed_size_refs_1.f90: New test.

	PR fortran/20868
	PR fortran/20870
	* gfortran.dg/assumed_size_refs_2.f90: New test.
	* gfortran.dg/initialization_1.f90: Change warning message.

From-SVN: r109449

1 files changed, 79 insertions, 17 deletions

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 1b56cf4..cf88918 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -209,6 +209,7 @@ tree
 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
@@ -218,28 +219,81 @@ gfc_trans_call (gfc_code * code)
 
   gcc_assert (code->resolved_sym);
 
-  /* Translate the call.  */
-  has_alternate_specifier
-    = gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);
+  ss = gfc_ss_terminator;
+  if (code->resolved_sym->attr.elemental)
+    ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
 
-  /* 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)
+  /* Is not an elemental subroutine call with array valued arguments.  */
+  if (ss == gfc_ss_terminator)
     {
-      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);
+
+      /* 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);
     }
+
   else
-    gfc_add_expr_to_block (&se.pre, se.expr);
+    {
+      /* An elemental subroutine call with array valued arguments has
+	 to be scalarized.  */
+      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.  */
+      gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual);
+      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);
+    }
 
-  gfc_add_block_to_block (&se.pre, &se.post);
   return gfc_finish_block (&se.pre);
 }
 
@@ -2501,6 +2555,14 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
           gfc_add_expr_to_block (&block, tmp);
           break;
 
+	/* Explicit subroutine calls are prevented by the frontend but interface
+	   assignments can legitimately produce them.  */
+	case EXEC_CALL:
+	  assign = gfc_trans_call (c);
+          tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
+          gfc_add_expr_to_block (&block, tmp);
+          break;
+
 	default:
 	  gcc_unreachable ();
 	}