Fortran: Check constant PDT type specification parameters [PR112460]

2026-01-14  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/112460
	* array.cc (resolve_array_list): Stash the first PDT element
	and check its type specification parameters against those of
	subsequent elements.
	* expr.cc (get_parm_list_from_expr): New function to extract the
	type spec lists from expressions to be compared.
	(gfc_check_type_spec_parms): New function to compare type spec
	lists between two expressions. Emit an error if any constant
	values are different.
	(gfc_check_assign): Check that the PDT type specification parms
	are the same on lhs and rhs.
	* gfortran.h : Add prototype for gfc_check_type_spec_parms.
	* trans-expr.cc (copyable_array_p): PDT arrays are not copyable

gcc/testsuite
	PR fortran/112460
	* gfortran.dg/pdt_81.f03: New test.

diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index be2eb595317bcbad640fd53851959202f565975f..e9199f3e77f50978bd686dbd826da5640189ec0d 100644 (file)
--- a/gcc/fortran/array.cc
+++ b/gcc/fortran/array.cc
@@ -2214,6 +2214,7 @@ resolve_array_list (gfc_constructor_base base)
   bool t;
   gfc_constructor *c;
   gfc_iterator *iter;
+  gfc_expr *expr1 = NULL;
 
   t = true;
 
@@ -2276,6 +2277,17 @@ resolve_array_list (gfc_constructor_base base)
          t = false;
        }
 
+      /* 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 (expr1 == NULL)
+           expr1 = c->expr;
+         else
+           t = gfc_check_type_spec_parms (expr1, c->expr, "in array constructor");
+       }
     }
 
   return t;

diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index a2f19607eb1eab3a8d3c1316c4cfb8b684ac355d..a47e970eda9f04338c1cf859d817b4dbc8acaf48 100644 (file)
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -3930,6 +3930,67 @@ gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, .
 }
 
 
+/* Functions to check constant valued type specification parameters.  */
+
+static gfc_actual_arglist *
+get_parm_list_from_expr (gfc_expr *expr)
+{
+  gfc_actual_arglist *a = NULL;
+  gfc_constructor *c;
+
+  if (expr->expr_type == EXPR_STRUCTURE)
+    a = expr->param_list;
+  else if (expr->expr_type == EXPR_ARRAY)
+    {
+      /* Take the first constant expression, if there is one.  */
+      c = gfc_constructor_first (expr->value.constructor);
+      for (; c; c = gfc_constructor_next (c))
+       if (!c->iterator && c->expr && c->expr->param_list)
+         {
+           a = c->expr->param_list;
+           break;
+         }
+    }
+  else if (expr->expr_type == EXPR_VARIABLE)
+    a = expr->symtree->n.sym->param_list;
+
+  return a;
+}
+
+bool
+gfc_check_type_spec_parms (gfc_expr *expr1, gfc_expr *expr2,
+                          const char *context)
+{
+  bool t = true;
+  gfc_actual_arglist *a1, *a2;
+
+  gcc_assert (expr1->ts.type == BT_DERIVED
+             && expr1->ts.u.derived->attr.pdt_type);
+
+  a1 = get_parm_list_from_expr (expr1);
+  a2 = get_parm_list_from_expr (expr2);
+
+  for (; a1 && a2; a1 = a1->next, a2 = a2->next)
+    {
+      if (a1->expr && a1->expr->expr_type == EXPR_CONSTANT
+         && a2->expr && a2->expr->expr_type == EXPR_CONSTANT
+         && !strcmp (a1->name, a2->name)
+         && mpz_cmp (a1->expr->value.integer, a2->expr->value.integer))
+       {
+         gfc_error ("Mismatched type parameters %qs(%d/%d) %s at %L/%L",
+                    a2->name,
+                    (int)mpz_get_ui (a1->expr->value.integer),
+                    (int)mpz_get_ui (a2->expr->value.integer),
+                    context,
+                    &expr1->where, &expr2->where);
+         t = false;
+       }
+    }
+
+  return t;
+}
+
+
 /* Given an assignable expression and an arbitrary expression, make
    sure that the assignment can take place.  Only add a call to the intrinsic
    conversion routines, when allow_convert is set.  When this assign is a
@@ -4123,6 +4184,12 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
       return false;
     }
 
+
+  /* Check that the type spec. parameters are the same on both sides.  */
+  if (lvalue->ts.type == BT_DERIVED && lvalue->ts.u.derived->attr.pdt_type
+      && !gfc_check_type_spec_parms (lvalue, rvalue, "in assignment"))
+    return false;
+
   if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
     return true;
 

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index cafd3ab53fef147b26d4c7c88c96c8736dfac13c..72b4c80487c4b1ab1671de6e413e313b6ddb865c 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3998,6 +3998,7 @@ bool gfc_numeric_ts (gfc_typespec *);
 int gfc_kind_max (gfc_expr *, gfc_expr *);
 
 bool gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3;
