This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, fortran] PR20541 - allocatable components (TR15541)
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: "'fortran at gcc dot gnu dot org'" <fortran at gcc dot gnu dot org>, patch <gcc-patches at gcc dot gnu dot org>
- Date: Thu, 05 Oct 2006 06:57:07 +0200
- Subject: [Patch, fortran] PR20541 - allocatable components (TR15541)
:ADDPATCH:
This patch implements the part of TR15541 that is concerned with
allocatable components of derived types. This extension to the F95
standard offers three important advantages over pointer components:
(i) Automatic deallocation of memory upon going out of scope;
(ii)The automatic handling of allocation and copying of data in
assignements of derived types with allocatable components; and
(iii) Performance advantages through the automatic transfer of allocated
resources.
In the end, we have concentrated on (i) and (ii) and rather less on
(iii). This is a starting point and it will be worthwhile looking for
opportunities to avoid copying and freeing, which undoubtedly occurs at
present.
The reason for (i) and (ii) is to ensure automatically that there is no
memory leakage. To the best of our ability, we have checked that this is
so but would appreciate users supplying us with evidence to the contrary.
It was not entirely intended, at the start, that the bulk of the patch
be in the translation stage. Instead, we had the idea that some master
library functions could do most of the work. This initial idea was not
overthrown by plan but rather because the initial demonstrations of
feasibility and the establishment of the framework all were done in
trans-XXXX.c. One area that could be improved, by returning to the
original concept, is that of deallocation on leaving scope. It would be
effective to traverse a list of allocated resources, rather than
checking all the allocatable components, whether allocated or not.
Equally though, since the code is all inline it is quite quick.
The patch has become rather substantial for which we apologise to the
reviewer(s). If it is any consolation, neither of us would have started
upon this project had we appreciated what would be involved!
It should be noted that a couple of other PRs have been cleared up in
the course of developing this patch and that several incipient but
unreported problems have also been dealt with. These are:
(i) PR29098, which involves ICEs resulting from default initializers
with components that are not set
http://gcc.gnu.org/ml/gcc-patches/2006-09/msg00671.html (Fixed on trunk);
(ii) PR29211, which is associated with character assignments with
depencies, in FORALL statements or blocks, causing ICEs (Bundled in here);
(iii) Derived type constructors with array components had no checks for
compliance, even of rank - ie. the constructor elements should either be
scalar of have the same rank as the component;
(iv) A failure of derived type association (groan!) that seems to be
specific to derived types with allocatable components had to be sorted
out; and
(v) The F2003 intrinsic MOVE_ALLOC has been implemented.
PR29115 was uncovered and fixed in the course of rather intensive work
on derived type constructors - it is also included here because it
became intimately intermingled with the main patch
Much of the patch consists of fairly mundane housekeeping or enabling
bits and pieces. It is not really worth covering those here and you are
referred to the patch, the ChangeLog and the patched code for these,
since they are relatively simple and clear.
The major action occurs in trans-array.c, trans-decl.c and trans-expr.c:
(i) trans-array.c
The patch to this file is mostly associated with the deallocation,
nullification and copying of derived types with allocatable components.
Life is made relatively easy by the arrays being whole and packed. Thus,
obtaining the size of and accessing all the components of the
allocatable arrays is very straight forward.
Three interface functions call a single multi-purpose, recursive
function structure_alloc_comps. This has to be recursive to handle
components that are themselves derived types with allocatable
components. The code branches between scalars and arrays. The latter
are handled using a helper function to obtain the array size and
looping, to make recursive calls to treat the allocatable components,
using bits of the scalarizer. The scalar section does the actual
business of deallocation, nullification and copying.
The rest of the modifications to this file are relatively minor.
(ii) trans-decl.c
The code modification to this file is small. Instead much of the
marshalling of the derived types with allocatable components is done
here; specifically by adding these beasts to the list of
"deferred_variables", which marks them for automatic nullifcation and
deallocation, on scope entry and exit. Similarly nullification of
function results with allocatable components is done here.
(iii) trans-expr.c
This file contains nearly all the modifications needed for assignement
and derived type constructors. These modifications are all associated
with memory management; ensuring that the resources are copied or
transferred, as necessary.
The handling of assignments requires the addition of an extra block
within gfc_trans_scalar_assign and two new arguments. Under the control
of these latter, which indicate that the lhs is a temporary or the rhs
is a variable, deallocation of the lhs and copying/transfer of the rhs
data are done.
As well as the assignment calls form within trans-expr.c, trans-stmt.c
is a big user because of the special ssignments made within FORALL and
WHERE blocks.
The testsuite additions check most of the major features of allocatable
components, although we have no doubt that future PRs in this are will
expose the need for more! They are all commented as to their purpose
and serve as a useful template of the capabilities of this extra feature.
The patch has been extensively tested and we thank Salvatore Filippone
and Steve Kargl for their efforts; Salvatore for doing his best as the
"Patch Buster"(We'll have to buy him a 50's Buick... ) and Steve for
checking that allocatable components do not break anything else. We are
grateful to a number of the other "usual suspects", such as Jerry
DeLisle and Jack Howarth, who have added vocal support and tests over a
range of platforms.
It is important to realise that this patch is mostly insulated from the
rest of Fortran95, behind if statements that require objects with
allocatable components. We are reasonably sure, thanks to Steve's and
our own efforts, that we have tested that this is the case. However,
uttering that thought is an invitation to be proven wrong! The most
serious breach of this "insulation" is the small change to derived type
association in trans_types.c. After the previous experience, one of us
will be watching this part like a hawk!
Steve has suggested an extra compiler option to go with -std=f95; add an
-fenable-tr15541 option. We will undertake to do this but not right
away; we have to get reaquainted with our families and friends.
We hope that this extension proves to be useful and that the bugs that
are almost certainly there will trickle in at a managable pace!
Regtested a silly number of times on a wide range of platforms and OS's
(in the last 24 hours: SUSE10.1/AMD64, FC5/Athlon1700 and Cygwin_NT/PIV)
- OK for trunk?
Phew!
Erik and Paul
2006-10-05 Erik Edelmann <edelmann@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/20541
* interface.c (gfc_compare_derived_types): Add comparison of
the allocatable field.
* intrinsic.c (add_subroutines): Add MOVE_ALLOC.
* trans-expr.c (gfc_conv_aliased_arg, gfc_trans_subarray_assign,
gfc_trans_subcomponent_assign, gfc_conv_string_parameter,
gfc_trans_scalar_assign): Add extra arguments l_is_temp
and r_is_var to references to latter function.
(gfc_conv_function_call): Add enum for types of argument and
an associated variable parm_kind. Deallocate components of
INTENT(OUT) and non-variable arrays.
(gfc_trans_subcomponent_assign): Add block to assign arrays
to allocatable components.
(gfc_trans_scalar_assign): Add block to handle assignments of
derived types with allocatable components, using the above new
arguments to control allocation/deallocation of memory and the
copying of allocated arrays.
* trans-array.c (gfc_array_allocate): Remove old identification
of pointer and replace with that of an allocatable array. Add
nullify of structures with allocatable components.
(gfc_conv_array_initializer): Treat EXPR_NULL.
(gfc_conv_array_parameter): Deallocate allocatable components
of non-variable structures.
(gfc_trans_dealloc_allocated): Use second argument of library
deallocate to inhibit, without error, freeing NULL pointers.
(get_full_array_size): New function to return the size of a
full array.
(gfc_duplicate_allocatable): New function to allocate and copy
allocated data.
(structure_alloc_comps): New recursive function to deallocate,
nullify or copy allocatable components.
(gfc_nullify_alloc_comp, gfc_deallocate_alloc_comp,
gfc_copy_alloc_comp): New interface functions to call previous.
(gfc_trans_deferred_array): Add the code to nullify allocatable
components, when entering scope, and to deallocate them on
leaving. Do not call gfc_trans_static_array_pointer and return
for structures with allocatable components and default
initializers.
* symbol.c (gfc_set_component_attr): Set allocatable field.
(gfc_get_component_attr): Set the allocatable attribute.
* intrinsic.h : Prototype for gfc_check_move_alloc.
* decl.c (build_struct): Apply TR15581 constraints for
allocatable components.
(variable_decl): Default initializer is always NULL for
allocatable components.
(match_attr_spec): Allow, or not, allocatable components,
according to the standard in force.
* trans-array.h : Prototypes for gfc_nullify_alloc_comp,
gfc_deallocate_alloc_comp, gfc_copy_alloc_comp and
gfc_duplicate_allocatable.
* gfortran.texi : Add mention of TR15581 extensions.
* gfortran.h : Add attribute alloc_comp, add
gfc_components field allocatable and add the prototype
for gfc_expr_to_initialize.
* trans-stmt.c (generate_loop_for_temp_to_lhs,
generate_loop_for_rhs_to_temp, gfc_trans_where_assign,
gfc_trans_where_3): Add extra arguments to calls to
gfc_trans_scalar_assign and set appropriately.
(gfc_trans_allocate): Nullify allocatable components.
(gfc_trans_deallocate): Deallocate to ultimate allocatable
components but stop at ultimate pointer components.
* module.c (mio_symbol_attribute, mio_symbol_attribute,
mio_component): Add module support for allocatable
components.
* trans-types.c (gfc_get_derived_type): Treat allocatable
components.
* trans.h : Add two boolean arguments to
gfc_trans_scalar_assign.
* resolve.c (resolve_structure_cons): Check conformance of
constructor element and the component.
(resolve_allocate_expr): Add expression to nullify the
constructor expression for allocatable components.
(resolve_transfer): Inhibit I/O of derived types with
allocatable components.
(resolve_fl_derived): Skip check of bounds of allocatable
components.
* trans-decl.c (gfc_get_symbol_decl): Add derived types
with allocatable components to deferred variable.
(gfc_trans_deferred_vars): Make calls for derived types
with allocatable components to gfc_trans_deferred_array.
(gfc_generate_function_code): Nullify allocatable
component function result on entry.
* parse.c (parse_derived): Set symbol attr.allocatable if
allocatable components are present.
* check.c (gfc_check_allocated): Enforce attr.allocatable
for intrinsic arguments.
(gfc_check_move_alloc): Check arguments of move_alloc.
* primary.c (gfc_variable_attr): Set allocatable attribute.
* intrinsic.texi : Add index entry and section for
for move_alloc.
PR fortran/29115
* resolve.c (resolve_structure_cons): It is an error if the
pointer component elements of a derived type constructor are
not pointer or target.
PR fortran/29211
* trans-stmt.c (generate_loop_for_temp_to_lhs,
generate_loop_for_rhs_to_temp): Provide a string length for
the temporary by copying that of the other side of the scalar
assignment.
2006-10-05 Paul Thomas <pault@gcc.gnu.org>
Erik Edelmann <edelmann@gcc.gnu.org>
PR libgfortran/20541
* Makefile.in : Add move_alloc.
* intrinsics/move_alloc.c: New function.
* Makefile.am : Add move_alloc.
2006-10-05 Erik Edelmann <edelmann@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/20541
* gfortran.dg/alloc_comp_basics_1.f90: New test.
* gfortran.dg/alloc_comp_basics_2.f90: New test.
* gfortran.dg/alloc_comp_assign_1.f90: New test.
* gfortran.dg/alloc_comp_assign_2.f90: New test.
* gfortran.dg/alloc_comp_assign_3.f90: New test.
* gfortran.dg/alloc_comp_assign_4.f90: New test.
* gfortran.dg/alloc_comp_constraint_1.f90: New test.
* gfortran.dg/alloc_comp_constraint_2.f90: New test.
* gfortran.dg/alloc_comp_constraint_3.f90: New test.
* gfortran.dg/alloc_comp_constructor_1.f90: New test.
* gfortran.dg/alloc_comp_constructor_2.f90: New test.
* gfortran.dg/alloc_comp_initializer_1.f90: New test.
* gfortran.dg/alloc_comp_std.f90: New test.
* gfortran.dg/move_alloc.f90: New test.
PR fortran/29115
* gfortran.dg/derived_constructor_comps_2.f90: New test.
PR fortran/29211
* gfortran.dg/forall_char_dependencies_1.f90: New test.
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (revision 117440)
--- gcc/fortran/interface.c (working copy)
*************** gfc_compare_derived_types (gfc_symbol *
*** 374,379 ****
--- 374,382 ----
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 117440)
--- gcc/fortran/intrinsic.c (working copy)
*************** add_subroutines (void)
*** 2391,2396 ****
--- 2391,2401 ----
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-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 117440)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 1701,1707 ****
if (intent != INTENT_OUT)
{
! tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
gfc_add_expr_to_block (&body, tmp);
gcc_assert (rse.ss == gfc_ss_terminator);
gfc_trans_scalarizing_loops (&loop, &body);
--- 1701,1707 ----
if (intent != INTENT_OUT)
{
! 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);
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 1792,1798 ****
gcc_assert (lse.ss == gfc_ss_terminator);
! tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
gfc_add_expr_to_block (&body, tmp);
/* Generate the copying loops. */
--- 1792,1798 ----
gcc_assert (lse.ss == gfc_ss_terminator);
! tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
gfc_add_expr_to_block (&body, tmp);
/* Generate the copying loops. */
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1864,1869 ****
--- 1864,1870 ----
gfc_ss *argss;
gfc_ss_info *info;
int byref;
+ int parm_kind;
tree type;
tree var;
tree len;
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1877,1882 ****
--- 1878,1884 ----
gfc_expr *e;
gfc_symbol *fsym;
stmtblock_t post;
+ enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
arglist = NULL_TREE;
retargs = NULL_TREE;
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1919,1924 ****
--- 1921,1927 ----
{
e = arg->expr;
fsym = formal ? formal->sym : NULL;
+ parm_kind = MISSING;
if (e == NULL)
{
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1947,1952 ****
--- 1950,1956 ----
/* An elemental function inside a scalarized loop. */
gfc_init_se (&parmse, se);
gfc_conv_expr_reference (&parmse, e);
+ parm_kind = ELEMENTAL;
}
else
{
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1957,1968 ****
--- 1961,1974 ----
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);
}
}
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 2050,2055 ****
--- 2056,2104 ----
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)
*************** gfc_trans_subarray_assign (tree dest, gf
*** 2636,2642 ****
gfc_conv_expr (&rse, expr);
! tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
gfc_add_expr_to_block (&body, tmp);
gcc_assert (rse.ss == gfc_ss_terminator);
--- 2685,2691 ----
gfc_conv_expr (&rse, expr);
! 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);
*************** gfc_trans_subarray_assign (tree dest, gf
*** 2657,2673 ****
--- 2706,2727 ----
return gfc_finish_block (&block);
}
+
/* Assign a single component of a derived type constructor. */
static tree
gfc_trans_subcomponent_assign (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 (cm->pointer)
{
gfc_init_se (&se, NULL);
*************** gfc_trans_subcomponent_assign (tree dest
*** 2700,2707 ****
}
else if (cm->dimension)
{
! tmp = gfc_trans_subarray_assign (dest, cm, expr);
! gfc_add_expr_to_block (&block, tmp);
}
else if (expr->ts.type == BT_DERIVED)
{
--- 2754,2821 ----
}
else if (cm->dimension)
{
! 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);
!
! rss = gfc_walk_expr (expr);
! se.want_pointer = 0;
! gfc_conv_expr_descriptor (&se, expr, rss);
! gfc_add_block_to_block (&block, &se.pre);
!
! tmp = fold_convert (TREE_TYPE (dest), se.expr);
! gfc_add_modify_expr (&block, dest, tmp);
!
! if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
! tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
! cm->as->rank);
! else
! tmp = gfc_duplicate_allocatable (dest, se.expr,
! TREE_TYPE(cm->backend_decl),
! cm->as->rank);
!
! gfc_add_expr_to_block (&block, tmp);
!
! gfc_add_block_to_block (&block, &se.post);
! gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
!
! /* 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)
{
*************** gfc_trans_subcomponent_assign (tree dest
*** 2722,2729 ****
else
{
/* Scalar component. */
- gfc_se lse;
-
gfc_init_se (&se, NULL);
gfc_init_se (&lse, NULL);
--- 2836,2841 ----
*************** gfc_trans_subcomponent_assign (tree dest
*** 2731,2737 ****
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);
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
--- 2843,2849 ----
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, true, false);
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
*************** gfc_conv_structure (gfc_se * se, gfc_exp
*** 2791,2800 ****
}
cm = expr->ts.derived->components;
for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
{
! /* Skip absent members in default initializers. */
! if (!c->expr)
continue;
val = gfc_conv_initializer (c->expr, &cm->ts,
--- 2903,2916 ----
}
cm = expr->ts.derived->components;
+
for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
{
! /* Skip absent members in default initializers and allocatable
! components. Although the latter have a default initializer
! of EXPR_NULL,... by default, the static nullify is not needed
! since this is done every time we come into scope. */
! if (!c->expr || cm->allocatable)
continue;
val = gfc_conv_initializer (c->expr, &cm->ts,
*************** gfc_conv_string_parameter (gfc_se * se)
*** 3089,3104 ****
/* Generate code for assignment of scalar variables. Includes character
! strings. */
tree
! gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
{
stmtblock_t block;
gfc_init_block (&block);
! if (type == BT_CHARACTER)
{
gcc_assert (lse->string_length != NULL_TREE
&& rse->string_length != NULL_TREE);
--- 3205,3223 ----
/* Generate code for assignment of scalar variables. Includes character
! strings and derived types with allocatable components. */
tree
! 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 (ts.type == BT_CHARACTER)
{
gcc_assert (lse->string_length != NULL_TREE
&& rse->string_length != NULL_TREE);
*************** gfc_trans_scalar_assign (gfc_se * lse, g
*** 3112,3117 ****
--- 3231,3280 ----
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, if 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);
*************** gfc_trans_assignment (gfc_expr * expr1,
*** 3217,3222 ****
--- 3380,3386 ----
tree tmp;
stmtblock_t block;
stmtblock_t body;
+ bool l_is_temp;
/* Special case a single function returning an array. */
if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
*************** gfc_trans_assignment (gfc_expr * expr1,
*** 3295,3304 ****
else
gfc_init_block (&body);
/* Translate the expression. */
gfc_conv_expr (&rse, expr2);
! if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
{
gfc_conv_tmp_array_ref (&lse);
gfc_advance_se_ss_chain (&lse);
--- 3459,3470 ----
else
gfc_init_block (&body);
+ l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
+
/* Translate the expression. */
gfc_conv_expr (&rse, expr2);
! if (l_is_temp)
{
gfc_conv_tmp_array_ref (&lse);
gfc_advance_se_ss_chain (&lse);
*************** gfc_trans_assignment (gfc_expr * expr1,
*** 3306,3312 ****
else
gfc_conv_expr (&lse, expr1);
! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)
--- 3472,3479 ----
else
gfc_conv_expr (&lse, expr1);
! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp,
! expr2->expr_type == EXPR_VARIABLE);
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)
*************** gfc_trans_assignment (gfc_expr * expr1,
*** 3319,3325 ****
gcc_assert (lse.ss == gfc_ss_terminator
&& rse.ss == gfc_ss_terminator);
! if (loop.temp_ss != NULL)
{
gfc_trans_scalarized_loop_boundary (&loop, &body);
--- 3486,3492 ----
gcc_assert (lse.ss == gfc_ss_terminator
&& rse.ss == gfc_ss_terminator);
! if (l_is_temp)
{
gfc_trans_scalarized_loop_boundary (&loop, &body);
*************** gfc_trans_assignment (gfc_expr * expr1,
*** 3339,3347 ****
gcc_assert (lse.ss == gfc_ss_terminator
&& rse.ss == gfc_ss_terminator);
! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
gfc_add_expr_to_block (&body, tmp);
}
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop, &body);
--- 3506,3515 ----
gcc_assert (lse.ss == gfc_ss_terminator
&& rse.ss == gfc_ss_terminator);
! 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/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 117440)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 3236,3267 ****
tree size;
gfc_expr **lower;
gfc_expr **upper;
! gfc_ref *ref;
! int allocatable_array;
! int must_be_pointer;
ref = expr->ref;
- /* In Fortran 95, components can only contain pointers, so that,
- in ALLOCATE (foo%bar(2)), bar must be a pointer component.
- We test this by checking for ref->next.
- An implementation of TR 15581 would need to change this. */
-
- if (ref)
- must_be_pointer = ref->next != NULL;
- else
- must_be_pointer = 0;
-
/* Find the last reference in the chain. */
while (ref && ref->next != NULL)
{
gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
ref = ref->next;
}
if (ref == NULL || ref->type != REF_ARRAY)
return false;
/* Figure out the size of the array. */
switch (ref->u.ar.type)
{
--- 3236,3262 ----
tree size;
gfc_expr **lower;
gfc_expr **upper;
! gfc_ref *ref, *prev_ref = NULL;
! bool allocatable_array;
ref = expr->ref;
/* Find the last reference in the chain. */
while (ref && ref->next != NULL)
{
gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
+ prev_ref = ref;
ref = ref->next;
}
if (ref == NULL || ref->type != REF_ARRAY)
return false;
+ if (!prev_ref)
+ allocatable_array = expr->symtree->n.sym->attr.allocatable;
+ else
+ allocatable_array = prev_ref->u.c.component->allocatable;
+
/* Figure out the size of the array. */
switch (ref->u.ar.type)
{
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 3294,3304 ****
tmp = gfc_conv_descriptor_data_addr (se->expr);
pointer = gfc_evaluate_now (tmp, &se->pre);
- if (must_be_pointer)
- allocatable_array = 0;
- else
- allocatable_array = expr->symtree->n.sym->attr.allocatable;
-
if (TYPE_PRECISION (gfc_array_index_type) == 32)
{
if (allocatable_array)
--- 3289,3294 ----
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 3325,3330 ****
--- 3315,3328 ----
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;
}
*************** gfc_conv_array_initializer (tree type, g
*** 3465,3470 ****
--- 3463,3471 ----
}
break;
+ case EXPR_NULL:
+ return gfc_build_null_descriptor (type);
+
default:
gcc_unreachable ();
}
*************** gfc_conv_array_parameter (gfc_se * se, g
*** 4547,4552 ****
--- 4548,4564 ----
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;
*************** tree
*** 4595,4619 ****
gfc_trans_dealloc_allocated (tree descriptor)
{
tree tmp;
! tree deallocate;
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 ());
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_finish_block (&block);
! return tmp;
}
! /* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
tree
gfc_trans_deferred_array (gfc_symbol * sym, tree body)
--- 4607,4928 ----
gfc_trans_dealloc_allocated (tree descriptor)
{
tree tmp;
! tree ptr;
! tree var;
stmtblock_t block;
gfc_start_block (&block);
! 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);
+ }
+
+ /* 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);
+ }
+
+
+ /* Allocate dest to the same size as src, and copy src -> dest. */
+
+ tree
+ gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
+ {
+ tree tmp;
+ tree size;
+ tree nelems;
+ 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, dest, null_pointer_node);
+ null_data = gfc_finish_block (&block);
+
+ gfc_init_block (&block);
+
+ nelems = get_full_array_size (&block, src, rank);
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+
+ /* 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 (src)),
+ tmp));
+ gfc_conv_descriptor_data_set (&block, dest, tmp);
+
+ /* We know the temporary and the value will be the same length,
+ so can use memcpy. */
+ tmp = gfc_conv_descriptor_data_get (dest);
+ args = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = gfc_conv_descriptor_data_get (src);
+ 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 (src);
! null_cond = convert (pvoid_type_node, null_cond);
! null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
! null_pointer_node);
! return build3_v (COND_EXPR, null_cond, tmp, null_data);
! }
!
!
! /* 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;
! tree vref, dref;
! tree null_cond = NULL_TREE;
!
! 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. */
! tmp = get_full_array_size (&fnblock, decl, rank);
! tmp = build2 (MINUS_EXPR, gfc_array_index_type,
! tmp, gfc_index_one_node);
!
! null_cond = gfc_conv_descriptor_data_get (decl);
! null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
! build_int_cst (TREE_TYPE (tmp), 0));
! }
! else
! {
! /* Otherwise use the TYPE_DOMAIN information. */
! tmp = array_type_nelts (TREE_TYPE (decl));
! tmp = fold_convert (gfc_array_index_type, tmp);
! }
!
! /* Remember that this is, in fact, the no. of elements - 1. */
! 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);
!
! vref = gfc_build_array_ref (var, index);
!
! if (purpose == COPY_ALLOC_COMP)
! {
! tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
! gfc_add_expr_to_block (&fnblock, tmp);
!
! tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
! dref = gfc_build_array_ref (tmp, index);
! tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
! }
! else
! tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, 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);
!
! tmp = gfc_finish_block (&fnblock);
! if (null_cond != NULL_TREE)
! tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
!
! return tmp;
! }
!
! /* Otherwise, act on the components or recursively call self to
! act on a chain of components. */
! for (c = der_type->components; c; c = c->next)
! {
! bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
! && c->ts.derived->attr.alloc_comp;
! cdecl = c->backend_decl;
! ctype = TREE_TYPE (cdecl);
!
! switch (purpose)
! {
! case DEALLOCATE_ALLOC_COMP:
! /* Do not deallocate the components of ultimate pointer
! components. */
! if (cmp_has_alloc_comps && !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 (cmp_has_alloc_comps)
! {
! 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;
!
! /* We need source and destination components. */
! 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 && !cmp_has_alloc_comps)
! {
! tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
! gfc_add_expr_to_block (&fnblock, tmp);
! }
!
! if (cmp_has_alloc_comps)
! {
! rank = c->as ? c->as->rank : 0;
! tmp = fold_convert (TREE_TYPE (dcmp), comp);
! gfc_add_modify_expr (&fnblock, dcmp, tmp);
! 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);
! }
!
!
! /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
! Do likewise, recursively if necessary, with the allocatable components of
! derived types. */
tree
gfc_trans_deferred_array (gfc_symbol * sym, tree body)
*************** gfc_trans_deferred_array (gfc_symbol * s
*** 4623,4638 ****
tree descriptor;
stmtblock_t fnblock;
locus loc;
/* 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.");
gfc_init_block (&fnblock);
gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
! || TREE_CODE (sym->backend_decl) == PARM_DECL);
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
--- 4932,4953 ----
tree descriptor;
stmtblock_t fnblock;
locus loc;
+ int rank;
+ bool sym_has_alloc_comp;
+
+ sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
+ && sym->ts.derived->attr.alloc_comp;
/* Make sure the frontend gets these right. */
! if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
! fatal_error ("Possible frontend bug: Deferred array size without pointer, "
! "allocatable attribute or derived type without allocatable "
! "components.");
gfc_init_block (&fnblock);
gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
! || TREE_CODE (sym->backend_decl) == PARM_DECL);
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
*************** gfc_trans_deferred_array (gfc_symbol * s
*** 4653,4659 ****
gfc_set_backend_locus (&sym->declared_at);
descriptor = sym->backend_decl;
! if (TREE_STATIC (descriptor))
{
/* SAVEd variables are not freed on exit. */
gfc_trans_static_array_pointer (sym);
--- 4968,4977 ----
gfc_set_backend_locus (&sym->declared_at);
descriptor = sym->backend_decl;
! /* Although static, derived types with deafult initializers and
! allocatable components must not be nulled wholesale; instead they
! are treated component by component. */
! if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
{
/* SAVEd variables are not freed on exit. */
gfc_trans_static_array_pointer (sym);
*************** gfc_trans_deferred_array (gfc_symbol * s
*** 4662,4683 ****
/* Get the descriptor type. */
type = TREE_TYPE (sym->backend_decl);
! 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);
gfc_add_expr_to_block (&fnblock, body);
gfc_set_backend_locus (&loc);
! /* Allocatable arrays need to be freed when they go out of scope. */
if (sym->attr.allocatable)
{
tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
--- 4980,5019 ----
/* Get the descriptor type. */
type = TREE_TYPE (sym->backend_decl);
!
! if (sym_has_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);
}
!
/* NULLIFY the data pointer. */
! 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.
! The allocatable components of pointers must not be touched. */
! if (sym_has_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/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 117440)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_set_component_attr (gfc_component *
*** 1523,1528 ****
--- 1523,1529 ----
c->dimension = attr->dimension;
c->pointer = attr->pointer;
+ c->allocatable = attr->allocatable;
}
*************** gfc_get_component_attr (symbol_attribute
*** 1536,1541 ****
--- 1537,1543 ----
gfc_clear_attr (attr);
attr->dimension = c->dimension;
attr->pointer = c->pointer;
+ attr->allocatable = c->allocatable;
}
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 117440)
--- gcc/fortran/decl.c (working copy)
*************** build_struct (const char *name, gfc_char
*** 962,975 ****
/* Check array components. */
if (!c->dimension)
! 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");
return FAILURE;
}
}
--- 962,992 ----
/* Check array components. */
if (!c->dimension)
! {
! 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");
! 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;
}
}
*************** variable_decl (int elem)
*** 1284,1289 ****
--- 1301,1314 ----
}
}
+ if (initializer != NULL && current_attr.allocatable
+ && gfc_current_state () == COMP_DERIVED)
+ {
+ gfc_error ("Initialization of allocatable component at %C is not allowed");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
/* Check if we are parsing an enumeration and if the current enumerator
variable has an initializer or not. If it does not have an
initializer, the initialization value of the previous enumerator
*************** variable_decl (int elem)
*** 1315,1322 ****
t = add_init_expr_to_sym (name, &initializer, &var_locus);
else
{
! if (current_ts.type == BT_DERIVED && !current_attr.pointer
! && !initializer)
initializer = gfc_default_initializer (¤t_ts);
t = build_struct (name, cl, &initializer, &as);
}
--- 1340,1348 ----
t = add_init_expr_to_sym (name, &initializer, &var_locus);
else
{
! if (current_ts.type == BT_DERIVED
! && !current_attr.pointer
! && !initializer)
initializer = gfc_default_initializer (¤t_ts);
t = build_struct (name, cl, &initializer, &as);
}
*************** match_attr_spec (void)
*** 2141,2151 ****
&& 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_PRIVATE || d == DECL_PUBLIC)
--- 2167,2190 ----
&& d != DECL_DIMENSION && d != DECL_POINTER
&& d != DECL_COLON && d != DECL_NONE)
{
! 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/intrinsic.h
===================================================================
*** gcc/fortran/intrinsic.h (revision 117440)
--- gcc/fortran/intrinsic.h (working copy)
*************** try gfc_check_free (gfc_expr *);
*** 153,158 ****
--- 153,159 ----
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/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h (revision 117440)
--- gcc/fortran/trans-array.h (working copy)
*************** tree gfc_trans_dummy_array_bias (gfc_sym
*** 43,48 ****
--- 43,57 ----
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_duplicate_allocatable(tree dest, tree src, tree type, int rank);
+
+ 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 117440)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef struct
*** 532,537 ****
--- 532,540 ----
/* 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;
*************** typedef struct gfc_component
*** 649,655 ****
const char *name;
gfc_typespec ts;
! int pointer, dimension;
gfc_array_spec *as;
tree backend_decl;
--- 652,658 ----
const char *name;
gfc_typespec ts;
! int pointer, allocatable, dimension;
gfc_array_spec *as;
tree backend_decl;
*************** void gfc_resolve_omp_do_blocks (gfc_code
*** 1971,1976 ****
--- 1974,1980 ----
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 117440)
--- gcc/fortran/trans-stmt.c (working copy)
*************** generate_loop_for_temp_to_lhs (gfc_expr
*** 1802,1808 ****
gfc_conv_expr (&lse, expr);
/* Use the scalar assignment. */
! tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
/* Form the mask expression according to the mask tree list. */
if (wheremask)
--- 1802,1809 ----
gfc_conv_expr (&lse, expr);
/* Use the scalar assignment. */
! rse.string_length = lse.string_length;
! tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
/* Form the mask expression according to the mask tree list. */
if (wheremask)
*************** generate_loop_for_rhs_to_temp (gfc_expr
*** 1897,1903 ****
}
/* Use the scalar assignment. */
! tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
/* Form the mask expression according to the mask tree list. */
if (wheremask)
--- 1898,1906 ----
}
/* Use the scalar assignment. */
! lse.string_length = rse.string_length;
! tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
! expr2->expr_type == EXPR_VARIABLE);
/* Form the mask expression according to the mask tree list. */
if (wheremask)
*************** gfc_trans_where_assign (gfc_expr *expr1,
*** 2978,2984 ****
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 = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
--- 2981,2988 ----
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,
! loop.temp_ss != NULL, false);
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
*************** gfc_trans_where_assign (gfc_expr *expr1,
*** 3031,3037 ****
maskexpr);
/* Use the scalar assignment as is. */
! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
--- 3035,3041 ----
maskexpr);
/* Use the scalar assignment as is. */
! 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);
*************** gfc_trans_where_3 (gfc_code * cblock, gf
*** 3406,3413 ****
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)
: build_empty_stmt ();
tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
gfc_add_expr_to_block (&body, tmp);
--- 3410,3417 ----
gfc_conv_expr (&edse, edst);
}
! 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);
*************** gfc_trans_allocate (gfc_code * code)
*** 3591,3596 ****
--- 3595,3608 ----
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);
*************** gfc_trans_deallocate (gfc_code * code)
*** 3675,3680 ****
--- 3687,3712 ----
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/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 117440)
--- gcc/fortran/expr.c (working copy)
*************** gfc_default_initializer (gfc_typespec *t
*** 2406,2412 ****
/* See if we have a default initializer. */
for (c = ts->derived->components; c; c = c->next)
{
! if (c->initializer && init == NULL)
init = gfc_get_expr ();
}
--- 2406,2412 ----
/* See if we have a default initializer. */
for (c = ts->derived->components; c; c = c->next)
{
! if ((c->initializer || c->allocatable) && init == NULL)
init = gfc_get_expr ();
}
*************** gfc_default_initializer (gfc_typespec *t
*** 2430,2435 ****
--- 2430,2442 ----
if (c->initializer)
tail->expr = gfc_copy_expr (c->initializer);
+
+ if (c->allocatable)
+ {
+ tail->expr = gfc_get_expr ();
+ tail->expr->expr_type = EXPR_NULL;
+ tail->expr->ts = c->ts;
+ }
}
return init;
}
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c (revision 117440)
--- gcc/fortran/module.c (working copy)
*************** typedef enum
*** 1435,1441 ****
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_attribute;
--- 1435,1441 ----
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_ALLOC_COMP
}
ab_attribute;
*************** static const mstring attr_bits[] =
*** 1465,1470 ****
--- 1465,1471 ----
minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
minit ("CRAY_POINTER", AB_CRAY_POINTER),
minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
+ minit ("ALLOC_COMP", AB_ALLOC_COMP),
minit (NULL, -1)
};
*************** mio_symbol_attribute (symbol_attribute *
*** 1555,1560 ****
--- 1556,1563 ----
MIO_NAME(ab_attribute) (AB_CRAY_POINTER, attr_bits);
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 ();
*************** mio_symbol_attribute (symbol_attribute *
*** 1644,1649 ****
--- 1647,1655 ----
case AB_CRAY_POINTEE:
attr->cray_pointee = 1;
break;
+ case AB_ALLOC_COMP:
+ attr->alloc_comp = 1;
+ break;
}
}
}
*************** mio_component (gfc_component * c)
*** 1951,1956 ****
--- 1957,1963 ----
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 117440)
--- gcc/fortran/trans-types.c (working copy)
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 1486,1497 ****
/* Derived types in an interface body obtain their parent reference
through the proc_name symbol. */
ns = derived->ns->parent ? derived->ns->parent
! : derived->ns->proc_name->ns->parent;
for (; ns; ns = ns->parent)
{
for (dt = ns->derived_types; dt; dt = dt->next)
{
if (dt->derived->backend_decl == NULL
&& gfc_compare_derived_types (dt->derived, derived))
gfc_get_derived_type (dt->derived);
--- 1486,1500 ----
/* Derived types in an interface body obtain their parent reference
through the proc_name symbol. */
ns = derived->ns->parent ? derived->ns->parent
! : derived->ns->proc_name->ns;
for (; ns; ns = ns->parent)
{
for (dt = ns->derived_types; dt; dt = dt->next)
{
+ if (dt->derived == derived)
+ continue;
+
if (dt->derived->backend_decl == NULL
&& gfc_compare_derived_types (dt->derived, derived))
gfc_get_derived_type (dt->derived);
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 1550,1556 ****
required. */
if (c->dimension)
{
! if (c->pointer)
{
/* Pointers to arrays aren't actually pointer types. The
descriptors are separate, but the data is common. */
--- 1553,1559 ----
required. */
if (c->dimension)
{
! 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 117440)
--- gcc/fortran/trans.h (working copy)
*************** int gfc_conv_function_call (gfc_se *, gf
*** 307,313 ****
/* 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);
/* Translate COMMON blocks. */
void gfc_trans_common (gfc_namespace *);
--- 307,313 ----
/* 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 *, gfc_typespec, bool, bool);
/* Translate COMMON blocks. */
void gfc_trans_common (gfc_namespace *);
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 117440)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_structure_cons (gfc_expr * expr)
*** 593,598 ****
--- 593,599 ----
gfc_constructor *cons;
gfc_component *comp;
try t;
+ symbol_attribute a;
t = SUCCESS;
cons = expr->value.constructor;
*************** resolve_structure_cons (gfc_expr * expr)
*** 615,620 ****
--- 616,632 ----
continue;
}
+ if (cons->expr->expr_type != EXPR_NULL
+ && comp->as && comp->as->rank != cons->expr->rank
+ && (comp->allocatable || cons->expr->rank))
+ {
+ gfc_error ("The rank of the element in the derived type "
+ "constructor at %L does not match that of the "
+ "component (%d/%d)", &cons->expr->where,
+ cons->expr->rank, comp->as ? comp->as->rank : 0);
+ t = FAILURE;
+ }
+
/* If we don't have the right type, try to convert it. */
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
*************** resolve_structure_cons (gfc_expr * expr)
*** 629,634 ****
--- 641,659 ----
else
t = gfc_convert_type (cons->expr, &comp->ts, 1);
}
+
+ if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
+ continue;
+
+ a = gfc_expr_attr (cons->expr);
+
+ if (!a.pointer && !a.target)
+ {
+ t = FAILURE;
+ gfc_error ("The element in the derived type constructor at %L, "
+ "for pointer component '%s' should be a POINTER or "
+ "a TARGET", &cons->expr->where, comp->name);
+ }
}
return t;
*************** find_sym_in_expr (gfc_symbol *sym, gfc_e
*** 3394,3400 ****
/* 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). */
static gfc_expr *
expr_to_initialize (gfc_expr * e)
--- 3419,3426 ----
/* 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, and derived types with allocatable
! components that need nullification.) */
static gfc_expr *
expr_to_initialize (gfc_expr * e)
*************** resolve_allocate_expr (gfc_expr * e, gfc
*** 3518,3525 ****
init_st->loc = code->loc;
init_st->op = EXEC_ASSIGN;
init_st->expr = expr_to_initialize (e);
! init_st->expr2 = init_e;
!
init_st->next = code->next;
code->next = init_st;
}
--- 3544,3550 ----
init_st->loc = code->loc;
init_st->op = EXEC_ASSIGN;
init_st->expr = expr_to_initialize (e);
! init_st->expr2 = init_e;
init_st->next = code->next;
code->next = init_st;
}
*************** resolve_transfer (gfc_code * code)
*** 4150,4155 ****
--- 4175,4187 ----
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 "
*************** resolve_fl_derived (gfc_symbol *sym)
*** 5531,5537 ****
}
}
! if (c->pointer || c->as == NULL)
continue;
for (i = 0; i < c->as->rank; i++)
--- 5563,5569 ----
}
}
! if (c->pointer || c->allocatable || c->as == NULL)
continue;
for (i = 0; i < c->as->rank; i++)
*************** resolve_fl_namelist (gfc_symbol *sym)
*** 5592,5607 ****
}
}
! /* Reject namelist arrays that are not constant shape. */
! for (nl = sym->namelist; nl; nl = nl->next)
! {
! if (is_non_constant_shape_array (nl->sym))
! {
! gfc_error ("The array '%s' must have constant shape to be "
! "a NAMELIST object at %L", nl->sym->name,
! &sym->declared_at);
! return FAILURE;
! }
}
/* 14.1.2 A module or internal procedure represent local entities
--- 5624,5651 ----
}
}
! /* Reject namelist arrays that are not constant shape. */
! for (nl = sym->namelist; nl; nl = nl->next)
! {
! if (is_non_constant_shape_array (nl->sym))
! {
! gfc_error ("The array '%s' must have constant shape to be "
! "a NAMELIST object at %L", nl->sym->name,
! &sym->declared_at);
! return FAILURE;
! }
! }
!
! /* Namelist objects cannot have allocatable components. */
! for (nl = sym->namelist; nl; nl = nl->next)
! {
! if (nl->sym->ts.type == BT_DERIVED
! && nl->sym->ts.derived->attr.alloc_comp)
! {
! gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
! "components", nl->sym->name, &sym->declared_at);
! return FAILURE;
! }
}
/* 14.1.2 A module or internal procedure represent local entities
*************** resolve_equivalence_derived (gfc_symbol
*** 6356,6361 ****
--- 6400,6413 ----
return FAILURE;
}
+ /* Shall not have allocatable components. */
+ if (derived->attr.alloc_comp)
+ {
+ gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
+ "components to be an EQUIVALENCE object",sym->name, &e->where);
+ return FAILURE;
+ }
+
for (; c ; c = c->next)
{
d = c->ts.derived;
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 117440)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 957,962 ****
--- 957,965 ----
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)
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 2560,2565 ****
--- 2563,2570 ----
for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
{
+ bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
+ && sym->ts.derived->attr.alloc_comp;
if (sym->attr.dimension)
{
switch (sym->as->type)
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 2602,2614 ****
break;
case AS_DEFERRED:
! fnbody = gfc_trans_deferred_array (sym, fnbody);
break;
default:
gcc_unreachable ();
}
}
else if (sym->ts.type == BT_CHARACTER)
{
gfc_get_backend_locus (&loc);
--- 2607,2624 ----
break;
case AS_DEFERRED:
! if (!sym_has_alloc_comp)
! fnbody = gfc_trans_deferred_array (sym, fnbody);
break;
default:
gcc_unreachable ();
}
+ if (sym_has_alloc_comp)
+ fnbody = gfc_trans_deferred_array (sym, fnbody);
}
+ else if (sym_has_alloc_comp)
+ fnbody = gfc_trans_deferred_array (sym, fnbody);
else if (sym->ts.type == BT_CHARACTER)
{
gfc_get_backend_locus (&loc);
*************** gfc_generate_function_code (gfc_namespac
*** 2960,2969 ****
--- 2970,2981 ----
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;
*************** gfc_generate_function_code (gfc_namespac
*** 3123,3129 ****
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)
{
--- 3135,3140 ----
*************** gfc_generate_function_code (gfc_namespac
*** 3138,3144 ****
else
result = sym->result->backend_decl;
! if (result == NULL_TREE)
warning (0, "Function return value not set");
else
{
--- 3149,3166 ----
else
result = sym->result->backend_decl;
! 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
{
*************** gfc_generate_function_code (gfc_namespac
*** 3149,3154 ****
--- 3171,3179 ----
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 117440)
--- gcc/fortran/parse.c (working copy)
*************** parse_derived (void)
*** 1499,1504 ****
--- 1499,1506 ----
int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
gfc_statement st;
gfc_state_data s;
+ gfc_symbol *sym;
+ gfc_component *c;
error_flag = 0;
*************** parse_derived (void)
*** 1595,1600 ****
--- 1597,1614 ----
}
}
+ /* 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 117440)
--- gcc/fortran/check.c (working copy)
*************** gfc_check_all_any (gfc_expr * mask, gfc_
*** 477,489 ****
try
gfc_check_allocated (gfc_expr * array)
{
if (variable_check (array, 0) == FAILURE)
return FAILURE;
if (array_check (array, 0) == FAILURE)
return FAILURE;
! if (!array->symtree->n.sym->attr.allocatable)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
--- 477,492 ----
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;
! 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,
*************** gfc_check_merge (gfc_expr * tsource, gfc
*** 1814,1819 ****
--- 1817,1880 ----
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 117440)
--- gcc/fortran/primary.c (working copy)
*************** check_substring:
*** 1715,1721 ****
symbol_attribute
gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
{
! int dimension, pointer, target;
symbol_attribute attr;
gfc_ref *ref;
--- 1715,1721 ----
symbol_attribute
gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
{
! int dimension, pointer, allocatable, target;
symbol_attribute attr;
gfc_ref *ref;
*************** gfc_variable_attr (gfc_expr * expr, gfc_
*** 1727,1732 ****
--- 1727,1733 ----
dimension = attr.dimension;
pointer = attr.pointer;
+ allocatable = attr.allocatable;
target = attr.target;
if (pointer)
*************** gfc_variable_attr (gfc_expr * expr, gfc_
*** 1747,1758 ****
break;
case AR_SECTION:
! pointer = 0;
dimension = 1;
break;
case AR_ELEMENT:
! pointer = 0;
break;
case AR_UNKNOWN:
--- 1748,1759 ----
break;
case AR_SECTION:
! allocatable = pointer = 0;
dimension = 1;
break;
case AR_ELEMENT:
! allocatable = pointer = 0;
break;
case AR_UNKNOWN:
*************** gfc_variable_attr (gfc_expr * expr, gfc_
*** 1767,1784 ****
*ts = ref->u.c.component->ts;
pointer = ref->u.c.component->pointer;
if (pointer)
target = 1;
break;
case REF_SUBSTRING:
! pointer = 0;
break;
}
attr.dimension = dimension;
attr.pointer = pointer;
attr.target = target;
return attr;
--- 1768,1787 ----
*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:
! allocatable = pointer = 0;
break;
}
attr.dimension = dimension;
attr.pointer = pointer;
+ attr.allocatable = allocatable;
attr.target = target;
return attr;
Index: gcc/fortran/intrinsic.texi
===================================================================
*** gcc/fortran/intrinsic.texi (revision 117440)
--- gcc/fortran/intrinsic.texi (working copy)
*************** Some intrinsics have documentation yet t
*** 181,186 ****
--- 181,187 ----
* @code{MINVAL}: MINVAL, Minimum value of an array
* @code{MOD}: MOD, Remainder function
* @code{MODULO}: MODULO, Modulo function
+ * @code{MOVE_ALLOC}: MOVE_ALLOC, Move allocation from one object to another
* @code{MVBITS}: MVBITS, Move bits from one integer to another
* @code{NEAREST}: NEAREST, Nearest representable number
* @code{NINT}: NINT, Nearest whole number
*************** Elemental subroutine
*** 5833,5838 ****
--- 5834,5883 ----
+ @node MOVE_ALLOC
+ @section @code{MOVE_ALLOC} --- Move allocation from one object to another
+ @findex @code{MOVE_ALLOC} intrinsic
+ @cindex MOVE_ALLOC
+
+ @table @asis
+ @item @emph{Description}:
+ @code{MOVE_ALLOC(SRC, DEST)} moves the allocation from @var{SRC} to
+ @var{DEST}. @var{SRC} will become deallocated in the process.
+
+ @item @emph{Option}:
+ f2003, gnu
+
+ @item @emph{Class}:
+ Subroutine
+
+ @item @emph{Syntax}:
+ @code{CALL MOVE_ALLOC(SRC, DEST)}
+
+ @item @emph{Arguments}:
+ @multitable @columnfractions .15 .80
+ @item @var{SRC} @tab @code{ALLOCATABLE}, @code{INTENT(INOUT)}, may be of any type and kind.
+ @item @var{DEST} @tab @code{ALLOCATABLE}, @code{INTENT(OUT)}, shall be of the same type, kind and rank as @var{SRC}
+ @end multitable
+
+ @item @emph{Return value}:
+ None
+
+ @item @emph{Example}:
+ @smallexample
+ program test_move_alloc
+ integer, allocatable :: a(:), b(:)
+
+ allocate(a(3))
+ a = [ 1, 2, 3 ]
+ call move_alloc(a, b)
+ print *, allocated(a), allocated(b)
+ print *, b
+ end program test_move_alloc
+ @end smallexample
+ @end table
+
+
+
@node NEAREST
@section @code{NEAREST} --- Nearest representable number
@findex @code{NEAREST} intrinsic
Index: libgfortran/Makefile.in
===================================================================
*** libgfortran/Makefile.in (revision 117440)
--- libgfortran/Makefile.in (working copy)
*************** am__objects_30 = associated.lo abort.lo
*** 169,180 ****
eoshift2.lo etime.lo exit.lo fget.lo flush.lo fnum.lo ftell.lo \
gerror.lo getcwd.lo getlog.lo getXid.lo hyper.lo hostnm.lo \
kill.lo ierrno.lo ishftc.lo link.lo malloc.lo mvbits.lo \
! pack_generic.lo perror.lo signal.lo size.lo sleep.lo \
! spread_generic.lo string_intrinsics.lo system.lo rand.lo \
! random.lo rename.lo reshape_generic.lo reshape_packed.lo \
! selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \
! system_clock.lo time.lo transpose_generic.lo tty.lo umask.lo \
! unlink.lo unpack_generic.lo in_pack_generic.lo \
in_unpack_generic.lo
am__objects_31 =
am__objects_32 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
--- 169,180 ----
eoshift2.lo etime.lo exit.lo fget.lo flush.lo fnum.lo ftell.lo \
gerror.lo getcwd.lo getlog.lo getXid.lo hyper.lo hostnm.lo \
kill.lo ierrno.lo ishftc.lo link.lo malloc.lo mvbits.lo \
! move_alloc.lo pack_generic.lo perror.lo signal.lo size.lo \
! sleep.lo spread_generic.lo string_intrinsics.lo system.lo \
! rand.lo random.lo rename.lo reshape_generic.lo \
! reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
! stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \
! tty.lo umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \
in_unpack_generic.lo
am__objects_31 =
am__objects_32 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
*************** intrinsics/ishftc.c \
*** 422,427 ****
--- 422,428 ----
intrinsics/link.c \
intrinsics/malloc.c \
intrinsics/mvbits.c \
+ intrinsics/move_alloc.c \
intrinsics/pack_generic.c \
intrinsics/perror.c \
intrinsics/signal.c \
*************** malloc.lo: intrinsics/malloc.c
*** 2334,2339 ****
--- 2335,2343 ----
mvbits.lo: intrinsics/mvbits.c
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o mvbits.lo `test -f 'intrinsics/mvbits.c' || echo '$(srcdir)/'`intrinsics/mvbits.c
+ move_alloc.lo: intrinsics/move_alloc.c
+ $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o move_alloc.lo `test -f 'intrinsics/move_alloc.c' || echo '$(srcdir)/'`intrinsics/move_alloc.c
+
pack_generic.lo: intrinsics/pack_generic.c
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_generic.lo `test -f 'intrinsics/pack_generic.c' || echo '$(srcdir)/'`intrinsics/pack_generic.c
Index: libgfortran/intrinsics/move_alloc.c
===================================================================
*** libgfortran/intrinsics/move_alloc.c (revision 0)
--- libgfortran/intrinsics/move_alloc.c (revision 0)
***************
*** 0 ****
--- 1,67 ----
+ /* Generic implementation of the MOVE_ALLOC intrinsic
+ Copyright (C) 2006 Free Software Foundation, Inc.
+ Contributed by Paul Thomas
+
+ This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+ Libgfortran is free software; you can redistribute it and/or
+ modify it under the terms of the GNU General Public
+ License as published by the Free Software Foundation; either
+ version 2 of the License, or (at your option) any later version.
+
+ In addition to the permissions in the GNU General Public License, the
+ Free Software Foundation gives you unlimited permission to link the
+ compiled version of this file into combinations with other programs,
+ and to distribute those combinations without any restriction coming
+ from the use of this file. (The General Public License restrictions
+ do apply in other respects; for example, they cover modification of
+ the file, and distribution when not linked into a combine
+ executable.)
+
+ Ligbfortran is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public
+ License along with libgfortran; see the file COPYING. If not,
+ write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ Boston, MA 02110-1301, USA. */
+
+ #include "libgfortran.h"
+
+ 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);
+ }
Index: libgfortran/Makefile.am
===================================================================
*** libgfortran/Makefile.am (revision 117440)
--- libgfortran/Makefile.am (working copy)
*************** intrinsics/ishftc.c \
*** 74,79 ****
--- 74,80 ----
intrinsics/link.c \
intrinsics/malloc.c \
intrinsics/mvbits.c \
+ intrinsics/move_alloc.c \
intrinsics/pack_generic.c \
intrinsics/perror.c \
intrinsics/signal.c \
Index: gcc/testsuite/gfortran.dg/alloc_comp_std.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_std.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_std.f90 (revision 0)
***************
*** 0 ****
--- 1,14 ----
+ ! { dg-do compile }
+ ! { dg-options "-std=f95" }
+ !
+ ! Check that we don't accept allocatable components for -std=f95 (PR 20541)
+ !
+ program main
+
+ type :: foo
+ integer, allocatable :: bar(:) ! { dg-error "ALLOCATABLE attribute" }
+
+ integer :: x ! Just to avoid "extra" error messages about empty type.
+ end type foo
+
+ end program main
Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90 (revision 0)
***************
*** 0 ****
--- 1,57 ----
+ ! { dg-do run }
+ ! Test assignments of derived type with allocatable components (PR 20541).
+ !
+ ! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org>
+ ! and Paul Thomas <pault@gcc.gnu.org>
+ !
+ type :: ivs
+ character(1), allocatable :: chars(:)
+ end type ivs
+
+ type(ivs) :: a, b
+ type(ivs) :: x(3), y(3)
+
+ allocate(a%chars(5))
+ a%chars = (/"h","e","l","l","o"/)
+
+ ! An intrinsic assignment must deallocate the l-value and copy across
+ ! the array from the r-value.
+ b = a
+ if (any (b%chars .ne. (/"h","e","l","l","o"/))) call abort ()
+ if (allocated (a%chars) .eqv. .false.) call abort ()
+
+ ! Scalar to array needs to copy the derived type, to its ultimate components,
+ ! to each of the l-value elements. */
+ x = b
+ x(2)%chars = (/"g","'","d","a","y"/)
+ if (any (x(1)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
+ if (any (x(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
+ if (allocated (b%chars) .eqv. .false.) call abort ()
+ deallocate (x(1)%chars, x(2)%chars, x(3)%chars)
+
+ ! Array intrinsic assignments are like their scalar counterpart and
+ ! must deallocate each element of the l-value and copy across the
+ ! arrays from the r-value elements.
+ allocate(x(1)%chars(5), x(2)%chars(5), x(3)%chars(5))
+ x(1)%chars = (/"h","e","l","l","o"/)
+ x(2)%chars = (/"g","'","d","a","y"/)
+ x(3)%chars = (/"g","o","d","a","g"/)
+ y(2:1:-1) = x(1:2)
+ if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
+ if (any (y(2)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
+ if (any (x(3)%chars .ne. (/"g","o","d","a","g"/))) call abort ()
+
+ ! In the case of an assignment where there is a dependency, so that a
+ ! temporary is necessary, each element must be copied to its
+ ! destination after it has been deallocated.
+ y(2:3) = y(1:2)
+ if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
+ if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
+ if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
+
+ ! An identity assignment must not do any deallocation....!
+ y = y
+ if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
+ if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
+ if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
+ end
Index: gcc/testsuite/gfortran.dg/alloc_comp_constraint_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_constraint_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_constraint_1.f90 (revision 0)
***************
*** 0 ****
--- 1,22 ----
+ ! { dg-do compile }
+ ! Check that we don't allow IO or NAMELISTs with types with allocatable
+ ! components (PR 20541)
+ program main
+
+ type :: foo
+ integer, allocatable :: x(:)
+ end type foo
+
+ type :: bar
+ type(foo) :: x
+ end type bar
+
+ type(foo) :: a
+ type(bar) :: b
+ namelist /blah/ a ! { dg-error "cannot have ALLOCATABLE components" }
+
+ write (*, *) a ! { dg-error "cannot have ALLOCATABLE components" }
+
+ read (*, *) b ! { dg-error "cannot have ALLOCATABLE components" }
+
+ end program main
Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90 (revision 0)
***************
*** 0 ****
--- 1,57 ----
+ ! { dg-do run }
+ ! Test FORALL and WHERE with derived types with allocatable components (PR 20541).
+ !
+ ! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org>
+ ! and Paul Thomas <pault@gcc.gnu.org>
+ !
+ type :: a
+ integer, allocatable :: i(:)
+ end type a
+
+ type :: b
+ type (a), allocatable :: at(:)
+ end type b
+
+ type(a) :: x(2)
+ type(b) :: y(2), z(2)
+ integer i, m(4)
+
+ ! Start with scalar and array element assignments in FORALL.
+
+ x(1) = a ((/1, 2, 3, 4/))
+ x(2) = a ((/1, 2, 3, 4/) + 10)
+ forall (j = 1:2, i = 1:4, x(j)%i(i) > 2 + (j-1)*10) x(j)%i(i) = j*4-i
+ if (any ((/((x(i)%i(j), j = 1,4), i = 1,2)/) .ne. &
+ (/1, 2, 1, 0, 11, 12, 5, 4/))) call abort ()
+
+ y(1) = b ((/x(1),x(2)/))
+ y(2) = b ((/x(2),x(1)/))
+ forall (k = 1:2, j=1:2, i = 1:4, y(k)%at(j)%i(i) <= 10)
+ y(k)%at(j)%i(i) = j*4-i+k
+ end forall
+ if (any ((/(((y(k)%at(i)%i(j), j = 1,4), i = 1,2), k = 1,2)/) .ne. &
+ (/4,3,2,1,11,12,6,5,11,12,3,2,9,8,7,6/))) call abort ()
+
+ ! Now simple assignments in WHERE.
+
+ where (y(1)%at(1)%i > 2) y(1)%at(1)%i = 0
+ if (any( (/(((y(k)%at(i)%i(j), j = 1,4), i = 1,2), k = 1,2)/) .ne. &
+ (/0,0,2,1,11,12,6,5,11,12,3,2,9,8,7,6/))) call abort ()
+
+ where (y((2))%at(:)%i(2) > 8)
+ y(2)%at(:)%i(2) = 77
+ end where
+ if (any ((/(((y(k)%at(i)%i(j), j = 1,4), i = 1,2), k = 1,2)/) .ne. &
+ (/0,0,2,1,11,12,6,5,11,77,3,2,9,8,7,6/))) call abort ()
+
+ ! Check that temporaries and full array alloctable component assignments
+ ! are correctly handled in FORALL.
+
+ x = (/a ((/1,2,3,4/)),a ((/5,6,7,8/))/)
+ forall (i=1:2) y(i) = b ((/x(i)/))
+ forall (i=1:2) y(i) = y(3-i) ! This needs a temporary.
+ forall (i=1:2) z(i) = y(i)
+ if (any ((/(((z(k)%at(i)%i(j), j = 1,4), i = 1,1), k = 1,2)/) .ne. &
+ (/(/5,6,7,8/),(/1,2,3,4/)/))) call abort ()
+
+ end
Index: gcc/testsuite/gfortran.dg/alloc_comp_constraint_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_constraint_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_constraint_2.f90 (revision 0)
***************
*** 0 ****
--- 1,15 ----
+ ! { dg-do compile }
+ ! Check that equivalence with allocatable components isn't allowed (PR 20541)
+ program main
+
+ type :: foo
+ sequence
+ integer, allocatable :: x(:)
+ end type foo
+
+ type(foo) :: a
+ integer :: b
+
+ equivalence (a, b) ! { dg-error "cannot have ALLOCATABLE components" }
+
+ end program main
Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90 (revision 0)
***************
*** 0 ****
--- 1,36 ----
+ ! { dg-do run }
+ ! Test assignments of nested derived types with allocatable components(PR 20541).
+ !
+ ! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org>
+ ! and Paul Thomas <pault@gcc.gnu.org>
+ !
+ type :: a
+ integer, allocatable :: i(:)
+ end type a
+
+ type :: b
+ type (a), allocatable :: at(:)
+ end type b
+
+ type(a) :: x(2)
+ type(b) :: y(2), z(2)
+ integer i, m(4)
+
+ x(1) = a((/1,2,3,4/))
+ x(2) = a((/1,2,3,4/)+10)
+
+ y(1) = b((/x(1),x(2)/))
+ y(2) = b((/x(2),x(1)/))
+
+ y(2) = y(1)
+ forall (j=1:2,k=1:4, y(1)%at(j)%i(k) .ne. y(2)%at(j)%i(k)) &
+ y(1)%at(j)%i(k) = 999
+ if (any ((/((y(1)%at(j)%i(k), k=1,4),j=1,2)/) .eq. 999)) call abort ()
+
+
+ z = y
+ forall (i=1:2,j=1:2,k=1:4, z(i)%at(j)%i(k) .ne. y(i)%at(j)%i(k)) &
+ z(i)%at(j)%i(k) = 999
+ if (any ((/(((z(i)%at(j)%i(k), k=1,4),j=1,2),i=1,2)/) .eq. 999)) call abort ()
+
+ end
Index: gcc/testsuite/gfortran.dg/move_alloc.f90
===================================================================
*** gcc/testsuite/gfortran.dg/move_alloc.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/move_alloc.f90 (revision 0)
***************
*** 0 ****
--- 1,39 ----
+ ! { dg-do run }
+ ! Test the move_alloc intrinsic.
+ !
+ ! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org>
+ ! and Paul Thomas <pault@gcc.gnu.org>
+ !
+ program test_move_alloc
+
+ implicit none
+ integer, allocatable :: x(:), y(:), temp(:)
+ character(4), allocatable :: a(:), b(:)
+ integer :: i
+
+ allocate (x(2))
+ allocate (a(2))
+
+ x = [ 42, 77 ]
+
+ call move_alloc (x, y)
+ if (allocated(x)) call abort()
+ if (.not.allocated(y)) call abort()
+ if (any(y /= [ 42, 77 ])) call abort()
+
+ a = [ "abcd", "efgh" ]
+ call move_alloc (a, b)
+ if (allocated(a)) call abort()
+ if (.not.allocated(b)) call abort()
+ if (any(b /= [ "abcd", "efgh" ])) call abort()
+
+ ! Now one of the intended applications of move_alloc; resizing
+
+ call move_alloc (y, temp)
+ allocate (y(6), stat=i)
+ if (i /= 0) call abort()
+ y(1:2) = temp
+ y(3:) = 99
+ deallocate(temp)
+ if (any(y /= [ 42, 77, 99, 99, 99, 99 ])) call abort()
+ end program test_move_alloc
Index: gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90 (revision 0)
***************
*** 0 ****
--- 1,71 ----
+ ! { dg-do run }
+ ! This checks the correct functioning of derived types with default initializers
+ ! and allocatable components.
+ !
+ ! Contributed by Salvatore Filippone <salvatore.filippone@uniroma2.it>
+ !
+ module p_type_mod
+
+ type m_type
+ integer, allocatable :: p(:)
+ end type m_type
+
+ type basep_type
+ type(m_type), allocatable :: av(:)
+ type(m_type), pointer :: ap => null ()
+ integer :: i = 101
+ end type basep_type
+
+ type p_type
+ type(basep_type), allocatable :: basepv(:)
+ integer :: p1 , p2 = 1
+ end type p_type
+ end module p_type_mod
+
+ program foo
+
+ use p_type_mod
+ implicit none
+
+ type(m_type), target :: a
+ type(p_type) :: pre
+ type(basep_type) :: wee
+
+ call test_ab8 ()
+
+ a = m_type ((/101,102/))
+
+ call p_bld (a, pre)
+
+ if (associated (wee%ap) .or. wee%i /= 101) call abort ()
+ wee%ap => a
+ if (.not.associated (wee%ap) .or. allocated (wee%av)) call abort ()
+ wee = basep_type ((/m_type ((/201, 202, 203/))/), null (), 99)
+ if (.not.allocated (wee%av) .or. associated (wee%ap) .or. (wee%i .ne. 99)) call abort ()
+
+ contains
+
+ ! Check that allocatable components are nullified after allocation.
+ subroutine test_ab8 ()
+ type(p_type) :: p
+ integer :: ierr
+
+ if (.not.allocated(p%basepv)) then
+ allocate(p%basepv(1),stat=ierr)
+ endif
+ if (allocated (p%basepv) .neqv. .true.) call abort ()
+ if (allocated (p%basepv(1)%av) .neqv. .false.) call abort
+ if (p%basepv(1)%i .ne. 101) call abort ()
+
+ end subroutine test_ab8
+
+ subroutine p_bld (a, p)
+ use p_type_mod
+ type (m_type) :: a
+ type(p_type) :: p
+ if (any (a%p .ne. (/101,102/))) call abort ()
+ if (allocated (p%basepv) .or. (p%p2 .ne. 1)) call abort ()
+ end subroutine p_bld
+
+ end program foo
+ ! { dg-final { cleanup-modules "p_type_mod" } }
Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_assign_4.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_assign_4.f90 (revision 0)
***************
*** 0 ****
--- 1,63 ----
+ ! { dg-do run }
+ ! Test assignments of nested derived types with character allocatable
+ ! components(PR 20541). Subroutine test_ab6 checks out a bug in a test
+ ! version of gfortran's allocatable arrays.
+ !
+ ! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org>
+ ! and Paul Thomas <pault@gcc.gnu.org>
+ !
+ type :: a
+ character(4), allocatable :: ch(:)
+ end type a
+
+ type :: b
+ type (a), allocatable :: at(:)
+ end type b
+
+ type(a) :: x(2)
+ type(b) :: y(2), z(2)
+
+ character(4) :: chr1(4) = (/"abcd","efgh","ijkl","mnop"/)
+ character(4) :: chr2(4) = (/"qrst","uvwx","yz12","3456"/)
+
+ x(1) = a(chr1)
+
+ ! Check constructor with character array constructors.
+ x(2) = a((/"qrst","uvwx","yz12","3456"/))
+
+ y(1) = b((/x(1),x(2)/))
+ y(2) = b((/x(2),x(1)/))
+
+ y(2) = y(1)
+
+ if (any((/((y(2)%at(i)%ch(j),j=1,4),i=1,2)/) .ne. &
+ (/chr1, chr2/))) call abort ()
+
+ call test_ab6 ()
+
+ contains
+
+ subroutine test_ab6 ()
+ ! This subroutine tests the presence of a scalar derived type, intermediate
+ ! in a chain of derived types with allocatable components.
+ ! Contributed by Salvatore Filippone <salvatore.filippone@uniroma2.it>
+
+ type b
+ type(a) :: a
+ end type b
+
+ type c
+ type(b), allocatable :: b(:)
+ end type c
+
+ type(c) :: p
+ type(b) :: bv
+
+ p = c((/b(a((/"Mary","Lamb"/)))/))
+ bv = p%b(1)
+
+ if (any ((bv%a%ch(:)) .ne. (/"Mary","Lamb"/))) call abort ()
+
+ end subroutine test_ab6
+
+ end
Index: gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 (revision 0)
***************
*** 0 ****
--- 1,108 ----
+ ! { dg-do run }
+ ! { dg-options "-fdump-tree-original" }
+ ! Test constructors of derived type with allocatable components (PR 20541).
+ !
+ ! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org>
+ ! and Paul Thomas <pault@gcc.gnu.org>
+ !
+
+ Program test_constructor
+
+ implicit none
+
+ type :: thytype
+ integer(4) :: a(2,2)
+ end type thytype
+
+ type :: mytype
+ integer(4), allocatable :: a(:, :)
+ type(thytype), allocatable :: q(:)
+ end type mytype
+
+ type (mytype) :: x
+ type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2]))
+ integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [2,2])
+ integer, allocatable :: yy(:,:)
+ type (thytype), allocatable :: bar(:)
+ integer :: i
+
+ ! Check that null() works
+ x = mytype(null(), null())
+ if (allocated(x%a) .or. allocated(x%q)) call abort()
+
+ ! Check that unallocated allocatables work
+ x = mytype(yy, bar)
+ if (allocated(x%a) .or. allocated(x%q)) call abort()
+
+ ! Check that non-allocatables work
+ x = mytype(y, [foo, foo])
+ if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
+ if (any(lbound(x%a) /= lbound(y))) call abort()
+ if (any(ubound(x%a) /= ubound(y))) call abort()
+ if (any(x%a /= y)) call abort()
+ if (size(x%q) /= 2) call abort()
+ do i = 1, 2
+ if (any(x%q(i)%a /= foo%a)) call abort()
+ end do
+
+ ! Check that allocated allocatables work
+ allocate(yy(size(y,1), size(y,2)))
+ yy = y
+ allocate(bar(2))
+ bar = [foo, foo]
+ x = mytype(yy, bar)
+ if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
+ if (any(x%a /= y)) call abort()
+ if (size(x%q) /= 2) call abort()
+ do i = 1, 2
+ if (any(x%q(i)%a /= foo%a)) call abort()
+ end do
+
+ ! Functions returning arrays
+ x = mytype(bluhu(), null())
+ if (.not.allocated(x%a) .or. allocated(x%q)) call abort()
+ if (any(x%a /= reshape ([41, 98, 54, 76], [2,2]))) call abort()
+
+ ! Functions returning allocatable arrays
+ x = mytype(blaha(), null())
+ if (.not.allocated(x%a) .or. allocated(x%q)) call abort()
+ if (any(x%a /= reshape ([40, 97, 53, 75], [2,2]))) call abort()
+
+ ! Check that passing the constructor to a procedure works
+ call check_mytype (mytype(y, [foo, foo]))
+
+ contains
+
+ subroutine check_mytype(x)
+ type(mytype), intent(in) :: x
+ integer :: i
+
+ if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
+ if (any(lbound(x%a) /= lbound(y))) call abort()
+ if (any(ubound(x%a) /= ubound(y))) call abort()
+ if (any(x%a /= y)) call abort()
+ if (size(x%q) /= 2) call abort()
+ do i = 1, 2
+ if (any(x%q(i)%a /= foo%a)) call abort()
+ end do
+
+ end subroutine check_mytype
+
+
+ function bluhu()
+ integer :: bluhu(2,2)
+
+ bluhu = reshape ([41, 98, 54, 76], [2,2])
+ end function bluhu
+
+
+ function blaha()
+ integer, allocatable :: blaha(:,:)
+
+ allocate(blaha(2,2))
+ blaha = reshape ([40, 97, 53, 75], [2,2])
+ end function blaha
+
+ end program test_constructor
+ ! { dg-final { scan-tree-dump-times "deallocate" 18 "original" } }
+ ! { dg-final { cleanup-tree-dump "original" } }
Index: gcc/testsuite/gfortran.dg/alloc_comp_initializer_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_initializer_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_initializer_2.f90 (revision 0)
***************
*** 0 ****
--- 1,12 ----
+ ! { dg-do compile }
+ ! Check that default initializer for allocatable components isn't accepted (PR
+ ! 20541)
+ program main
+
+ type :: foo
+ integer, allocatable :: a(:) = [ 1 ] ! { dg-error "Initialization of allocatable" }
+
+ integer :: x ! Just to avoid "extra" error messages about empty type.
+ end type foo
+
+ end program main
Index: gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90 (revision 0)
***************
*** 0 ****
--- 1,26 ----
+ ! { dg-do run }
+ ! Test constructors of nested derived types with allocatable components(PR 20541).
+ !
+ ! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org>
+ ! and Paul Thomas <pault@gcc.gnu.org>
+ !
+ type :: thytype
+ integer(4), allocatable :: h(:)
+ end type thytype
+
+ type :: mytype
+ type(thytype), allocatable :: q(:)
+ end type mytype
+
+ type (mytype) :: x
+ type (thytype) :: w(2)
+ integer :: y(2) =(/1,2/)
+
+ w = (/thytype(y), thytype (2*y)/)
+ x = mytype (w)
+ if (any ((/((x%q(j)%h(i),j=1,2),i=1,2)/) .ne. (/1,2,2,4/))) call abort ()
+
+ x = mytype ((/thytype(3*y), thytype (4*y)/))
+ if (any ((/((x%q(j)%h(i),j=1,2),i=1,2)/) .ne. (/3,4,6,8/))) call abort ()
+
+ end
Index: gcc/testsuite/gfortran.dg/derived_constructor_comps_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/derived_constructor_comps_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/derived_constructor_comps_2.f90 (revision 0)
***************
*** 0 ****
--- 1,15 ----
+ ! { dg-do compile }
+ ! Tests fix for PR29115, in which an ICE would be produced by
+ ! non-pointer elements being supplied to the pointer components
+ ! in a derived type constructor.
+ !
+ ! Contributed by Paul Thomas <pault@gcc.gnu.org>
+ !
+ type :: homer
+ integer, pointer :: bart(:)
+ end type homer
+ type(homer) :: marge
+ integer :: duff_beer
+ marge = homer (duff_beer) ! { dg-error "should be a POINTER or a TARGET" }
+ end
+
Index: gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 (revision 0)
***************
*** 0 ****
--- 1,143 ----
+ ! { dg-do run}
+ ! { dg-options "-O2 -fdump-tree-original" }
+ !
+ ! Check some basic functionality of allocatable components, including that they
+ ! are nullified when created and automatically deallocated when
+ ! 1. A variable goes out of scope
+ ! 2. INTENT(OUT) dummies
+ ! 3. Function results
+ !
+ !
+ ! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org>
+ ! and Paul Thomas <pault@gcc.gnu.org>
+ !
+ module alloc_m
+
+ implicit none
+
+ type :: alloc1
+ real, allocatable :: x(:)
+ end type alloc1
+
+ end module alloc_m
+
+
+ program alloc
+
+ use alloc_m
+
+ implicit none
+
+ type :: alloc2
+ type(alloc1), allocatable :: a1(:)
+ integer, allocatable :: a2(:)
+ end type alloc2
+
+ type(alloc2) :: b
+ integer :: i
+ type(alloc2), allocatable :: c(:)
+
+ if (allocated(b%a2) .OR. allocated(b%a1)) then
+ write (0, *) 'main - 1'
+ call abort()
+ end if
+
+ ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
+ call allocate_alloc2(b)
+ call check_alloc2(b)
+
+ do i = 1, size(b%a1)
+ ! 1 call to _gfortran_deallocate
+ deallocate(b%a1(i)%x)
+ end do
+
+ ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
+ call allocate_alloc2(b)
+
+ call check_alloc2(return_alloc2())
+ ! 3 calls to _gfortran_deallocate (function result)
+
+ allocate(c(1))
+ ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
+ call allocate_alloc2(c(1))
+ ! 4 calls to _gfortran_deallocate
+ deallocate(c)
+
+ ! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope)
+
+ contains
+
+ subroutine allocate_alloc2(b)
+ type(alloc2), intent(out) :: b
+ integer :: i
+
+ if (allocated(b%a2) .OR. allocated(b%a1)) then
+ write (0, *) 'allocate_alloc2 - 1'
+ call abort()
+ end if
+
+ allocate (b%a2(3))
+ b%a2 = [ 1, 2, 3 ]
+
+ allocate (b%a1(3))
+
+ do i = 1, 3
+ if (allocated(b%a1(i)%x)) then
+ write (0, *) 'allocate_alloc2 - 2', i
+ call abort()
+ end if
+ allocate (b%a1(i)%x(3))
+ b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
+ end do
+
+ end subroutine allocate_alloc2
+
+
+ type(alloc2) function return_alloc2() result(b)
+ if (allocated(b%a2) .OR. allocated(b%a1)) then
+ write (0, *) 'return_alloc2 - 1'
+ call abort()
+ end if
+
+ allocate (b%a2(3))
+ b%a2 = [ 1, 2, 3 ]
+
+ allocate (b%a1(3))
+
+ do i = 1, 3
+ if (allocated(b%a1(i)%x)) then
+ write (0, *) 'return_alloc2 - 2', i
+ call abort()
+ end if
+ allocate (b%a1(i)%x(3))
+ b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
+ end do
+ end function return_alloc2
+
+
+ subroutine check_alloc2(b)
+ type(alloc2), intent(in) :: b
+
+ if (.NOT.(allocated(b%a2) .AND. allocated(b%a1))) then
+ write (0, *) 'check_alloc2 - 1'
+ call abort()
+ end if
+ if (any(b%a2 /= [ 1, 2, 3 ])) then
+ write (0, *) 'check_alloc2 - 2'
+ call abort()
+ end if
+ do i = 1, 3
+ if (.NOT.allocated(b%a1(i)%x)) then
+ write (0, *) 'check_alloc2 - 3', i
+ call abort()
+ end if
+ if (any(b%a1(i)%x /= i + [ 1.0, 2.0, 3.0 ])) then
+ write (0, *) 'check_alloc2 - 4', i
+ call abort()
+ end if
+ end do
+ end subroutine check_alloc2
+
+ end program alloc
+ ! { dg-final { scan-tree-dump-times "deallocate" 38 "original" } }
+ ! { dg-final { cleanup-tree-dump "original" } }
Index: gcc/testsuite/gfortran.dg/forall_char_dependencies_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/forall_char_dependencies_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/forall_char_dependencies_1.f90 (revision 0)
***************
*** 0 ****
--- 1,13 ----
+ ! { dg-do compile }
+ ! Tests fix for PR29211, in which an ICE would be produced by FORALL assignments
+ ! with dependencies.
+ !
+ ! Contributed by Paul Thomas <pault@gcc.gnu.org>
+ !
+ character(12), dimension(2) :: a, b
+ a= (/"abcdefghijkl","mnopqrstuvwx"/)
+ ! OK because it uses gfc_trans_assignment
+ forall (i=1:2) b(i) = a(i)
+ ! Was broken - gfc_trans_assign_need_temp had no handling of string lengths
+ forall (i=1:2) a(3-i) = a(i)
+ end
Index: gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90 (revision 0)
***************
*** 0 ****
--- 1,39 ----
+ ! { dg-do run }
+ ! Check "double" allocations of allocatable components (PR 20541).
+ !
+ ! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org>
+ ! and Paul Thomas <pault@gcc.gnu.org>
+ !
+ program main
+
+ implicit none
+
+ type foo
+ integer, dimension(:), allocatable :: array
+ end type foo
+
+ type(foo),allocatable,dimension(:) :: mol
+ type(foo),pointer,dimension(:) :: molp
+ integer :: i
+
+ allocate (mol(1))
+ allocate (mol(1), stat=i)
+ !print *, i ! /= 0
+ if (i == 0) call abort()
+
+ allocate (mol(1)%array(5))
+ allocate (mol(1)%array(5),stat=i)
+ !print *, i ! /= 0
+ if (i == 0) call abort()
+
+ allocate (molp(1))
+ allocate (molp(1), stat=i)
+ !print *, i ! == 0
+ if (i /= 0) call abort()
+
+ allocate (molp(1)%array(5))
+ allocate (molp(1)%array(5),stat=i)
+ !print *, i ! /= 0
+ if (i == 0) call abort()
+
+ end program main