2007-04-14 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/29507
	PR fortran/31404
	* expr.c (scalarize_intrinsic_call): New function to
	scalarize elemental intrinsic functions in initialization
	expressions.
	(check_init_expr): Detect elemental intrinsic functions
	in initalization expressions and call previous.


2007-04-14 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/29507
	PR fortran/31404
	* gfortran.dg/initialization_6.f90: New test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@123815 138bc75d-0d04-0410-961f-82ee72b054a4

4 files changed, 172 insertions, 1 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index aaad10f7f07..cd70c921c14 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,4 +1,14 @@
-2007-04-13  Tobias Burnus  <burnus@net-b.de>
+2007-04-14 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29507
+	PR fortran/31404
+	* expr.c (scalarize_intrinsic_call): New function to
+	scalarize elemental intrinsic functions in initialization
+	expressions.
+	(check_init_expr): Detect elemental intrinsic functions
+	in initalization expressions and call previous.
+
+	2007-04-13  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/31559
 	* primary.c (match_variable): External functions
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index f2064fb42fa..a408229242d 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1574,6 +1574,128 @@ et0 (gfc_expr *e)
 
 static try check_init_expr (gfc_expr *);
 
+
+/* Scalarize an expression for an elemental intrinsic call.  */
+
+static try
+scalarize_intrinsic_call (gfc_expr *e)
+{
+  gfc_actual_arglist *a, *b;
+  gfc_constructor *args[5], *ctor, *new_ctor;
+  gfc_expr *expr, *old;
+  int n, i, rank[5];
+
+  old = gfc_copy_expr (e);
+
+/* Assume that the old expression carries the type information and
+   that the first arg carries all the shape information.  */
+  expr = gfc_copy_expr (old->value.function.actual->expr);
+  gfc_free_constructor (expr->value.constructor);
+  expr->value.constructor = NULL;
+
+  expr->ts = old->ts;
+  expr->expr_type = EXPR_ARRAY;
+
+  /* Copy the array argument constructors into an array, with nulls
+     for the scalars.  */
+  n = 0;
+  a = old->value.function.actual;
+  for (; a; a = a->next)
+    {
+      /* Check that this is OK for an initialization expression.  */
+      if (a->expr && check_init_expr (a->expr) == FAILURE)
+	goto cleanup;
+
+      rank[n] = 0;
+      if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
+	{
+	  rank[n] = a->expr->rank;
+	  ctor = a->expr->symtree->n.sym->value->value.constructor;
+	  args[n] = gfc_copy_constructor (ctor);
+	}
+      else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
+	{
+	  if (a->expr->rank)
+	    rank[n] = a->expr->rank;
+	  else
+	    rank[n] = 1;
+	  args[n] = gfc_copy_constructor (a->expr->value.constructor);
+	}
+      else
+	args[n] = NULL;
+      n++;
+    }
+
+  for (i = 1; i < n; i++)
+    if (rank[i] && rank[i] != rank[0])
+      goto compliance;
+
+  /* Using the first argument as the master, step through the array
+     calling the function for each element and advancing the array
+     constructors together.  */
+  ctor = args[0];
+  new_ctor = NULL;
+  for (; ctor; ctor = ctor->next)
+    {
+	  if (expr->value.constructor == NULL)
+	    expr->value.constructor
+		= new_ctor = gfc_get_constructor ();
+	  else
+	    {
+	      new_ctor->next = gfc_get_constructor ();
+	      new_ctor = new_ctor->next;
+	    }
+	  new_ctor->expr = gfc_copy_expr (old);
+	  gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
+	  a = NULL;
+	  b = old->value.function.actual;
+	  for (i = 0; i < n; i++)
+	    {
+	      if (a == NULL)
+		new_ctor->expr->value.function.actual
+			= a = gfc_get_actual_arglist ();
+	      else
+		{
+		  a->next = gfc_get_actual_arglist ();
+		  a = a->next;
+		}
+	      if (args[i])
+		a->expr = gfc_copy_expr (args[i]->expr);
+	      else
+		a->expr = gfc_copy_expr (b->expr);
+
+	      b = b->next;
+	    }
+
+	  /* Simplify the function calls.  */
+	  if (gfc_simplify_expr (new_ctor->expr, 0) == FAILURE)
+	    goto cleanup;
+
+	  for (i = 0; i < n; i++)
+	    if (args[i])
+	      args[i] = args[i]->next;
+
+	  for (i = 1; i < n; i++)
+	    if (rank[i] && ((args[i] != NULL && args[0] == NULL)
+			 || (args[i] == NULL && args[0] != NULL)))
+	      goto compliance;
+    }
+
+  free_expr0 (e);
+  *e = *expr;
+  gfc_free_expr (old);
+  return SUCCESS;
+
+compliance:
+  gfc_error_now ("elemental function arguments at %C are not compliant");
+
+cleanup:
+  gfc_free_expr (expr);
+  gfc_free_expr (old);
+  return FAILURE;
+}
+
+
 static try
 check_intrinsic_op (gfc_expr *e, try (*check_function) (gfc_expr *))
 {
@@ -1775,6 +1897,7 @@ check_init_expr (gfc_expr *e)
   gfc_actual_arglist *ap;
   match m;
   try t;
+  gfc_intrinsic_sym *isym;
 
   if (e == NULL)
     return SUCCESS;
@@ -1802,6 +1925,16 @@ check_init_expr (gfc_expr *e)
 	      }
 	}
 
