===================================================================
*************** compare_actual_formal (gfc_actual_arglis
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
*************** compare_actual_formal (gfc_actual_arglis
{
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);
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);
return 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);
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);
return 0;
}
===================================================================
*************** gfc_conv_procedure_call (gfc_se * se, gf
}
end_pointer_check:
+ /* Deferred length dummys 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. */
*************** gfc_conv_procedure_call (gfc_se * se, gf
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)
cl.backend_decl = VEC_index (tree, stringargs, 0);
else
{
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 (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
{
*************** gfc_conv_procedure_call (gfc_se * se, gf
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);
*************** gfc_conv_procedure_call (gfc_se * se, gf
else
se->expr = var;
! se->string_length = len;
}
else
{
else
se->expr = var;
! if (!ts.deferred)
! se->string_length = len;
! else if (sym->attr.allocatable || sym->attr.pointer)
! se->string_length = cl.backend_decl;
}
else
{
*************** gfc_trans_pointer_assignment (gfc_expr *
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. */
if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
&& !expr1->symtree->n.sym->attr.proc_pointer
&& !gfc_is_proc_ptr_comp (expr1, NULL))
{
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. 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))
{
*************** gfc_trans_pointer_assignment (gfc_expr *
&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));
*************** 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);
}
*************** 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
*************** gfc_trans_assignment_1 (gfc_expr * expr1
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,
*************** gfc_trans_assignment_1 (gfc_expr * expr1
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_trans_assignment_1 (gfc_expr * expr1
gfc_add_expr_to_block (&body, tmp);
}
! /* Allocate or reallocate lhs of allocatable array. */
if (gfc_option.flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1)
&& !gfc_expr_attr (expr1).codimension
gfc_add_expr_to_block (&body, tmp);
}
! /* F2003: Allocate or reallocate lhs of allocatable array. */
if (gfc_option.flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1)
&& !gfc_expr_attr (expr1).codimension
*************** gfc_trans_assignment (gfc_expr * expr1,
{
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)
{
===================================================================
*************** type-specification with type parameter a
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
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.
@item Transferring of allocations via @code{MOVE_ALLOC}.
from a @code{SOURCE=} expression; @code{ALLOCATE} and @code{DEALLOCATE}
optionally return an error message string via @code{ERRMSG=}.
! @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, 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}.
===================================================================
***************
/* Statement translation -- generate GCC trees from gfc_code.
! Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
/* Statement translation -- generate GCC trees from gfc_code.
! 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>
*************** gfc_trans_allocate (gfc_code * code)
else
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
}
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;
!
/* Allocate - for non-pointers with re-alloc checking. */
{
gfc_ref *ref;
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)
! {
! 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;
===================================================================
*************** 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 ();
}
===================================================================
***************
/* Backend support for Fortran 95 basic types and derived types.
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
! 2010
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
/* Backend support for Fortran 95 basic types and derived types.
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>
*************** 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
*************** 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;
*************** 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);
}
/* Build the argument types for the function. */
typelist = gfc_chainon_list (typelist, type);
if (arg->ts.type == BT_CHARACTER)
! {
! 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. */
*************** 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
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. */
!
typelist = gfc_chainon_list (typelist, type);
}
else
*************** gfc_get_function_type (gfc_symbol * sym)
}
/* Add hidden string length parameters. */
! while (nstr--)
! typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
if (typelist)
typelist = chainon (typelist, void_list_node);
}
/* Add hidden string length parameters. */
! 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);
===================================================================
*************** resolve_contained_fntype (gfc_symbol *sy
if (sym->result->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->result->ts.u.cl;
! if (!cl || !cl->length)
{
/* See if this is a module-procedure and adapt error message
accordingly. */
if (sym->result->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->result->ts.u.cl;
! if ((!cl || !cl->length) && !sym->result->ts.deferred)
{
/* See if this is a module-procedure and adapt error message
accordingly. */
*************** 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)
{
*************** 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:
*************** resolve_fl_procedure (gfc_symbol *sym, i
}
/* 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)
gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
"CHARACTER(*) function '%s' at %L",
sym->name, &sym->declared_at);
}
/* Appendix B.2 of the standard. Contained functions give an
! 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);
*************** resolve_fl_derived (gfc_symbol *sym)
return FAILURE;
}
! if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
{
if (c->ts.u.cl->length == NULL
|| (resolve_charlen (c->ts.u.cl) == FAILURE)
return FAILURE;
}
! 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)
*************** 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)
===================================================================
*************** alloc_opt_list:
}
/* Check F03:C623, */
! if (saw_deferred && ts.type == BT_UNKNOWN && !source)
{
gfc_error ("Allocate-object at %L with a deferred type parameter "
! "requires either a type-spec or SOURCE tag", &deferred_locus);
goto cleanup;
}
}
/* Check F03:C623, */
! 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 or a MOLD tag",
! &deferred_locus);
goto cleanup;
}
===================================================================
***************
/* Backend function setup
! Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Paul Brook
/* Backend function setup
! Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
! 2011
Free Software Foundation, Inc.
Contributed by Paul Brook
*************** 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. */
*************** 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
*************** create_function_arglist (gfc_symbol * sy
{
/* 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,
*************** create_function_arglist (gfc_symbol * sy
{
tree len_type = TREE_VALUE (hidden_typelist);
tree length = NULL_TREE;
! gcc_assert (len_type == gfc_charlen_type_node);
strcpy (&name[1], f->sym->name);
name[0] = '_';
{
tree len_type = TREE_VALUE (hidden_typelist);
tree length = NULL_TREE;
! 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_trans_deferred_vars (gfc_symbol * pr
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. */
*************** gfc_trans_deferred_vars (gfc_symbol * pr
}
else if (proc_sym->ts.type == BT_CHARACTER)
{
! 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
}
else if (proc_sym->ts.type == BT_CHARACTER)
{
! 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
*************** gfc_trans_deferred_vars (gfc_symbol * pr
if (sym_has_alloc_comp && !seen_trans_deferred_array)
gfc_trans_deferred_array (sym, block);
}
! else if (!sym->attr.dummy
&& (sym->attr.allocatable
|| (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.allocatable)))
if (sym_has_alloc_comp && !seen_trans_deferred_array)
gfc_trans_deferred_array (sym, block);
}
! else if ((!sym->attr.dummy || sym->ts.deferred)
&& (sym->attr.allocatable
|| (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.allocatable)))
*************** gfc_trans_deferred_vars (gfc_symbol * pr
{
/* 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_trans_deferred_vars (gfc_symbol * pr
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));
/* Deallocate when leaving the scope. Nullifying is not
needed. */
! if (!sym->attr.result)
tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
NULL, sym->ts);
gfc_conv_expr (&se, e);
gfc_free_expr (e);
gfc_start_block (&init);
!
! 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 && !sym->attr.dummy)
tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
NULL, sym->ts);
*************** gfc_trans_deferred_vars (gfc_symbol * pr
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)
===================================================================
*************** 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 (pstr) ! { dg-error "requires either a type-spec or SOURCE tag" }
allocate (character(len=:) :: str1(1)) ! { dg-error "cannot contain a deferred type parameter" }
str1 = ["abc"]
pstr2 => str1
! 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" }
===================================================================
***************
+ ! { 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
===================================================================
***************
+ ! { 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
===================================================================
***************
+ ! { 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
===================================================================
***************
+ ! { 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
+