[Patch, Fortran] PR35203 - Fix VALUE + OPTIONAL handling for pass-by-value arguments

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

Dear all,

using VALUE, gfortran passes the arguments by value.* That works well, 
except if VALUE is combined with OPTIONAL. Currently, "call foo(0)" and 
"call foo()" are indistinguishable.

With this patch, a hidden argument is added which includes the present 
information. I think that's the least intrusive version which also has 
the performance advantage of continuing to use pass-by-value semantics.

Build and regtested on x86-64-gnu-linux.
OK for the trunk?

Tobias

PS: At some point, we need to handle VALUE with arrays, derived types 
and class. For those, one should pass by reference, doing a copy in. In 
that case, using the NULL-pointer check for present() should work. (PR 
49802)

* Except for character. (Note: value+optional for characters currently 
fails with an ICE, also tracked at PR 49802.)
2013-03-21  Tobias Burnus  <burnus@net-b.de>

	PR fortran/35203
	* trans-decl.c (create_function_arglist): Pass hidden argument
	for passed-by-value optional+value dummies.
	* trans-expr.c (gfc_conv_expr_present,
	gfc_conv_procedure_call): Handle those.

2013-03-21  Tobias Burnus  <burnus@net-b.de>

	PR fortran/35203
	* gfortran.dg/optional_absent_3.f90: New.

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 0e853ba..fafde89 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -2142,6 +2142,27 @@ create_function_arglist (gfc_symbol * sym)
 		type = gfc_sym_type (f->sym);
 	    }
 	}
+      /* For noncharacter scalar intrinsic types, VALUE passes the value,
+	 hence, the optional status cannot be transfered via a NULL pointer.
+	 Thus, we will use a hidden argument in that case.  */
+      else if (f->sym->attr.optional && f->sym->attr.value
+	       && !f->sym->attr.dimension && !f->sym->ts.type != BT_CLASS
+	       && f->sym->ts.type != BT_DERIVED)
+	{
+          tree tmp;
+          strcpy (&name[1], f->sym->name);
+          name[0] = '_';
+          tmp = build_decl (input_location,
+			    PARM_DECL, get_identifier (name),
+			    boolean_type_node);
+
+          hidden_arglist = chainon (hidden_arglist, tmp);
+          DECL_CONTEXT (tmp) = fndecl;
+          DECL_ARTIFICIAL (tmp) = 1;
+          DECL_ARG_TYPE (tmp) = boolean_type_node;
+          TREE_READONLY (tmp) = 1;
+          gfc_finish_decl (tmp);
+	}
 
       /* For non-constant length array arguments, make sure they use
 	 a different type node from TYPE_ARG_TYPES type.  */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 2c3ff1f..34e1ef0 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1126,8 +1126,32 @@ gfc_conv_expr_present (gfc_symbol * sym)
   tree decl, cond;
 
   gcc_assert (sym->attr.dummy);
-
   decl = gfc_get_symbol_decl (sym);
+
+  /* Intrinsic scalars with VALUE attribute which are passed by value
+     use a hidden argument to denote the present status.  */
+  if (sym->attr.value && sym->ts.type != BT_CHARACTER
+      && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
+      && !sym->attr.dimension)
+    {
+      char name[GFC_MAX_SYMBOL_LEN + 2];
+      tree tree_name;
+
+      gcc_assert (TREE_CODE (decl) == PARM_DECL);
+      name[0] = '_';
+      strcpy (&name[1], sym->name);
+      tree_name = get_identifier (name);
+
+      /* Walk function argument list to find hidden arg.  */
+      cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
+      for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
+	if (DECL_NAME (cond) == tree_name)
+	  break;
+
+      gcc_assert (cond);
+      return cond;
+    }
+
   if (TREE_CODE (decl) != PARM_DECL)
     {
       /* Array parameters use a temporary descriptor, we want the real
@@ -4052,11 +4076,27 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	    }
 	  else
 	    {
-	      /* Pass a NULL pointer for an absent arg.  */
 	      gfc_init_se (&parmse, NULL);
-	      parmse.expr = null_pointer_node;
-	      if (arg->missing_arg_type == BT_CHARACTER)
-		parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
+
+	      /* For scalar arguments with VALUE attribute which are passed by
+		 value, pass "0" and a hidden argument gives the optional
+		 status.  */
+	      if (fsym && fsym->attr.optional && fsym->attr.value
+		  && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
+		  && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
+		{
+		  parmse.expr = fold_convert (gfc_sym_type (fsym),
+					      integer_zero_node);
+		  vec_safe_push (stringargs, boolean_false_node);
+		}
+	      else
+		{
+		  /* Pass a NULL pointer for an absent arg.  */
+		  parmse.expr = null_pointer_node;
+		  if (arg->missing_arg_type == BT_CHARACTER)
+		    parmse.string_length = build_int_cst (gfc_charlen_type_node,
+							  0);
+		}
 	    }
 	}
       else if (arg->expr->expr_type == EXPR_NULL
@@ -4227,7 +4267,31 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			gfc_conv_expr (&parmse, e);
 		    }
 		  else
