[multiple changes]
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. From-SVN: r117558
This commit is contained in:
Paul Thomas
parent
4afa41f130
commit
5046aff56b
42 changed files with 1878 additions and 106 deletions
|
|
@ -1,3 +1,111 @@
|
|||
2006-10-08 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.
|
||||
|
||||
2006-10-08 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
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-08 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/28585
|
||||
|
|
|
|||
|
|
@ -477,13 +477,16 @@ gfc_check_all_any (gfc_expr * mask, gfc_expr * dim)
|
|||
try
|
||||
gfc_check_allocated (gfc_expr * array)
|
||||
{
|
||||
symbol_attribute attr;
|
||||
|
||||
if (variable_check (array, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (array_check (array, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (!array->symtree->n.sym->attr.allocatable)
|
||||
attr = gfc_variable_attr (array, NULL);
|
||||
if (!attr.allocatable)
|
||||
{
|
||||
gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
|
||||
gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
|
||||
|
|
@ -1814,6 +1817,64 @@ gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
|
|||
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)
|
||||
|
|
|
|||
|
|
@ -962,14 +962,31 @@ build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
|
|||
|
||||
/* Check array components. */
|
||||
if (!c->dimension)
|
||||
return SUCCESS;
|
||||
{
|
||||
if (c->allocatable)
|
||||
{
|
||||
gfc_error ("Allocatable component at %C must be an array");
|
||||
return FAILURE;
|
||||
}
|
||||
else
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
if (c->pointer)
|
||||
{
|
||||
if (c->as->type != AS_DEFERRED)
|
||||
{
|
||||
gfc_error ("Pointer array component of structure at %C "
|
||||
"must have a deferred shape");
|
||||
gfc_error ("Pointer array component of structure at %C must have a "
|
||||
"deferred shape");
|
||||
return FAILURE;
|
||||
}
|
||||
}
|
||||
else if (c->allocatable)
|
||||
{
|
||||
if (c->as->type != AS_DEFERRED)
|
||||
{
|
||||
gfc_error ("Allocatable component of structure at %C must have a "
|
||||
"deferred shape");
|
||||
return FAILURE;
|
||||
}
|
||||
}
|
||||
|
|
@ -1284,6 +1301,14 @@ variable_decl (int elem)
|
|||
}
|
||||
}
|
||||
|
||||
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
|
||||
|
|
@ -1315,8 +1340,9 @@ variable_decl (int elem)
|
|||
t = add_init_expr_to_sym (name, &initializer, &var_locus);
|
||||
else
|
||||
{
|
||||
if (current_ts.type == BT_DERIVED && !current_attr.pointer
|
||||
&& !initializer)
|
||||
if (current_ts.type == BT_DERIVED
|
||||
&& !current_attr.pointer
|
||||
&& !initializer)
|
||||
initializer = gfc_default_initializer (¤t_ts);
|
||||
t = build_struct (name, cl, &initializer, &as);
|
||||
}
|
||||
|
|
@ -2141,11 +2167,24 @@ match_attr_spec (void)
|
|||
&& d != DECL_DIMENSION && d != DECL_POINTER
|
||||
&& d != DECL_COLON && d != DECL_NONE)
|
||||
{
|
||||
|
||||
gfc_error ("Attribute at %L is not allowed in a TYPE definition",
|
||||
&seen_at[d]);
|
||||
m = MATCH_ERROR;
|
||||
goto cleanup;
|
||||
if (d == DECL_ALLOCATABLE)
|
||||
{
|
||||
if (gfc_notify_std (GFC_STD_F2003,
|
||||
"In the selected standard, the ALLOCATABLE "
|
||||
"attribute at %C is not allowed in a TYPE "
|
||||
"definition") == FAILURE)
|
||||
{
|
||||
m = MATCH_ERROR;
|
||||
goto cleanup;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
gfc_error ("Attribute at %L is not allowed in a TYPE definition",
|
||||
&seen_at[d]);
|
||||
m = MATCH_ERROR;
|
||||
goto cleanup;
|
||||
}
|
||||
}
|
||||
|
||||
if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
|
||||
|
|
|
|||
|
|
@ -2406,7 +2406,7 @@ gfc_default_initializer (gfc_typespec *ts)
|
|||
/* See if we have a default initializer. */
|
||||
for (c = ts->derived->components; c; c = c->next)
|
||||
{
|
||||
if (c->initializer && init == NULL)
|
||||
if ((c->initializer || c->allocatable) && init == NULL)
|
||||
init = gfc_get_expr ();
|
||||
}
|
||||
|
||||
|
|
@ -2430,6 +2430,13 @@ gfc_default_initializer (gfc_typespec *ts)
|
|||
|
||||
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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -532,6 +532,9 @@ typedef struct
|
|||
/* Special attributes for Cray pointers, pointees. */
|
||||
unsigned cray_pointer:1, cray_pointee:1;
|
||||
|
||||
/* The symbol is a derived type with allocatable components, possibly nested.
|
||||
*/
|
||||
unsigned alloc_comp:1;
|
||||
}
|
||||
symbol_attribute;
|
||||
|
||||
|
|
@ -649,7 +652,7 @@ typedef struct gfc_component
|
|||
const char *name;
|
||||
gfc_typespec ts;
|
||||
|
||||
int pointer, dimension;
|
||||
int pointer, allocatable, dimension;
|
||||
gfc_array_spec *as;
|
||||
|
||||
tree backend_decl;
|
||||
|
|
@ -1972,6 +1975,7 @@ void gfc_resolve_omp_do_blocks (gfc_code *, gfc_namespace *);
|
|||
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 *);
|
||||
|
|
|
|||
|
|
@ -374,6 +374,9 @@ gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
|
|||
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;
|
||||
|
||||
|
|
|
|||
|
|
@ -2424,6 +2424,11 @@ add_subroutines (void)
|
|||
length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
|
||||
trim_name, BT_LOGICAL, dl, OPTIONAL);
|
||||
|
||||
add_sym_2s ("move_alloc", 0, 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, 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,
|
||||
|
|
|
|||
|
|
@ -154,6 +154,7 @@ try gfc_check_free (gfc_expr *);
|
|||
try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_gerror (gfc_expr *);
|
||||
try gfc_check_getlog (gfc_expr *);
|
||||
try gfc_check_move_alloc (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
|
||||
gfc_expr *);
|
||||
try gfc_check_random_number (gfc_expr *);
|
||||
|
|
|
|||
|
|
@ -181,6 +181,7 @@ Some intrinsics have documentation yet to be completed as indicated by 'document
|
|||
* @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{NEW_LINE}: NEW_LINE, New line character
|
||||
|
|
@ -5834,6 +5835,50 @@ Elemental subroutine
|
|||
|
||||
|
||||
|
||||
@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
|
||||
|
|
|
|||
|
|
@ -1435,7 +1435,7 @@ typedef enum
|
|||
AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON,
|
||||
AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
|
||||
AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,
|
||||
AB_CRAY_POINTEE, AB_THREADPRIVATE
|
||||
AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP
|
||||
}
|
||||
ab_attribute;
|
||||
|
||||
|
|
@ -1465,6 +1465,7 @@ static const mstring attr_bits[] =
|
|||
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)
|
||||
};
|
||||
|
||||
|
|
@ -1555,6 +1556,8 @@ mio_symbol_attribute (symbol_attribute * attr)
|
|||
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 ();
|
||||
|
||||
|
|
@ -1644,6 +1647,9 @@ mio_symbol_attribute (symbol_attribute * attr)
|
|||
case AB_CRAY_POINTEE:
|
||||
attr->cray_pointee = 1;
|
||||
break;
|
||||
case AB_ALLOC_COMP:
|
||||
attr->alloc_comp = 1;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -1951,6 +1957,7 @@ mio_component (gfc_component * c)
|
|||
|
||||
mio_integer (&c->dimension);
|
||||
mio_integer (&c->pointer);
|
||||
mio_integer (&c->allocatable);
|
||||
|
||||
mio_expr (&c->initializer);
|
||||
mio_rparen ();
|
||||
|
|
|
|||
|
|
@ -1499,6 +1499,8 @@ parse_derived (void)
|
|||
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;
|
||||
|
||||
|
|
@ -1595,6 +1597,18 @@ parse_derived (void)
|
|||
}
|
||||
}
|
||||
|
||||
/* Look for allocatable components. */
|
||||
sym = gfc_current_block ();
|
||||
for (c = sym->components; c; c = c->next)
|
||||
{
|
||||
if (c->allocatable || (c->ts.type == BT_DERIVED
|
||||
&& c->ts.derived->attr.alloc_comp))
|
||||
{
|
||||
sym->attr.alloc_comp = 1;
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
pop_state ();
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -1715,7 +1715,7 @@ check_substring:
|
|||
symbol_attribute
|
||||
gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
|
||||
{
|
||||
int dimension, pointer, target;
|
||||
int dimension, pointer, allocatable, target;
|
||||
symbol_attribute attr;
|
||||
gfc_ref *ref;
|
||||
|
||||
|
|
@ -1727,6 +1727,7 @@ gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
|
|||
|
||||
dimension = attr.dimension;
|
||||
pointer = attr.pointer;
|
||||
allocatable = attr.allocatable;
|
||||
|
||||
target = attr.target;
|
||||
if (pointer)
|
||||
|
|
@ -1747,12 +1748,12 @@ gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
|
|||
break;
|
||||
|
||||
case AR_SECTION:
|
||||
pointer = 0;
|
||||
allocatable = pointer = 0;
|
||||
dimension = 1;
|
||||
break;
|
||||
|
||||
case AR_ELEMENT:
|
||||
pointer = 0;
|
||||
allocatable = pointer = 0;
|
||||
break;
|
||||
|
||||
case AR_UNKNOWN:
|
||||
|
|
@ -1767,18 +1768,20 @@ gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
|
|||
*ts = ref->u.c.component->ts;
|
||||
|
||||
pointer = ref->u.c.component->pointer;
|
||||
allocatable = ref->u.c.component->allocatable;
|
||||
if (pointer)
|
||||
target = 1;
|
||||
|
||||
break;
|
||||
|
||||
case REF_SUBSTRING:
|
||||
pointer = 0;
|
||||
allocatable = pointer = 0;
|
||||
break;
|
||||
}
|
||||
|
||||
attr.dimension = dimension;
|
||||
attr.pointer = pointer;
|
||||
attr.allocatable = allocatable;
|
||||
attr.target = target;
|
||||
|
||||
return attr;
|
||||
|
|
|
|||
|
|
@ -593,6 +593,7 @@ resolve_structure_cons (gfc_expr * expr)
|
|||
gfc_constructor *cons;
|
||||
gfc_component *comp;
|
||||
try t;
|
||||
symbol_attribute a;
|
||||
|
||||
t = SUCCESS;
|
||||
cons = expr->value.constructor;
|
||||
|
|
@ -615,6 +616,17 @@ resolve_structure_cons (gfc_expr * expr)
|
|||
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))
|
||||
|
|
@ -629,6 +641,19 @@ resolve_structure_cons (gfc_expr * expr)
|
|||
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;
|
||||
|
|
@ -3408,7 +3433,8 @@ find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
|
|||
|
||||
/* Given the expression node e for an allocatable/pointer of derived type to be
|
||||
allocated, get the expression node to be initialized afterwards (needed for
|
||||
derived types with default initializers). */
|
||||
derived types with default initializers, and derived types with allocatable
|
||||
components that need nullification.) */
|
||||
|
||||
static gfc_expr *
|
||||
expr_to_initialize (gfc_expr * e)
|
||||
|
|
@ -3532,8 +3558,7 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code)
|
|||
init_st->loc = code->loc;
|
||||
init_st->op = EXEC_ASSIGN;
|
||||
init_st->expr = expr_to_initialize (e);
|
||||
init_st->expr2 = init_e;
|
||||
|
||||
init_st->expr2 = init_e;
|
||||
init_st->next = code->next;
|
||||
code->next = init_st;
|
||||
}
|
||||
|
|
@ -4164,6 +4189,13 @@ resolve_transfer (gfc_code * code)
|
|||
return;
|
||||
}
|
||||
|
||||
if (ts->derived->attr.alloc_comp)
|
||||
{
|
||||
gfc_error ("Data transfer element at %L cannot have "
|
||||
"ALLOCATABLE components", &code->loc);
|
||||
return;
|
||||
}
|
||||
|
||||
if (derived_inaccessible (ts->derived))
|
||||
{
|
||||
gfc_error ("Data transfer element at %L cannot have "
|
||||
|
|
@ -5545,7 +5577,7 @@ resolve_fl_derived (gfc_symbol *sym)
|
|||
}
|
||||
}
|
||||
|
||||
if (c->pointer || c->as == NULL)
|
||||
if (c->pointer || c->allocatable || c->as == NULL)
|
||||
continue;
|
||||
|
||||
for (i = 0; i < c->as->rank; i++)
|
||||
|
|
@ -5606,16 +5638,28 @@ resolve_fl_namelist (gfc_symbol *sym)
|
|||
}
|
||||
}
|
||||
|
||||
/* 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;
|
||||
}
|
||||
/* 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
|
||||
|
|
@ -6370,6 +6414,14 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
|
|||
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;
|
||||
|
|
|
|||
|
|
@ -1523,6 +1523,7 @@ gfc_set_component_attr (gfc_component * c, symbol_attribute * attr)
|
|||
|
||||
c->dimension = attr->dimension;
|
||||
c->pointer = attr->pointer;
|
||||
c->allocatable = attr->allocatable;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1536,6 +1537,7 @@ gfc_get_component_attr (symbol_attribute * attr, gfc_component * c)
|
|||
gfc_clear_attr (attr);
|
||||
attr->dimension = c->dimension;
|
||||
attr->pointer = c->pointer;
|
||||
attr->allocatable = c->allocatable;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -3236,32 +3236,27 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
|
|||
tree size;
|
||||
gfc_expr **lower;
|
||||
gfc_expr **upper;
|
||||
gfc_ref *ref;
|
||||
int allocatable_array;
|
||||
int must_be_pointer;
|
||||
gfc_ref *ref, *prev_ref = NULL;
|
||||
bool allocatable_array;
|
||||
|
||||
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);
|
||||
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)
|
||||
{
|
||||
|
|
@ -3294,11 +3289,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
|
|||
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)
|
||||
|
|
@ -3325,6 +3315,14 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
|
|||
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;
|
||||
}
|
||||
|
||||
|
|
@ -3465,6 +3463,9 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
|
|||
}
|
||||
break;
|
||||
|
||||
case EXPR_NULL:
|
||||
return gfc_build_null_descriptor (type);
|
||||
|
||||
default:
|
||||
gcc_unreachable ();
|
||||
}
|
||||
|
|
@ -4547,6 +4548,17 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
|
|||
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;
|
||||
|
|
@ -4595,25 +4607,322 @@ tree
|
|||
gfc_trans_dealloc_allocated (tree descriptor)
|
||||
{
|
||||
tree tmp;
|
||||
tree deallocate;
|
||||
tree ptr;
|
||||
tree var;
|
||||
stmtblock_t block;
|
||||
|
||||
gfc_start_block (&block);
|
||||
deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
|
||||
|
||||
tmp = gfc_conv_descriptor_data_get (descriptor);
|
||||
tmp = build2 (NE_EXPR, boolean_type_node, tmp,
|
||||
build_int_cst (TREE_TYPE (tmp), 0));
|
||||
tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
|
||||
tmp = gfc_conv_descriptor_data_addr (descriptor);
|
||||
var = gfc_evaluate_now (tmp, &block);
|
||||
tmp = gfc_create_var (gfc_array_index_type, NULL);
|
||||
ptr = build_fold_addr_expr (tmp);
|
||||
|
||||
/* Call array_deallocate with an int* present in the second argument.
|
||||
Although it is ignored here, it's presence ensures that arrays that
|
||||
are already deallocated are ignored. */
|
||||
tmp = gfc_chainon_list (NULL_TREE, var);
|
||||
tmp = gfc_chainon_list (tmp, ptr);
|
||||
tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
|
||||
tmp = gfc_finish_block (&block);
|
||||
|
||||
return tmp;
|
||||
return gfc_finish_block (&block);
|
||||
}
|
||||
|
||||
|
||||
/* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
|
||||
/* 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)
|
||||
|
|
@ -4623,16 +4932,22 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
|
|||
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))
|
||||
fatal_error
|
||||
("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
|
||||
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);
|
||||
|| TREE_CODE (sym->backend_decl) == PARM_DECL);
|
||||
|
||||
if (sym->ts.type == BT_CHARACTER
|
||||
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
|
||||
|
|
@ -4653,7 +4968,10 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
|
|||
gfc_set_backend_locus (&sym->declared_at);
|
||||
descriptor = sym->backend_decl;
|
||||
|
||||
if (TREE_STATIC (descriptor))
|
||||
/* 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);
|
||||
|
|
@ -4662,22 +4980,40 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
|
|||
|
||||
/* Get the descriptor type. */
|
||||
type = TREE_TYPE (sym->backend_decl);
|
||||
if (!GFC_DESCRIPTOR_TYPE_P (type))
|
||||
|
||||
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);
|
||||
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
|
||||
}
|
||||
|
||||
|
||||
/* NULLIFY the data pointer. */
|
||||
gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
|
||||
if (GFC_DESCRIPTOR_TYPE_P (type))
|
||||
gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
|
||||
|
||||
gfc_add_expr_to_block (&fnblock, body);
|
||||
|
||||
gfc_set_backend_locus (&loc);
|
||||
/* Allocatable arrays need to be freed when they go out of scope. */
|
||||
|
||||
/* Allocatable arrays need to be freed when they go out of scope.
|
||||
The allocatable components of pointers must not be touched. */
|
||||
if (sym_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);
|
||||
|
|
|
|||
|
|
@ -43,6 +43,15 @@ tree gfc_trans_dummy_array_bias (gfc_symbol *, tree, tree);
|
|||
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. */
|
||||
|
|
|
|||
|
|
@ -964,6 +964,9 @@ gfc_get_symbol_decl (gfc_symbol * sym)
|
|||
GFC_DECL_PACKED_ARRAY (decl) = 1;
|
||||
}
|
||||
|
||||
if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
|
||||
gfc_defer_symbol_init (sym);
|
||||
|
||||
gfc_finish_var_decl (decl, sym);
|
||||
|
||||
if (sym->ts.type == BT_CHARACTER)
|
||||
|
|
@ -2572,6 +2575,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
|
|||
|
||||
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)
|
||||
|
|
@ -2614,13 +2619,18 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
|
|||
break;
|
||||
|
||||
case AS_DEFERRED:
|
||||
fnbody = gfc_trans_deferred_array (sym, fnbody);
|
||||
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);
|
||||
|
|
@ -2972,10 +2982,12 @@ gfc_generate_function_code (gfc_namespace * ns)
|
|||
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;
|
||||
|
||||
|
|
@ -3135,7 +3147,6 @@ gfc_generate_function_code (gfc_namespace * ns)
|
|||
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)
|
||||
{
|
||||
|
|
@ -3150,7 +3161,18 @@ gfc_generate_function_code (gfc_namespace * ns)
|
|||
else
|
||||
result = sym->result->backend_decl;
|
||||
|
||||
if (result == NULL_TREE)
|
||||
if (result != NULL_TREE && sym->attr.function
|
||||
&& sym->ts.type == BT_DERIVED
|
||||
&& sym->ts.derived->attr.alloc_comp)
|
||||
{
|
||||
rank = sym->as ? sym->as->rank : 0;
|
||||
tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
|
||||
gfc_add_expr_to_block (&block, tmp2);
|
||||
}
|
||||
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
|
||||
if (result == NULL_TREE)
|
||||
warning (0, "Function return value not set");
|
||||
else
|
||||
{
|
||||
|
|
@ -3161,6 +3183,9 @@ gfc_generate_function_code (gfc_namespace * ns)
|
|||
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;
|
||||
|
|
|
|||
|
|
@ -1701,7 +1701,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
|
|||
|
||||
if (intent != INTENT_OUT)
|
||||
{
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
|
||||
gfc_add_expr_to_block (&body, tmp);
|
||||
gcc_assert (rse.ss == gfc_ss_terminator);
|
||||
gfc_trans_scalarizing_loops (&loop, &body);
|
||||
|
|
@ -1792,7 +1792,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
|
|||
|
||||
gcc_assert (lse.ss == gfc_ss_terminator);
|
||||
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
|
||||
gfc_add_expr_to_block (&body, tmp);
|
||||
|
||||
/* Generate the copying loops. */
|
||||
|
|
@ -1864,6 +1864,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
gfc_ss *argss;
|
||||
gfc_ss_info *info;
|
||||
int byref;
|
||||
int parm_kind;
|
||||
tree type;
|
||||
tree var;
|
||||
tree len;
|
||||
|
|
@ -1877,6 +1878,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
gfc_expr *e;
|
||||
gfc_symbol *fsym;
|
||||
stmtblock_t post;
|
||||
enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
|
||||
|
||||
arglist = NULL_TREE;
|
||||
retargs = NULL_TREE;
|
||||
|
|
@ -1919,6 +1921,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
{
|
||||
e = arg->expr;
|
||||
fsym = formal ? formal->sym : NULL;
|
||||
parm_kind = MISSING;
|
||||
if (e == NULL)
|
||||
{
|
||||
|
||||
|
|
@ -1947,6 +1950,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
/* An elemental function inside a scalarized loop. */
|
||||
gfc_init_se (&parmse, se);
|
||||
gfc_conv_expr_reference (&parmse, e);
|
||||
parm_kind = ELEMENTAL;
|
||||
}
|
||||
else
|
||||
{
|
||||
|
|
@ -1957,12 +1961,14 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
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);
|
||||
}
|
||||
}
|
||||
|
|
@ -2050,6 +2056,49 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
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)
|
||||
|
|
@ -2636,7 +2685,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
|
|||
|
||||
gfc_conv_expr (&rse, expr);
|
||||
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
|
||||
gfc_add_expr_to_block (&body, tmp);
|
||||
|
||||
gcc_assert (rse.ss == gfc_ss_terminator);
|
||||
|
|
@ -2657,17 +2706,22 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
|
|||
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);
|
||||
|
|
@ -2700,8 +2754,68 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
|
|||
}
|
||||
else if (cm->dimension)
|
||||
{
|
||||
tmp = gfc_trans_subarray_assign (dest, cm, expr);
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
if (cm->allocatable && expr->expr_type == EXPR_NULL)
|
||||
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
|
||||
else if (cm->allocatable)
|
||||
{
|
||||
tree tmp2;
|
||||
|
||||
gfc_init_se (&se, NULL);
|
||||
|
||||
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)
|
||||
{
|
||||
|
|
@ -2722,8 +2836,6 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
|
|||
else
|
||||
{
|
||||
/* Scalar component. */
|
||||
gfc_se lse;
|
||||
|
||||
gfc_init_se (&se, NULL);
|
||||
gfc_init_se (&lse, NULL);
|
||||
|
||||
|
|
@ -2731,7 +2843,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
|
|||
if (cm->ts.type == BT_CHARACTER)
|
||||
lse.string_length = cm->ts.cl->backend_decl;
|
||||
lse.expr = dest;
|
||||
tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
|
||||
tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
}
|
||||
return gfc_finish_block (&block);
|
||||
|
|
@ -2791,10 +2903,14 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
|
|||
}
|
||||
|
||||
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)
|
||||
/* 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,
|
||||
|
|
@ -3089,16 +3205,19 @@ gfc_conv_string_parameter (gfc_se * se)
|
|||
|
||||
|
||||
/* Generate code for assignment of scalar variables. Includes character
|
||||
strings. */
|
||||
strings and derived types with allocatable components. */
|
||||
|
||||
tree
|
||||
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
|
||||
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
|
||||
bool l_is_temp, bool r_is_var)
|
||||
{
|
||||
stmtblock_t block;
|
||||
tree tmp;
|
||||
tree cond;
|
||||
|
||||
gfc_init_block (&block);
|
||||
|
||||
if (type == BT_CHARACTER)
|
||||
if (ts.type == BT_CHARACTER)
|
||||
{
|
||||
gcc_assert (lse->string_length != NULL_TREE
|
||||
&& rse->string_length != NULL_TREE);
|
||||
|
|
@ -3112,6 +3231,50 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
|
|||
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);
|
||||
|
|
@ -3217,6 +3380,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
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)
|
||||
|
|
@ -3295,10 +3459,12 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
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 (lss != gfc_ss_terminator && loop.temp_ss != NULL)
|
||||
if (l_is_temp)
|
||||
{
|
||||
gfc_conv_tmp_array_ref (&lse);
|
||||
gfc_advance_se_ss_chain (&lse);
|
||||
|
|
@ -3306,7 +3472,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
else
|
||||
gfc_conv_expr (&lse, expr1);
|
||||
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp,
|
||||
expr2->expr_type == EXPR_VARIABLE);
|
||||
gfc_add_expr_to_block (&body, tmp);
|
||||
|
||||
if (lss == gfc_ss_terminator)
|
||||
|
|
@ -3319,7 +3486,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
gcc_assert (lse.ss == gfc_ss_terminator
|
||||
&& rse.ss == gfc_ss_terminator);
|
||||
|
||||
if (loop.temp_ss != NULL)
|
||||
if (l_is_temp)
|
||||
{
|
||||
gfc_trans_scalarized_loop_boundary (&loop, &body);
|
||||
|
||||
|
|
@ -3339,9 +3506,10 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
gcc_assert (lse.ss == gfc_ss_terminator
|
||||
&& rse.ss == gfc_ss_terminator);
|
||||
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
|
||||
gfc_add_expr_to_block (&body, tmp);
|
||||
}
|
||||
|
||||
/* Generate the copying loops. */
|
||||
gfc_trans_scalarizing_loops (&loop, &body);
|
||||
|
||||
|
|
|
|||
|
|
@ -1802,7 +1802,8 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
|
|||
gfc_conv_expr (&lse, expr);
|
||||
|
||||
/* Use the scalar assignment. */
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
|
||||
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)
|
||||
|
|
@ -1897,7 +1898,9 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
|
|||
}
|
||||
|
||||
/* Use the scalar assignment. */
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
|
||||
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)
|
||||
|
|
@ -2978,7 +2981,8 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
|
|||
maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
|
||||
|
||||
/* Use the scalar assignment as is. */
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
|
||||
loop.temp_ss != NULL, false);
|
||||
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
|
||||
|
||||
gfc_add_expr_to_block (&body, tmp);
|
||||
|
|
@ -3031,7 +3035,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
|
|||
maskexpr);
|
||||
|
||||
/* Use the scalar assignment as is. */
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
|
||||
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
|
||||
gfc_add_expr_to_block (&body, tmp);
|
||||
|
||||
|
|
@ -3406,8 +3410,8 @@ gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
|
|||
gfc_conv_expr (&edse, edst);
|
||||
}
|
||||
|
||||
tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts.type);
|
||||
estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts.type)
|
||||
tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
|
||||
estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
|
||||
: build_empty_stmt ();
|
||||
tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
|
||||
gfc_add_expr_to_block (&body, tmp);
|
||||
|
|
@ -3591,6 +3595,14 @@ gfc_trans_allocate (gfc_code * code)
|
|||
parm, tmp, build_empty_stmt ());
|
||||
gfc_add_expr_to_block (&se.pre, tmp);
|
||||
}
|
||||
|
||||
if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
|
||||
{
|
||||
tmp = build_fold_indirect_ref (se.expr);
|
||||
tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0);
|
||||
gfc_add_expr_to_block (&se.pre, tmp);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
tmp = gfc_finish_block (&se.pre);
|
||||
|
|
@ -3675,6 +3687,26 @@ gfc_trans_deallocate (gfc_code * code)
|
|||
se.descriptor_only = 1;
|
||||
gfc_conv_expr (&se, expr);
|
||||
|
||||
if (expr->ts.type == BT_DERIVED
|
||||
&& expr->ts.derived->attr.alloc_comp)
|
||||
{
|
||||
gfc_ref *ref;
|
||||
gfc_ref *last = NULL;
|
||||
for (ref = expr->ref; ref; ref = ref->next)
|
||||
if (ref->type == REF_COMPONENT)
|
||||
last = ref;
|
||||
|
||||
/* Do not deallocate the components of a derived type
|
||||
ultimate pointer component. */
|
||||
if (!(last && last->u.c.component->pointer)
|
||||
&& !(!last && expr->symtree->n.sym->attr.pointer))
|
||||
{
|
||||
tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
|
||||
expr->rank);
|
||||
gfc_add_expr_to_block (&se.pre, tmp);
|
||||
}
|
||||
}
|
||||
|
||||
if (expr->rank)
|
||||
tmp = gfc_array_deallocate (se.expr, pstat);
|
||||
else
|
||||
|
|
|
|||
|
|
@ -1486,12 +1486,15 @@ gfc_get_derived_type (gfc_symbol * derived)
|
|||
/* 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;
|
||||
: 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);
|
||||
|
|
@ -1550,7 +1553,7 @@ gfc_get_derived_type (gfc_symbol * derived)
|
|||
required. */
|
||||
if (c->dimension)
|
||||
{
|
||||
if (c->pointer)
|
||||
if (c->pointer || c->allocatable)
|
||||
{
|
||||
/* Pointers to arrays aren't actually pointer types. The
|
||||
descriptors are separate, but the data is common. */
|
||||
|
|
|
|||
|
|
@ -307,7 +307,7 @@ int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *);
|
|||
/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
|
||||
|
||||
/* Generate code for a scalar assignment. */
|
||||
tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, bt);
|
||||
tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool);
|
||||
|
||||
/* Translate COMMON blocks. */
|
||||
void gfc_trans_common (gfc_namespace *);
|
||||
|
|
|
|||
|
|
@ -1,3 +1,30 @@
|
|||
2006-10-08 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.
|
||||
|
||||
2006-10-08 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/29115
|
||||
* gfortran.dg/derived_constructor_comps_2.f90: New test.
|
||||
|
||||
PR fortran/29211
|
||||
* gfortran.dg/forall_char_dependencies_1.f90: New test.
|
||||
|
||||
2006-10-08 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/28585
|
||||
|
|
|
|||
57
gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90
Normal file
57
gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90
Normal file
|
|
@ -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
|
||||
57
gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90
Normal file
57
gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90
Normal file
|
|
@ -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
|
||||
36
gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90
Normal file
36
gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90
Normal file
|
|
@ -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
|
||||
63
gcc/testsuite/gfortran.dg/alloc_comp_assign_4.f90
Normal file
63
gcc/testsuite/gfortran.dg/alloc_comp_assign_4.f90
Normal file
|
|
@ -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
|
||||
143
gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
Normal file
143
gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
Normal file
|
|
@ -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" } }
|
||||
39
gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90
Normal file
39
gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90
Normal file
|
|
@ -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
|
||||
22
gcc/testsuite/gfortran.dg/alloc_comp_constraint_1.f90
Normal file
22
gcc/testsuite/gfortran.dg/alloc_comp_constraint_1.f90
Normal file
|
|
@ -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
|
||||
15
gcc/testsuite/gfortran.dg/alloc_comp_constraint_2.f90
Normal file
15
gcc/testsuite/gfortran.dg/alloc_comp_constraint_2.f90
Normal file
|
|
@ -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
|
||||
12
gcc/testsuite/gfortran.dg/alloc_comp_constraint_3.f90
Normal file
12
gcc/testsuite/gfortran.dg/alloc_comp_constraint_3.f90
Normal file
|
|
@ -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
|
||||
108
gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
Normal file
108
gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
Normal file
|
|
@ -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" } }
|
||||
26
gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90
Normal file
26
gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90
Normal file
|
|
@ -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
|
||||
71
gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90
Normal file
71
gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90
Normal file
|
|
@ -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" } }
|
||||
12
gcc/testsuite/gfortran.dg/alloc_comp_initializer_2.f90
Normal file
12
gcc/testsuite/gfortran.dg/alloc_comp_initializer_2.f90
Normal file
|
|
@ -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
|
||||
14
gcc/testsuite/gfortran.dg/alloc_comp_std.f90
Normal file
14
gcc/testsuite/gfortran.dg/alloc_comp_std.f90
Normal file
|
|
@ -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
|
||||
15
gcc/testsuite/gfortran.dg/derived_constructor_comps_2.f90
Normal file
15
gcc/testsuite/gfortran.dg/derived_constructor_comps_2.f90
Normal file
|
|
@ -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
|
||||
|
||||
13
gcc/testsuite/gfortran.dg/forall_char_dependencies_1.f90
Normal file
13
gcc/testsuite/gfortran.dg/forall_char_dependencies_1.f90
Normal file
|
|
@ -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
|
||||
39
gcc/testsuite/gfortran.dg/move_alloc.f90
Normal file
39
gcc/testsuite/gfortran.dg/move_alloc.f90
Normal file
|
|
@ -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
|
||||
|
|
@ -1,3 +1,11 @@
|
|||
2006-10-08 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-08 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
PR libfortran/26540
|
||||
|
|
|
|||
|
|
@ -169,12 +169,12 @@ am__objects_30 = associated.lo abort.lo access.lo args.lo bessel.lo \
|
|||
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 \
|
||||
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 \
|
||||
|
|
@ -427,6 +427,7 @@ intrinsics/ishftc.c \
|
|||
intrinsics/link.c \
|
||||
intrinsics/malloc.c \
|
||||
intrinsics/mvbits.c \
|
||||
intrinsics/move_alloc.c \
|
||||
intrinsics/pack_generic.c \
|
||||
intrinsics/perror.c \
|
||||
intrinsics/signal.c \
|
||||
|
|
@ -2409,6 +2410,9 @@ malloc.lo: intrinsics/malloc.c
|
|||
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
|
||||
|
||||
|
|
|
|||
67
libgfortran/intrinsics/move_alloc.c
Normal file
67
libgfortran/intrinsics/move_alloc.c
Normal file
|
|
@ -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);
|
||||
}
|
||||
Loading…
Add table
Reference in a new issue