[gcc r16-6735] Fortran: Check constant PDT type specification parameters [PR112460]
Paul Thomas
pault@gcc.gnu.org
Tue Jan 13 08:19:15 GMT 2026
https://gcc.gnu.org/g:fdfb0452237d10afd3488b08ec84237a1f4e7bff
commit r16-6735-gfdfb0452237d10afd3488b08ec84237a1f4e7bff
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Tue Jan 13 08:19:05 2026 +0000
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:
---
gcc/fortran/array.cc | 12 +++++++
gcc/fortran/expr.cc | 67 ++++++++++++++++++++++++++++++++++++
gcc/fortran/gfortran.h | 1 +
gcc/fortran/trans-expr.cc | 3 +-
gcc/testsuite/gfortran.dg/pdt_81.f03 | 48 ++++++++++++++++++++++++++
5 files changed, 130 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index be2eb595317b..e9199f3e77f5 100644
--- 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 a2f19607eb1e..a47e970eda9f 100644
--- 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 cafd3ab53fef..72b4c80487c4 100644
--- 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 33adff6b9195..eb050506a34e 100644
--- 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
index 000000000000..0a0c3037f2fa
--- /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
More information about the Gcc-cvs
mailing list