diff options
Diffstat (limited to 'gcc/fortran/trans-expr.c')
| -rw-r--r-- | gcc/fortran/trans-expr.c | 74 |
1 files changed, 55 insertions, 19 deletions
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 94921bc..1e1802e 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -142,6 +142,31 @@ gfc_conv_expr_present (gfc_symbol * sym) } +/* Converts a missing, dummy argument into a null or zero. */ + +void +gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts) +{ + tree present; + tree tmp; + + present = gfc_conv_expr_present (arg->symtree->n.sym); + tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr, + convert (TREE_TYPE (se->expr), integer_zero_node)); + tmp = gfc_evaluate_now (tmp, &se->pre); + se->expr = tmp; + if (ts.type == BT_CHARACTER) + { + tmp = convert (gfc_charlen_type_node, integer_zero_node); + tmp = build3 (COND_EXPR, gfc_charlen_type_node, present, + se->string_length, tmp); + tmp = gfc_evaluate_now (tmp, &se->pre); + se->string_length = tmp; + } + return; +} + + /* Get the character length of an expression, looking through gfc_refs if necessary. */ @@ -1805,6 +1830,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, bool callee_alloc; gfc_typespec ts; gfc_charlen cl; + gfc_expr *e; + gfc_symbol *fsym; arglist = NULL_TREE; retargs = NULL_TREE; @@ -1844,7 +1871,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, /* Evaluate the arguments. */ for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) { - if (arg->expr == NULL) + e = arg->expr; + fsym = formal ? formal->sym : NULL; + if (e == NULL) { if (se->ignore_optional) @@ -1872,19 +1901,19 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, { /* An elemental function inside a scalarized loop. */ gfc_init_se (&parmse, se); - gfc_conv_expr_reference (&parmse, arg->expr); + gfc_conv_expr_reference (&parmse, e); } else { /* A scalar or transformational function. */ gfc_init_se (&parmse, NULL); - argss = gfc_walk_expr (arg->expr); + argss = gfc_walk_expr (e); if (argss == gfc_ss_terminator) { - gfc_conv_expr_reference (&parmse, arg->expr); - if (formal && formal->sym->attr.pointer - && arg->expr->expr_type != EXPR_NULL) + gfc_conv_expr_reference (&parmse, e); + if (fsym && fsym->attr.pointer + && e->expr_type != EXPR_NULL) { /* Scalar pointer dummy args require an extra level of indirection. The null pointer already contains @@ -1901,27 +1930,27 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, convention, and pass the address of the array descriptor instead. Otherwise we use g77's calling convention. */ int f; - f = (formal != NULL) - && !(formal->sym->attr.pointer || formal->sym->attr.allocatable) - && formal->sym->as->type != AS_ASSUMED_SHAPE; + f = (fsym != NULL) + && !(fsym->attr.pointer || fsym->attr.allocatable) + && fsym->as->type != AS_ASSUMED_SHAPE; f = f || !sym->attr.always_explicit; - if (arg->expr->expr_type == EXPR_VARIABLE - && is_aliased_array (arg->expr)) + if (e->expr_type == EXPR_VARIABLE + && is_aliased_array (e)) /* The actual argument is a component reference to an array of derived types. In this case, the argument is converted to a temporary, which is passed and then written back after the procedure call. */ - gfc_conv_aliased_arg (&parmse, arg->expr, f); + gfc_conv_aliased_arg (&parmse, e, f); else - gfc_conv_array_parameter (&parmse, arg->expr, argss, f); + gfc_conv_array_parameter (&parmse, e, argss, f); /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ - if (formal && formal->sym->attr.allocatable - && formal->sym->attr.intent == INTENT_OUT) + if (fsym && fsym->attr.allocatable + && fsym->attr.intent == INTENT_OUT) { - tmp = arg->expr->symtree->n.sym->backend_decl; - if (arg->expr->symtree->n.sym->attr.dummy) + tmp = e->symtree->n.sym->backend_decl; + if (e->symtree->n.sym->attr.dummy) tmp = build_fold_indirect_ref (tmp); tmp = gfc_trans_dealloc_allocated (tmp); gfc_add_expr_to_block (&se->pre, tmp); @@ -1930,8 +1959,15 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, } } - if (formal && need_interface_mapping) - gfc_add_interface_mapping (&mapping, formal->sym, &parmse); + /* If an optional argument is itself an optional dummy argument, + check its presence and substitute a null if absent. */ + if (e && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional + && fsym && fsym->attr.optional) + gfc_conv_missing_dummy (&parmse, e, fsym->ts); + + if (fsym && need_interface_mapping) + gfc_add_interface_mapping (&mapping, fsym, &parmse); gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&se->post, &parmse.post); |