https://gcc.gnu.org/g:fdfb0452237d10afd3488b08ec84237a1f4e7bff
commit r16-6735-gfdfb0452237d10afd3488b08ec84237a1f4e7bff Author: Paul Thomas <[email protected]> Date: Tue Jan 13 08:19:05 2026 +0000 Fortran: Check constant PDT type specification parameters [PR112460] 2026-01-14 Paul Thomas <[email protected]> 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 <[email protected]> +! +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
