This patch looks to be mightier than it actually is :-) The concept is to detect PDT components of ordinary, non-PDT derived types, ensure that the new 'pdt_comp' field is set for the derived type, propagated through module usage, add type spec parameter lists to these components and do the allocation and deallocation of parameterized fields. The ChangeLog indicates where these things are happening.
An issue came up in preparing this patch: Several existing testcases were leaking memory because deallocations were absent. These have been added as appropriate. Unfortunately several leaks remain, either because deallocation crashes or memory is lost in operations such as allocation or assignment. Comments have been added in these tests and I will update PR121972(pdt_3.f03 leaks memory). Regtests on FC42/x86_64 - OK for mainline? Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 74fcd1ad9de..219c4b67ed8 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1033,7 +1033,7 @@ typedef struct
/* These are the attributes required for parameterized derived
types. */
unsigned pdt_kind:1, pdt_len:1, pdt_type:1, pdt_template:1,
- pdt_array:1, pdt_string:1;
+ pdt_array:1, pdt_string:1, pdt_comp:1;
/* This is omp_{out,in,priv,orig} artificial variable in
!$OMP DECLARE REDUCTION. */
diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc
index 3168a6082eb..c489decec8d 100644
--- a/gcc/fortran/module.cc
+++ b/gcc/fortran/module.cc
@@ -2093,7 +2093,7 @@ enum ab_attribute
AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR,
AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK,
AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE,
- AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING,
+ AB_PDT_COMP, AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING,
AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER,
AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ,
AB_OACC_ROUTINE_NOHOST,
@@ -2172,6 +2172,7 @@ static const mstring attr_bits[] =
minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE),
minit ("PDT_ARRAY", AB_PDT_ARRAY),
minit ("PDT_STRING", AB_PDT_STRING),
+ minit ("PDT_COMP", AB_PDT_COMP),
minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG),
minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER),
minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR),
@@ -2404,6 +2405,8 @@ mio_symbol_attribute (symbol_attribute *attr)
MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits);
if (attr->pdt_type)
MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits);
+ if (attr->pdt_comp)
+ MIO_NAME (ab_attribute) (AB_PDT_COMP , attr_bits);
if (attr->pdt_template)
MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits);
if (attr->pdt_array)
@@ -2681,6 +2684,9 @@ mio_symbol_attribute (symbol_attribute *attr)
case AB_PDT_TYPE:
attr->pdt_type = 1;
break;
+ case AB_PDT_COMP:
+ attr->pdt_comp = 1;
+ break;
case AB_PDT_TEMPLATE:
attr->pdt_template = 1;
break;
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index daff3b3e33b..00b143c07db 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -16663,6 +16663,26 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
return false;
}
+ if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_template
+ && !sym->attr.pdt_type && !sym->attr.pdt_template
+ && !(gfc_get_derived_super_type (sym)
+ && (gfc_get_derived_super_type (sym)->attr.pdt_type
+ || gfc_get_derived_super_type (sym)->attr.pdt_template)))
+ {
+ gfc_actual_arglist *type_spec_list;
+ if (gfc_get_pdt_instance (c->param_list, &c->ts.u.derived,
+ &type_spec_list)
+ != MATCH_YES)
+ return false;
+ gfc_free_actual_arglist (c->param_list);
+ c->param_list = type_spec_list;
+ if (!sym->attr.pdt_type)
+ sym->attr.pdt_comp = 1;
+ }
+ else if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type
+ && !sym->attr.pdt_type)
+ sym->attr.pdt_comp = 1;
+
if (c->attr.proc_pointer && c->ts.interface)
{
gfc_symbol *ifc = c->ts.interface;
@@ -16863,16 +16883,16 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
}
if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
- && !c->ts.deferred)
+ && !c->ts.deferred)
{
- if (c->ts.u.cl->length == NULL
- || (!resolve_charlen(c->ts.u.cl))
- || !gfc_is_constant_expr (c->ts.u.cl->length))
- {
- gfc_error ("Character length of component %qs needs to "
- "be a constant specification expression at %L",
- c->name,
- c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
+ if (c->ts.u.cl->length == NULL
+ || (!resolve_charlen(c->ts.u.cl))
+ || !gfc_is_constant_expr (c->ts.u.cl->length))
+ {
+ gfc_error ("Character length of component %qs needs to "
+ "be a constant specification expression at %L",
+ c->name,
+ c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
return false;
}
@@ -16894,8 +16914,8 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
&& !c->attr.pointer && !c->attr.allocatable)
{
gfc_error ("Character component %qs of %qs at %L with deferred "
- "length must be a POINTER or ALLOCATABLE",
- c->name, sym->name, &c->loc);
+ "length must be a POINTER or ALLOCATABLE",
+ c->name, sym->name, &c->loc);
return false;
}
@@ -16910,14 +16930,14 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
sprintf (name, "_%s_length", c->name);
strlen = gfc_find_component (sym, name, true, true, NULL);
if (strlen == NULL)
- {
- if (!gfc_add_component (sym, name, &strlen))
- return false;
- strlen->ts.type = BT_INTEGER;
- strlen->ts.kind = gfc_charlen_int_kind;
- strlen->attr.access = ACCESS_PRIVATE;
- strlen->attr.artificial = 1;
- }
+ {
+ if (!gfc_add_component (sym, name, &strlen))
+ return false;
+ strlen->ts.type = BT_INTEGER;
+ strlen->ts.kind = gfc_charlen_int_kind;
+ strlen->attr.access = ACCESS_PRIVATE;
+ strlen->attr.artificial = 1;
+ }
}
if (c->ts.type == BT_DERIVED
@@ -16927,27 +16947,27 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
&& !c->ts.u.derived->attr.use_assoc
&& !gfc_check_symbol_access (c->ts.u.derived)
&& !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
- "PRIVATE type and cannot be a component of "
- "%qs, which is PUBLIC at %L", c->name,
- sym->name, &sym->declared_at))
+ "PRIVATE type and cannot be a component of "
+ "%qs, which is PUBLIC at %L", c->name,
+ sym->name, &sym->declared_at))
return false;
if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
{
gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
- "type %s", c->name, &c->loc, sym->name);
+ "type %s", c->name, &c->loc, sym->name);
return false;
}
if (sym->attr.sequence)
{
if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
- {
+ {
gfc_error ("Component %s of SEQUENCE type declared at %L does "
- "not have the SEQUENCE attribute",
- c->ts.u.derived->name, &sym->declared_at);
- return false;
- }
+ "not have the SEQUENCE attribute",
+ c->ts.u.derived->name, &sym->declared_at);
+ return false;
+ }
}
if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
@@ -16955,7 +16975,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
else if (c->ts.type == BT_CLASS && c->attr.class_ok
&& CLASS_DATA (c)->ts.u.derived->attr.generic)
CLASS_DATA (c)->ts.u.derived
- = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
+ = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
/* If an allocatable component derived type is of the same type as
the enclosing derived type, we need a vtable generating so that
@@ -16968,10 +16988,10 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
derived type list; even in formal namespaces, where derived type
pointer components might not have been declared. */
if (c->ts.type == BT_DERIVED
- && c->ts.u.derived
- && c->ts.u.derived->components
- && c->attr.pointer
- && sym != c->ts.u.derived)
+ && c->ts.u.derived
+ && c->ts.u.derived->components
+ && c->attr.pointer
+ && sym != c->ts.u.derived)
add_dt_to_dt_list (c->ts.u.derived);
if (c->as && c->as->type != AS_DEFERRED
@@ -16979,8 +16999,8 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
return false;
if (!gfc_resolve_array_spec (c->as,
- !(c->attr.pointer || c->attr.proc_pointer
- || c->attr.allocatable)))
+ !(c->attr.pointer || c->attr.proc_pointer
+ || c->attr.allocatable)))
return false;
if (c->initializer && !sym->attr.vtype
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 055698b1efd..c31c7569882 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -1688,6 +1688,11 @@ gfc_get_symbol_decl (gfc_symbol * sym)
&& !(sym->attr.use_assoc || sym->attr.dummy))
gfc_defer_symbol_init (sym);
+ if ((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_comp)
+ && gfc_current_ns == sym->ns
+ && !(sym->attr.use_assoc || sym->attr.dummy))
+ gfc_defer_symbol_init (sym);
+
/* Dummy PDT 'len' parameters should be checked when they are explicit. */
if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
&& (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
@@ -4921,7 +4926,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
if (sym->ts.type == BT_DERIVED
&& sym->ts.u.derived
- && sym->ts.u.derived->attr.pdt_type)
+ && (sym->ts.u.derived->attr.pdt_type || sym->ts.u.derived->attr.pdt_comp))
{
is_pdt_type = true;
gfc_init_block (&tmpblock);
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index f4e6c57114e..f25335d6bdb 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -7922,6 +7922,8 @@ gfc_trans_deallocate (gfc_code *code)
gfc_expr *expr = gfc_copy_expr (al->expr);
bool is_coarray = false, is_coarray_array = false;
int caf_mode = 0;
+ gfc_ref * ref;
+ gfc_actual_arglist * param_list;
gcc_assert (expr->expr_type == EXPR_VARIABLE);
@@ -7937,9 +7939,18 @@ gfc_trans_deallocate (gfc_code *code)
/* Deallocate PDT components that are parameterized. */
tmp = NULL;
+ param_list = expr->param_list;
+ if (!param_list && expr->symtree->n.sym->param_list)
+ param_list = expr->symtree->n.sym->param_list;
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->ts.type == BT_DERIVED
+ && ref->u.c.component->ts.u.derived->attr.pdt_type
+ && ref->u.c.component->param_list)
+ param_list = ref->u.c.component->param_list;
if (expr->ts.type == BT_DERIVED
- && expr->ts.u.derived->attr.pdt_type
- && expr->symtree->n.sym->param_list)
+ && ((expr->ts.u.derived->attr.pdt_type && param_list)
+ || expr->ts.u.derived->attr.pdt_comp))
tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank);
else if (expr->ts.type == BT_CLASS
&& CLASS_DATA (expr)->ts.u.derived->attr.pdt_type
diff --git a/gcc/testsuite/gfortran.dg/pdt_11.f03 b/gcc/testsuite/gfortran.dg/pdt_11.f03
index 41b506af41e..3ddbafe4efb 100644
--- a/gcc/testsuite/gfortran.dg/pdt_11.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_11.f03
@@ -47,6 +47,7 @@ program test
write(*,*) 'o_fdef FAIL'
STOP 2
end if
+ deallocate (o_fdef)
end program test
diff --git a/gcc/testsuite/gfortran.dg/pdt_15.f03 b/gcc/testsuite/gfortran.dg/pdt_15.f03
index 4ae19839923..17d4d37d3fa 100644
--- a/gcc/testsuite/gfortran.dg/pdt_15.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_15.f03
@@ -98,9 +98,9 @@ contains
if (int (pop_8 (root)) .ne. 3) STOP 1
if (int (pop_8 (root)) .ne. 2) STOP 2
if (int (pop_8 (root)) .ne. 1) STOP 3
-! if (int (pop_8 (root)) .ne. 0) STOP 4
+ if (int (pop_8 (root)) .ne. 0) STOP 4
end subroutine
end program ch2701
! { dg-final { scan-tree-dump-times "Pdtlink_8._deallocate " 5 "original" } }
-! { dg-final { scan-tree-dump-times ".n.data = 0B" 8 "original" } }
-! { dg-final { scan-tree-dump-times "__builtin_free" 14 "original" } }
+! { dg-final { scan-tree-dump-times ".n.data = 0B" 9 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 15 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/pdt_20.f03 b/gcc/testsuite/gfortran.dg/pdt_20.f03
index 3aa9b2e086b..3c4b5b8dfca 100644
--- a/gcc/testsuite/gfortran.dg/pdt_20.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_20.f03
@@ -17,4 +17,5 @@ program p
if (x%b .ne. 3) STOP 1
if (x%b .ne. size (x%r, 1)) STOP 2
if (x%r%a .ne. 1) STOP 3
+! deallocate (x) ! Segmentation fault: triggered at trans-array.cc:11009.
end
diff --git a/gcc/testsuite/gfortran.dg/pdt_23.f03 b/gcc/testsuite/gfortran.dg/pdt_23.f03
index c0cec9afe0f..dadea11a3ca 100644
--- a/gcc/testsuite/gfortran.dg/pdt_23.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_23.f03
@@ -30,4 +30,5 @@ program p
buffer = "lmn"
read (buffer, *) x ! PDT IO was incorrect (PRs 84143/84432).
if (x%c .ne. 'lmn') STOP 5
+! if (allocated (x)) deallocate (x) ! Used to seg fault - invalid memory reference.
end
diff --git a/gcc/testsuite/gfortran.dg/pdt_3.f03 b/gcc/testsuite/gfortran.dg/pdt_3.f03
index 68007689aec..7359519b9ba 100644
--- a/gcc/testsuite/gfortran.dg/pdt_3.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_3.f03
@@ -32,7 +32,6 @@ end module
type (mytype (b=s*2)) :: mat2
end type x
- real, allocatable :: matrix (:,:)
type(thytype(ftype, 4, 4)) :: w
type(x(ftype,ftype,256)) :: q
class(mytype(ftype, :)), allocatable :: cz
@@ -54,10 +53,9 @@ end module
if (size (q%mat2%d) .ne. 4*mat_dim**2) STOP 10
! Now check some basic OOP with PDTs
- matrix = w%d
-! TODO - for some reason, using w%d directly in the source causes a seg fault.
- allocate (cz, source = mytype(ftype, d_dim)( 0, matrix))
+! Using w%d directly in the source used to cause a seg fault.
+ allocate (cz, source = mytype(ftype, d_dim)( 0, w%d)) ! Leaks 64 bytes in 1 block.
select type (cz)
type is (mytype(ftype, *))
if (int (sum (cz%d)) .ne. 136) STOP 11
@@ -76,5 +74,4 @@ end module
end select
deallocate (cz)
- deallocate (matrix)
end
diff --git a/gcc/testsuite/gfortran.dg/pdt_39.f03 b/gcc/testsuite/gfortran.dg/pdt_39.f03
index 7378cf50983..7cfd232a72f 100644
--- a/gcc/testsuite/gfortran.dg/pdt_39.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_39.f03
@@ -49,7 +49,7 @@ contains
subroutine geta_r8(a_lhs, t_rhs)
real(r8), allocatable, intent(out) :: a_lhs(:,:)
class(mat_t(k=r8,c=*,r=*)), intent(in) :: t_rhs
- a_lhs = t_rhs%m_a
+ a_lhs = t_rhs%m_a ! Leaks 152 bytes in 2 blocks
return
end subroutine geta_r8
@@ -94,7 +94,7 @@ program p
if (mat_r4%c /= N) stop 2
if (mat_r4%r /= M) stop 3
mat_r4 = reshape( [ (real(i, kind=mat_r4%k), i=1,N*M) ], [ N, M ] )
- a_r4 = mat_r4
+ a_r4 = mat_r4 ! Leaks 24 bytes in 1 block.
if (int (sum (a_r4)) /= 21) stop 4
N = 4
M = 4
diff --git a/gcc/testsuite/gfortran.dg/pdt_40.f03 b/gcc/testsuite/gfortran.dg/pdt_40.f03
index 48535087f54..673ffdec29d 100644
--- a/gcc/testsuite/gfortran.dg/pdt_40.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_40.f03
@@ -22,4 +22,5 @@
if (bar%x%ell /= parm) stop 1 ! Then these component references failed in
if (bar%x%i /= 2 * parm) stop 2 ! translation.
+ deallocate (foo, bar%x)
end
diff --git a/gcc/testsuite/gfortran.dg/pdt_49.f03 b/gcc/testsuite/gfortran.dg/pdt_49.f03
new file mode 100644
index 00000000000..9ddfd14da3e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_49.f03
@@ -0,0 +1,19 @@
+! { dg-do compile }
+!
+! Check PR105380 has gone away. Used to ICE with, "internal compiler error:
+! tree check: expected array_type, have record_type in ....."
+!
+! Contributed by Martin Liska <[email protected]>
+!
+program p
+ type t(n)
+ integer, len :: n
+ end type
+ type t2(m)
+ integer, len :: m
+ type(t(1)) :: a(m)
+ end type
+ type(t2(3)) :: x
+
+ print *, x%m, size (x%a), x%a%n ! Outputs 3 3 1 as expected.
+end
diff --git a/gcc/testsuite/gfortran.dg/pdt_50.f03 b/gcc/testsuite/gfortran.dg/pdt_50.f03
new file mode 100644
index 00000000000..9c036e43563
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_50.f03
@@ -0,0 +1,54 @@
+! { dg-do compile }
+! ! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR102241, which caused an ICE in gfc_get_derived_type.
+! The test in comment 4 used to cause a spurious error.
+!
+! Contributed by Roland Wirth <[email protected]>
+!
+ MODULE mo
+ TYPE t1(n)
+ INTEGER, LEN :: n
+ INTEGER :: a(n)
+ END TYPE
+
+ TYPE t2
+ TYPE(t1(:)), allocatable :: p_t1
+ END TYPE
+ END MODULE
+
+!---Check test in comment 4 now works---
+ MODULE mo2
+ TYPE u1(n)
+ INTEGER, LEN :: n
+ INTEGER :: a(n)
+ END TYPE
+
+ TYPE u2
+ TYPE(u1(2)), POINTER :: p_u1
+ END TYPE
+
+ CONTAINS
+
+ SUBROUTINE sr
+
+ type(u1(2)), target :: tgt
+ type(u2) :: pt
+
+ tgt = u1(2)([42,84])
+ pt%p_u1 => tgt
+ if (any (pt%p_u1%a /= [42,84])) stop 1
+ END SUBROUTINE
+ END MODULE
+!------
+
+ use mo
+ use mo2
+ type(t2) :: d
+ d%p_t1 = t1(8)([42,43,44,45,42,43,44,45])
+ if (any (d%p_t1%a /= [42,43,44,45,42,43,44,45])) stop 2
+ call sr
+ deallocate (d%p_t1)
+end
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 8 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 9 "original" } }
