This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
| Other format: | [Raw text] | |
Hi all,
attached patch fixes on ICE, when freeing a scalar allocatable component in a
derived typed coarray.
Furthermore does it fix freeing of nested derived typed allocatable components.
A simple code explains the bug that is solved by the patch:
type inner
integer, allocatable :: i
end type
type outer
type(inner), allocatable :: link
end type
type(outer), allocatable :: obj
allocate(obj)
allocate(obj%link)
allocate(obj%link%i)
deallocate(obj%link)
deallocate(obj) ! <- this will generate pseudo-pseudo-code of the kind:
if (obj.link.i != 0) // But link is already NULL, i.e. a crash occurs.
free(obj.link.i)
The patch fixes this by moving the code for freeing link.i into the check if
link is allocated, i.e.:
if (obj.link != 0) {
if (obj.link.i != 0) {
free (obj.link.i);
obj.link.i = 0;
}
free (obj.link);
obj.link = 0;
}
Furthermore does the patch ensure that the handle of an allocatable component is
set to 0.
Bootstraped and regtested ok on x86_64-linux/F23. Ok for trunk?
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
Attachment:
dealloc_comps_fix_v1.clog
Description: Text document
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index ac90a4b..a5deb42 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -8157,8 +8157,11 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
tree null_cond = NULL_TREE;
tree add_when_allocated;
tree dealloc_fndecl;
- bool called_dealloc_with_status;
+ tree caf_token;
gfc_symbol *vtab;
+ int caf_dereg_mode;
+ symbol_attribute *attr;
+ bool deallocate_called;
gfc_init_block (&fnblock);
@@ -8265,7 +8268,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
|| c->ts.type == BT_CLASS)
&& c->ts.u.derived->attr.alloc_comp;
- bool same_type = c->ts.type == BT_DERIVED && der_type == c->ts.u.derived;
+ bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived)
+ || (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived);
cdecl = c->backend_decl;
ctype = TREE_TYPE (cdecl);
@@ -8274,112 +8278,120 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
{
case DEALLOCATE_ALLOC_COMP:
- /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
- (i.e. this function) so generate all the calls and suppress the
- recursion from here, if necessary. */
- called_dealloc_with_status = false;
gfc_init_block (&tmpblock);
- if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
- || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
- {
- comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
- /* The finalizer frees allocatable components. */
- called_dealloc_with_status
- = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
- purpose == DEALLOCATE_ALLOC_COMP
- && caf_enabled (caf_mode));
- }
+ /* Shortcut to get the attributes of the component. */
+ if (c->ts.type == BT_CLASS)
+ attr = &CLASS_DATA (c)->attr;
else
- comp = NULL_TREE;
+ attr = &c->attr;
- if (c->attr.allocatable && !c->attr.proc_pointer && !same_type
- && (c->attr.dimension
- || (caf_enabled (caf_mode)
- && (caf_in_coarray (caf_mode) || c->attr.codimension))))
- {
- /* Allocatable arrays or coarray'ed components (scalar or
- array). */
- int caf_dereg_mode
- = (caf_in_coarray (caf_mode) || c->attr.codimension)
- ? (gfc_caf_is_dealloc_only (caf_mode)
- ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
- : GFC_CAF_COARRAY_DEREGISTER)
- : GFC_CAF_COARRAY_NOCOARRAY;
- if (comp == NULL_TREE)
- comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
+ if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+ || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
+ /* Call the finalizer, which will free the memory and nullify the
+ pointer of an array. */
+ deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
+ caf_enabled (caf_mode))
+ && attr->dimension;
+ else
+ deallocate_called = false;
- if (c->attr.dimension || c->attr.codimension)
- /* Deallocate array. */
- tmp = gfc_trans_dealloc_allocated (comp, NULL, caf_dereg_mode);
+ /* Add the _class ref for classes. */
+ if (c->ts.type == BT_CLASS && attr->allocatable)
+ comp = gfc_class_data_get (comp);
+
+ add_when_allocated = NULL_TREE;
+ if (cmp_has_alloc_comps
+ && !c->attr.pointer && !c->attr.proc_pointer
+ && !same_type
+ && !deallocate_called)
+ {
+ /* Add checked deallocation of the components. This code is
+ obviously added because the finalizer is not trusted to free
+ all memory. */
+ if (c->ts.type == BT_CLASS)
+ {
+ rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
+ add_when_allocated
+ = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
+ comp, NULL_TREE, rank, purpose,
+ caf_mode);
+ }
else
{
- /* Deallocate scalar. */
- tree cond = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, comp,
- build_int_cst (TREE_TYPE (comp),
- 0));
-
- tmp = fold_build3_loc (input_location, COMPONENT_REF,
- pvoid_type_node, decl, c->caf_token,
- NULL_TREE);
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_caf_deregister, 5,
- gfc_build_addr_expr (NULL_TREE,
- tmp),
- build_int_cst (integer_type_node,
- caf_dereg_mode),
- null_pointer_node,
- null_pointer_node,
- integer_zero_node);
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, cond, tmp,
- build_empty_stmt (input_location));
+ rank = c->as ? c->as->rank : 0;
+ add_when_allocated = structure_alloc_comps (c->ts.u.derived,
+ comp, NULL_TREE,
+ rank, purpose,
+ caf_mode);
}
-
- gfc_add_expr_to_block (&tmpblock, tmp);
}
- else if (c->attr.allocatable && !c->attr.codimension && !same_type)
+
+ if (attr->allocatable && !attr->proc_pointer && !same_type
+ && (!c->attr.codimension
+ || (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) != 0))
{
- /* Allocatable scalar components. */
- if (comp == NULL_TREE)
- comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
+ /* Handle all types of components besides components of the
+ same_type as the current one, because those would create an
+ endless loop. */
+ caf_dereg_mode
+ = ((caf_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY) != 0
+ || attr->codimension)
+ ? ((caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY) != 0
+ ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
+ : GFC_CAF_COARRAY_DEREGISTER)
+ : GFC_CAF_COARRAY_NOCOARRAY;
- tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE,
- NULL_TREE, true, NULL,
- c->ts);
- gfc_add_expr_to_block (&tmpblock, tmp);
- called_dealloc_with_status = true;
+ caf_token = NULL_TREE;
+ /* Coarray components are handled directly by
+ deallocate_with_status. */
+ if (!attr->codimension
+ && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
+ {
+ if (c->caf_token)
+ caf_token = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (c->caf_token),
+ decl, c->caf_token, NULL_TREE);
+ else if (attr->dimension)
+ caf_token = gfc_conv_descriptor_token (comp);
+ }
+ if (attr->dimension && !attr->codimension)
+ /* When this is an array but not in conjunction with a coarray
+ then add the data-ref. For coarray'ed arrays the data-ref
+ is added by deallocate_with_status. */
+ comp = gfc_conv_descriptor_data_get (comp);
+
+ tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE, true,
+ NULL, caf_dereg_mode,
+ add_when_allocated, caf_token);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- void_type_node, comp,
- build_int_cst (TREE_TYPE (comp), 0));
gfc_add_expr_to_block (&tmpblock, tmp);
}
- else if (c->attr.allocatable && !c->attr.codimension)
+ else if (attr->allocatable && !attr->codimension
+ && !deallocate_called)
{
/* Case of recursive allocatable derived types. */
tree is_allocated;
tree ubound;
tree cdesc;
- tree data;
stmtblock_t dealloc_block;
gfc_init_block (&dealloc_block);
+ if (add_when_allocated)
+ gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
/* Convert the component into a rank 1 descriptor type. */
- if (comp == NULL_TREE)
- comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
-
- if (c->attr.dimension)
+ if (attr->dimension)
{
tmp = gfc_get_element_type (TREE_TYPE (comp));
- ubound = gfc_full_array_size (&dealloc_block, comp, c->as->rank);
+ ubound = gfc_full_array_size (&dealloc_block, comp,
+ c->ts.type == BT_CLASS
+ ? CLASS_DATA (c)->as->rank
+ : c->as->rank);
}
else
{
@@ -8406,11 +8418,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_index_zero_node, ubound);
if (c->attr.dimension)
- data = gfc_conv_descriptor_data_get (comp);
- else
- data = comp;
+ comp = gfc_conv_descriptor_data_get (comp);
- gfc_conv_descriptor_data_set (&dealloc_block, cdesc, data);
+ gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
/* Now call the deallocator. */
vtab = gfc_find_vtab (&c->ts);
@@ -8420,10 +8430,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
dealloc_fndecl);
- tmp = build_int_cst (TREE_TYPE (data), 0);
+ tmp = build_int_cst (TREE_TYPE (comp), 0);
is_allocated = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, tmp,
- data);
+ comp);
cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
tmp = build_call_expr_loc (input_location,
@@ -8438,49 +8448,21 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&tmpblock, tmp);
-
- gfc_add_modify (&tmpblock, data,
- build_int_cst (TREE_TYPE (data), 0));
}
+ else if (add_when_allocated)
+ gfc_add_expr_to_block (&tmpblock, add_when_allocated);
- else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable
- && (!CLASS_DATA (c)->attr.codimension
- || !caf_enabled (caf_mode)))
+ if (c->ts.type == BT_CLASS && attr->allocatable
+ && (!attr->codimension
+ || (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) == 0))
{
- /* Allocatable CLASS components. */
-
- /* Add reference to '_data' component. */
- tmp = CLASS_DATA (c)->backend_decl;
- comp = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (tmp), comp, tmp, NULL_TREE);
-
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
- tmp = gfc_trans_dealloc_allocated (comp, NULL,
- CLASS_DATA (c)->attr.codimension
- ? GFC_CAF_COARRAY_DEREGISTER
- : GFC_CAF_COARRAY_NOCOARRAY);
- else
- {
- tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE,
- NULL_TREE, true,
- NULL,
- CLASS_DATA (c)->ts);
- gfc_add_expr_to_block (&tmpblock, tmp);
- called_dealloc_with_status = true;
-
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- void_type_node, comp,
- build_int_cst (TREE_TYPE (comp), 0));
- }
- gfc_add_expr_to_block (&tmpblock, tmp);
-
/* Finally, reset the vptr to the declared type vtable and, if
necessary reset the _len field.
First recover the reference to the component and obtain
the vptr. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
+ decl, cdecl, NULL_TREE);
tmp = gfc_class_vptr_get (comp);
if (UNLIMITED_POLY (c))
@@ -8507,22 +8489,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
}
}
- if (cmp_has_alloc_comps
- && !c->attr.pointer && !c->attr.proc_pointer
- && !same_type
- && !called_dealloc_with_status)
- {
- /* Do not deallocate the components of ultimate pointer
- components or iteratively call self if call has been made
- to gfc_trans_dealloc_allocated */
- comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
- rank = c->as ? c->as->rank : 0;
- tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
- rank, purpose, caf_mode);
- gfc_add_expr_to_block (&fnblock, tmp);
- }
-
/* Now add the deallocation of this component. */
gfc_add_block_to_block (&fnblock, &tmpblock);
break;
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 6a1d481..a16bf92 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1281,30 +1281,55 @@ tree
gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
tree errlen, tree label_finish,
bool can_fail, gfc_expr* expr,
- int coarray_dealloc_mode)
+ int coarray_dealloc_mode, tree add_when_allocated,
+ tree caf_token)
{
stmtblock_t null, non_null;
tree cond, tmp, error;
tree status_type = NULL_TREE;
- tree caf_decl = NULL_TREE;
+ tree token = NULL_TREE;
gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE)
{
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)));
- caf_decl = pointer;
- pointer = gfc_conv_descriptor_data_get (caf_decl);
- STRIP_NOPS (pointer);
- if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
+ if (flag_coarray == GFC_FCOARRAY_LIB)
{
- bool comp_ref;
- if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
- && comp_ref)
- caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
- // else do a deregister as set by default.
+ if (caf_token)
+ token = caf_token;
+ else
+ {
+ tree caf_type, caf_decl = pointer;
+ pointer = gfc_conv_descriptor_data_get (caf_decl);
+ caf_type = TREE_TYPE (caf_decl);
+ STRIP_NOPS (pointer);
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+ token = gfc_conv_descriptor_token (caf_decl);
+ else if (DECL_LANG_SPECIFIC (caf_decl)
+ && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+ token = GFC_DECL_TOKEN (caf_decl);
+ else
+ {
+ gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type)
+ != NULL_TREE);
+ token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
+ }
+ }
+
+ if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
+ {
+ bool comp_ref;
+ if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
+ && comp_ref)
+ caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
+ // else do a deregister as set by default.
+ }
+ else
+ caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
}
- else
- caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
+ else if (flag_coarray == GFC_FCOARRAY_SINGLE)
+ pointer = gfc_conv_descriptor_data_get (pointer);
}
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
@@ -1348,6 +1373,8 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
/* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null);
+ if (add_when_allocated)
+ gfc_add_expr_to_block (&non_null, add_when_allocated);
gfc_add_finalizer_call (&non_null, expr);
if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY
|| flag_coarray != GFC_FCOARRAY_LIB)
@@ -1356,6 +1383,8 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
builtin_decl_explicit (BUILT_IN_FREE), 1,
fold_convert (pvoid_type_node, pointer));
gfc_add_expr_to_block (&non_null, tmp);
+ gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
+ 0));
if (status != NULL_TREE && !integer_zerop (status))
{
@@ -1378,8 +1407,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
}
else
{
- tree caf_type, token, cond2;
- tree pstat = null_pointer_node;
+ tree cond2, pstat = null_pointer_node;
if (errmsg == NULL_TREE)
{
@@ -1394,27 +1422,12 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
}
- caf_type = TREE_TYPE (caf_decl);
-
if (status != NULL_TREE && !integer_zerop (status))
{
gcc_assert (status_type == integer_type_node);
pstat = status;
}
- if (GFC_DESCRIPTOR_TYPE_P (caf_type)
- && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
- token = gfc_conv_descriptor_token (caf_decl);
- else if (DECL_LANG_SPECIFIC (caf_decl)
- && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
- token = GFC_DECL_TOKEN (caf_decl);
- else
- {
- gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
- && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
- token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
- }
-
token = gfc_build_addr_expr (NULL_TREE, token);
gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE);
tmp = build_call_expr_loc (input_location,
@@ -1431,6 +1444,8 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
ASM_VOLATILE_P (tmp) = 1;
gfc_add_expr_to_block (&non_null, tmp);
+ gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
+ 0));
if (status != NULL_TREE)
{
@@ -1516,7 +1531,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
finalizable = gfc_add_finalizer_call (&non_null, expr);
if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
{
- if (coarray)
+ if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
tmp = gfc_conv_descriptor_data_get (pointer);
else
tmp = build_fold_indirect_ref_loc (input_location, pointer);
@@ -1573,7 +1588,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
gfc_add_expr_to_block (&non_null, tmp);
/* It guarantees memory consistency within the same segment. */
- tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
+ tmp = gfc_build_string_const (strlen ("memory")+1, "memory");
tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index ae1f156..bfc2a24 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -719,7 +719,8 @@ void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree);
/* Generate code to deallocate an array. */
tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool,
- gfc_expr *, int);
+ gfc_expr *, int, tree a = NULL_TREE,
+ tree c = NULL_TREE);
tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr*,
gfc_typespec, bool c = false);
diff --git a/gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08 b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08
new file mode 100644
index 0000000..4e9effd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08
@@ -0,0 +1,50 @@
+! { dg-do run }
+!
+! Contributed by Andre Vehreschild
+! Check that manually freeing components does not lead to a runtime crash,
+! when the auto-deallocation is taking care.
+
+program coarray_alloc_comp_3
+ implicit none
+
+ type dt
+ integer, allocatable :: i
+ end type dt
+
+ type linktype
+ type(dt), allocatable :: link
+ end type linktype
+
+ type(linktype), allocatable :: obj
+
+ allocate(obj)
+ allocate(obj%link)
+
+ if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated."
+ if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated."
+ if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' already allocated."
+
+ allocate(obj%link%i, source = 42)
+
+ if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated."
+ if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated."
+ if (.not. allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' not allocated."
+ if (obj%link%i /= 42) error stop "Test failed. obj%link%i /= 42."
+
+ deallocate(obj%link%i)
+
+ if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' still allocated."
+ if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' no longer allocated."
+ if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated."
+
+ ! Freeing this object, lead to crash with older gfortran...
+ deallocate(obj%link)
+
+ if (allocated(obj%link)) error stop "Test failed. 'obj%link' still allocated."
+ if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated."
+
+ ! ... when auto-deallocating the allocated components.
+ deallocate(obj)
+
+ if (allocated(obj)) error stop "Test failed. 'obj' still allocated."
+end program
diff --git a/gcc/testsuite/gfortran.dg/finalize_18.f90 b/gcc/testsuite/gfortran.dg/finalize_18.f90
index c8b4afc..3e64332 100644
--- a/gcc/testsuite/gfortran.dg/finalize_18.f90
+++ b/gcc/testsuite/gfortran.dg/finalize_18.f90
@@ -33,8 +33,8 @@ end
! { dg-final { scan-tree-dump-times "if \\(y.aa != 0B\\)" 2 "original" } }
! { dg-final { scan-tree-dump-times "if \\(y.cc._data != 0B\\)" 2 "original" } }
-! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 2 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 2 "original" } }
! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.aa;" 1 "original" } }
! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.cc._data;" 1 "original" } }
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |