[Fortran,patch] PR 41850 - Wrong-code with optional allocatable arrays

[Tobias Burnus <burnus at net-b dot de>]

The first part is obvious: if the actual argument to an optional
allocatable dummy is in turn an optional dummy and it is not present,
then one needs to guard the access with "if(present(...))".

The second part removes unnecessary code. Currently, one generates:

    D.555 = a != 0B ? a : 0B;
    sub2 (D.555);

which is identical to passing "a" directly. As additional variables make
the alias analysis, the -O0 code side and the reading of the dump
harder, I removed it. For scalar arguments to elemental functions one
still has unnecessarily
    integer(kind=4) * D.1388;
    D.1388 = ivec;
    [...]
            set_optional (&ivec_[S.6], &D.1390, D.1388);
while for array arguments to elementals the IF is needed:
            D.1415 = ivec != 0B ? &(*ivec.0)[(S.10 + 1) * D.1413 +
D.1408] : 0B;
            set_optional (&ivec_[S.10], &D.1414, D.1415);
In some cases, the argument needs always to resolve to a valid pointer
of value 1 or 0; also in this case one needs to add an IF. (I am not
sure whether it is always needed for CHARACTER but I play save.) The
third case where one needs it is if one passes a deferred array dummy as
actual argument to a non-deferred dummy as one here packs the array.

Build and regtested on x86-84-linux.
OK for the trunk? The first part of the patch I also would like to
backport to 4.4.

Tobias

2009-10-30  Tobias Burnus  <burnus@net-b.de>

	PR fortran/41850
	* trans-expr.c (gfc_conv_procedure_call): Deallocate intent-out
	variables only when present. Remove unneccessary present check.

2009-10-30  Tobias Burnus  <burnus@net-b.de>

	PR fortran/41850
	* gfortran.dg/intent_out_6.f90: New testcase.

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 153738)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -2935,17 +2935,22 @@ gfc_conv_procedure_call (gfc_se * se, gf
 	        gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
 					  sym->name, NULL);
 
-              /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
-                 allocated on entry, it must be deallocated.  */
-              if (fsym && fsym->attr.allocatable
-                  && fsym->attr.intent == INTENT_OUT)
-                {
-                  tmp = build_fold_indirect_ref_loc (input_location,
-						 parmse.expr);
-                  tmp = gfc_trans_dealloc_allocated (tmp);
-                  gfc_add_expr_to_block (&se->pre, tmp);
-                }
-
+	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
+		 allocated on entry, it must be deallocated.  */
+	      if (fsym && fsym->attr.allocatable
+		  && fsym->attr.intent == INTENT_OUT)
+		{
+		  tmp = build_fold_indirect_ref_loc (input_location,
+						     parmse.expr);
+		  tmp = gfc_trans_dealloc_allocated (tmp);
+		  if (fsym->attr.optional
+		      && e->expr_type == EXPR_VARIABLE
+		      && e->symtree->n.sym->attr.optional)
+		    tmp = fold_build3 (COND_EXPR, void_type_node,
+				     gfc_conv_expr_present (e->symtree->n.sym),
+				       tmp, build_empty_stmt (input_location));
+		  gfc_add_expr_to_block (&se->pre, tmp);
+		}
 	    } 
 	}
 
@@ -2957,9 +2962,20 @@ gfc_conv_procedure_call (gfc_se * se, gf
       if (e && (fsym == NULL || fsym->attr.optional))
 	{
 	  /* If an optional argument is itself an optional dummy argument,
-	     check its presence and substitute a null if absent.  */
+	     check its presence and substitute a null if absent.  This is
+	     only needed when passing an array to an elemental procedure
+	     as then array elements are accessed - or no NULL pointer is
+	     allowed and a "1" or "0" should be passed if not present.
+	     When passing a deferred array to a non-deferred array dummy,
+	     the array needs to be packed an a check needs thus to be
+	     inserted. */
 	  if (e->expr_type == EXPR_VARIABLE
-	      && e->symtree->n.sym->attr.optional)
+	      && e->symtree->n.sym->attr.optional
+	      && ((e->rank > 0 && sym->attr.elemental)
+		  || e->representation.length || e->ts.type == BT_CHARACTER
+		  || (e->rank > 0 && (fsym == NULL
+				      || (fsym->as->type != AS_ASSUMED_SHAPE
+					  && fsym->as->type != AS_DEFERRED)))))
 	    gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
 				    e->representation.length);
 	}
Index: gcc/testsuite/gfortran.dg/intent_out_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/intent_out_6.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/intent_out_6.f90	(revision 0)
@@ -0,0 +1,39 @@
+! { dg-do run }
+!
+! PR fortran/41850
+!
+module test_module
+  implicit none
+contains
+  subroutine sub2(a)
+    implicit none
+    real,allocatable,intent(out),optional :: a(:)
+    if(present(a)) then
+      if(allocated(a)) call abort()
+      allocate(a(1))
+      a(1) = 5
+    end if
+  end subroutine sub2
+  subroutine sub1(a)
+    implicit none
+    real,allocatable,intent(out),optional :: a(:)
+!    print *,'in sub1'
+    call sub2(a)
+    if(present(a)) then
+      if(a(1) /= 5) call abort()
+    end if
+  end subroutine sub1
+end module test_module
+
+program test
+  use test_module
+  implicit none
+  real, allocatable :: x(:)
+  allocate(x(1))
+  call sub1()
+  x = 8
+  call sub1(x)
+  if(x(1) /= 5) call abort()
+end program
+
+! { dg-final { cleanup-modules "test_module" } }