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 <bur...@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 <bur...@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
