2013-06-13 Tobias Burnus <burnus@net-b.de>
PR fortran/57596
* trans-decl.c (gfc_trans_deferred_vars): Honor OPTIONAL
for nullify and deferred-strings' length variable.
2013-06-13 Tobias Burnus <burnus@net-b.de>
PR fortran/57596
* gfortran.dg/deferred_type_param_9.f90: New.
@@ -3855,12 +3857,21 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
{
/* Nullify when entering the scope. */
- gfc_add_modify (&init, se.expr,
- fold_convert (TREE_TYPE (se.expr),
- null_pointer_node));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (se.expr), se.expr,
+ fold_convert (TREE_TYPE (se.expr),
+ null_pointer_node));
+ if (sym->attr.optional)
+ {
+ tree present = gfc_conv_expr_present (sym);
+ tmp = build3_loc (input_location, COND_EXPR,
+ void_type_node, present, tmp,
+ build_empty_stmt (input_location));
+ }
+ gfc_add_expr_to_block (&init, tmp);
}
- if ((sym->attr.dummy ||sym->attr.result)
+ if ((sym->attr.dummy || sym->attr.result)
&& sym->ts.type == BT_CHARACTER
&& sym->ts.deferred)
{
@@ -3874,15 +3885,38 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
build_int_cst (gfc_charlen_type_node, 0));
else
- gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
+ {
+ tree tmp2;
+
+ tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
+ gfc_charlen_type_node,
+ sym->ts.u.cl->backend_decl, tmp);
+ if (sym->attr.optional)
+ {
+ tree present = gfc_conv_expr_present (sym);
+ tmp2 = build3_loc (input_location, COND_EXPR,
+ void_type_node, present, tmp2,
+ build_empty_stmt (input_location));
+ }
+ gfc_add_expr_to_block (&init, tmp2);
+ }
gfc_restore_backend_locus (&loc);
/* Pass the final character length back. */
if (sym->attr.intent != INTENT_IN)
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- gfc_charlen_type_node, tmp,
- sym->ts.u.cl->backend_decl);
+ {
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ gfc_charlen_type_node, tmp,
+ sym->ts.u.cl->backend_decl);
+ if (sym->attr.optional)
+ {
+ tree present = gfc_conv_expr_present (sym);
+ tmp = build3_loc (input_location, COND_EXPR,
+ void_type_node, present, tmp,
+ build_empty_stmt (input_location));
+ }
+ }
else
tmp = NULL_TREE;
}
@@ -0,0 +1,22 @@
+! { dg-do run }
+!
+! PR fortran/57596
+!
+! Contributed by Valery Weber
+!
+PROGRAM main
+ IMPLICIT NONE
+ call get ()
+ call get2 ()
+contains
+ SUBROUTINE get (c_val)
+ CHARACTER( : ), INTENT( INOUT ), ALLOCATABLE, OPTIONAL :: c_val
+ CHARACTER( 10 ) :: c_val_tmp
+ if(present(c_val)) call abort()
+ END SUBROUTINE get
+ SUBROUTINE get2 (c_val)
+ CHARACTER( : ), INTENT( OUT ), ALLOCATABLE, OPTIONAL :: c_val
+ CHARACTER( 10 ) :: c_val_tmp
+ if(present(c_val)) call abort()
+ END SUBROUTINE get2
+END PROGRAM main
A rather simple patch. I wonder why we didn't get in trouble before - the "*dummy = NULL;" part should affect also other optional allocatable dummy arguments. Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias PS: Pending patches: * Unreviewed: Print exception status at STOP, http://gcc.gnu.org/ml/fortran/2013-06/msg00077.html * Uncommitted: Mikael's CLASS+function patch, http://gcc.gnu.org/ml/fortran/2013-06/msg00079.html PPS: The old dump (GCC 4.8, 4.9 w/o patch should be the same) produced: get (character(kind=1)[1:(integer(kind=4)) _c_val] * * c_val, integer(kind=4) * _c_val) { *c_val = 0B; ... finally { *_c_val = .c_val; } } and with intent(inout): .c_val = *_c_val;