https://gcc.gnu.org/g:39961581f247660c451018563f1407c614a19bd8
commit r16-4282-g39961581f247660c451018563f1407c614a19bd8 Author: Paul Thomas <[email protected]> Date: Wed Oct 8 08:17:10 2025 +0100 Fortran: Fix PDT parameter substitution [PR93175,PR102240,PR102686] 2025-10-08 Paul Thomas <[email protected]> gcc/fortran PR fortran/93175 PR fortran/102240 PR fortran/102686 * array.cc (match_array_element_spec): For pdt templates, call gfc_correct_parm_expr to elimante extraneous symbols from the bound expressions. * decl.cc (correct_parm_expr, gfc_correct_parm_expr): New fcns that remove symbols that are not PDT parameters from the type specification expressions. (insert_parameter_exprs): Process function symbols as if they are variables in the substitution with parameter expressions. (gfc_get_pdt_instance): Make sure that the parameter list of PDT components is updated as the instance is built. Move the construction of pdt_strings down a bit in the function and remove the tie up with pdt_arrays. * gfortran.h: Add prototype for gfc_correct_parm_expr. * resolve.cc (resolve_component): Skip testing for constant specification expressions in pdt_template component string lengths and pdt_strings. * trans-array.cc (structure_alloc_comps): Remove testing for deferred parameters and instead make sure that components of PDT type have parameters substituted with the parameter exprs of the enclosing PDT. gcc/testsuite/ PR fortran/93175 PR fortran/102240 PR fortran/102686 * gfortran.dg/pdt_55.f03: New test. Diff: --- gcc/fortran/array.cc | 11 +++++ gcc/fortran/decl.cc | 91 +++++++++++++++++++++++++--------- gcc/fortran/gfortran.h | 1 + gcc/fortran/resolve.cc | 15 +++--- gcc/fortran/trans-array.cc | 8 ++- gcc/testsuite/gfortran.dg/pdt_55.f03 | 96 ++++++++++++++++++++++++++++++++++++ 6 files changed, 189 insertions(+), 33 deletions(-) diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc index fa177fa91f7e..8f0004992e81 100644 --- a/gcc/fortran/array.cc +++ b/gcc/fortran/array.cc @@ -566,6 +566,7 @@ match_array_element_spec (gfc_array_spec *as) gfc_expr **upper, **lower; match m; int rank; + bool is_pdt_template; rank = as->rank == -1 ? 0 : as->rank; lower = &as->lower[rank + as->corank - 1]; @@ -613,6 +614,13 @@ match_array_element_spec (gfc_array_spec *as) return AS_UNKNOWN; } + is_pdt_template = gfc_current_block () + && gfc_current_block ()->attr.pdt_template + && gfc_current_block ()->f2k_derived; + + if ((*upper)->expr_type != EXPR_CONSTANT && is_pdt_template) + gfc_correct_parm_expr (gfc_current_block (), upper); + if (gfc_match_char (':') == MATCH_NO) { *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); @@ -645,6 +653,9 @@ match_array_element_spec (gfc_array_spec *as) return AS_UNKNOWN; } + if ((*upper)->expr_type != EXPR_CONSTANT && is_pdt_template) + gfc_correct_parm_expr (gfc_current_block (), upper); + return AS_EXPLICIT; } diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 3761b6589e81..ab43cec6f4ba 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -3790,6 +3790,48 @@ match_record_decl (char *name) } + /* In parsing a PDT, it is possible that one of the type parameters has the + same name as a previously declared symbol that is not a type parameter. + Intercept this now by looking for the symtree in f2k_derived. */ + +static bool +correct_parm_expr (gfc_expr* e, gfc_symbol* pdt, int* f ATTRIBUTE_UNUSED) +{ + if (!e || (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)) + return false; + + if (!(e->symtree->n.sym->attr.pdt_len + || e->symtree->n.sym->attr.pdt_kind)) + { + gfc_symtree *st; + st = gfc_find_symtree (pdt->f2k_derived->sym_root, + e->symtree->n.sym->name); + if (st && st->n.sym + && (st->n.sym->attr.pdt_len || st->n.sym->attr.pdt_kind)) + { + gfc_expr *new_expr; + gfc_set_sym_referenced (st->n.sym); + new_expr = gfc_get_expr (); + new_expr->ts = st->n.sym->ts; + new_expr->expr_type = EXPR_VARIABLE; + new_expr->symtree = st; + new_expr->where = e->where; + gfc_replace_expr (e, new_expr); + } + } + + return false; +} + + +void +gfc_correct_parm_expr (gfc_symbol *pdt, gfc_expr **bound) +{ + if (!*bound || (*bound)->expr_type == EXPR_CONSTANT) + return; + gfc_traverse_expr (*bound, pdt, &correct_parm_expr, 0); +} + /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source of expressions to substitute into the possibly parameterized expression 'e'. Using a list is inefficient but should not be too bad since the @@ -3801,12 +3843,13 @@ insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, gfc_actual_arglist *param; gfc_expr *copy; - if (e->expr_type != EXPR_VARIABLE) + if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION) return false; gcc_assert (e->symtree); if (e->symtree->n.sym->attr.pdt_kind - || (*f != 0 && e->symtree->n.sym->attr.pdt_len)) + || (*f != 0 && e->symtree->n.sym->attr.pdt_len) + || (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym)) { for (param = type_param_spec_list; param; param = param->next) if (strcmp (e->symtree->n.sym->name, param->name) == 0) @@ -4141,7 +4184,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, /* Now obtain the PDT instance for the extended type. */ c2->param_list = type_param_spec_list; m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived, - NULL); + &c2->param_list); type_param_spec_list = old_param_spec_list; c2->ts.u.derived->refs++; @@ -4205,20 +4248,6 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, } } - /* Similarly, set the string length if parameterized. */ - if (c1->ts.type == BT_CHARACTER - && c1->ts.u.cl->length - && gfc_derived_parameter_expr (c1->ts.u.cl->length)) - { - gfc_expr *e; - e = gfc_copy_expr (c1->ts.u.cl->length); - gfc_insert_kind_parameter_exprs (e); - gfc_simplify_expr (e, 1); - c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - c2->ts.u.cl->length = e; - c2->attr.pdt_string = 1; - } - /* Set up either the KIND/LEN initializer, if constant, or the parameterized expression. Use the template initializer if one is not already set in this instance. */ @@ -4283,7 +4312,8 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, gfc_free_expr (c2->as->upper[i]); c2->as->upper[i] = e; } - c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string; + + c2->attr.pdt_array = 1; if (c1->initializer) { c2->initializer = gfc_copy_expr (c1->initializer); @@ -4292,6 +4322,20 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, } } + /* Similarly, set the string length if parameterized. */ + if (c1->ts.type == BT_CHARACTER + && c1->ts.u.cl->length + && gfc_derived_parameter_expr (c1->ts.u.cl->length)) + { + gfc_expr *e; + e = gfc_copy_expr (c1->ts.u.cl->length); + gfc_insert_kind_parameter_exprs (e); + gfc_simplify_expr (e, 1); + gfc_free_expr (c2->ts.u.cl->length); + c2->ts.u.cl->length = e; + c2->attr.pdt_string = 1; + } + /* Recurse into this function for PDT components. */ if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS) && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template) @@ -4304,15 +4348,18 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, /* Substitute the template parameters with the expressions from the specification list. */ for (;actual_param; actual_param = actual_param->next) - gfc_insert_parameter_exprs (actual_param->expr, - type_param_spec_list); + { + gfc_correct_parm_expr (pdt, &actual_param->expr); + gfc_insert_parameter_exprs (actual_param->expr, + type_param_spec_list); + } /* Now obtain the PDT instance for the component. */ old_param_spec_list = type_param_spec_list; - m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL); + m = gfc_get_pdt_instance (params, &c2->ts.u.derived, + &c2->param_list); type_param_spec_list = old_param_spec_list; - c2->param_list = params; if (!(c2->attr.pointer || c2->attr.allocatable)) c2->initializer = gfc_default_initializer (&c2->ts); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 219c4b67ed81..a14202fda8fd 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3462,6 +3462,7 @@ extern hash_map<nofree_string_hash, int> *gfc_vectorized_builtins; /* Handling Parameterized Derived Types */ bool gfc_insert_parameter_exprs (gfc_expr *, gfc_actual_arglist *); +void gfc_correct_parm_expr (gfc_symbol *, gfc_expr **); match gfc_get_pdt_instance (gfc_actual_arglist *, gfc_symbol **, gfc_actual_arglist **); diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 00b143c07db0..75270064ed43 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -16877,27 +16877,30 @@ resolve_component (gfc_component *c, gfc_symbol *sym) && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) { gfc_error ("Component %qs of %qs at %L has the same name as an" - " inherited type-bound procedure", - c->name, sym->name, &c->loc); + " inherited type-bound procedure", + c->name, sym->name, &c->loc); return false; } if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer && !c->ts.deferred) { + if (sym->attr.pdt_template || c->attr.pdt_string) + gfc_correct_parm_expr (sym, &c->ts.u.cl->length); + if (c->ts.u.cl->length == NULL - || (!resolve_charlen(c->ts.u.cl)) + || !resolve_charlen(c->ts.u.cl) || !gfc_is_constant_expr (c->ts.u.cl->length)) { gfc_error ("Character length of component %qs needs to " "be a constant specification expression at %L", c->name, c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); - return false; - } + return false; + } if (c->ts.u.cl->length && c->ts.u.cl->length->ts.type != BT_INTEGER) - { + { if (!c->ts.u.cl->length->error) { gfc_error ("Character length expression of component %qs at %L " diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 9dd61f98ca76..b11ef57f9814 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -11084,17 +11084,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, && c->ts.u.derived && c->ts.u.derived->attr.pdt_type && !(c->attr.pointer || c->attr.allocatable)) { - bool is_deferred = false; gfc_actual_arglist *tail = c->param_list; for (; tail; tail = tail->next) - if (!tail->expr) - is_deferred = true; + if (tail->expr) + gfc_insert_parameter_exprs (tail->expr, pdt_param_list); - tail = is_deferred ? pdt_param_list : c->param_list; tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp, c->as ? c->as->rank : 0, - tail); + c->param_list); gfc_add_expr_to_block (&fnblock, tmp); } diff --git a/gcc/testsuite/gfortran.dg/pdt_55.f03 b/gcc/testsuite/gfortran.dg/pdt_55.f03 new file mode 100644 index 000000000000..bcdb1518fde3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_55.f03 @@ -0,0 +1,96 @@ +! { dg-do run } +! +! Test fix for PRs 102240, 102686 and 93175. +! +! PR102240 +! Contributed by Roland Wirth <[email protected]> +! +MODULE m1 + IMPLICIT NONE + private + public r + INTEGER :: n0, n ! Symbols that confused the parameter substitution. + type t0(m0,n0) + INTEGER, kind :: m0 + INTEGER, LEN :: n0 + INTEGER(kind=m0) :: a0(n0*2) + end type t0 + + TYPE t(m,n) + INTEGER, kind :: m + INTEGER, LEN :: n + INTEGER(kind=m) :: a(n/8:(n/2 + 4)) + type(t0(m,n)) :: p ! During testing, getting this to work fixed PR93175. + END TYPE t +contains + subroutine r + type (t(kind(1_8), 8)) :: x + x%a = [1,2,3,4,5,6,7,8] + if (kind (x%a) /= kind(1_8)) stop 1 + if (sum (x%a) /= 36_8) stop 2 + if (size(x%p%a0) /= 16) stop 3 + end +END + +! PR102686 +! Contributed by Gerhard Steinmetz <[email protected]> +! +module m2 + implicit none + private + public s +contains + pure integer function n() ! Confused the parameter substitution. + n = 1 + end + subroutine s + type t(n) + integer, len :: n = 2 + character(len=n) :: c ! ICE because function n() referenced rather than parameter. + end type + type (t(4)) :: c_type, c_type2 + c_type = t(4)("abcd") + if (len (c_type%c) /= 4) stop 4 + if (c_type%c /= "abcd") stop 5 + c_type2%c = "efgh" + if (len (c_type2%c) /= 4) stop 6 + if (c_type2%c /= "efgh") stop 7 + end +end + +! PR93175 +! Contributed by Rich Townsend <[email protected]> +! +module m3 + private + public u + type :: matrix (k,n) + integer, kind :: k + integer, len :: n + real(k) :: a(n,n) + end type matrix + + type :: problem(n) + integer, len :: n + type(matrix(kind(0.D0),n)) :: m + end type problem + +contains + subroutine u + implicit none + type(problem(2)) :: p + + p%m%a = 1. + if (p%n /= 2) stop 8 + if (p%m%n /= 2) stop 9 + if (int (sum (p%m%a)) /= 4) stop 10 + end subroutine +end module m3 + + use m1 + use m2 + use m3 + call r + call s + call u +end
