+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
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}.
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
{
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;
}
}
/* 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;
}
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 ();
}
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. */
&& sym->ts.u.cl
&& sym->ts.u.cl->length == NULL
&& !sym->attr.dummy
+ && !sym->ts.deferred
&& expr->value.function.esym == NULL
&& !sym->attr.contained)
{
}
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:
}
/* 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);
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)
}
}
+ 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)
/* 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
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. */
/* 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
{
/* 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,
{
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] = '_';
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. */
}
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
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)))
{
/* 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);
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);
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)
}
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. */
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
{
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);
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
{
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))
{
&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));
}
gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
- gcc_assert (se->string_length
- && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
}
}
+/* 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
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,
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);
}
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
{
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)
{
/* 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>
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;
/* 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>
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
if (sym->backend_decl)
return TREE_TYPE (sym->backend_decl);
- nstr = 0;
alternate_return = 0;
typelist = NULL_TREE;
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. */
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
}
/* 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);
+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
--- /dev/null
+! { 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
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" }
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
+
projects / thirdparty / gcc.git / commitdiff
