bool has_parameterized_comps (gfc_symbol * der_type)
{
bool parameterized_comps = false;
+
+ if (!der_type->attr.pdt_type && !der_type->attr.pdt_comp)
+ return false;
+
for (gfc_component *c = der_type->components; c; c = c->next)
if (c->attr.pdt_array || c->attr.pdt_string)
parameterized_comps = true;
- else if (IS_PDT (c) && strcmp (der_type->name, c->ts.u.derived->name))
- parameterized_comps = has_parameterized_comps (c->ts.u.derived);
+ else if (IS_PDT (c) && strcmp (der_type->name, c->ts.u.derived->name)
+ && has_parameterized_comps (c->ts.u.derived))
+ parameterized_comps = true;
+
return parameterized_comps;
}
NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
expr1, 1);
}
- else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
+ else if (expr1->ts.type == BT_DERIVED
+ && (expr1->ts.u.derived->attr.alloc_comp
+ || has_parameterized_comps (expr1->ts.u.derived)))
{
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_CALLOC),
gfc_add_expr_to_block (&block, tmp);
}
/* Set KIND and LEN PDT components and allocate those that are
- parameterized. */
- else if (IS_PDT (expr))
+ parameterized and make sure that allocatable components are
+ nullified. */
+ else if (IS_PDT (expr) || IS_CLASS_PDT (expr))
{
+ gfc_symbol *declared;
+ gfc_symbol *type_spec_dt;
+ tree type;
+ tree ptr;
+
+ declared = IS_PDT (expr) ? expr->ts.u.derived
+ : CLASS_DATA (expr)->ts.u.derived;
+
+ if (code->ext.alloc.ts.type == BT_DERIVED)
+ type_spec_dt = code->ext.alloc.ts.u.derived;
+ else
+ type_spec_dt = NULL;
+
if (code->expr3 && code->expr3->param_list)
param_list = code->expr3->param_list;
else if (expr->param_list)
int pdt_rank = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
? GFC_TYPE_ARRAY_RANK (TREE_TYPE (se.expr))
: expr->rank);
- tmp = gfc_allocate_pdt_comp (expr->ts.u.derived, se.expr,
+ tmp = gfc_allocate_pdt_comp (declared, se.expr,
pdt_rank, param_list);
gfc_add_expr_to_block (&block, tmp);
- }
- /* Ditto for CLASS expressions. */
- else if (IS_CLASS_PDT (expr))
- {
- if (code->expr3 && code->expr3->param_list)
- param_list = code->expr3->param_list;
- else if (expr->param_list)
- param_list = expr->param_list;
- else
- param_list = expr->symtree->n.sym->param_list;
- int pdt_rank = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
- ? GFC_TYPE_ARRAY_RANK (TREE_TYPE (se.expr))
- : expr->rank);
- tmp = gfc_allocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
- se.expr, pdt_rank, param_list);
- gfc_add_expr_to_block (&block, tmp);
+
+ /* If this is a CLASS allocation and the declared type does not have
+ allocatable components but the explicit type_spec does, nullify
+ the allocatable components of the type_spec derived type. */
+ if (pdt_rank == 0 && type_spec_dt
+ && !declared->attr.alloc_comp && type_spec_dt->attr.alloc_comp)
+ {
+ type = build_pointer_type (gfc_get_derived_type (type_spec_dt));
+ ptr = fold_convert (type, se.expr);
+ tmp = gfc_nullify_alloc_comp (type_spec_dt, ptr, 0);
+ gfc_add_expr_to_block (&block, tmp);
+ }
}
else if (code->expr3 && code->expr3->mold
&& code->expr3->ts.type == BT_CLASS)
--- /dev/null
+! { dg-do run }
+!
+! Test the fix for PR83763 in which a dependency was not handled correctly, which
+! resulted in a runtime segfault.
+!
+! Contributed by Berke Durak <berke.durak@gmail.com>
+!
+module bar
+ implicit none
+
+ type :: foo(n)
+ integer, len :: n = 10
+ real :: vec(n)
+ end type foo
+
+contains
+
+ function baz(a) result(b)
+ type(foo(n = *)), intent(in) :: a
+ type(foo(n = a%n)) :: b
+
+ b%vec = a%vec * 10
+ end function baz
+
+end module bar
+
+program test
+ use bar
+ implicit none
+ call main1 ! Original report
+ call main2 ! Check for memory loss with allocatable 'x' and 'y'.
+
+contains
+
+ subroutine main1
+ type(foo(5)) :: x, y
+ integer :: a(5) = [1,2,3,4,5]
+
+ x = foo(5)(a)
+ x = baz (x) ! Segmentation fault because dependency not handled.
+ if (any (x%vec /= 10 * a)) stop 1
+ y = x
+ x = baz (y) ! No dependecy and so this worked.
+ if (any (x%vec /= 100 * a)) stop 2
+ end subroutine main1
+
+ subroutine main2
+ type(foo(5)), allocatable :: x, y
+ integer :: a(5) = [1,2,3,4,5]
+
+ x = foo(5)(a)
+ x = baz (x) ! Segmentation fault because dependency not handled.
+ if (any (x%vec /= 10 * a)) stop 3
+ y = x
+ x = baz (y) ! No dependecy and so this worked.
+ if (any (x%vec /= 100 * a)) stop 4
+ end subroutine main2
+
+end program test
--- /dev/null
+! { dg-do run }
+!
+! Test the fix for PR110012, which failed to compile with an ICE.
+! Later, it was found that mfe_disc_test was leaking memory because
+! the 'navier_stokes' component p was given the PDT template dynamic
+! type, rather than that of the correct instance. This is detected
+! by the added, final subroutine being called twice, rather than
+! once (PR121972).
+!
+! Contributed by Neil Carlson <neil.n.carlson@gmail.com>
+!
+module pde_class
+ type, abstract :: pde(npde)
+ integer,len :: npde
+ end type
+end module
+
+module navier_stokes_type
+ use pde_class
+ type, extends(pde) :: navier_stokes
+ integer, allocatable :: data_(:)
+ contains
+ final :: finalIze_navier_stokes
+ end type
+ integer :: ctr = 0
+contains
+ subroutine alloc_navier_stokes(p , n)
+ class(pde(:)), allocatable :: p
+ integer :: n
+ allocate(navier_stokes(npde=n) :: p)
+ select type (p)
+ type is (navier_stokes(*))
+ p%data_ = [(i, i = 1, p%npde)]
+ end select
+ end subroutine
+ impure elemental subroutine finalIze_navier_stokes (self)
+ type(navier_stokes), intent(inout) :: self
+ ctr = ctr + 1
+ end
+end module
+
+module mfe_disc_type
+ use pde_class
+ type :: foo
+ class(pde(:)), allocatable :: p ! This caused the ICE in resolution.
+ end type
+end module
+
+program test
+ use navier_stokes_type
+ call navier_stokes_test
+ call mfe_disc_test
+ if (ctr /= 2) stop 3
+contains
+ subroutine navier_stokes_test
+ class (pde(:)), allocatable :: x
+ call alloc_navier_stokes (x, 4)
+ select type (x)
+ type is (navier_stokes(*))
+ if (any (x%data_ /= [1,2,3,4])) stop 1
+ end select
+ end subroutine
+
+ subroutine mfe_disc_test
+ use mfe_disc_type
+ type (foo), allocatable :: x
+ allocate (x)
+ call alloc_navier_stokes (x%p, 3)
+ select type (z => x%p)
+ type is (navier_stokes(*))
+ if (any (z%data_ /= [1,2,3])) stop 2
+ end select
+ if (allocated (x) .and. allocated (x%p)) deallocate (x%p)
+ end subroutine
+end program
end program test
! { dg-final { scan-tree-dump-times "__builtin_free" 16 "original" } }
-! { dg-final { scan-tree-dump-times "__builtin_malloc" 12 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 8 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_calloc" 4 "original" } }
call sr
deallocate (d%p_t1)
end
-! { dg-final { scan-tree-dump-times "__builtin_malloc" 8 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 7 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_calloc" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_free" 9 "original" } }
projects / thirdparty / gcc.git / commitdiff
