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 --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index e9199f3e77f50978bd686dbd826da5640189ec0d..87b37c8a5ddb50b1ae691e4615ca80a81d1b1ff2 100644 (file)
--- 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 72b4c80487c4b1ab1671de6e413e313b6ddb865c..37b24f97fa3a0cb6d9bdf055657aceb066a30d0a 100644 (file)
--- 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 64bfeb0918906093519cd7f3cb583e57d28e6081..b2996759c68e1d3b32400885b629ef004821d279 100644 (file)
--- 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 0c52511790f39b6a7deea6c37a6db3f05db26709..e5b36234d7e6fea2287e55c5c207a53cc835fc06 100644 (file)
--- 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 ca2bff22ba31b0db7d23d57863edd23311a43b97..8657101b89a98c0119bd05d7d7f3ea9efc236af9 100644 (file)
--- 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 8f6819d2f776c04affcce22d26030f83884ec5da..b3262729c98e8353e9f15cf21fd58bc2768d995b 100644 (file)
--- 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 eb050506a34ed401dbc4b3a3d56ba605f6ab2bfe..cc32d5dbb64479ee114842e1572c63f82098a1d8 100644 (file)
--- 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 3433738c3730d1da55498facc2d18ed392cd865d..1e1179323c4667c50e84ff81616336fa67e168ed 100644 (file)
--- 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);