+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
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,
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)
/* 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;
}
}
}
}
+ 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
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);
}
&& 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)
/* 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 ();
}
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;
}
/* 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;
const char *name;
gfc_typespec ts;
- int pointer, dimension;
+ int pointer, allocatable, dimension;
gfc_array_spec *as;
tree backend_decl;
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 *);
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;
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,
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 *);
* @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
+@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
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;
minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
minit ("CRAY_POINTER", AB_CRAY_POINTER),
minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
+ minit ("ALLOC_COMP", AB_ALLOC_COMP),
minit (NULL, -1)
};
MIO_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 ();
case AB_CRAY_POINTEE:
attr->cray_pointee = 1;
break;
+ case AB_ALLOC_COMP:
+ attr->alloc_comp = 1;
+ break;
}
}
}
mio_integer (&c->dimension);
mio_integer (&c->pointer);
+ mio_integer (&c->allocatable);
mio_expr (&c->initializer);
mio_rparen ();
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;
}
}
+ /* 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 ();
}
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;
dimension = attr.dimension;
pointer = attr.pointer;
+ allocatable = attr.allocatable;
target = attr.target;
if (pointer)
break;
case AR_SECTION:
- pointer = 0;
+ allocatable = pointer = 0;
dimension = 1;
break;
case AR_ELEMENT:
- pointer = 0;
+ allocatable = pointer = 0;
break;
case AR_UNKNOWN:
*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;
gfc_constructor *cons;
gfc_component *comp;
try t;
+ symbol_attribute a;
t = SUCCESS;
cons = expr->value.constructor;
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))
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;
/* 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)
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;
}
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 "
}
}
- if (c->pointer || c->as == NULL)
+ if (c->pointer || c->allocatable || c->as == NULL)
continue;
for (i = 0; i < c->as->rank; i++)
}
}
- /* 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
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;
c->dimension = attr->dimension;
c->pointer = attr->pointer;
+ c->allocatable = attr->allocatable;
}
gfc_clear_attr (attr);
attr->dimension = c->dimension;
attr->pointer = c->pointer;
+ attr->allocatable = c->allocatable;
}
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)
{
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)
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;
}
}
break;
+ case EXPR_NULL:
+ return gfc_build_null_descriptor (type);
+
default:
gcc_unreachable ();
}
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;
gfc_trans_dealloc_allocated (tree descriptor)
{
tree tmp;
- tree deallocate;
+ tree ptr;
+ tree var;
stmtblock_t block;
gfc_start_block (&block);
- deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
- tmp = gfc_conv_descriptor_data_get (descriptor);
- tmp = build2 (NE_EXPR, boolean_type_node, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
- tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
+ tmp = gfc_conv_descriptor_data_addr (descriptor);
+ var = gfc_evaluate_now (tmp, &block);
+ tmp = gfc_create_var (gfc_array_index_type, NULL);
+ ptr = build_fold_addr_expr (tmp);
+
+ /* Call array_deallocate with an int* present in the second argument.
+ Although it is ignored here, it's presence ensures that arrays that
+ are already deallocated are ignored. */
+ tmp = gfc_chainon_list (NULL_TREE, var);
+ tmp = gfc_chainon_list (tmp, ptr);
+ tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
gfc_add_expr_to_block (&block, tmp);
+ return gfc_finish_block (&block);
+}
+
+
+/* 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);
- return tmp;
+ /* 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);
}
-/* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
+/* 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)
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))
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);
/* 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);
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. */
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)
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)
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);
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;
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)
{
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
{
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;
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);
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. */
gfc_ss *argss;
gfc_ss_info *info;
int byref;
+ int parm_kind;
tree type;
tree var;
tree len;
gfc_expr *e;
gfc_symbol *fsym;
stmtblock_t post;
+ enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
arglist = NULL_TREE;
retargs = NULL_TREE;
{
e = arg->expr;
fsym = formal ? formal->sym : NULL;
+ parm_kind = MISSING;
if (e == NULL)
{
/* An elemental function inside a scalarized loop. */
gfc_init_se (&parmse, se);
gfc_conv_expr_reference (&parmse, e);
+ parm_kind = ELEMENTAL;
}
else
{
if (argss == gfc_ss_terminator)
{
gfc_conv_expr_reference (&parmse, e);
+ parm_kind = SCALAR;
if (fsym && fsym->attr.pointer
&& e->expr_type != EXPR_NULL)
{
/* Scalar pointer dummy args require an extra level of
indirection. The null pointer already contains
this level of indirection. */
+ parm_kind = SCALAR_POINTER;
parmse.expr = build_fold_addr_expr (parmse.expr);
}
}
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&post, &parmse.post);
+ /* Allocated allocatable components of derived types must be
+ deallocated for INTENT(OUT) dummy arguments and non-variable
+ scalars. Non-variable arrays are dealt with in trans-array.c
+ (gfc_conv_array_parameter). */
+ if (e && e->ts.type == BT_DERIVED
+ && e->ts.derived->attr.alloc_comp
+ && ((formal && formal->sym->attr.intent == INTENT_OUT)
+ ||
+ (e->expr_type != EXPR_VARIABLE && !e->rank)))
+ {
+ int parm_rank;
+ tmp = build_fold_indirect_ref (parmse.expr);
+ parm_rank = e->rank;
+ switch (parm_kind)
+ {
+ case (ELEMENTAL):
+ case (SCALAR):
+ parm_rank = 0;
+ break;
+
+ case (SCALAR_POINTER):
+ tmp = build_fold_indirect_ref (tmp);
+ break;
+ case (ARRAY):
+ tmp = parmse.expr;
+ break;
+ }
+
+ tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
+ if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
+ tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
+ tmp, build_empty_stmt ());
+
+ if (e->expr_type != EXPR_VARIABLE)
+ /* Don't deallocate non-variables until they have been used. */
+ gfc_add_expr_to_block (&se->post, tmp);
+ else
+ {
+ gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+ }
+
/* Character strings are passed as two parameters, a length and a
pointer. */
if (parmse.string_length != NULL_TREE)
gfc_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);
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);
}
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)
{
else
{
/* Scalar component. */
- gfc_se lse;
-
gfc_init_se (&se, NULL);
gfc_init_se (&lse, NULL);
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);
}
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,
/* 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);
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);
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)
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);
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)
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);
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);
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)
}
/* 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)
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);
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);
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);
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);
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
/* 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);
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. */
/* 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 *);
+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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { dg-do run }\r
+! Check "double" allocations of allocatable components (PR 20541).\r
+!\r
+! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org>\r
+! and Paul Thomas <pault@gcc.gnu.org>\r
+!\r
+program main\r
+\r
+ implicit none\r
+\r
+ type foo\r
+ integer, dimension(:), allocatable :: array\r
+ end type foo\r
+\r
+ type(foo),allocatable,dimension(:) :: mol\r
+ type(foo),pointer,dimension(:) :: molp\r
+ integer :: i\r
+\r
+ allocate (mol(1))\r
+ allocate (mol(1), stat=i)\r
+ !print *, i ! /= 0\r
+ if (i == 0) call abort()\r
+\r
+ allocate (mol(1)%array(5))\r
+ allocate (mol(1)%array(5),stat=i)\r
+ !print *, i ! /= 0\r
+ if (i == 0) call abort()\r
+\r
+ allocate (molp(1))\r
+ allocate (molp(1), stat=i)\r
+ !print *, i ! == 0\r
+ if (i /= 0) call abort()\r
+\r
+ allocate (molp(1)%array(5))\r
+ allocate (molp(1)%array(5),stat=i)\r
+ !print *, i ! /= 0\r
+ if (i == 0) call abort()\r
+\r
+end program main\r
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { dg-do run }\r
+! { dg-options "-fdump-tree-original" }\r
+! Test constructors of derived type with allocatable components (PR 20541).\r
+!\r
+! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org>\r
+! and Paul Thomas <pault@gcc.gnu.org>\r
+!\r
+\r
+Program test_constructor\r
+\r
+ implicit none\r
+\r
+ type :: thytype\r
+ integer(4) :: a(2,2)\r
+ end type thytype\r
+\r
+ type :: mytype\r
+ integer(4), allocatable :: a(:, :)\r
+ type(thytype), allocatable :: q(:)\r
+ end type mytype\r
+\r
+ type (mytype) :: x\r
+ type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2]))\r
+ integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [2,2])\r
+ integer, allocatable :: yy(:,:)\r
+ type (thytype), allocatable :: bar(:)\r
+ integer :: i\r
+\r
+ ! Check that null() works\r
+ x = mytype(null(), null())\r
+ if (allocated(x%a) .or. allocated(x%q)) call abort()\r
+\r
+ ! Check that unallocated allocatables work\r
+ x = mytype(yy, bar)\r
+ if (allocated(x%a) .or. allocated(x%q)) call abort()\r
+\r
+ ! Check that non-allocatables work\r
+ x = mytype(y, [foo, foo])\r
+ if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()\r
+ if (any(lbound(x%a) /= lbound(y))) call abort()\r
+ if (any(ubound(x%a) /= ubound(y))) call abort()\r
+ if (any(x%a /= y)) call abort()\r
+ if (size(x%q) /= 2) call abort()\r
+ do i = 1, 2\r
+ if (any(x%q(i)%a /= foo%a)) call abort()\r
+ end do\r
+\r
+ ! Check that allocated allocatables work\r
+ allocate(yy(size(y,1), size(y,2)))\r
+ yy = y\r
+ allocate(bar(2))\r
+ bar = [foo, foo]\r
+ x = mytype(yy, bar)\r
+ if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()\r
+ if (any(x%a /= y)) call abort()\r
+ if (size(x%q) /= 2) call abort()\r
+ do i = 1, 2\r
+ if (any(x%q(i)%a /= foo%a)) call abort()\r
+ end do\r
+\r
+ ! Functions returning arrays\r
+ x = mytype(bluhu(), null())\r
+ if (.not.allocated(x%a) .or. allocated(x%q)) call abort()\r
+ if (any(x%a /= reshape ([41, 98, 54, 76], [2,2]))) call abort()\r
+\r
+ ! Functions returning allocatable arrays\r
+ x = mytype(blaha(), null())\r
+ if (.not.allocated(x%a) .or. allocated(x%q)) call abort()\r
+ if (any(x%a /= reshape ([40, 97, 53, 75], [2,2]))) call abort()\r
+\r
+ ! Check that passing the constructor to a procedure works\r
+ call check_mytype (mytype(y, [foo, foo]))\r
+\r
+contains\r
+\r
+ subroutine check_mytype(x)\r
+ type(mytype), intent(in) :: x\r
+ integer :: i\r
+\r
+ if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()\r
+ if (any(lbound(x%a) /= lbound(y))) call abort()\r
+ if (any(ubound(x%a) /= ubound(y))) call abort()\r
+ if (any(x%a /= y)) call abort()\r
+ if (size(x%q) /= 2) call abort()\r
+ do i = 1, 2\r
+ if (any(x%q(i)%a /= foo%a)) call abort()\r
+ end do\r
+\r
+ end subroutine check_mytype\r
+\r
+\r
+ function bluhu()\r
+ integer :: bluhu(2,2)\r
+\r
+ bluhu = reshape ([41, 98, 54, 76], [2,2])\r
+ end function bluhu\r
+\r
+\r
+ function blaha()\r
+ integer, allocatable :: blaha(:,:)\r
+\r
+ allocate(blaha(2,2))\r
+ blaha = reshape ([40, 97, 53, 75], [2,2])\r
+ end function blaha\r
+\r
+end program test_constructor\r
+! { dg-final { scan-tree-dump-times "deallocate" 18 "original" } }\r
+! { dg-final { cleanup-tree-dump "original" } }\r
--- /dev/null
+! { 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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+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
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 \
intrinsics/link.c \
intrinsics/malloc.c \
intrinsics/mvbits.c \
+intrinsics/move_alloc.c \
intrinsics/pack_generic.c \
intrinsics/perror.c \
intrinsics/signal.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
--- /dev/null
+/* 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);
+}
projects / platform / upstream / linaro-gcc.git / commitdiff