procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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
This commit is contained in:
Tobias Burnus 2013-03-29 23:26:17 +01:00 • committed by Tobias Burnus
parent 50e10fa881
commit 60f97ac859
5 changed files with 193 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View file

@ -1,3 +1,11 @@
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

21
gcc/fortran/trans-decl.c
View file

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

83
gcc/fortran/trans-expr.c
View file

@ -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);

5
gcc/testsuite/ChangeLog
View file

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

83
gcc/testsuite/gfortran.dg/optional_absent_3.f90 Normal file
View file

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