Status of allocatable components
Erik Edelmann
erik.edelmann@iki.fi
Sat Jul 29 18:19:00 GMT 2006
On Wed, Jul 26, 2006 at 11:18:48PM +0300, Erik Edelmann wrote:
> - trans-array.c (gfc_trans_deferred_array) for local
> variables on procedure entry.
>
> FIXME: The comment on this function needs to be changed
> slightly to reflect that it does DTWACs too.
Hm, actually, I think the comment is fine.
> - trans-array.c (gfc_array_allocate) for newly allocated
> arrays of DTWAC.
>
> CHECK: Shouldn't we do this for allocated scalars (e.g.
> pointers) too?
Yes, we should. Fixed.
> - trans-expr.c (gfc_conv_function_call) for arguments that
> are INTENT(OUT) or non-variable scalars (to be deallocated
> before the call), or function results (after the call).
>
> CHECK: Shouldn't non-variables be deallocated after the
> call too?
Yes, they should. Fixed.
> CHECK: Do we need the rename + move of the function resolve.c
> (expr_to_initialize) --> expr.c (gfc_expr_to_initialize)?
No, we don't. Change undone.
> FIXME: trans-array.c (copy_alloc_comp, deallocate_alloc_comp,
> nullify_alloc_comp) need a gfc_ prefix.
Fixed.
Latest version of the patch attached.
Erik
-------------- next part --------------
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 115800)
+++ gcc/fortran/interface.c (working copy)
@@ -374,6 +374,9 @@ gfc_compare_derived_types (gfc_symbol *
if (dt1->dimension != dt2->dimension)
return 0;
+ if (dt1->allocatable != dt2->allocatable)
+ return 0;
+
if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
return 0;
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c (revision 115800)
+++ gcc/fortran/intrinsic.c (working copy)
@@ -2354,6 +2354,11 @@ add_subroutines (void)
length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
trim_name, BT_LOGICAL, dl, OPTIONAL);
+ add_sym_2s ("move_alloc", 0, 0, BT_UNKNOWN, 0, GFC_STD_F2003,
+ gfc_check_move_alloc, NULL, NULL,
+ f, BT_UNKNOWN, 0, REQUIRED,
+ t, BT_UNKNOWN, 0, REQUIRED);
+
add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95,
gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (revision 115800)
+++ gcc/fortran/trans-array.c (working copy)
@@ -3316,6 +3316,13 @@ gfc_array_allocate (gfc_se * se, gfc_exp
tmp = gfc_conv_descriptor_offset (se->expr);
gfc_add_modify_expr (&se->pre, tmp, offset);
+ if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
+ {
+ tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
+ ref->u.ar.as->rank);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
return true;
}
@@ -3456,6 +3463,9 @@ gfc_conv_array_initializer (tree type, g
}
break;
+ case EXPR_NULL:
+ return gfc_build_null_descriptor (type);
+
default:
gcc_unreachable ();
}
@@ -4538,6 +4548,17 @@ gfc_conv_array_parameter (gfc_se * se, g
se->want_pointer = 1;
gfc_conv_expr_descriptor (se, expr, ss);
+ /* Deallocate the allocatable components of structures that are
+ not variable. */
+ if (expr->ts.type == BT_DERIVED
+ && expr->ts.derived->attr.alloc_comp
+ && expr->expr_type != EXPR_VARIABLE)
+ {
+ tmp = build_fold_indirect_ref (se->expr);
+ tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
+ gfc_add_expr_to_block (&se->post, tmp);
+ }
+
if (g77)
{
desc = se->expr;
@@ -4586,21 +4607,293 @@ tree
gfc_trans_dealloc_allocated (tree descriptor)
{
tree tmp;
- tree deallocate;
+ tree ptr;
+ tree var;
stmtblock_t block;
gfc_start_block (&block);
- deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
- tmp = gfc_conv_descriptor_data_get (descriptor);
- tmp = build2 (NE_EXPR, boolean_type_node, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
- tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
+ tmp = gfc_conv_descriptor_data_addr (descriptor);
+ var = gfc_evaluate_now (tmp, &block);
+ tmp = gfc_create_var (gfc_array_index_type, NULL);
+ ptr = build_fold_addr_expr (tmp);
+
+ /* Call array_deallocate with an int* present in the second argument.
+ Although it is ignored here, it's presence ensures that arrays that
+ are already deallocated are ignored. */
+ tmp = gfc_chainon_list (NULL_TREE, var);
+ tmp = gfc_chainon_list (tmp, ptr);
+ tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
gfc_add_expr_to_block (&block, tmp);
+ return gfc_finish_block (&block);
+}
- tmp = gfc_finish_block (&block);
- return tmp;
+/* This helper function calculates the size in words of a full array. */
+
+static tree
+get_full_array_size (stmtblock_t *block, tree decl, int rank)
+{
+ tree idx;
+ tree nelems;
+ tree tmp;
+ idx = gfc_rank_cst[rank - 1];
+ nelems = gfc_conv_descriptor_ubound (decl, idx);
+ tmp = gfc_conv_descriptor_lbound (decl, idx);
+ tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
+ tmp = build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ tmp = gfc_evaluate_now (tmp, block);
+
+ nelems = gfc_conv_descriptor_stride (decl, idx);
+ tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
+ return gfc_evaluate_now (tmp, block);
+}
+
+
+/* Recursively traverse an object of derived type, generating code to deallocate,
+ nullify or copy allocatable components. This is the work horse function for
+ the functions named in this enum. */
+enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
+
+static tree
+structure_alloc_comps (gfc_symbol * der_type, tree decl,
+ tree dest, int rank, int purpose)
+{
+ gfc_component *c;
+ gfc_loopinfo loop;
+ stmtblock_t fnblock;
+ stmtblock_t loopbody;
+ tree tmp;
+ tree comp;
+ tree dcmp;
+ tree nelems;
+ tree index;
+ tree var;
+ tree cdecl;
+ tree ctype;
+
+ gfc_init_block (&fnblock);
+
+ /* If this an array of derived types with allocatable components
+ build a loop and recursively call this function. */
+ if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
+ || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ {
+ tmp = gfc_conv_array_data (decl);
+ var = build_fold_indirect_ref (tmp);
+
+ /* Get the number of elements - 1 and set the counter. */
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ {
+ /* Use the descriptor for an allocatable array. Since this
+ is a full array reference, we only need the descriptor
+ information from dimension = rank. */
+ nelems = get_full_array_size (&fnblock, decl, rank);
+
+ /* Set the result to -1 if already deallocated, so that the
+ loop does not run. */
+ tmp = gfc_conv_descriptor_data_get (decl);
+ tmp = build2 (NE_EXPR, boolean_type_node, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+ tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
+ nelems, gfc_index_zero_node);
+ tmp = gfc_evaluate_now (tmp, &fnblock);
+ tmp = build2 (MINUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ }
+ else
+ {
+ /* Otherwise use the TYPE_DOMAIN information. */
+ tmp = array_type_nelts (TREE_TYPE (decl));
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ }
+
+ nelems = gfc_evaluate_now (tmp, &fnblock);
+ index = gfc_create_var (gfc_array_index_type, "S");
+
+ /* Build the body of the loop. */
+ gfc_init_block (&loopbody);
+
+ tmp = gfc_build_array_ref (var, index);
+
+ if (purpose == COPY_ALLOC_COMP)
+ tmp = structure_alloc_comps (der_type, tmp,
+ gfc_build_array_ref (dest, index),
+ 0, purpose);
+ else
+ tmp = structure_alloc_comps (der_type, tmp, NULL_TREE, 0, purpose);
+
+ gfc_add_expr_to_block (&loopbody, tmp);
+
+ /* Build the loop and return. */
+ gfc_init_loopinfo (&loop);
+ loop.dimen = 1;
+ loop.from[0] = gfc_index_zero_node;
+ loop.loopvar[0] = index;
+ loop.to[0] = nelems;
+ gfc_trans_scalarizing_loops (&loop, &loopbody);
+ gfc_add_block_to_block (&fnblock, &loop.pre);
+ return gfc_finish_block (&fnblock);
+ }
+
+ /* Otherwise, deallocate the components or recursively call self to
+ deallocate the components of components. */
+ for (c = der_type->components; c; c = c->next)
+ {
+ cdecl = c->backend_decl;
+ ctype = TREE_TYPE (cdecl);
+
+ switch (purpose)
+ {
+ case DEALLOCATE_ALLOC_COMP:
+ /* Do not deallocate the components of ultimate pointer
+ components. */
+ if (c->ts.type == BT_DERIVED
+ && c->ts.derived->attr.alloc_comp
+ && !c->pointer)
+ {
+ comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ rank = c->as ? c->as->rank : 0;
+ tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
+ rank, purpose);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+
+ if (c->allocatable)
+ {
+ comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ tmp = gfc_trans_dealloc_allocated (comp);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ break;
+
+ case NULLIFY_ALLOC_COMP:
+ if (c->pointer)
+ continue;
+ else if (c->allocatable)
+ {
+ comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
+ }
+ else if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
+ {
+ comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ rank = c->as ? c->as->rank : 0;
+ tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
+ rank, purpose);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ break;
+
+ case COPY_ALLOC_COMP:
+ if (c->pointer)
+ continue;
+
+ comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
+ dcmp = fold_convert (TREE_TYPE (comp), dcmp);
+
+ if (c->allocatable)
+ {
+ tree size;
+ tree args;
+ tree null_cond;
+ tree null_data;
+ stmtblock_t block;
+
+ /* If the source is null, set the destination to null. */
+ gfc_init_block (&block);
+ gfc_conv_descriptor_data_set (&block, dcmp,
+ null_pointer_node);
+ null_data = gfc_finish_block (&block);
+
+ gfc_init_block (&block);
+ nelems = get_full_array_size (&block, comp, c->as->rank);
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
+ TYPE_SIZE_UNIT (gfc_get_element_type (ctype)));
+
+ /* Allocate memory to the destination. */
+ tmp = gfc_chainon_list (NULL_TREE, size);
+ if (gfc_index_integer_kind == 4)
+ tmp = build_function_call_expr (gfor_fndecl_internal_malloc, tmp);
+ else if (gfc_index_integer_kind == 8)
+ tmp = build_function_call_expr (gfor_fndecl_internal_malloc64, tmp);
+ else
+ gcc_unreachable ();
+ tmp = fold (convert (TREE_TYPE (gfc_conv_descriptor_data_get (comp)),
+ tmp));
+ gfc_conv_descriptor_data_set (&block, dcmp, tmp);
+
+ /* We know the temporary and the value will be the same length,
+ so can use memcpy. */
+ tmp = gfc_conv_descriptor_data_get (dcmp);
+ args = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = gfc_conv_descriptor_data_get (comp);
+ args = gfc_chainon_list (args, tmp);
+ args = gfc_chainon_list (args, size);
+ tmp = built_in_decls[BUILT_IN_MEMCPY];
+ tmp = build_function_call_expr (tmp, args);
+ gfc_add_expr_to_block (&block, tmp);
+ tmp = gfc_finish_block (&block);
+
+ /* Null the destination if the source is null; otherwise do
+ the allocate and copy. */
+ null_cond = gfc_conv_descriptor_data_get (comp);
+ null_cond = convert (pvoid_type_node, null_cond);
+ null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
+ null_pointer_node);
+ tmp = build3_v (COND_EXPR, null_cond, tmp, null_data);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+
+ if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
+ {
+ rank = c->as ? c->as->rank : 0;
+ tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
+ rank, purpose);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ break;
+
+ default:
+ gcc_unreachable ();
+ break;
+ }
+ }
+
+ return gfc_finish_block (&fnblock);
+}
+
+/* Recursively traverse an object of derived type, generating code to
+ nullify allocatable components. */
+
+tree
+gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
+{
+ return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+ NULLIFY_ALLOC_COMP);
+}
+
+
+/* Recursively traverse an object of derived type, generating code to
+ deallocate allocatable components. */
+
+tree
+gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
+{
+ return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+ DEALLOCATE_ALLOC_COMP);
+}
+
+
+/* Recursively traverse an object of derived type, generating code to
+ copy its allocatable components. */
+
+tree
+gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
+{
+ return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
}
@@ -4614,16 +4907,18 @@ gfc_trans_deferred_array (gfc_symbol * s
tree descriptor;
stmtblock_t fnblock;
locus loc;
+ int rank;
/* Make sure the frontend gets these right. */
- if (!(sym->attr.pointer || sym->attr.allocatable))
- fatal_error
- ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
+ if (!(sym->attr.pointer || sym->attr.allocatable
+ || (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)))
+ fatal_error ("Possible frontend bug: Deferred array size without pointer"
+ "allocatable attribute.");
gfc_init_block (&fnblock);
gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
- || TREE_CODE (sym->backend_decl) == PARM_DECL);
+ || TREE_CODE (sym->backend_decl) == PARM_DECL);
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
@@ -4653,22 +4948,43 @@ gfc_trans_deferred_array (gfc_symbol * s
/* Get the descriptor type. */
type = TREE_TYPE (sym->backend_decl);
- if (!GFC_DESCRIPTOR_TYPE_P (type))
+
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.derived->attr.alloc_comp
+ && !(sym->attr.pointer || sym->attr.allocatable))
+ {
+ rank = sym->as ? sym->as->rank : 0;
+ tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ else if (!GFC_DESCRIPTOR_TYPE_P (type))
{
/* If the backend_decl is not a descriptor, we must have a pointer
to one. */
descriptor = build_fold_indirect_ref (sym->backend_decl);
type = TREE_TYPE (descriptor);
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
}
-
+
/* NULLIFY the data pointer. */
- gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
+ if (GFC_DESCRIPTOR_TYPE_P (type))
+ gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
gfc_add_expr_to_block (&fnblock, body);
gfc_set_backend_locus (&loc);
- /* Allocatable arrays need to be freed when they go out of scope. */
+
+ /* Allocatable arrays need to be freed when they go out of scope.
+ The allocatable components of pointers must not be touched. */
+ if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp
+ && !(sym->attr.function || sym->attr.result)
+ && !sym->attr.pointer)
+ {
+ int rank;
+ rank = sym->as ? sym->as->rank : 0;
+ tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+
if (sym->attr.allocatable)
{
tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 115800)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -42,7 +42,7 @@ Software Foundation, 51 Franklin Street,
#include "trans-stmt.h"
#include "dependency.h"
-static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
+static tree gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr);
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
gfc_expr *);
@@ -1702,7 +1702,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, g
if (intent != INTENT_OUT)
{
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
gfc_add_expr_to_block (&body, tmp);
gcc_assert (rse.ss == gfc_ss_terminator);
gfc_trans_scalarizing_loops (&loop, &body);
@@ -1787,7 +1787,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, g
gcc_assert (lse.ss == gfc_ss_terminator);
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
gfc_add_expr_to_block (&body, tmp);
/* Generate the copying loops. */
@@ -1859,6 +1859,7 @@ gfc_conv_function_call (gfc_se * se, gfc
gfc_ss *argss;
gfc_ss_info *info;
int byref;
+ int parm_kind;
tree type;
tree var;
tree len;
@@ -1872,6 +1873,7 @@ gfc_conv_function_call (gfc_se * se, gfc
gfc_expr *e;
gfc_symbol *fsym;
stmtblock_t post;
+ enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
arglist = NULL_TREE;
retargs = NULL_TREE;
@@ -1914,6 +1916,7 @@ gfc_conv_function_call (gfc_se * se, gfc
{
e = arg->expr;
fsym = formal ? formal->sym : NULL;
+ parm_kind = MISSING;
if (e == NULL)
{
@@ -1942,6 +1945,7 @@ gfc_conv_function_call (gfc_se * se, gfc
/* An elemental function inside a scalarized loop. */
gfc_init_se (&parmse, se);
gfc_conv_expr_reference (&parmse, e);
+ parm_kind = ELEMENTAL;
}
else
{
@@ -1952,12 +1956,14 @@ gfc_conv_function_call (gfc_se * se, gfc
if (argss == gfc_ss_terminator)
{
gfc_conv_expr_reference (&parmse, e);
+ parm_kind = SCALAR;
if (fsym && fsym->attr.pointer
&& e->expr_type != EXPR_NULL)
{
/* Scalar pointer dummy args require an extra level of
indirection. The null pointer already contains
this level of indirection. */
+ parm_kind = SCALAR_POINTER;
parmse.expr = build_fold_addr_expr (parmse.expr);
}
}
@@ -2014,6 +2020,49 @@ gfc_conv_function_call (gfc_se * se, gfc
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&post, &parmse.post);
+ /* Allocated allocatable components of derived types must be
+ deallocated for INTENT(OUT) dummy arguments and non-variable
+ scalars. Non-variable arrays are dealt with in trans-array.c
+ (gfc_conv_array_parameter). */
+ if (e && e->ts.type == BT_DERIVED
+ && e->ts.derived->attr.alloc_comp
+ && ((formal && formal->sym->attr.intent == INTENT_OUT)
+ ||
+ (e->expr_type != EXPR_VARIABLE && !e->rank)))
+ {
+ int parm_rank;
+ tmp = build_fold_indirect_ref (parmse.expr);
+ parm_rank = e->rank;
+ switch (parm_kind)
+ {
+ case (ELEMENTAL):
+ case (SCALAR):
+ parm_rank = 0;
+ break;
+
+ case (SCALAR_POINTER):
+ tmp = build_fold_indirect_ref (tmp);
+ break;
+ case (ARRAY):
+ tmp = parmse.expr;
+ break;
+ }
+
+ tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
+ if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
+ tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
+ tmp, build_empty_stmt ());
+
+ if (e->expr_type != EXPR_VARIABLE)
+ /* Don't deallocate non-variables until they have been used. */
+ gfc_add_expr_to_block (&se->post, tmp);
+ else
+ {
+ gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+ }
+
/* Character strings are passed as two parameters, a length and a
pointer. */
if (parmse.string_length != NULL_TREE)
@@ -2590,7 +2639,7 @@ gfc_trans_subarray_assign (tree dest, gf
gfc_conv_expr (&rse, expr);
- tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
gfc_add_expr_to_block (&body, tmp);
gcc_assert (rse.ss == gfc_ss_terminator);
@@ -2614,14 +2663,24 @@ gfc_trans_subarray_assign (tree dest, gf
/* Assign a single component of a derived type constructor. */
static tree
-gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
+gfc_trans_subcomponent_assign (gfc_se * outer_se, tree dest,
+ gfc_component * cm, gfc_expr * expr)
{
gfc_se se;
+ gfc_se lse;
gfc_ss *rss;
stmtblock_t block;
tree tmp;
+ tree offset;
+ int n;
gfc_start_block (&block);
+
+#if 0
+ if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
+ gfc_todo_error ("derived types with allocatable components as "
+ "arguments of derived type constructors");
+#endif
if (cm->pointer)
{
gfc_init_se (&se, NULL);
@@ -2654,20 +2713,85 @@ gfc_trans_subcomponent_assign (tree dest
}
else if (cm->dimension)
{
- tmp = gfc_trans_subarray_assign (dest, cm, expr);
- gfc_add_expr_to_block (&block, tmp);
+ if (cm->allocatable && expr->expr_type == EXPR_NULL)
+ gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+ else if (cm->allocatable)
+ {
+ tree tmp2;
+
+ gfc_init_se (&se, NULL);
+ gfc_init_se (&lse, NULL);
+
+ se.want_pointer = 0;
+ gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
+ if (cm->ts.type == BT_CHARACTER)
+ lse.string_length = cm->ts.cl->backend_decl;
+
+ lse.expr = dest;
+
+ /* Clean up temporaries at the right time. */
+ if (expr->expr_type == EXPR_FUNCTION)
+ {
+ stmtblock_t tmp_block;
+
+ /* Prevent the freeing of the memory after the array assignment to
+ the derived type component.... */
+ gfc_init_block (&tmp_block);
+ gfc_add_block_to_block (&tmp_block, &se.post);
+ gfc_conv_descriptor_data_set (&se.post, se.expr, null_pointer_node);
+ gfc_add_block_to_block (&se.post, &tmp_block);
+
+ /* ...and do it when the derived type is completed. */
+ tmp = gfc_conv_descriptor_data_get (lse.expr);
+ tmp = convert (pvoid_type_node, tmp);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
+ gfc_add_expr_to_block (&outer_se->post, tmp);
+ }
+
+ tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
+ gfc_add_expr_to_block (&block, tmp);
+
+ /* Shift the lbound and ubound of temporaries to being unity, rather
+ than zero, based. Calculate the offset for all cases. */
+ offset = gfc_conv_descriptor_offset (dest);
+ gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
+ tmp2 =gfc_create_var (gfc_array_index_type, NULL);
+ for (n = 0; n < expr->rank; n++)
+ {
+ if (expr->expr_type != EXPR_VARIABLE
+ && expr->expr_type != EXPR_CONSTANT)
+ {
+ tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
+ gfc_add_modify_expr (&block, tmp,
+ fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node));
+ tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
+ gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
+ }
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]),
+ gfc_conv_descriptor_stride (dest, gfc_rank_cst[n]));
+ gfc_add_modify_expr (&block, tmp2, tmp);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
+ gfc_add_modify_expr (&block, offset, tmp);
+ }
+ }
+ else
+ {
+ tmp = gfc_trans_subarray_assign (dest, cm, expr);
+ gfc_add_expr_to_block (&block, tmp);
+ }
}
else if (expr->ts.type == BT_DERIVED)
{
/* Nested derived type. */
- tmp = gfc_trans_structure_assign (dest, expr);
+ tmp = gfc_trans_structure_assign (outer_se, dest, expr);
gfc_add_expr_to_block (&block, tmp);
}
else
{
/* Scalar component. */
- gfc_se lse;
-
gfc_init_se (&se, NULL);
gfc_init_se (&lse, NULL);
@@ -2675,7 +2799,7 @@ gfc_trans_subcomponent_assign (tree dest
if (cm->ts.type == BT_CHARACTER)
lse.string_length = cm->ts.cl->backend_decl;
lse.expr = dest;
- tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
+ tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
@@ -2684,7 +2808,7 @@ gfc_trans_subcomponent_assign (tree dest
/* Assign a derived type constructor to a variable. */
static tree
-gfc_trans_structure_assign (tree dest, gfc_expr * expr)
+gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr)
{
gfc_constructor *c;
gfc_component *cm;
@@ -2702,7 +2826,7 @@ gfc_trans_structure_assign (tree dest, g
field = cm->backend_decl;
tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
- tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
+ tmp = gfc_trans_subcomponent_assign (outer_se, tmp, cm, c->expr);
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
@@ -2729,7 +2853,7 @@ gfc_conv_structure (gfc_se * se, gfc_exp
{
/* Create a temporary variable and fill it in. */
se->expr = gfc_create_var (type, expr->ts.derived->name);
- tmp = gfc_trans_structure_assign (se->expr, expr);
+ tmp = gfc_trans_structure_assign (se, se->expr, expr);
gfc_add_expr_to_block (&se->pre, tmp);
return;
}
@@ -3036,13 +3160,16 @@ gfc_conv_string_parameter (gfc_se * se)
strings. */
tree
-gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
+gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
+ bool l_is_temp, bool r_is_var)
{
stmtblock_t block;
+ tree tmp;
+ tree cond;
gfc_init_block (&block);
- if (type == BT_CHARACTER)
+ if (ts.type == BT_CHARACTER)
{
gcc_assert (lse->string_length != NULL_TREE
&& rse->string_length != NULL_TREE);
@@ -3056,6 +3183,50 @@ gfc_trans_scalar_assign (gfc_se * lse, g
gfc_trans_string_copy (&block, lse->string_length, lse->expr,
rse->string_length, rse->expr);
}
+ else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
+ {
+ cond = NULL_TREE;
+
+ /* Are the rhs and the lhs the same? */
+ if (r_is_var)
+ {
+ cond = fold_build2 (EQ_EXPR, boolean_type_node,
+ build_fold_addr_expr (lse->expr),
+ build_fold_addr_expr (rse->expr));
+ cond = gfc_evaluate_now (cond, &lse->pre);
+ }
+
+ /* Deallocate the lhs allocated components as long as it is not
+ the same as the rhs. */
+ if (!l_is_temp)
+ {
+ tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
+ if (r_is_var)
+ tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
+ gfc_add_expr_to_block (&lse->pre, tmp);
+ }
+
+ gfc_add_block_to_block (&block, &lse->pre);
+ gfc_add_block_to_block (&block, &rse->pre);
+
+ gfc_add_modify_expr (&block, lse->expr,
+ fold_convert (TREE_TYPE (lse->expr), rse->expr));
+
+ /* Do a deep copy if the rhs is a variable, as long as it is not the
+ same as the lhs. Otherwise, nullify the data fields so that the
+ lhs retains the allocated resources. */
+ if (r_is_var)
+ {
+ tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
+ tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ {
+ tmp = gfc_nullify_alloc_comp (ts.derived, rse->expr, 0);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ }
else
{
gfc_add_block_to_block (&block, &lse->pre);
@@ -3250,7 +3421,9 @@ gfc_trans_assignment (gfc_expr * expr1,
else
gfc_conv_expr (&lse, expr1);
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+ loop.temp_ss != NULL,
+ expr2->expr_type == EXPR_VARIABLE);
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)
@@ -3283,9 +3456,10 @@ gfc_trans_assignment (gfc_expr * expr1,
gcc_assert (lse.ss == gfc_ss_terminator
&& rse.ss == gfc_ss_terminator);
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
gfc_add_expr_to_block (&body, tmp);
}
+
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop, &body);
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 115800)
+++ gcc/fortran/symbol.c (working copy)
@@ -1523,6 +1523,7 @@ gfc_set_component_attr (gfc_component *
c->dimension = attr->dimension;
c->pointer = attr->pointer;
+ c->allocatable = attr->allocatable;
}
@@ -1536,6 +1537,7 @@ gfc_get_component_attr (symbol_attribute
gfc_clear_attr (attr);
attr->dimension = c->dimension;
attr->pointer = c->pointer;
+ attr->allocatable = c->allocatable;
}
Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h (revision 115800)
+++ gcc/fortran/intrinsic.h (working copy)
@@ -150,6 +150,7 @@ try gfc_check_free (gfc_expr *);
try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_gerror (gfc_expr *);
try gfc_check_getlog (gfc_expr *);
+try gfc_check_move_alloc (gfc_expr *, gfc_expr *);
try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
try gfc_check_random_number (gfc_expr *);
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 115800)
+++ gcc/fortran/decl.c (working copy)
@@ -963,14 +963,31 @@ build_struct (const char *name, gfc_char
/* Check array components. */
if (!c->dimension)
- return SUCCESS;
+ {
+ if (c->allocatable)
+ {
+ gfc_error ("Allocatable component at %C must be an array");
+ return FAILURE;
+ }
+ else
+ return SUCCESS;
+ }
if (c->pointer)
{
if (c->as->type != AS_DEFERRED)
{
- gfc_error ("Pointer array component of structure at %C "
- "must have a deferred shape");
+ gfc_error ("Pointer array component of structure at %C must have a "
+ "deferred shape");
+ return FAILURE;
+ }
+ }
+ else if (c->allocatable)
+ {
+ if (c->as->type != AS_DEFERRED)
+ {
+ gfc_error ("Allocatable component of structure at %C must have a "
+ "deferred shape");
return FAILURE;
}
}
@@ -2142,11 +2159,24 @@ match_attr_spec (void)
&& d != DECL_DIMENSION && d != DECL_POINTER
&& d != DECL_COLON && d != DECL_NONE)
{
-
- gfc_error ("Attribute at %L is not allowed in a TYPE definition",
- &seen_at[d]);
- m = MATCH_ERROR;
- goto cleanup;
+ if (d == DECL_ALLOCATABLE)
+ {
+ if (gfc_notify_std (GFC_STD_F2003,
+ "In the selected standard, the ALLOCATABLE "
+ "attribute at %C is not allowed in a TYPE "
+ "definition") == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
+ else
+ {
+ gfc_error ("Attribute at %L is not allowed in a TYPE definition",
+ &seen_at[d]);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
}
if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h (revision 115800)
+++ gcc/fortran/trans-array.h (working copy)
@@ -43,6 +43,13 @@ tree gfc_trans_dummy_array_bias (gfc_sym
tree gfc_trans_g77_array (gfc_symbol *, tree);
/* Generate code to deallocate an array, if it is allocated. */
tree gfc_trans_dealloc_allocated (tree);
+
+tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
+
+tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int);
+
+tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int);
+
/* Add initialization for deferred arrays. */
tree gfc_trans_deferred_array (gfc_symbol *, tree);
/* Generate an initializer for a static pointer or allocatable array. */
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 115800)
+++ gcc/fortran/gfortran.h (working copy)
@@ -528,6 +528,9 @@ typedef struct
/* Special attributes for Cray pointers, pointees. */
unsigned cray_pointer:1, cray_pointee:1;
+ /* The symbol is a derived type with allocatable components, possibly nested.
+ */
+ unsigned alloc_comp:1;
}
symbol_attribute;
@@ -645,7 +648,7 @@ typedef struct gfc_component
const char *name;
gfc_typespec ts;
- int pointer, dimension;
+ int pointer, allocatable, dimension;
gfc_array_spec *as;
tree backend_decl;
@@ -1965,6 +1968,7 @@ void gfc_resolve_omp_do_blocks (gfc_code
void gfc_free_actual_arglist (gfc_actual_arglist *);
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
const char *gfc_extract_int (gfc_expr *, int *);
+gfc_expr *gfc_expr_to_initialize (gfc_expr *);
gfc_expr *gfc_build_conversion (gfc_expr *);
void gfc_free_ref_list (gfc_ref *);
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 115800)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -1796,7 +1796,7 @@ generate_loop_for_temp_to_lhs (gfc_expr
gfc_conv_expr (&lse, expr);
/* Use the scalar assignment. */
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
/* Form the mask expression according to the mask tree list. */
if (wheremask)
@@ -1891,7 +1891,7 @@ generate_loop_for_rhs_to_temp (gfc_expr
}
/* Use the scalar assignment. */
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, false, false);
/* Form the mask expression according to the mask tree list. */
if (wheremask)
@@ -2972,7 +2972,8 @@ gfc_trans_where_assign (gfc_expr *expr1,
maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
/* Use the scalar assignment as is. */
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+ loop.temp_ss != NULL, false);
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
@@ -3025,7 +3026,7 @@ gfc_trans_where_assign (gfc_expr *expr1,
maskexpr);
/* Use the scalar assignment as is. */
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
@@ -3400,8 +3401,8 @@ gfc_trans_where_3 (gfc_code * cblock, gf
gfc_conv_expr (&edse, edst);
}
- tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts.type);
- estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts.type)
+ tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
+ estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
: build_empty_stmt ();
tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
gfc_add_expr_to_block (&body, tmp);
@@ -3585,6 +3586,14 @@ gfc_trans_allocate (gfc_code * code)
parm, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se.pre, tmp);
}
+
+ if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
+ {
+ tmp = build_fold_indirect_ref (se.expr);
+ tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ }
+
}
tmp = gfc_finish_block (&se.pre);
@@ -3669,6 +3678,26 @@ gfc_trans_deallocate (gfc_code * code)
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
+ if (expr->ts.type == BT_DERIVED
+ && expr->ts.derived->attr.alloc_comp)
+ {
+ gfc_ref *ref;
+ gfc_ref *last = NULL;
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ last = ref;
+
+ /* Do not deallocate the components of a derived type
+ ultimate pointer component. */
+ if (!(last && last->u.c.component->pointer)
+ && !(!last && expr->symtree->n.sym->attr.pointer))
+ {
+ tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
+ expr->rank);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ }
+ }
+
if (expr->rank)
tmp = gfc_array_deallocate (se.expr, pstat);
else
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 115800)
+++ gcc/fortran/module.c (working copy)
@@ -1435,7 +1435,7 @@ typedef enum
AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON,
AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,
- AB_CRAY_POINTEE, AB_THREADPRIVATE
+ AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP
}
ab_attribute;
@@ -1465,6 +1465,8 @@ static const mstring attr_bits[] =
minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
minit ("CRAY_POINTER", AB_CRAY_POINTER),
minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
+ minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
+ minit ("ALLOC_COMP", AB_ALLOC_COMP),
minit (NULL, -1)
};
@@ -1556,6 +1558,9 @@ mio_symbol_attribute (symbol_attribute *
if (attr->cray_pointee)
MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);
+ if (attr->alloc_comp)
+ MIO_NAME(ab_attribute) (AB_ALLOC_COMP, attr_bits);
+
mio_rparen ();
}
@@ -1644,6 +1649,9 @@ mio_symbol_attribute (symbol_attribute *
case AB_CRAY_POINTEE:
attr->cray_pointee = 1;
break;
+ case AB_ALLOC_COMP:
+ attr->alloc_comp = 1;
+ break;
}
}
}
@@ -1951,6 +1959,7 @@ mio_component (gfc_component * c)
mio_integer (&c->dimension);
mio_integer (&c->pointer);
+ mio_integer (&c->allocatable);
mio_expr (&c->initializer);
mio_rparen ();
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c (revision 115800)
+++ gcc/fortran/trans-types.c (working copy)
@@ -1547,7 +1547,7 @@ gfc_get_derived_type (gfc_symbol * deriv
required. */
if (c->dimension)
{
- if (c->pointer)
+ if (c->pointer || c->allocatable)
{
/* Pointers to arrays aren't actually pointer types. The
descriptors are separate, but the data is common. */
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 115800)
+++ gcc/fortran/trans.h (working copy)
@@ -307,7 +307,7 @@ int gfc_conv_function_call (gfc_se *, gf
/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
/* Generate code for a scalar assignment. */
-tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, bt);
+tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool);
/* Translate COMMON blocks. */
void gfc_trans_common (gfc_namespace *);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 115800)
+++ gcc/fortran/resolve.c (working copy)
@@ -911,13 +911,12 @@ resolve_actual_arglist (gfc_actual_argli
/* Do the checks of the actual argument list that are specific to elemental
- procedures. If called with c == NULL, we have a function, otherwise if
- expr == NULL, we have a subroutine. */
+ procedures. */
static try
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
{
- gfc_actual_arglist *arg0;
- gfc_actual_arglist *arg;
+ gfc_actual_arglist * arg0;
+ gfc_actual_arglist * arg;
gfc_symbol *esym = NULL;
gfc_intrinsic_sym *isym = NULL;
gfc_expr *e = NULL;
@@ -928,7 +927,6 @@ resolve_elemental_actual (gfc_expr *expr
int i;
int rank = 0;
- /* Is this an elemental procedure? */
if (expr && expr->value.function.actual != NULL)
{
if (expr->value.function.esym != NULL
@@ -965,7 +963,7 @@ resolve_elemental_actual (gfc_expr *expr
&& arg->expr->symtree->n.sym->attr.optional)
set_by_optional = true;
- /* Function specific; set the result rank and shape. */
+ /* Function specific. */
if (expr)
{
expr->rank = rank;
@@ -1007,7 +1005,7 @@ resolve_elemental_actual (gfc_expr *expr
else if (isym)
formal_optional = true;
- if (arg->expr != NULL
+ if (arg->expr !=NULL
&& arg->expr->expr_type == EXPR_VARIABLE
&& arg->expr->symtree->n.sym->attr.optional
&& formal_optional
@@ -3301,7 +3299,8 @@ resolve_deallocate_expr (gfc_expr * e)
/* Given the expression node e for an allocatable/pointer of derived type to be
allocated, get the expression node to be initialized afterwards (needed for
- derived types with default initializers). */
+ derived types with default initializers, and derived types with allocatable
+ components that need nullification.) */
static gfc_expr *
expr_to_initialize (gfc_expr * e)
@@ -3410,8 +3409,7 @@ resolve_allocate_expr (gfc_expr * e, gfc
init_st->loc = code->loc;
init_st->op = EXEC_ASSIGN;
init_st->expr = expr_to_initialize (e);
- init_st->expr2 = init_e;
-
+ init_st->expr2 = init_e;
init_st->next = code->next;
code->next = init_st;
}
@@ -4020,6 +4018,13 @@ resolve_transfer (gfc_code * code)
return;
}
+ if (ts->derived->attr.alloc_comp)
+ {
+ gfc_error ("Data transfer element at %L cannot have "
+ "ALLOCATABLE components", &code->loc);
+ return;
+ }
+
if (derived_inaccessible (ts->derived))
{
gfc_error ("Data transfer element at %L cannot have "
@@ -5390,7 +5395,7 @@ resolve_fl_derived (gfc_symbol *sym)
return FAILURE;
}
- if (c->pointer || c->as == NULL)
+ if (c->pointer || c->allocatable || c->as == NULL)
continue;
for (i = 0; i < c->as->rank; i++)
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 115800)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -945,6 +945,9 @@ gfc_get_symbol_decl (gfc_symbol * sym)
GFC_DECL_PACKED_ARRAY (decl) = 1;
}
+ if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
+ gfc_defer_symbol_init (sym);
+
gfc_finish_var_decl (decl, sym);
if (sym->ts.type == BT_CHARACTER)
@@ -2587,13 +2590,19 @@ gfc_trans_deferred_vars (gfc_symbol * pr
break;
case AS_DEFERRED:
- fnbody = gfc_trans_deferred_array (sym, fnbody);
+ if (!(sym->ts.type == BT_DERIVED
+ && sym->ts.derived->attr.alloc_comp))
+ fnbody = gfc_trans_deferred_array (sym, fnbody);
break;
default:
gcc_unreachable ();
}
+ if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
+ fnbody = gfc_trans_deferred_array (sym, fnbody);
}
+ else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
+ fnbody = gfc_trans_deferred_array (sym, fnbody);
else if (sym->ts.type == BT_CHARACTER)
{
gfc_get_backend_locus (&loc);
@@ -2829,10 +2838,12 @@ gfc_generate_function_code (gfc_namespac
tree old_context;
tree decl;
tree tmp;
+ tree tmp2;
stmtblock_t block;
stmtblock_t body;
tree result;
gfc_symbol *sym;
+ int rank;
sym = ns->proc_name;
@@ -2992,7 +3003,6 @@ gfc_generate_function_code (gfc_namespac
tmp = gfc_finish_block (&body);
/* Add code to create and cleanup arrays. */
tmp = gfc_trans_deferred_vars (sym, tmp);
- gfc_add_expr_to_block (&block, tmp);
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
{
@@ -3007,7 +3017,18 @@ gfc_generate_function_code (gfc_namespac
else
result = sym->result->backend_decl;
- if (result == NULL_TREE)
+ if (result != NULL_TREE && sym->attr.function
+ && sym->ts.type == BT_DERIVED
+ && sym->ts.derived->attr.alloc_comp)
+ {
+ rank = sym->as ? sym->as->rank : 0;
+ tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
+ gfc_add_expr_to_block (&block, tmp2);
+ }
+
+ gfc_add_expr_to_block (&block, tmp);
+
+ if (result == NULL_TREE)
warning (0, "Function return value not set");
else
{
@@ -3018,6 +3039,9 @@ gfc_generate_function_code (gfc_namespac
gfc_add_expr_to_block (&block, tmp);
}
}
+ else
+ gfc_add_expr_to_block (&block, tmp);
+
/* Add all the decls we created during processing. */
decl = saved_function_decls;
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (revision 115800)
+++ gcc/fortran/parse.c (working copy)
@@ -1500,6 +1500,7 @@ parse_derived (void)
gfc_statement st;
gfc_component *c;
gfc_state_data s;
+ gfc_symbol *sym;
error_flag = 0;
@@ -1610,6 +1611,18 @@ parse_derived (void)
}
}
+ /* Look for allocatable components. */
+ sym = gfc_current_block ();
+ for (c = sym->components; c; c = c->next)
+ {
+ if (c->allocatable || (c->ts.type == BT_DERIVED
+ && c->ts.derived->attr.alloc_comp))
+ {
+ sym->attr.alloc_comp = 1;
+ break;
+ }
+ }
+
pop_state ();
}
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c (revision 115800)
+++ gcc/fortran/check.c (working copy)
@@ -461,13 +461,16 @@ gfc_check_all_any (gfc_expr * mask, gfc_
try
gfc_check_allocated (gfc_expr * array)
{
+ symbol_attribute attr;
+
if (variable_check (array, 0) == FAILURE)
return FAILURE;
if (array_check (array, 0) == FAILURE)
return FAILURE;
- if (!array->symtree->n.sym->attr.allocatable)
+ attr = gfc_variable_attr (array, NULL);
+ if (!attr.allocatable)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
@@ -1763,6 +1766,64 @@ gfc_check_merge (gfc_expr * tsource, gfc
return SUCCESS;
}
+try
+gfc_check_move_alloc (gfc_expr * from, gfc_expr * to)
+{
+ symbol_attribute attr;
+
+ if (variable_check (from, 0) == FAILURE)
+ return FAILURE;
+
+ if (array_check (from, 0) == FAILURE)
+ return FAILURE;
+
+ attr = gfc_variable_attr (from, NULL);
+ if (!attr.allocatable)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &from->where);
+ return FAILURE;
+ }
+
+ if (variable_check (to, 0) == FAILURE)
+ return FAILURE;
+
+ if (array_check (to, 0) == FAILURE)
+ return FAILURE;
+
+ attr = gfc_variable_attr (to, NULL);
+ if (!attr.allocatable)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &to->where);
+ return FAILURE;
+ }
+
+ if (same_type_check (from, 0, to, 1) == FAILURE)
+ return FAILURE;
+
+ if (to->rank != from->rank)
+ {
+ gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
+ "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ &to->where, from->rank, to->rank);
+ return FAILURE;
+ }
+
+ if (to->ts.kind != from->ts.kind)
+ {
+ gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
+ "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+ &to->where, from->ts.kind, to->ts.kind);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
try
gfc_check_nearest (gfc_expr * x, gfc_expr * s)
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c (revision 115800)
+++ gcc/fortran/primary.c (working copy)
@@ -1711,7 +1711,7 @@ check_substring:
symbol_attribute
gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
{
- int dimension, pointer, target;
+ int dimension, pointer, allocatable, target;
symbol_attribute attr;
gfc_ref *ref;
@@ -1723,6 +1723,7 @@ gfc_variable_attr (gfc_expr * expr, gfc_
dimension = attr.dimension;
pointer = attr.pointer;
+ allocatable = attr.allocatable;
target = attr.target;
if (pointer)
@@ -1743,12 +1744,12 @@ gfc_variable_attr (gfc_expr * expr, gfc_
break;
case AR_SECTION:
- pointer = 0;
+ allocatable = pointer = 0;
dimension = 1;
break;
case AR_ELEMENT:
- pointer = 0;
+ allocatable = pointer = 0;
break;
case AR_UNKNOWN:
@@ -1763,18 +1764,20 @@ gfc_variable_attr (gfc_expr * expr, gfc_
*ts = ref->u.c.component->ts;
pointer = ref->u.c.component->pointer;
+ allocatable = ref->u.c.component->allocatable;
if (pointer)
target = 1;
break;
case REF_SUBSTRING:
- pointer = 0;
+ allocatable = pointer = 0;
break;
}
attr.dimension = dimension;
attr.pointer = pointer;
+ attr.allocatable = allocatable;
attr.target = target;
return attr;
Index: libgfortran/intrinsics/pack_generic.c
===================================================================
--- libgfortran/intrinsics/pack_generic.c (revision 115800)
+++ libgfortran/intrinsics/pack_generic.c (working copy)
@@ -469,3 +469,41 @@ pack_s_char (gfc_array_char *ret,
{
pack_s_internal (ret, array, mask, vector, array_length);
}
+
+extern void move_alloc (gfc_array_char *, gfc_array_char *);
+export_proto(move_alloc);
+
+void
+move_alloc (gfc_array_char * from, gfc_array_char * to)
+{
+ int i;
+
+ internal_free (to->data);
+
+ for (i = 0; i < GFC_DESCRIPTOR_RANK (from); i++)
+ {
+ to->dim[i].lbound = from->dim[i].lbound;
+ to->dim[i].ubound = from->dim[i].ubound;
+ to->dim[i].stride = from->dim[i].stride;
+ from->dim[i].stride = 0;
+ from->dim[i].ubound = from->dim[i].lbound;
+ }
+
+ to->offset = from->offset;
+ to->dtype = from->dtype;
+ to->data = from->data;
+ from->data = NULL;
+}
+
+extern void move_alloc_c (gfc_array_char *, GFC_INTEGER_4,
+ gfc_array_char *, GFC_INTEGER_4);
+export_proto(move_alloc_c);
+
+void
+move_alloc_c (gfc_array_char * from, GFC_INTEGER_4 from_length __attribute__((unused)),
+ gfc_array_char * to, GFC_INTEGER_4 to_length __attribute__((unused)))
+{
+ move_alloc (from, to);
+}
+
+
More information about the Fortran
mailing list