diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f5380cd511f..ae0b36cc9ea 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,50 @@ +2011-01-28 Paul Thomas + Tobias Burnus + + PR fortran/45170 + PR fortran/35810 + PR fortran/47350 + * interface.c (compare_actual_formal): An allocatable or pointer + deferred length actual is only allowed if the formal argument + is also deferred length. Clean up whitespace. + * trans-expr.c (gfc_conv_procedure_call): Pass string length for + deferred character length formal arguments by reference. Do the + same for function results. + (gfc_trans_pointer_assignment): Do not do runtime check of lhs + and rhs character lengths, if deferred length lhs. In this case + set the lhs character length to that of the rhs. + (gfc_conv_string_parameter): Remove assert that string length is + an integer type. + (is_scalar_reallocatable_lhs): New function. + (alloc_scalar_allocatable_for_assignment): New function. + (gfc_trans_assignment_1): Call above new function. If the rhs is + a deferred character length itself, makes ure that the function + is called before reallocation, so that the length is available. + (gfc_trans_asssignment): Remove error about assignment to + deferred length character variables. + * gfortran.texi : Update entry about (re)allocation on + assignment. + * trans-stmt.c (gfc_trans_allocate): Add code to handle deferred + length character variables. + * module.c (mio_typespec): Transfer deferred characteristic. + * trans-types.c (gfc_get_function_type): New code to generate + hidden typelist, so that those character lengths that are + passed by reference get the right type. + * resolve.c (resolve_contained_fntype): Supress error for + deferred character length functions. + (resolve_function, resolve_fl_procedure) The same. + (check_symbols): Remove the error that support for + entity with deferred type parameter is not yet implemented. + (resolve_fl_derived): The same. + match.c (alloc_opt_list): Allow MOLD for deferred length object. + * trans-decl.c (gfc_get_symbol_decl): For deferred character + length dummies, generate a local variable for string length. + (create_function_arglist): Hidden length can be a pointer. + (gfc_trans_deferred_vars): For deferred character length + results and dummies, assign the string length to the local + variable from the hidden argument on entry and the other way + round on exit, as appropriate. + 2011-01-27 Tobias Burnus PR fortran/47474 diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 39180353111..4f5875d8c2a 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -830,10 +830,11 @@ type-specification with type parameter and for allocation and initialization from a @code{SOURCE=} expression; @code{ALLOCATE} and @code{DEALLOCATE} optionally return an error message string via @code{ERRMSG=}. -@item Reallocation on assignment for arrays: If an intrinsic assignment is +@item Reallocation on assignment: If an intrinsic assignment is used, an allocatable variable on the left-hand side is automatically allocated -(if unallocated) or reallocated (if the shape is different). Currently, the -reallocation for scalars is not implemented. +(if unallocated) or reallocated (if the shape is different). Currently, scalar +deferred character length left-hand sides are correctly handled but arrays +are not yet fully implemented. @item Transferring of allocations via @code{MOVE_ALLOC}. diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index c5b690ea385..1cbba248354 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2093,6 +2093,18 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, return 0; } + if ((f->sym->attr.pointer || f->sym->attr.allocatable) + && f->sym->ts.deferred != a->expr->ts.deferred + && a->expr->ts.type == BT_CHARACTER) + { + if (where) + gfc_error ("Actual argument argument at %L to allocatable or " + "pointer dummy argument '%s' must have a deferred " + "length type parameter if and only if the dummy has one", + &a->expr->where, f->sym->name); + return 0; + } + actual_size = get_expr_storage_size (a->expr); formal_size = get_sym_storage_size (f->sym); if (actual_size != 0 @@ -2101,14 +2113,14 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, { if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where) gfc_warning ("Character length of actual argument shorter " - "than of dummy argument '%s' (%lu/%lu) at %L", - f->sym->name, actual_size, formal_size, - &a->expr->where); + "than of dummy argument '%s' (%lu/%lu) at %L", + f->sym->name, actual_size, formal_size, + &a->expr->where); else if (where) gfc_warning ("Actual argument contains too few " - "elements for dummy argument '%s' (%lu/%lu) at %L", - f->sym->name, actual_size, formal_size, - &a->expr->where); + "elements for dummy argument '%s' (%lu/%lu) at %L", + f->sym->name, actual_size, formal_size, + &a->expr->where); return 0; } diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 0793b8cfc36..01b88ffd46e 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -3134,10 +3134,11 @@ alloc_opt_list: } /* Check F03:C623, */ - if (saw_deferred && ts.type == BT_UNKNOWN && !source) + if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold) { gfc_error ("Allocate-object at %L with a deferred type parameter " - "requires either a type-spec or SOURCE tag", &deferred_locus); + "requires either a type-spec or SOURCE tag or a MOLD tag", + &deferred_locus); goto cleanup; } diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 8de19273f34..6c3455b22c8 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -2138,6 +2138,20 @@ mio_typespec (gfc_typespec *ts) else mio_charlen (&ts->u.cl); + /* So as not to disturb the existing API, use an ATOM_NAME to + transmit deferred characteristic for characters (F2003). */ + if (iomode == IO_OUTPUT) + { + if (ts->type == BT_CHARACTER && ts->deferred) + write_atom (ATOM_NAME, "DEFERRED_CL"); + } + else if (peek_atom () != ATOM_RPAREN) + { + if (parse_atom () != ATOM_NAME) + bad_module ("Expected string"); + ts->deferred = 1; + } + mio_rparen (); } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index a4a77accf9c..243628397aa 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -500,7 +500,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) if (sym->result->ts.type == BT_CHARACTER) { gfc_charlen *cl = sym->result->ts.u.cl; - if (!cl || !cl->length) + if ((!cl || !cl->length) && !sym->result->ts.deferred) { /* See if this is a module-procedure and adapt error message accordingly. */ @@ -2990,6 +2990,7 @@ resolve_function (gfc_expr *expr) && sym->ts.u.cl && sym->ts.u.cl->length == NULL && !sym->attr.dummy + && !sym->ts.deferred && expr->value.function.esym == NULL && !sym->attr.contained) { @@ -6916,12 +6917,6 @@ check_symbols: } success: - if (e->ts.deferred) - { - gfc_error ("Support for entity at %L with deferred type parameter " - "not yet implemented", &e->where); - return FAILURE; - } return SUCCESS; failure: @@ -10267,8 +10262,11 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) } /* Appendix B.2 of the standard. Contained functions give an - error anyway. Fixed-form is likely to be F77/legacy. */ - if (!sym->attr.contained && gfc_current_form != FORM_FIXED) + error anyway. Fixed-form is likely to be F77/legacy. Deferred + character length is an F2003 feature. */ + if (!sym->attr.contained + && gfc_current_form != FORM_FIXED + && !sym->ts.deferred) gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: " "CHARACTER(*) function '%s' at %L", sym->name, &sym->declared_at); @@ -11605,7 +11603,8 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer) + if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer + && !c->ts.deferred) { if (c->ts.u.cl->length == NULL || (resolve_charlen (c->ts.u.cl) == FAILURE) @@ -11619,6 +11618,15 @@ resolve_fl_derived (gfc_symbol *sym) } } + if (c->ts.type == BT_CHARACTER && c->ts.deferred + && !c->attr.pointer && !c->attr.allocatable) + { + gfc_error ("Character component '%s' of '%s' at %L with deferred " + "length must be a POINTER or ALLOCATABLE", + c->name, sym->name, &c->loc); + return FAILURE; + } + if (c->ts.type == BT_DERIVED && sym->component_access != ACCESS_PRIVATE && gfc_check_access (sym->attr.access, sym->ns->default_access) diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 74de59ea384..fb2f9a85d54 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1,5 +1,6 @@ /* Backend function setup - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, + 2011 Free Software Foundation, Inc. Contributed by Paul Brook @@ -1067,6 +1068,21 @@ gfc_get_symbol_decl (gfc_symbol * sym) gfc_find_derived_vtab (c->ts.u.derived); } + /* All deferred character length procedures need to retain the backend + decl, which is a pointer to the character length in the caller's + namespace and to declare a local character length. */ + if (!byref && sym->attr.function + && sym->ts.type == BT_CHARACTER + && sym->ts.deferred + && sym->ts.u.cl->passed_length == NULL + && sym->ts.u.cl->backend_decl + && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL) + { + sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; + sym->ts.u.cl->backend_decl = NULL_TREE; + length = gfc_create_string_length (sym); + } + if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref)) { /* Return via extra parameter. */ @@ -1087,6 +1103,20 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* Create a character length variable. */ if (sym->ts.type == BT_CHARACTER) { + /* For a deferred dummy, make a new string length variable. */ + if (sym->ts.deferred + && + (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl)) + sym->ts.u.cl->backend_decl = NULL_TREE; + + if (sym->ts.deferred && sym->attr.result + && sym->ts.u.cl->passed_length == NULL + && sym->ts.u.cl->backend_decl) + { + sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; + sym->ts.u.cl->backend_decl = NULL_TREE; + } + if (sym->ts.u.cl->backend_decl == NULL_TREE) length = gfc_create_string_length (sym); else @@ -1793,7 +1823,6 @@ create_function_arglist (gfc_symbol * sym) { /* Length of character result. */ tree len_type = TREE_VALUE (TREE_CHAIN (typelist)); - gcc_assert (len_type == gfc_charlen_type_node); length = build_decl (input_location, PARM_DECL, @@ -1879,7 +1908,10 @@ create_function_arglist (gfc_symbol * sym) { tree len_type = TREE_VALUE (hidden_typelist); tree length = NULL_TREE; - gcc_assert (len_type == gfc_charlen_type_node); + if (!f->sym->ts.deferred) + gcc_assert (len_type == gfc_charlen_type_node); + else + gcc_assert (POINTER_TYPE_P (len_type)); strcpy (&name[1], f->sym->name); name[0] = '_'; @@ -3182,6 +3214,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_formal_arglist *f; stmtblock_t tmpblock; bool seen_trans_deferred_array = false; + tree tmp = NULL; + gfc_expr *e; + gfc_se se; + stmtblock_t init; /* Deal with implicit return variables. Explicit return variables will already have been added. */ @@ -3213,7 +3249,34 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else if (proc_sym->ts.type == BT_CHARACTER) { - if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL) + if (proc_sym->ts.deferred) + { + tmp = NULL; + gfc_start_block (&init); + /* Zero the string length on entry. */ + gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl, + build_int_cst (gfc_charlen_type_node, 0)); + /* Null the pointer. */ + e = gfc_lval_expr_from_sym (proc_sym); + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, e); + gfc_free_expr (e); + tmp = se.expr; + gfc_add_modify (&init, tmp, + fold_convert (TREE_TYPE (se.expr), + null_pointer_node)); + + /* Pass back the string length on exit. */ + tmp = proc_sym->ts.u.cl->passed_length; + tmp = build_fold_indirect_ref_loc (input_location, tmp); + tmp = fold_convert (gfc_charlen_type_node, tmp); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + gfc_charlen_type_node, tmp, + proc_sym->ts.u.cl->backend_decl); + gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); + } + else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL) gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block); } else @@ -3304,7 +3367,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) if (sym_has_alloc_comp && !seen_trans_deferred_array) gfc_trans_deferred_array (sym, block); } - else if (!sym->attr.dummy + else if ((!sym->attr.dummy || sym->ts.deferred) && (sym->attr.allocatable || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.allocatable))) @@ -3313,11 +3376,6 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) { /* Nullify and automatic deallocation of allocatable scalars. */ - tree tmp = NULL; - gfc_expr *e; - gfc_se se; - stmtblock_t init; - e = gfc_lval_expr_from_sym (sym); if (sym->ts.type == BT_CLASS) gfc_add_data_component (e); @@ -3327,15 +3385,44 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_conv_expr (&se, e); gfc_free_expr (e); - /* Nullify when entering the scope. */ gfc_start_block (&init); - gfc_add_modify (&init, se.expr, - fold_convert (TREE_TYPE (se.expr), - null_pointer_node)); + + 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)); + } + + if ((sym->attr.dummy ||sym->attr.result) + && sym->ts.type == BT_CHARACTER + && sym->ts.deferred) + { + /* Character length passed by reference. */ + tmp = sym->ts.u.cl->passed_length; + tmp = build_fold_indirect_ref_loc (input_location, tmp); + tmp = fold_convert (gfc_charlen_type_node, tmp); + + if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT) + /* Zero the string length when entering the scope. */ + 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); + + /* 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); + else + tmp = NULL_TREE; + } /* Deallocate when leaving the scope. Nullifying is not needed. */ - if (!sym->attr.result) + if (!sym->attr.result && !sym->attr.dummy) tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true, NULL, sym->ts); @@ -3358,6 +3445,33 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); } } + else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred) + { + tree tmp = NULL; + stmtblock_t init; + + /* If we get to here, all that should be left are pointers. */ + gcc_assert (sym->attr.pointer); + + if (sym->attr.dummy) + { + gfc_start_block (&init); + + /* Character length passed by reference. */ + tmp = sym->ts.u.cl->passed_length; + tmp = build_fold_indirect_ref_loc (input_location, tmp); + tmp = fold_convert (gfc_charlen_type_node, tmp); + gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp); + /* 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); + else + tmp = NULL_TREE; + gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); + } + } else if (sym->ts.deferred) gfc_fatal_error ("Deferred type parameter not yet supported"); else if (sym_has_alloc_comp) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index ec1e848509c..9bbe791d88b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3322,6 +3322,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } end_pointer_check: + /* Deferred length dummies pass the character length by reference + so that the value can be returned. */ + if (parmse.string_length && fsym && fsym->ts.deferred) + { + tmp = parmse.string_length; + if (TREE_CODE (tmp) != VAR_DECL) + tmp = gfc_evaluate_now (parmse.string_length, &se->pre); + parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp); + } /* Character strings are passed as two parameters, a length and a pointer - except for Bind(c) which only passes the pointer. */ @@ -3349,7 +3358,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, we take the character length of the first argument for the result. For dummies, we have to look through the formal argument list for this function and use the character length found there.*/ - if (!sym->attr.dummy) + if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer)) + cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen"); + else if (!sym->attr.dummy) cl.backend_decl = VEC_index (tree, stringargs, 0); else { @@ -3534,6 +3545,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, VEC_safe_push (tree, gc, retargs, var); } + if (ts.type == BT_CHARACTER && ts.deferred + && (sym->attr.allocatable || sym->attr.pointer)) + { + tmp = len; + if (TREE_CODE (tmp) != VAR_DECL) + tmp = gfc_evaluate_now (len, &se->pre); + len = gfc_build_addr_expr (NULL_TREE, tmp); + } + /* Add the string length to the argument list. */ if (ts.type == BT_CHARACTER) VEC_safe_push (tree, gc, retargs, len); @@ -3642,7 +3662,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else se->expr = var; - se->string_length = len; + if (!ts.deferred) + se->string_length = len; + else if (sym->attr.allocatable || sym->attr.pointer) + se->string_length = cl.backend_decl; } else { @@ -4919,8 +4942,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_block_to_block (&block, &rse.pre); /* Check character lengths if character expression. The test is only - really added if -fbounds-check is enabled. */ + really added if -fbounds-check is enabled. Exclude deferred + character length lefthand sides. */ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL + && !(expr1->ts.deferred + && (TREE_CODE (lse.string_length) == VAR_DECL)) && !expr1->symtree->n.sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (expr1, NULL)) { @@ -4931,6 +4957,17 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) &block); } + /* The assignment to an deferred character length sets the string + length to that of the rhs. */ + if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL)) + { + if (expr2->expr_type != EXPR_NULL) + gfc_add_modify (&block, lse.string_length, rse.string_length); + else + gfc_add_modify (&block, lse.string_length, + build_int_cst (gfc_charlen_type_node, 0)); + } + gfc_add_modify (&block, lse.expr, fold_convert (TREE_TYPE (lse.expr), rse.expr)); @@ -5206,8 +5243,6 @@ gfc_conv_string_parameter (gfc_se * se) } gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr))); - gcc_assert (se->string_length - && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE); } @@ -5792,6 +5827,136 @@ expr_is_variable (gfc_expr *expr) } +/* Is the lhs OK for automatic reallocation? */ + +static bool +is_scalar_reallocatable_lhs (gfc_expr *expr) +{ + gfc_ref * ref; + + /* An allocatable variable with no reference. */ + if (expr->symtree->n.sym->attr.allocatable + && !expr->ref) + return true; + + /* All that can be left are allocatable components. */ + if ((expr->symtree->n.sym->ts.type != BT_DERIVED + && expr->symtree->n.sym->ts.type != BT_CLASS) + || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp) + return false; + + /* Find an allocatable component ref last. */ + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT + && !ref->next + && ref->u.c.component->attr.allocatable) + return true; + + return false; +} + + +/* Allocate or reallocate scalar lhs, as necessary. */ + +static void +alloc_scalar_allocatable_for_assignment (stmtblock_t *block, + tree string_length, + gfc_expr *expr1, + gfc_expr *expr2) + +{ + tree cond; + tree tmp; + tree size; + tree size_in_bytes; + tree jump_label1; + tree jump_label2; + gfc_se lse; + + if (!expr1 || expr1->rank) + return; + + if (!expr2 || expr2->rank) + return; + + /* Since this is a scalar lhs, we can afford to do this. That is, + there is no risk of side effects being repeated. */ + gfc_init_se (&lse, NULL); + lse.want_pointer = 1; + gfc_conv_expr (&lse, expr1); + + jump_label1 = gfc_build_label_decl (NULL_TREE); + jump_label2 = gfc_build_label_decl (NULL_TREE); + + /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */ + tmp = build_int_cst (TREE_TYPE (lse.expr), 0); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + lse.expr, tmp); + tmp = build3_v (COND_EXPR, cond, + build1_v (GOTO_EXPR, jump_label1), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (block, tmp); + + if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) + { + /* Use the rhs string length and the lhs element size. */ + size = string_length; + tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)); + tmp = TYPE_SIZE_UNIT (tmp); + size_in_bytes = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), tmp, + fold_convert (TREE_TYPE (tmp), size)); + } + else + { + /* Otherwise use the length in bytes of the rhs. */ + size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts)); + size_in_bytes = size; + } + + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MALLOC], 1, + size_in_bytes); + tmp = fold_convert (TREE_TYPE (lse.expr), tmp); + gfc_add_modify (block, lse.expr, tmp); + if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) + { + /* Deferred characters need checking for lhs and rhs string + length. Other deferred parameter variables will have to + come here too. */ + tmp = build1_v (GOTO_EXPR, jump_label2); + gfc_add_expr_to_block (block, tmp); + } + tmp = build1_v (LABEL_EXPR, jump_label1); + gfc_add_expr_to_block (block, tmp); + + /* For a deferred length character, reallocate if lengths of lhs and + rhs are different. */ + if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) + { + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + expr1->ts.u.cl->backend_decl, size); + /* Jump past the realloc if the lengths are the same. */ + tmp = build3_v (COND_EXPR, cond, + build1_v (GOTO_EXPR, jump_label2), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (block, tmp); + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_REALLOC], 2, + fold_convert (pvoid_type_node, lse.expr), + size_in_bytes); + tmp = fold_convert (TREE_TYPE (lse.expr), tmp); + gfc_add_modify (block, lse.expr, tmp); + tmp = build1_v (LABEL_EXPR, jump_label2); + gfc_add_expr_to_block (block, tmp); + + /* Update the lhs character length. */ + size = string_length; + gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size); + } +} + + /* Subroutine of gfc_trans_assignment that actually scalarizes the assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. init_flag indicates initialization expressions and dealloc that no @@ -5929,6 +6094,15 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_add_expr_to_block (&loop.post, tmp); } + /* For a deferred character length function, the function call must + happen before the (re)allocation of the lhs, otherwise the character + length of the result is not known. */ + if (gfc_option.flag_realloc_lhs + && expr2->expr_type == EXPR_FUNCTION + && expr2->ts.type == BT_CHARACTER + && expr2->ts.deferred) + gfc_add_block_to_block (&block, &rse.pre); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp || init_flag, expr_is_variable (expr2) || scalar_to_array, @@ -5937,6 +6111,12 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, if (lss == gfc_ss_terminator) { + /* F2003: Add the code for reallocation on assignment. */ + if (gfc_option.flag_realloc_lhs + && is_scalar_reallocatable_lhs (expr1)) + alloc_scalar_allocatable_for_assignment (&block, rse.string_length, + expr1, expr2); + /* Use the scalar assignment as is. */ gfc_add_block_to_block (&block, &body); } @@ -5972,7 +6152,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_add_expr_to_block (&body, tmp); } - /* Allocate or reallocate lhs of allocatable array. */ + /* F2003: Allocate or reallocate lhs of allocatable array. */ if (gfc_option.flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1) && !gfc_expr_attr (expr1).codimension @@ -6042,13 +6222,6 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, { tree tmp; - if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - { - gfc_error ("Assignment to deferred-length character variable at %L " - "not implemented", &expr1->where); - return NULL_TREE; - } - /* Special case a single function returning an array. */ if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) { diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 8781d0e723c..161b309e00f 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1,5 +1,6 @@ /* Statement translation -- generate GCC trees from gfc_code. - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, + 2011 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -4507,14 +4508,73 @@ gfc_trans_allocate (gfc_code * code) else memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); } + else if (al->expr->ts.type == BT_CHARACTER + && al->expr->ts.deferred && code->expr3) + { + if (!code->expr3->ts.u.cl->backend_decl) + { + /* Convert and use the length expression. */ + gfc_se se_sz; + gfc_init_se (&se_sz, NULL); + if (code->expr3->expr_type == EXPR_VARIABLE + || code->expr3->expr_type == EXPR_CONSTANT) + { + gfc_conv_expr (&se_sz, code->expr3); + memsz = se_sz.string_length; + } + else + { + gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); + memsz = se_sz.expr; + } + if (TREE_CODE (se.string_length) == VAR_DECL) + gfc_add_modify (&block, se.string_length, + fold_convert (TREE_TYPE (se.string_length), + memsz)); + } + else + /* Otherwise use the stored string length. */ + memsz = code->expr3->ts.u.cl->backend_decl; + tmp = al->expr->ts.u.cl->backend_decl; + + /* Store the string length. */ + if (tmp && TREE_CODE (tmp) == VAR_DECL) + gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), + memsz)); + + /* Convert to size in bytes, using the character KIND. */ + tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts)); + tmp = TYPE_SIZE_UNIT (tmp); + memsz = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), tmp, + fold_convert (TREE_TYPE (tmp), memsz)); + } else if (code->ext.alloc.ts.type != BT_UNKNOWN) memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); else memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE) - memsz = se.string_length; - + { + if (expr->ts.deferred) + { + gfc_se se_sz; + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); + memsz = se_sz.expr; + gfc_add_modify (&block, se.string_length, + fold_convert (TREE_TYPE (se.string_length), + memsz)); + } + else + memsz = se.string_length; + /* Convert to size in bytes, using the character KIND. */ + tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts)); + tmp = TYPE_SIZE_UNIT (tmp); + memsz = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), tmp, + fold_convert (TREE_TYPE (tmp), memsz)); + } /* Allocate - for non-pointers with re-alloc checking. */ { gfc_ref *ref; diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 1de7e1e3a12..7c299741aec 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1,6 +1,6 @@ /* Backend support for Fortran 95 basic types and derived types. Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, - 2010 + 2010, 2011 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -2352,7 +2352,6 @@ gfc_get_function_type (gfc_symbol * sym) tree typelist; gfc_formal_arglist *f; gfc_symbol *arg; - int nstr; int alternate_return; /* Make sure this symbol is a function, a subroutine or the main @@ -2363,7 +2362,6 @@ gfc_get_function_type (gfc_symbol * sym) if (sym->backend_decl) return TREE_TYPE (sym->backend_decl); - nstr = 0; alternate_return = 0; typelist = NULL_TREE; @@ -2392,7 +2390,16 @@ gfc_get_function_type (gfc_symbol * sym) typelist = gfc_chainon_list (typelist, type); if (arg->ts.type == BT_CHARACTER) - typelist = gfc_chainon_list (typelist, gfc_charlen_type_node); + { + if (!arg->ts.deferred) + /* Transfer by value. */ + typelist = gfc_chainon_list (typelist, gfc_charlen_type_node); + else + /* Deferred character lengths are transferred by reference + so that the value can be returned. */ + typelist = gfc_chainon_list (typelist, + build_pointer_type (gfc_charlen_type_node)); + } } /* Build the argument types for the function. */ @@ -2428,8 +2435,7 @@ gfc_get_function_type (gfc_symbol * sym) Contained procedures could pass by value as these are never used without an explicit interface, and cannot be passed as actual parameters for a dummy procedure. */ - if (arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c) - nstr++; + typelist = gfc_chainon_list (typelist, type); } else @@ -2440,8 +2446,22 @@ gfc_get_function_type (gfc_symbol * sym) } /* Add hidden string length parameters. */ - while (nstr--) - typelist = gfc_chainon_list (typelist, gfc_charlen_type_node); + for (f = sym->formal; f; f = f->next) + { + arg = f->sym; + if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c) + { + if (!arg->ts.deferred) + /* Transfer by value. */ + type = gfc_charlen_type_node; + else + /* Deferred character lengths are transferred by reference + so that the value can be returned. */ + type = build_pointer_type (gfc_charlen_type_node); + + typelist = gfc_chainon_list (typelist, type); + } + } if (typelist) typelist = chainon (typelist, void_list_node); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4638e57ce61..cd0a2099b4c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,17 @@ +2011-01-28 Paul Thomas + Tobias Burnus + + PR fortran/45170 + PR fortran/35810 + PR fortran/47350 + * gfortran.dg/realloc_on_assign_3.f03: New test. + * gfortran.dg/realloc_on_assign_4.f03: New test. + * gfortran.dg/realloc_on_assign_5.f90: New test. + * gfortran.dg/allocatable_function_5.f90: New test. + * gfortran.dg/allocate_deferred_char_scalar_1.f90: New test. + * gfortran.dg/deferred_type_param_2.f90: Remove two "not yet + implemented" dg-errors. + 2011-01-27 Jan Hubicka PR middle-end/46949 diff --git a/gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_1.f03 b/gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_1.f03 new file mode 100644 index 00000000000..a14318a64f5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_1.f03 @@ -0,0 +1,267 @@ +! { dg-do run} +! +! Automatic reallocate on assignment, deferred length parameter for char +! +! PR fortran/45170 +! PR fortran/35810 +! PR fortran/47350 +! +! Contributed by Tobias Burnus +! +program test + implicit none + call mold_check() + call mold_check4() + call source_check() + call source_check4() + call ftn_test() + call ftn_test4() + call source3() +contains + subroutine source_check() + character(len=:), allocatable :: str, str2 + target :: str + character(len=8) :: str3 + character(len=:), pointer :: str4, str5 + nullify(str4) + str3 = 'AbCdEfGhIj' + if(allocated(str)) call abort() + allocate(str, source=str3) + if(.not.allocated(str)) call abort() + if(len(str) /= 8) call abort() + if(str /= 'AbCdEfGh') call abort() + if(associated(str4)) call abort() + str4 => str + if(str4 /= str .or. len(str4)/=8) call abort() + if(.not.associated(str4, str)) call abort() + str4 => null() + str = '12a56b78' + if(str4 == '12a56b78') call abort() + str4 = 'ABCDEFGH' + if(str == 'ABCDEFGH') call abort() + allocate(str5, source=str) + if(associated(str5, str)) call abort() + if(str5 /= '12a56b78' .or. len(str5)/=8) call abort() + str = 'abcdef' + if(str5 == 'abcdef') call abort() + str5 = 'ABCDEF' + if(str == 'ABCDEF') call abort() + end subroutine source_check + subroutine source_check4() + character(kind=4,len=:), allocatable :: str, str2 + target :: str + character(kind=4,len=8) :: str3 + character(kind=4,len=:), pointer :: str4, str5 + nullify(str4) + str3 = 4_'AbCdEfGhIj' + if(allocated(str)) call abort() + allocate(str, source=str3) + if(.not.allocated(str)) call abort() + if(len(str) /= 8) call abort() + if(str /= 4_'AbCdEfGh') call abort() + if(associated(str4)) call abort() + str4 => str + if(str4 /= str .or. len(str4)/=8) call abort() + if(.not.associated(str4, str)) call abort() + str4 => null() + str = 4_'12a56b78' + if(str4 == 4_'12a56b78') call abort() + str4 = 4_'ABCDEFGH' + if(str == 4_'ABCDEFGH') call abort() + allocate(str5, source=str) + if(associated(str5, str)) call abort() + if(str5 /= 4_'12a56b78' .or. len(str5)/=8) call abort() + str = 4_'abcdef' + if(str5 == 4_'abcdef') call abort() + str5 = 4_'ABCDEF' + if(str == 4_'ABCDEF') call abort() + end subroutine source_check4 + subroutine mold_check() + character(len=:), allocatable :: str, str2 + character(len=8) :: str3 + character(len=:), pointer :: str4, str5 + nullify(str4) + str2 = "ABCE" + ALLOCATE( str, MOLD=str3) + if (len(str) /= 8) call abort() + DEALLOCATE(str) + ALLOCATE( str, MOLD=str2) + if (len(str) /= 4) call abort() + + IF (associated(str4)) call abort() + ALLOCATE( str4, MOLD=str3) + IF (.not.associated(str4)) call abort() + str4 = '12345678' + if (len(str4) /= 8) call abort() + if(str4 /= '12345678') call abort() + DEALLOCATE(str4) + ALLOCATE( str4, MOLD=str2) + str4 = 'ABCD' + if (len(str4) /= 4) call abort() + if (str4 /= 'ABCD') call abort() + str5 => str4 + if(.not.associated(str4,str5)) call abort() + if(len(str5) /= 4 .or. len(str4) /= len(str5)) call abort() + if(str5 /= str4) call abort() + deallocate(str4) + end subroutine mold_check + subroutine mold_check4() + character(len=:,kind=4), allocatable :: str, str2 + character(len=8,kind=4) :: str3 + character(len=:,kind=4), pointer :: str4, str5 + nullify(str4) + str2 = 4_"ABCE" + ALLOCATE( str, MOLD=str3) + if (len(str) /= 8) call abort() + DEALLOCATE(str) + ALLOCATE( str, MOLD=str2) + if (len(str) /= 4) call abort() + + IF (associated(str4)) call abort() + ALLOCATE( str4, MOLD=str3) + IF (.not.associated(str4)) call abort() + str4 = 4_'12345678' + if (len(str4) /= 8) call abort() + if(str4 /= 4_'12345678') call abort() + DEALLOCATE(str4) + ALLOCATE( str4, MOLD=str2) + str4 = 4_'ABCD' + if (len(str4) /= 4) call abort() + if (str4 /= 4_'ABCD') call abort() + str5 => str4 + if(.not.associated(str4,str5)) call abort() + if(len(str5) /= 4 .or. len(str4) /= len(str5)) call abort() + if(str5 /= str4) call abort() + deallocate(str4) + end subroutine mold_check4 + subroutine ftn_test() + character(len=:), allocatable :: str_a + character(len=:), pointer :: str_p + nullify(str_p) + call proc_test(str_a, str_p, .false.) + if (str_p /= '123457890abcdef') call abort() + if (len(str_p) /= 50) call abort() + if (str_a(1:5) /= 'ABCDE ') call abort() + if (len(str_a) /= 50) call abort() + deallocate(str_p) + str_a = '1245' + if(len(str_a) /= 4) call abort() + if(str_a /= '1245') call abort() + allocate(character(len=6) :: str_p) + if(len(str_p) /= 6) call abort() + str_p = 'AbCdEf' + call proc_test(str_a, str_p, .true.) + if (str_p /= '123457890abcdef') call abort() + if (len(str_p) /= 50) call abort() + if (str_a(1:5) /= 'ABCDE ') call abort() + if (len(str_a) /= 50) call abort() + deallocate(str_p) + end subroutine ftn_test + subroutine proc_test(a, p, alloc) + character(len=:), allocatable :: a + character(len=:), pointer :: p + character(len=5), target :: loc + logical :: alloc + if (.not. alloc) then + if(associated(p)) call abort() + if(allocated(a)) call abort() + else + if(len(a) /= 4) call abort() + if(a /= '1245') call abort() + if(len(p) /= 6) call abort() + if(p /= 'AbCdEf') call abort() + deallocate(a) + nullify(p) + end if + allocate(character(len=50) :: a) + a(1:5) = 'ABCDE' + if(len(a) /= 50) call abort() + if(a(1:5) /= "ABCDE") call abort() + loc = '12345' + p => loc + if (len(p) /= 5) call abort() + if (p /= '12345') call abort() + p = '12345679' + if (len(p) /= 5) call abort() + if (p /= '12345') call abort() + p = 'ABC' + if (loc /= 'ABC ') call abort() + allocate(p, mold=a) + if (.not.associated(p)) call abort() + p = '123457890abcdef' + if (p /= '123457890abcdef') call abort() + if (len(p) /= 50) call abort() + end subroutine proc_test + subroutine ftn_test4() + character(len=:,kind=4), allocatable :: str_a + character(len=:,kind=4), pointer :: str_p + nullify(str_p) + call proc_test4(str_a, str_p, .false.) + if (str_p /= 4_'123457890abcdef') call abort() + if (len(str_p) /= 50) call abort() + if (str_a(1:5) /= 4_'ABCDE ') call abort() + if (len(str_a) /= 50) call abort() + deallocate(str_p) + str_a = 4_'1245' + if(len(str_a) /= 4) call abort() + if(str_a /= 4_'1245') call abort() + allocate(character(len=6, kind = 4) :: str_p) + if(len(str_p) /= 6) call abort() + str_p = 4_'AbCdEf' + call proc_test4(str_a, str_p, .true.) + if (str_p /= 4_'123457890abcdef') call abort() + if (len(str_p) /= 50) call abort() + if (str_a(1:5) /= 4_'ABCDE ') call abort() + if (len(str_a) /= 50) call abort() + deallocate(str_p) + end subroutine ftn_test4 + subroutine proc_test4(a, p, alloc) + character(len=:,kind=4), allocatable :: a + character(len=:,kind=4), pointer :: p + character(len=5,kind=4), target :: loc + logical :: alloc + if (.not. alloc) then + if(associated(p)) call abort() + if(allocated(a)) call abort() + else + if(len(a) /= 4) call abort() + if(a /= 4_'1245') call abort() + if(len(p) /= 6) call abort() + if(p /= 4_'AbCdEf') call abort() + deallocate(a) + nullify(p) + end if + allocate(character(len=50,kind=4) :: a) + a(1:5) = 4_'ABCDE' + if(len(a) /= 50) call abort() + if(a(1:5) /= 4_"ABCDE") call abort() + loc = '12345' + p => loc + if (len(p) /= 5) call abort() + if (p /= 4_'12345') call abort() + p = 4_'12345679' + if (len(p) /= 5) call abort() + if (p /= 4_'12345') call abort() + p = 4_'ABC' + if (loc /= 4_'ABC ') call abort() + allocate(p, mold=a) + if (.not.associated(p)) call abort() + p = 4_'123457890abcdef' + if (p /= 4_'123457890abcdef') call abort() + if (len(p) /= 50) call abort() + end subroutine proc_test4 + subroutine source3() + character(len=:, kind=1), allocatable :: a1 + character(len=:, kind=4), allocatable :: a4 + character(len=:, kind=1), pointer :: p1 + character(len=:, kind=4), pointer :: p4 + allocate(a1, source='ABC') ! << ICE + if(len(a1) /= 3 .or. a1 /= 'ABC') call abort() + allocate(a4, source=4_'12345') ! << ICE + if(len(a4) /= 5 .or. a4 /= 4_'12345') call abort() + allocate(p1, mold='AB') ! << ICE + if(len(p1) /= 2) call abort() + allocate(p4, mold=4_'145') ! << ICE + if(len(p4) /= 3) call abort() + end subroutine source3 +end program test diff --git a/gcc/testsuite/gfortran.dg/deferred_type_param_2.f90 b/gcc/testsuite/gfortran.dg/deferred_type_param_2.f90 index 7bfd2a6ece0..8ac48c3f153 100644 --- a/gcc/testsuite/gfortran.dg/deferred_type_param_2.f90 +++ b/gcc/testsuite/gfortran.dg/deferred_type_param_2.f90 @@ -34,9 +34,9 @@ subroutine three() str1 = ["abc"] pstr2 => str1 - allocate (character(len=77) :: str1(1)) ! OK ! { dg-error "not yet implemented" } - allocate (pstr, source=str2) ! OK ! { dg-error "not yet implemented" } - allocate (pstr, mold=str2) ! { dg-error "requires either a type-spec or SOURCE tag" } + allocate (character(len=77) :: str1(1)) + allocate (pstr, source=str2) + allocate (pstr, mold=str2) allocate (pstr) ! { dg-error "requires either a type-spec or SOURCE tag" } allocate (character(len=:) :: str1(1)) ! { dg-error "cannot contain a deferred type parameter" } diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_3.f03 b/gcc/testsuite/gfortran.dg/realloc_on_assign_3.f03 new file mode 100644 index 00000000000..d975f472705 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_3.f03 @@ -0,0 +1,88 @@ +! { dg-do run } +! Test (re)allocation on assignment of scalars +! +! Contributed by Paul Thomas +! + call test_real + call test_derived + call test_char1 + call test_char4 + call test_deferred_char1 + call test_deferred_char4 +contains + subroutine test_real + real, allocatable :: x + real :: y = 42 + x = 42.0 + if (x .ne. y) call abort + deallocate (x) + x = y + if (x .ne. y) call abort + end subroutine + subroutine test_derived + type :: mytype + real :: x + character(4) :: c + end type + type (mytype), allocatable :: t + t = mytype (99.0, "abcd") + if (t%c .ne. "abcd") call abort + end subroutine + subroutine test_char1 + character(len = 8), allocatable :: c1 + character(len = 8) :: c2 = "abcd1234" + c1 = "abcd1234" + if (c1 .ne. c2) call abort + deallocate (c1) + c1 = c2 + if (c1 .ne. c2) call abort + end subroutine + subroutine test_char4 + character(len = 8, kind = 4), allocatable :: c1 + character(len = 8, kind = 4) :: c2 = 4_"abcd1234" + c1 = 4_"abcd1234" + if (c1 .ne. c2) call abort + deallocate (c1) + c1 = c2 + if (c1 .ne. c2) call abort + end subroutine + subroutine test_deferred_char1 + character(:), allocatable :: c + c = "Hello" + if (c .ne. "Hello") call abort + if (len(c) .ne. 5) call abort + c = "Goodbye" + if (c .ne. "Goodbye") call abort + if (len(c) .ne. 7) call abort +! Check that the hidden LEN dummy is passed by reference + call test_pass_c1 (c) + if (c .ne. "Made in test!") print *, c + if (len(c) .ne. 13) call abort + end subroutine + subroutine test_pass_c1 (carg) + character(:), allocatable :: carg + if (carg .ne. "Goodbye") call abort + if (len(carg) .ne. 7) call abort + carg = "Made in test!" + end subroutine + subroutine test_deferred_char4 + character(:, kind = 4), allocatable :: c + c = 4_"Hello" + if (c .ne. 4_"Hello") call abort + if (len(c) .ne. 5) call abort + c = 4_"Goodbye" + if (c .ne. 4_"Goodbye") call abort + if (len(c) .ne. 7) call abort +! Check that the hidden LEN dummy is passed by reference + call test_pass_c4 (c) + if (c .ne. 4_"Made in test!") print *, c + if (len(c) .ne. 13) call abort + end subroutine + subroutine test_pass_c4 (carg) + character(:, kind = 4), allocatable :: carg + if (carg .ne. 4_"Goodbye") call abort + if (len(carg) .ne. 7) call abort + carg = 4_"Made in test!" + end subroutine +end + diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_4.f03 b/gcc/testsuite/gfortran.dg/realloc_on_assign_4.f03 new file mode 100644 index 00000000000..a71f5d59bd1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_4.f03 @@ -0,0 +1,50 @@ +! { dg-do run } +! Tests function return of deferred length scalars. +! +! Contributed by Paul Thomas +! +module m +contains + function mfoo (carg) result(res) + character (:), allocatable :: res + character (*) :: carg + res = carg(2:4) + end function + function mbar (carg) + character (:), allocatable :: mbar + character (*) :: carg + mbar = carg(2:13) + end function +end module + + use m + character (:), allocatable :: lhs + lhs = foo ("foo calling ") + if (lhs .ne. "foo") call abort + if (len (lhs) .ne. 3) call abort + deallocate (lhs) + lhs = bar ("bar calling - baaaa!") + if (lhs .ne. "bar calling") call abort + if (len (lhs) .ne. 12) call abort + deallocate (lhs) + lhs = mfoo ("mfoo calling ") + if (lhs .ne. "foo") call abort + if (len (lhs) .ne. 3) call abort + deallocate (lhs) + lhs = mbar ("mbar calling - baaaa!") + if (lhs .ne. "bar calling") call abort + if (len (lhs) .ne. 12) call abort +contains + function foo (carg) result(res) + character (:), allocatable :: res + character (*) :: carg + res = carg(1:3) + end function + function bar (carg) + character (:), allocatable :: bar + character (*) :: carg + bar = carg(1:12) + end function +end + +