re PR fortran/29507 ([4.2 only] INDEX in an array initialization causes ICE)

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.

From-SVN: r123815

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index aaad10f7f07858612e9d149dfff23d96d3866cd4..cd70c921c14f1e94b93b4ebf0525aeff45bc6365 100644 (file)
--- 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 f2064fb42fa15bcd6b12f213adc31c7989a0fc95..a408229242dbfeda0fb2f0c6d486337eb29eec8e 100644 (file)
--- 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 5ab36769d0928b23a559e266ba28a2c192e0ce16..eba3c95991f1817d5bb983db57bb1c07efecef9f 100644 (file)
--- 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 (file)
index 0000000..71ef171
--- /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