re PR fortran/53692 (OPTIONAL: Scalarizing over the wrong array)

2012-06-18  Tobias Burnus  <burnus@net-b.de>

        PR fortran/53692
        * trans-array.c (set_loop_bounds): Don't scalarize via absent
        optional arrays.
        * resolve.c (resolve_elemental_actual): Don't stop resolving
        after printing a warning.

2012-06-18  Tobias Burnus  <burnus@net-b.de>

        PR fortran/53692
        * gfortran.dg/elemental_optional_args_6.f90: New.

From-SVN: r188749

5 files changed, 84 insertions, 2 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8be7142..a89e197 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,13 @@
 2012-06-18  Tobias Burnus  <burnus@net-b.de>
 
+	PR fortran/53692
+	* trans-array.c (set_loop_bounds): Don't scalarize via absent
+	optional arrays.
+	* resolve.c (resolve_elemental_actual): Don't stop resolving after printing
+	a warning.
+
+2012-06-18  Tobias Burnus  <burnus@net-b.de>
+
 	PR fortran/53526
 	* trans-intrinsic.c (conv_intrinsic_move_alloc): Handle coarrays.
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 8531318..d09cb11 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1957,7 +1957,6 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
 		       "ELEMENTAL procedure unless there is a non-optional "
 		       "argument with the same rank (12.4.1.5)",
 		       arg->expr->symtree->n.sym->name, &arg->expr->where);
-	  return FAILURE;
 	}
     }
 
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0e78210..f135af1 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4337,6 +4337,7 @@ set_loop_bounds (gfc_loopinfo *loop)
   bool dynamic[GFC_MAX_DIMENSIONS];
   mpz_t *cshape;
   mpz_t i;
+  bool nonoptional_arr;
 
   loopspec = loop->specloop;
 
@@ -4345,6 +4346,18 @@ set_loop_bounds (gfc_loopinfo *loop)
     {
       loopspec[n] = NULL;
       dynamic[n] = false;
+
+      /* If there are both optional and nonoptional array arguments, scalarize
+	 over the nonoptional; otherwise, it does not matter as then all
+	 (optional) arrays have to be present per F2008, 125.2.12p3(6).  */
+
+      nonoptional_arr = false;
+
+      for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+	if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
+	    && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
+	  nonoptional_arr = true;
+
       /* We use one SS term, and use that to determine the bounds of the
 	 loop for this dimension.  We try to pick the simplest term.  */
       for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
@@ -4354,7 +4367,8 @@ set_loop_bounds (gfc_loopinfo *loop)
 	  ss_type = ss->info->type;
 	  if (ss_type == GFC_SS_SCALAR
 	      || ss_type == GFC_SS_TEMP
-	      || ss_type == GFC_SS_REFERENCE)
+	      || ss_type == GFC_SS_REFERENCE
+	      || (ss->info->can_be_null_ref && nonoptional_arr))
 	    continue;
 
 	  info = &ss->info->data.array;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e8c27ec..6dc143e 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,10 @@
 2012-06-18  Tobias Burnus  <burnus@net-b.de>
 
+	PR fortran/53692
+	* gfortran.dg/elemental_optional_args_6.f90: New.
+
+2012-06-18  Tobias Burnus  <burnus@net-b.de>
+
 	PR fortran/53526
 	* gfortran.dg/coarray_lib_move_alloc_1.f90: New.
 	* gfortran.dg/coarray/move_alloc_1.f90
diff --git a/gcc/testsuite/gfortran.dg/elemental_optional_args_6.f90 b/gcc/testsuite/gfortran.dg/elemental_optional_args_6.f90
new file mode 100644
index 0000000..ad1c252
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/elemental_optional_args_6.f90
@@ -0,0 +1,56 @@
+! { dg-do run }
+!
+! PR fortran/53692
+!
+! Check that the nonabsent arrary is used for scalarization:
+! Either the NONOPTIONAL one or, if there are none, any array.
+!
+! Based on a program by Daniel C Chen
+!
+Program main
+  implicit none
+  integer :: arr1(2), arr2(2)
+  arr1 = [ 1, 2 ]
+  arr2 = [ 1, 2 ]
+  call sub1 (arg2=arr2)
+
+  call two ()
+contains
+   subroutine sub1 (arg1, arg2)
+      integer, optional :: arg1(:)
+      integer :: arg2(:)
+!      print *, fun1 (arg1, arg2)
+      if (size (fun1 (arg1, arg2)) /= 2) call abort() ! { dg-warning "is an array and OPTIONAL" }
+      if (any (fun1 (arg1, arg2) /= [1,2])) call abort() ! { dg-warning "is an array and OPTIONAL" }
+   end subroutine
+
+   elemental function fun1 (arg1, arg2)
+      integer,intent(in), optional :: arg1
+      integer,intent(in)           :: arg2
+      integer                      :: fun1
+      fun1 = arg2
+   end function
+end program
+
+subroutine two ()
+  implicit none
+  integer :: arr1(2), arr2(2)
+  arr1 = [ 1, 2 ]
+  arr2 = [ 1, 2 ]
+  call sub2 (arr1, arg2=arr2)
+contains
+   subroutine sub2 (arg1, arg2)
+      integer, optional :: arg1(:)
+      integer, optional :: arg2(:)
+!      print *, fun2 (arg1, arg2)
+      if (size (fun2 (arg1, arg2)) /= 2) call abort() ! { dg-warning "is an array and OPTIONAL" }
+      if (any (fun2 (arg1, arg2) /= [1,2])) call abort() ! { dg-warning "is an array and OPTIONAL" }
+   end subroutine
+
+   elemental function fun2 (arg1,arg2)
+      integer,intent(in), optional :: arg1
+      integer,intent(in), optional :: arg2
+      integer                      :: fun2
+      fun2 = arg2
+   end function
+end subroutine two