+		    {
 		    gfc_conv_expr (&parmse, e);
+		    if (fsym->attr.optional
+			&& fsym->ts.type != BT_CLASS
+			&& fsym->ts.type != BT_DERIVED)
+		      {
+			if (e->expr_type != EXPR_VARIABLE
+			    || !e->symtree->n.sym->attr.optional
+			    || e->ref != NULL)
+			  vec_safe_push (stringargs, boolean_true_node);
+			else
+			  {
+			    tmp = gfc_conv_expr_present (e->symtree->n.sym);
+			    if (!e->symtree->n.sym->attr.value)
+			      parmse.expr
+				= fold_build3_loc (input_location, COND_EXPR,
+					TREE_TYPE (parmse.expr),
+					tmp, parmse.expr,
+					fold_convert (TREE_TYPE (parmse.expr),
+						      integer_zero_node));
+
+			    vec_safe_push (stringargs, tmp);
+			  }
+		      }
+		    }
 		}
 	      else if (arg->name && arg->name[0] == '%')
 		/* Argument list functions %VAL, %LOC and %REF are signalled
diff --git a/gcc/testsuite/gfortran.dg/optional_absent_3.f90 b/gcc/testsuite/gfortran.dg/optional_absent_3.f90
new file mode 100644
index 0000000..f03b479
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_absent_3.f90
@@ -0,0 +1,83 @@
+! { dg-do run }
+!
+! PR fortran/35203
+!
+! Test VALUE + OPTIONAL
+! for integer/real/complex/logical which are passed by value
+!
+program main
+  implicit none
+  call value_test ()
+contains
+  subroutine value_test (ii, rr, cc, ll, ii2, rr2, cc2, ll2)
+    integer, optional :: ii, ii2
+    real,    optional :: rr, rr2
+    complex, optional :: cc, cc2
+    logical, optional :: ll, ll2
+    value :: ii, rr, cc, ll
+
+    call int_test (.false., 0)
+    call int_test (.false., 0, ii)
+    call int_test (.false., 0, ii2)
+    call int_test (.true., 0, 0)
+    call int_test (.true., 2, 2)
+
+    call real_test (.false., 0.0)
+    call real_test (.false., 0.0, rr)
+    call real_test (.false., 0.0, rr2)
+    call real_test (.true., 0.0, 0.0)
+    call real_test (.true., 2.0, 2.0)
+
+    call cmplx_test (.false., cmplx (0.0))
+    call cmplx_test (.false., cmplx (0.0), cc)
+    call cmplx_test (.false., cmplx (0.0), cc2)
+    call cmplx_test (.true., cmplx (0.0), cmplx (0.0))
+    call cmplx_test (.true., cmplx (2.0), cmplx (2.0))
+
+    call bool_test (.false., .false.)
+    call bool_test (.false., .false., ll)
+    call bool_test (.false., .false., ll2)
+    call bool_test (.true., .false., .false.)
+    call bool_test (.true., .true., .true.)
+  end subroutine value_test
+
+  subroutine int_test (ll, val, x)
+    logical, value :: ll
+    integer, value :: val
+    integer, value, optional :: x
+    if (ll .neqv. present(x)) call abort
+    if (present(x)) then
+      if (x /= val) call abort ()
+    endif
+  end subroutine int_test
+
+  subroutine real_test (ll, val, x)
+    logical, value :: ll
+    real, value :: val
+    real, value, optional :: x
+    if (ll .neqv. present(x)) call abort
+    if (present(x)) then
+      if (x /= val) call abort ()
+    endif
+  end subroutine real_test
+
+  subroutine cmplx_test (ll, val, x)
+    logical, value :: ll
+    complex, value :: val
+    complex, value, optional :: x
+    if (ll .neqv. present(x)) call abort
+    if (present(x)) then
+      if (x /= val) call abort ()
+    endif
+  end subroutine cmplx_test
+
+  subroutine bool_test (ll, val, x)
+    logical, value :: ll
+    logical, value :: val
+    logical, value, optional :: x
+    if (ll .neqv. present(x)) call abort
+    if (present(x)) then
+      if (x .neqv. val) call abort ()
+    endif
+  end subroutine bool_test
+end program main