+      /* Try to scalarize an elemental intrinsic function that has an
+	 array argument.  */
+      isym = gfc_find_function (e->symtree->n.sym->name);
+      if (isym && isym->elemental
+	    && e->value.function.actual->expr->expr_type == EXPR_ARRAY)
+	{
+	  if (scalarize_intrinsic_call (e) == SUCCESS)
+	    break;
+	}
+
       if (t == SUCCESS)
 	{
 	  m = gfc_intrinsic_func_interface (e, 0);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 5ab36769d09..eba3c95991f 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2007-04-14 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29507
+	PR fortran/31404
+	* gfortran.dg/initialization_6.f90: New test.
+
 2007-04-14  Kazu Hirata  <kazu@codesourcery.com>
 
 	* gcc.c-torture/compile/pr27528.c: Require nonpic.
diff --git a/gcc/testsuite/gfortran.dg/initialization_6.f90 b/gcc/testsuite/gfortran.dg/initialization_6.f90
new file mode 100644
index 00000000000..71ef1717fd3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/initialization_6.f90
@@ -0,0 +1,22 @@
+! { dg-do run }
+! { dg-options -O2 }
+! Tests the fix for PRs29507 and 31404, where elemental functions in
+! initialization expressions could not be simplified with array arguments.
+!
+! Contributed by Steve Kargl <kargl@gcc.gnu.org >
+!             and Vivek Rao <vivekrao4@yahoo.com>
+!
+  real, parameter :: a(2,2) = reshape ((/1.0, 2.0, 3.0, 4.0/), (/2,2/))
+  real, parameter :: b(2,2) = sin (a)
+  character(8), parameter :: oa(1:3)=(/'nint()  ', 'log10() ', 'sqrt()  '/)
+  integer, parameter :: ob(1:3) = index(oa, '(')
+  character(6), parameter :: ch(3) = (/"animal", "person", "mantee"/)
+  character(1), parameter :: ch2(3) = (/"n", "r", "t"/)
+  integer, parameter :: i(3) = index (ch, ch2)
+  integer :: ic(1) = len_trim((/"a"/))
+
+  if (any (reshape (b, (/4/)) .ne. (/(sin(real(k)), k = 1,4)/))) call abort ()
+  if (any (ob .ne. (/5,6,5/))) call abort ()  ! Original PR29507
+  if (any (i .ne. (/2,3,4/))) call abort ()
+  if (ic(1) .ne. 1) call abort ()             ! Original PR31404
+end