aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/gfortran.h2
-rw-r--r--gcc/fortran/module.cc8
-rw-r--r--gcc/fortran/resolve.cc90
-rw-r--r--gcc/fortran/trans-decl.cc7
-rw-r--r--gcc/fortran/trans-stmt.cc15
5 files changed, 82 insertions, 40 deletions
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 74fcd1a..219c4b6 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 3168a60..c489dec 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 daff3b3..00b143c 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 055698b..c31c756 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 f4e6c57..f25335d 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
generated by cgit v1.1 at 2025-09-30 23:27:23 +0000