OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/45170 ([F2003] allocatable character lengths)

Browse Source 
2011-01-28  Paul Thomas  <pault@gcc.gnu.org>
	    Tobias Burnus  <burnus@gcc.gnu.org>

	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-28  Paul Thomas  <pault@gcc.gnu.org>
	    Tobias Burnus  <burnus@gcc.gnu.org>

	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.


Co-Authored-By: Tobias Burnus <burnus@gcc.gnu.org>

From-SVN: r169356
This commit is contained in:
Paul Thomas 2011-01-28 13:53:19 +00:00
parent c9f58b9add
commit 8d51f26f8e
15 changed files with 932 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
gcc/fortran/ChangeLog
View File

@ -1,3 +1,50 @@
2011-01-28 Paul Thomas <pault@gcc.gnu.org>
Tobias Burnus <burnus@gcc.gnu.org>
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 <burnus@net-b.de>
PR fortran/47474

7
gcc/fortran/gfortran.texi
View File

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

24
gcc/fortran/interface.c
View File

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

5
gcc/fortran/match.c
View File

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

14
gcc/fortran/module.c
View File

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

28
gcc/fortran/resolve.c
View File

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

144
gcc/fortran/trans-decl.c
View File

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

199
gcc/fortran/trans-expr.c
View File

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

66
gcc/fortran/trans-stmt.c
View File

@ -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 <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
@ -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;

36
gcc/fortran/trans-types.c
View File

@ -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 <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
@ -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);

14
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,17 @@
2011-01-28 Paul Thomas <pault@gcc.gnu.org>
Tobias Burnus <burnus@gcc.gnu.org>
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 <jh@suse.cz>
PR middle-end/46949

267
gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_1.f03 Normal file
View File

@ -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 <burnus@gcc.gnu.org>
!
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

6
gcc/testsuite/gfortran.dg/deferred_type_param_2.f90
View File

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

88
gcc/testsuite/gfortran.dg/realloc_on_assign_3.f03 Normal file
View File

@ -0,0 +1,88 @@
! { dg-do run }
! Test (re)allocation on assignment of scalars
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
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

50
gcc/testsuite/gfortran.dg/realloc_on_assign_4.f03 Normal file
View File

@ -0,0 +1,50 @@
! { dg-do run }
! Tests function return of deferred length scalars.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
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