From: Paul Thomas <pault@gcc.gnu.org>
Date: Sat, 31 Jan 2026 10:34:26 +0000 (+0000)
Subject: Fortran: Introduce macros IS_PDT and IS_CLASS_PDT
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=c40b573828fccaa9e03122404bf9d316b4f9378f;p=thirdparty%2Fgcc.git

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 e9199f3e77f..87b37c8a5dd 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 72b4c80487c..37b24f97fa3 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 64bfeb09189..b2996759c68 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 0c52511790f..e5b36234d7e 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 ca2bff22ba3..8657101b89a 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 8f6819d2f77..b3262729c98 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 eb050506a34..cc32d5dbb64 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 3433738c373..1e1179323c4 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);