[gcc r16-7214] Fortran: Introduce macros IS_PDT and IS_CLASS_PDT
Paul Thomas
pault@gcc.gnu.org
Sat Jan 31 10:34:40 GMT 2026
https://gcc.gnu.org/g:c40b573828fccaa9e03122404bf9d316b4f9378f
commit r16-7214-gc40b573828fccaa9e03122404bf9d316b4f9378f
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Sat Jan 31 10:34:26 2026 +0000
Fortran: Introduce macros IS_PDT and IS_CLASS_PDT
2026-01-31 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
* array.cc (resolve_array_list): Use macro IS_PDT.
* gfortran.h : Supply macros IS_PDT and IS_CLASS_PDT.
* match.cc (gfc_match_type_is): Use IS_PDT and IS_CLASS_PDT as
appropriate.
* resolve.cc (gfc_resolve_ref, build_init_assign,
resolve_component): Likewise.
* trans-array.cc (gfc_trans_array_constructor_value,
trans_array_constructor, structure_alloc_comps,
has_parameterized_comps): Likewise.
* trans-decl.cc (gfc_get_symbol_decl, gfc_init_default_dt,
gfc_trans_deferred_vars, gfc_generate_function_code): Likewise.
* trans-expr.cc (conv_dummy_value, gfc_conv_structure,
gfc_trans_assignment_1): Likewise.
* trans-stmt.cc (trans_associate_var, gfc_trans_allocate,
gfc_trans_deallocate): Likewise.
Diff:
---
gcc/fortran/array.cc | 4 +---
gcc/fortran/gfortran.h | 9 +++++++++
gcc/fortran/match.cc | 6 ++----
gcc/fortran/resolve.cc | 10 +++-------
gcc/fortran/trans-array.cc | 31 ++++++++++---------------------
gcc/fortran/trans-decl.cc | 19 +++++--------------
gcc/fortran/trans-expr.cc | 15 ++++-----------
gcc/fortran/trans-stmt.cc | 28 +++++++---------------------
8 files changed, 41 insertions(+), 81 deletions(-)
diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index e9199f3e77f5..87b37c8a5ddb 100644
--- a/gcc/fortran/array.cc
+++ b/gcc/fortran/array.cc
@@ -2279,9 +2279,7 @@ resolve_array_list (gfc_constructor_base base)
/* For valid expressions, check that the type specification parameters
are the same. */
- if (t && !c->iterator && c->expr
- && c->expr->ts.type == BT_DERIVED
- && c->expr->ts.u.derived->attr.pdt_type)
+ if (t && !c->iterator && c->expr && IS_PDT (c->expr))
{
if (expr1 == NULL)
expr1 = c->expr;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 72b4c80487c4..37b24f97fa3a 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4304,6 +4304,15 @@ bool gfc_may_be_finalized (gfc_typespec);
(expr && expr->expr_type == EXPR_VARIABLE \
&& expr->symtree->n.sym->assoc \
&& expr->symtree->n.sym->assoc->inferred_type)
+#define IS_PDT(sym) \
+ (sym != NULL && sym->ts.type == BT_DERIVED \
+ && sym->ts.u.derived \
+ && sym->ts.u.derived->attr.pdt_type)
+#define IS_CLASS_PDT(sym) \
+ (sym != NULL && sym->ts.type == BT_CLASS \
+ && CLASS_DATA (sym) \
+ && CLASS_DATA (sym)->ts.u.derived \
+ && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
/* frontend-passes.cc */
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 64bfeb091890..b2996759c68e 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -7947,10 +7947,8 @@ gfc_match_type_is (void)
return MATCH_ERROR;
}
- if (c->ts.type == BT_DERIVED
- && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
- && gfc_spec_list_type (type_param_spec_list, c->ts.u.derived)
- != SPEC_ASSUMED)
+ if (IS_PDT (c) && gfc_spec_list_type (type_param_spec_list,
+ c->ts.u.derived) != SPEC_ASSUMED)
{
gfc_error ("All the LEN type parameters in the TYPE IS statement "
"at %C must be ASSUMED");
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 0c52511790f3..e5b36234d7e6 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -6080,9 +6080,7 @@ gfc_resolve_ref (gfc_expr *expr)
n_components = 0;
array_ref = NULL;
- if (expr->expr_type == EXPR_VARIABLE
- && expr->symtree->n.sym->ts.type == BT_DERIVED
- && expr->symtree->n.sym->ts.u.derived->attr.pdt_type)
+ if (expr->expr_type == EXPR_VARIABLE && IS_PDT (expr))
last_pdt = expr->symtree->n.sym->ts.u.derived;
for (ref = expr->ref; ref; ref = ref->next)
@@ -14918,8 +14916,7 @@ build_init_assign (gfc_symbol *sym, gfc_expr *init)
gfc_code *init_st;
gfc_namespace *ns = sym->ns;
- if (sym->attr.function && sym->result == sym
- && sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
+ if (sym->attr.function && sym->result == sym && IS_PDT (sym))
{
gfc_free_expr (init);
return;
@@ -17061,8 +17058,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
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)
+ else if (IS_PDT (c) && !sym->attr.pdt_type)
sym->attr.pdt_comp = 1;
if (c->attr.proc_pointer && c->ts.interface)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ca2bff22ba31..8657101b89a9 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -2248,9 +2248,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock,
{
/* Scalar values. */
gfc_init_se (&se, NULL);
- if (c->expr->ts.type == BT_DERIVED
- && c->expr->ts.u.derived->attr.pdt_type
- && c->expr->expr_type == EXPR_STRUCTURE)
+ if (IS_PDT (c->expr) && c->expr->expr_type == EXPR_STRUCTURE)
c->expr->must_finalize = 1;
gfc_trans_array_ctor_element (&body, desc, *poffset,
@@ -3094,7 +3092,7 @@ trans_array_constructor (gfc_ss * ss, locus * where)
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
finalize_required = true;
- if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.pdt_type)
+ if (IS_PDT (expr))
finalize_required = true;
gfc_trans_array_constructor_value (&outer_loop->pre,
@@ -10334,8 +10332,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
&& seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived));
bool inside_wrapper = generating_copy_helper;
- bool is_pdt_type = c->ts.type == BT_DERIVED
- && c->ts.u.derived->attr.pdt_type;
+ bool is_pdt_type = IS_PDT (c);
cdecl = c->backend_decl;
ctype = TREE_TYPE (cdecl);
@@ -10873,8 +10870,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
cdecl, NULL_TREE);
dcmp = fold_convert (TREE_TYPE (comp), dcmp);
- if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type
- && !c->attr.allocatable)
+ if (IS_PDT (c) && !c->attr.allocatable)
{
tmp = gfc_copy_alloc_comp (c->ts.u.derived, comp, dcmp,
0, 0);
@@ -11134,8 +11130,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
}
}
else if (c->initializer && !c->attr.pdt_string && !c->attr.pdt_array
- && !c->as && !(c->ts.type == BT_DERIVED
- && c->ts.u.derived->attr.pdt_type)) /* Take care of arrays. */
+ && !c->as && !IS_PDT (c)) /* Take care of arrays. */
{
gfc_se tse;
gfc_expr *c_expr;
@@ -11183,8 +11178,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
/* Allocate parameterized arrays of parameterized derived types. */
if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
- && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
- && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
+ && !(IS_PDT (c) || IS_CLASS_PDT (c)))
continue;
if (c->ts.type == BT_CLASS)
@@ -11283,8 +11277,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
}
/* Recurse in to PDT components. */
- if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
- && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
+ if ((IS_PDT (c) || IS_CLASS_PDT (c))
&& !(c->attr.pointer || c->attr.allocatable))
{
gfc_actual_arglist *tail = c->param_list;
@@ -11306,8 +11299,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
of parameterized derived types. */
if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
&& !c->attr.pdt_string
- && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
- && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
+ && !(IS_PDT (c) || IS_CLASS_PDT (c)))
continue;
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
@@ -11316,8 +11308,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
comp = gfc_class_data_get (comp);
/* Recurse in to PDT components. */
- if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
- && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
+ if ((IS_PDT (c) || IS_CLASS_PDT (c))
&& (!c->attr.pointer && !c->attr.allocatable))
{
tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
@@ -11596,9 +11587,7 @@ has_parameterized_comps (gfc_symbol * der_type)
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 (c->ts.type == BT_DERIVED
- && c->ts.u.derived->attr.pdt_type
- && strcmp (der_type->name, c->ts.u.derived->name))
+ else if (IS_PDT (c) && strcmp (der_type->name, c->ts.u.derived->name))
parameterized_comps = has_parameterized_comps (c->ts.u.derived);
return parameterized_comps;
}
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 8f6819d2f776..b3262729c98e 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -2100,9 +2100,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
|| sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
&& (flag_coarray != GFC_FCOARRAY_LIB
|| !sym->attr.codimension || sym->attr.allocatable)
- && !(sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
- && !(sym->ts.type == BT_CLASS
- && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type))
+ && !(IS_PDT (sym) || IS_CLASS_PDT (sym)))
{
/* Add static initializer. For procedures, it is only needed if
SAVE is specified otherwise they need to be reinitialized
@@ -4580,8 +4578,7 @@ gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc,
gcc_assert (block);
/* Initialization of PDTs is done elsewhere. */
- if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type
- && !pdt_ok)
+ if (IS_PDT (sym) && !pdt_ok)
return;
gcc_assert (!sym->attr.allocatable);
@@ -4924,10 +4921,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
&& proc_sym != proc_sym->result) ? proc_sym->result : NULL;
if (sym && !sym->attr.allocatable && !sym->attr.pointer
- && sym->ts.type == BT_DERIVED
- && sym->ts.u.derived
- && !gfc_has_default_initializer (sym->ts.u.derived)
- && sym->ts.u.derived->attr.pdt_type)
+ && IS_PDT (sym) && !gfc_has_default_initializer (sym->ts.u.derived))
{
gfc_init_block (&tmpblock);
tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
@@ -5048,9 +5042,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
}
}
- else if (sym->ts.type == BT_CLASS
- && CLASS_DATA (sym)->ts.u.derived
- && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
+ else if (IS_CLASS_PDT (sym))
{
gfc_component *data = CLASS_DATA (sym);
is_pdt_type = true;
@@ -8236,8 +8228,7 @@ gfc_generate_function_code (gfc_namespace * ns)
/* This permits the return value to be correctly initialized, even when the
function result was not referenced. */
if (sym->abr_modproc_decl
- && sym->ts.type == BT_DERIVED
- && sym->ts.u.derived->attr.pdt_type
+ && IS_PDT (sym)
&& !sym->attr.allocatable
&& sym->result == sym
&& get_proc_result (sym) == NULL_TREE)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index eb050506a34e..cc32d5dbb644 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6595,7 +6595,7 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
- if (e && e->ts.type == BT_DERIVED && e->ts.u.derived->attr.pdt_type)
+ if (IS_PDT (e))
{
tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT");
gfc_add_modify (&parmse->pre, tmp, parmse->expr);
@@ -10393,8 +10393,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
if (!init)
{
- if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.pdt_type
- && expr->must_finalize)
+ if (IS_PDT (expr) && expr->must_finalize)
final_block = &se->finalblock;
/* Create a temporary variable and fill it in. */
@@ -13305,12 +13304,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
if (dealloc
&& !expr1->symtree->n.sym->attr.associate_var
&& expr2->expr_type != EXPR_ARRAY
- && ((expr1->ts.type == BT_DERIVED
- && expr1->ts.u.derived
- && expr1->ts.u.derived->attr.pdt_type)
- || (expr1->ts.type == BT_CLASS
- && CLASS_DATA (expr1)->ts.u.derived
- && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)))
+ && (IS_PDT (expr1) || IS_CLASS_PDT (expr1)))
{
bool pdt_dep = gfc_check_dependency (expr1, expr2, true);
@@ -13567,8 +13561,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
/* Since parameterized components cannot have default initializers,
the default PDT constructor leaves them unallocated. Do the
allocation now. */
- if (init_flag && expr1->ts.type == BT_DERIVED
- && expr1->ts.u.derived->attr.pdt_type
+ if (init_flag && IS_PDT (expr1)
&& !expr1->symtree->n.sym->attr.allocatable
&& !expr1->symtree->n.sym->attr.dummy)
{
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 3433738c3730..1e1179323c46 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2195,10 +2195,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
dim, gfc_index_one_node);
}
- if (e->expr_type == EXPR_FUNCTION
- && sym->ts.type == BT_DERIVED
- && sym->ts.u.derived
- && sym->ts.u.derived->attr.pdt_type)
+ if (e->expr_type == EXPR_FUNCTION && IS_PDT (e))
{
tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, se.expr,
sym->as->rank);
@@ -2516,18 +2513,12 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
}
tmp = sym->backend_decl;
- if (e->expr_type == EXPR_FUNCTION
- && sym->ts.type == BT_DERIVED
- && sym->ts.u.derived
- && sym->ts.u.derived->attr.pdt_type)
+ if (e->expr_type == EXPR_FUNCTION && IS_PDT (sym))
{
tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, tmp,
0);
}
- else if (e->expr_type == EXPR_FUNCTION
- && sym->ts.type == BT_CLASS
- && CLASS_DATA (sym)->ts.u.derived
- && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
+ else if (e->expr_type == EXPR_FUNCTION && IS_CLASS_PDT (sym))
{
tmp = gfc_class_data_get (tmp);
tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived,
@@ -7687,8 +7678,7 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
}
/* Set KIND and LEN PDT components and allocate those that are
parameterized. */
- else if (expr->ts.type == BT_DERIVED
- && expr->ts.u.derived->attr.pdt_type)
+ else if (IS_PDT (expr))
{
if (code->expr3 && code->expr3->param_list)
param_list = code->expr3->param_list;
@@ -7701,8 +7691,7 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
gfc_add_expr_to_block (&block, tmp);
}
/* Ditto for CLASS expressions. */
- else if (expr->ts.type == BT_CLASS
- && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type)
+ else if (IS_CLASS_PDT (expr))
{
if (code->expr3 && code->expr3->param_list)
param_list = code->expr3->param_list;
@@ -7961,17 +7950,14 @@ gfc_trans_deallocate (gfc_code *code)
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
+ && IS_PDT (ref->u.c.component)
&& 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 && 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
- && expr->symtree->n.sym->param_list)
+ else if (IS_CLASS_PDT (expr) && expr->symtree->n.sym->param_list)
tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
se.expr, expr->rank);
More information about the Gcc-cvs
mailing list