From 60f97ac8596d65a73164e2967e73404b99534f92 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Fri, 29 Mar 2013 23:26:17 +0100 Subject: [PATCH] re PR fortran/35203 (OPTIONAL, VALUE actual argument cannot be an INTEGER 0) 2013-03-29 Tobias Burnus 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 PR fortran/35203 * gfortran.dg/optional_absent_3.f90: New. From-SVN: r197252 --- gcc/fortran/ChangeLog | 8 ++ gcc/fortran/trans-decl.c | 21 +++++ gcc/fortran/trans-expr.c | 83 +++++++++++++++++-- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/optional_absent_3.f90 | 83 +++++++++++++++++++ 5 files changed, 193 insertions(+), 7 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/optional_absent_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f1f176573c4..ab23bcaecda 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2013-03-29 Tobias Burnus + + 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 PR fortran/45159 diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 0e853bac6a1..fafde89f37b 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 d0a9446fcce..98a54d9f688 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 @@ -3729,6 +3753,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tree len; tree base_object; vec *stringargs; + vec *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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6a02bbd891a..776a0318001 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -3,6 +3,11 @@ * gcc.target/i386/avx2-vbroadcastsi128-1.c: Fix intrinsic name. * gcc.target/i386/avx2-vbroadcastsi128-1.c: Ditto. +2013-03-29 Tobias Burnus + + PR fortran/35203 + * gfortran.dg/optional_absent_3.f90: New. + 2013-03-29 Tobias Burnus PR fortran/56737 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 00000000000..f03b4798b3d --- /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