re PR fortran/35203 (OPTIONAL, VALUE actual argument cannot be an INTEGER 0)

2013-03-29  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-29  Tobias Burnus  <burnus@net-b.de>

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

From-SVN: r197252

gcc/fortran/ChangeLog

+2013-03-29  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-28  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/45159

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.  */

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
@@ -3729,6 +3753,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   tree len;
   tree base_object;
   vec<tree, va_gc> *stringargs;
+  vec<tree, va_gc> *optionalargs;
   tree result = NULL;
   gfc_formal_arglist *formal;
   gfc_actual_arglist *arg;
@@ -3747,6 +3772,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   arglist = NULL;
   retargs = NULL;
   stringargs = NULL;
+  optionalargs = NULL;
   var = NULL_TREE;
   len = NULL_TREE;
   gfc_clear_ts (&ts);
@@ -3835,11 +3861,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 (optionalargs, 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
@@ -4010,7 +4052,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 (optionalargs, 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 (optionalargs, tmp);
+			  }
+		      }
+		    }
 		}
 	      else if (arg->name && arg->name[0] == '%')
 		/* Argument list functions %VAL, %LOC and %REF are signalled
@@ -4844,13 +4910,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   gfc_free_interface_mapping (&mapping);
 
   /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS.  */
-  arglen = (vec_safe_length (arglist) + vec_safe_length (stringargs)
-	    + vec_safe_length (append_args));
+  arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
+	    + vec_safe_length (stringargs) + vec_safe_length (append_args));
   vec_safe_reserve (retargs, arglen);
 
   /* Add the return arguments.  */
   retargs->splice (arglist);
 
+  /* Add the hidden present status for optional+value to the arguments.  */
+  retargs->splice (optionalargs);
+
   /* Add the hidden string length parameters to the arguments.  */
   retargs->splice (stringargs);
 

gcc/testsuite/ChangeLog

@@ -5,6 +5,11 @@
 
 2013-03-29  Tobias Burnus  <burnus@net-b.de>
 
+	PR fortran/35203
+	* gfortran.dg/optional_absent_3.f90: New.
+
+2013-03-29  Tobias Burnus  <burnus@net-b.de>
+
 	PR fortran/56737
 	* testsuite/gfortran.dg/fmt_cache_3.f90: New.
 

gcc/testsuite/gfortran.dg/optional_absent_3.f90

+! { 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