re PR fortran/50981 ([OOP] Wrong-code for scalarizing ELEMENTAL call with absent OPTIONAL argument)

fortran/
	PR fortran/50981
	* trans-expr.c (gfc_conv_procedure_call): Save se->ss's value. 
	Handle the case of unallocated arrays passed to elemental procedures.

testsuite/
	PR fortran/50981
	* gfortran.dg/elemental_optional_args_5.f03: Add array checks.

From-SVN: r184896

gcc/fortran/ChangeLog

 2012-03-04  Mikael Morin  <mikael@gcc.gnu.org>
 
+	PR fortran/50981
+	* trans-expr.c (gfc_conv_procedure_call): Save se->ss's value. 
+	Handle the case of unallocated arrays passed to elemental procedures.
+
+2012-03-04  Mikael Morin  <mikael@gcc.gnu.org>
+
 	* trans.h (struct gfc_ss_info): Move can_be_null_ref component from
 	the data::scalar subcomponent to the toplevel.
 	* trans-expr.c (gfc_conv_expr): Update component reference.

gcc/fortran/trans-expr.c

@@ -3522,12 +3522,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	}
       else if (se->ss && se->ss->info->useflags)
 	{
+	  gfc_ss *ss;
+
+	  ss = se->ss;
+
 	  /* An elemental function inside a scalarized loop.  */
 	  gfc_init_se (&parmse, se);
 	  parm_kind = ELEMENTAL;
 
-	  if (se->ss->dimen > 0 && e->expr_type == EXPR_VARIABLE
-	      && se->ss->info->data.array.ref == NULL)
+	  if (ss->dimen > 0 && e->expr_type == EXPR_VARIABLE
+	      && ss->info->data.array.ref == NULL)
 	    {
 	      gfc_conv_tmp_array_ref (&parmse);
 	      if (e->ts.type == BT_CHARACTER)
@@ -3538,6 +3542,29 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  else
 	    gfc_conv_expr_reference (&parmse, e);
 
+	  /* If we are passing an absent array as optional dummy to an
+	     elemental procedure, make sure that we pass NULL when the data
+	     pointer is NULL.  We need this extra conditional because of
+	     scalarization which passes arrays elements to the procedure,
+	     ignoring the fact that the array can be absent/unallocated/...  */
+	  if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
+	    {
+	      tree descriptor_data;
+
+	      descriptor_data = ss->info->data.array.data;
+	      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				     descriptor_data,
+				     fold_convert (TREE_TYPE (descriptor_data),
+						   null_pointer_node));
+	      parmse.expr
+		= fold_build3_loc (input_location, COND_EXPR,
+				   TREE_TYPE (parmse.expr),
+				   gfc_unlikely (tmp),
+				   fold_convert (TREE_TYPE (parmse.expr), 
+						 null_pointer_node),
+				   parmse.expr);
+	    }
+
 	  /* The scalarizer does not repackage the reference to a class
 	     array - instead it returns a pointer to the data element.  */
 	  if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)

gcc/testsuite/ChangeLog

+2012-03-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/50981
+	* gfortran.dg/elemental_optional_args_5.f03: Add array checks.
+
 2012-03-04  Georg-Johann Lay  <avr@gjlay.de>
 
 	* gcc.dg/torture/pr52402.c: Add dg-require-effective-target

gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03

@@ -69,6 +69,51 @@ if (s /= 5*2) call abort()
 if (any (v /= [5*2, 5*2])) call abort()
 
 
+! ARRAY COMPONENTS: Non alloc/assoc
+
+v = [9, 33]
+
+call sub1 (v, x%a2, .false.)
+!print *, v
+if (any (v /= [9, 33])) call abort()
+
+call sub1 (v, x%p2, .false.)
+!print *, v
+if (any (v /= [9, 33])) call abort()
+
+
+! ARRAY COMPONENTS: alloc/assoc
+
+allocate (x%a2(2), x%p2(2))
+x%a2(:) = [84, 82]
+x%p2    = [35, 58]
+
+call sub1 (v, x%a2, .true.)
+!print *, v
+if (any (v /= [84*2, 82*2])) call abort()
+
+call sub1 (v, x%p2, .true.)
+!print *, v
+if (any (v /= [35*2, 58*2])) call abort()
+
+
+! =============== sub_t ==================
+! SCALAR DT: Non alloc/assoc
+
+s = 3
+v = [9, 33]
+
+call sub_t (s, ta, .false.)
+call sub_t (v, ta, .false.)
+!print *, s, v
+if (s /= 3) call abort()
+if (any (v /= [9, 33])) call abort()
+
+call sub_t (s, tp, .false.)
+call sub_t (v, tp, .false.)
+!print *, s, v
+if (s /= 3) call abort()
+if (any (v /= [9, 33])) call abort()
 
 contains
 
@@ -82,5 +127,15 @@ contains
       x = y*2
   end subroutine sub1
 
+  elemental subroutine sub_t(x, y, alloc)
+    integer, intent(inout) :: x
+    type(t), intent(in), optional :: y
+    logical, intent(in) :: alloc
+    if (alloc .neqv. present (y)) &
+      x = -99
+    if (present(y)) &
+      x = y%a*2
+  end subroutine sub_t
+
 end