https://gcc.gnu.org/g:c40b573828fccaa9e03122404bf9d316b4f9378f
commit r16-7214-gc40b573828fccaa9e03122404bf9d316b4f9378f Author: Paul Thomas <[email protected]> Date: Sat Jan 31 10:34:26 2026 +0000 Fortran: Introduce macros IS_PDT and IS_CLASS_PDT 2026-01-31 Paul Thomas <[email protected]> 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);
