/* 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. */
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,
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),
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)
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;
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;
}
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;
}
&& !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;
}
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
&& !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)
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
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
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
&& !(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)
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);
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);
/* 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
write(*,*) 'o_fdef FAIL'
STOP 2
end if
+ deallocate (o_fdef)
end program test
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" } }
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
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
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
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
end select
deallocate (cz)
- deallocate (matrix)
end
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
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
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
--- /dev/null
+! { 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 <marxin@gcc.gnu.org>
+!
+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
--- /dev/null
+! { 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 <roland_wirth@web.de>
+!
+ 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" } }
projects / thirdparty / gcc.git / commitdiff