+bool gfc_check_type_spec_parms (gfc_expr *, gfc_expr *, const char *);
 bool gfc_check_assign (gfc_expr *, gfc_expr *, int, bool c = true);
 bool gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
                               bool suppres_type_test = false,

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 33adff6b9195b770d1ff8346afdc46a372d23927..eb050506a34ed401dbc4b3a3d56ba605f6ab2bfe 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -13612,7 +13612,8 @@ copyable_array_p (gfc_expr * expr)
       return false;
 
     case_bt_struct:
-      return !expr->ts.u.derived->attr.alloc_comp;
+      return (!expr->ts.u.derived->attr.alloc_comp
+             && !expr->ts.u.derived->attr.pdt_type);
 
     default:
       break;

diff --git a/gcc/testsuite/gfortran.dg/pdt_81.f03 b/gcc/testsuite/gfortran.dg/pdt_81.f03
new file mode 100644 (file)
index 0000000..0a0c303
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_81.f03
@@ -0,0 +1,48 @@
+! { dg-do compile )
+!
+! Test the fix for PR112460, in which mismatched, constant typespec parameters were
+! not detected.
+!
+! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
+!
+module color_propagator
+  implicit none
+  integer, parameter :: pk = kind (1.0)
+  type :: t (k, n_in, n_out)
+     integer, kind :: k = pk
+     integer, len :: n_in = 0, n_out = 0
+     logical :: is_ghost = .false.
+     integer, dimension(n_in) :: in
+     integer, dimension(n_out) :: out
+  end type t
+end module color_propagator
+
+program foo
+  use color_propagator
+  type(t(n_out=1)) :: aa
+  type(t(n_in=1,n_out=2)) :: bb
+  type(t), dimension(3) :: cc, dd, ee, gg
+  type(t(pk,n_in=1,n_out=2)), dimension(3) :: ff, hh
+  type(t(kind(1d0),n_in=1,n_out=2)), dimension(3) :: ii
+  type(t(pk,n_in=1,n_out=1)), dimension(3) :: jj
+  integer :: i
+
+! Starting point was mismatched parameters in array constructors; eg.:
+! Error: Mismatched type parameters ‘n_in’(1/0) in array constructor at (1)/(2)
+
+  cc = [t(pk,1,1)(.true.,[5] ,[6]), aa, bb]     ! { dg-error "Mismatched type parameters" }
+  dd = [aa, [t(pk,1,2)(.true.,[5] ,[6,6]), bb]] ! { dg-error "Mismatched type parameters" }
+  ee = [bb, [t(pk,1,2)(.true.,[5],[6,6]), aa]]  ! { dg-error "Mismatched type parameters" }
+  ff = [bb, [t(pk,1,2)(.true.,[5],[6,6]), bb]]  ! OK
+  gg = [bb, [t(kind (1d0),1,2)(.true.,[5],[6,6]), bb]]  ! { dg-error "Mismatched type parameters" }
+
+! Test ordinary assignment; eg.:
+! Error: Mismatched type parameters ‘k’(8/4) in assignment at (1)/(2)
+
+  aa = t(pk,1,2)(.true.,[5] ,[6,7])             ! { dg-error "Mismatched type parameters" }
+  bb = t(pk,1,2)(.true.,[5] ,[6,7])             ! OK
+  hh = ff                                       ! OK
+  ii = ff                                       ! { dg-error "Mismatched type parameters" }
+  jj = ff                                       ! { dg-error "Mismatched type parameters" }
+  print *, ff
+end program foo