https://gcc.gnu.org/g:d9a9628046f7c1e70d56c082e3f2cec034415298
commit r17-3892-gd9a9628046f7c1e70d56c082e3f2cec034415298 Author: Paul Thomas <[email protected]> Date: Thu Sep 3 11:10:49 2026 +0100 Fortran: Fix ex-module inherited PDT parameter namespaces [PR104750] 2026-09-03 Amir Shahmoradi <[email protected]> Paul Thomas <[email protected]> gcc/fortran PR fortran/104750 * module.cc (mio_full_f2k_derived) : Instead of transferring the sym_root from the formal namespace, call mio_f2k_derived so that all required symbols and references are fully loaded. (read_cleanup): Restore named symtree entries for referenced PDT type specification parameters during module cleanup, while preserving existing handling for ordinary hidden symbols and ignoring formal parameters without namespaces. (fixup_pdt_parameter_namespaces): A new function that transfers the namespace of locally declared PDT type specification parms to the derived-type namespace after skipping inherited parameters, preserving the existing namespace ownership and ref counting. (read_module): Call the new fcn after read_cleanup, so that the required symbol and formal-parameter information has been fully reconstructed first. gcc/testsuite PR fortran/104750 * gfortran.dg/pdt_93.f90: New test. Diff: --- gcc/fortran/module.cc | 98 ++++++++++++++++----- gcc/testsuite/gfortran.dg/pdt_93.f90 | 165 +++++++++++++++++++++++++++++++++++ 2 files changed, 240 insertions(+), 23 deletions(-) diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc index b79db02a30cc..798e7d9ca1d2 100644 --- a/gcc/fortran/module.cc +++ b/gcc/fortran/module.cc @@ -4353,6 +4353,7 @@ mio_f2k_derived (gfc_namespace *f2k) mio_rparen (); } + static void mio_full_f2k_derived (gfc_symbol *sym) { @@ -4367,24 +4368,10 @@ mio_full_f2k_derived (gfc_symbol *sym) { if (peek_atom () != ATOM_RPAREN) { - gfc_namespace *ns; - sym->f2k_derived = gfc_get_namespace (NULL, 0); - /* PDT templates make use of the mechanisms for formal args - and so the parameter symbols are stored in the formal - namespace. Transfer the sym_root to f2k_derived and then - free the formal namespace since it is unneeded. */ - if (sym->attr.pdt_template && sym->formal && sym->formal->sym) - { - ns = sym->formal->sym->ns; - sym->f2k_derived->sym_root = ns->sym_root; - ns->sym_root = NULL; - ns->refs++; - gfc_free_namespace (ns); - ns = NULL; - } - + /* PDT type-parameter namespaces are reconstructed + after all needed module symbols are loaded. */ mio_f2k_derived (sym->f2k_derived); } else @@ -5711,25 +5698,37 @@ read_cleanup (pointer_info *p) read_cleanup (p->left); read_cleanup (p->right); - if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced) + if (p->type == P_SYMBOL && p->u.rsym.state == USED + && (!p->u.rsym.referenced + || (p->u.rsym.sym && (p->u.rsym.sym->attr.pdt_kind + || p->u.rsym.sym->attr.pdt_len)))) { gfc_namespace *ns; - /* Add hidden symbols to the symtree. */ + + /* Add hidden symbols and PDT parameters to the symtree. */ q = get_integer (p->u.rsym.ns); ns = (gfc_namespace *) q->u.pointer; - if (!p->u.rsym.sym->attr.vtype - && !p->u.rsym.sym->attr.vtab) - st = gfc_get_unique_symtree (ns); - else + /* PDT parameters have no namespace so return. */ + if (ns == NULL) + { + gcc_assert (p->u.rsym.sym->attr.pdt_kind + || p->u.rsym.sym->attr.pdt_len); + return; + } + + if (p->u.rsym.sym->attr.pdt_kind || p->u.rsym.sym->attr.pdt_len + || p->u.rsym.sym->attr.vtype || p->u.rsym.sym->attr.vtab) { /* There is no reason to use 'unique_symtrees' for vtabs or vtypes - their name is fine for a symtree and reduces the - namespace pollution. */ + namespace pollution. PDT parameters need their source name. */ st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name); if (!st) st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name); } + else + st = gfc_get_unique_symtree (ns); st->n.sym = p->u.rsym.sym; st->n.sym->refs++; @@ -5746,6 +5745,55 @@ read_cleanup (pointer_info *p) } +/* Reconstruct PDT parameter namespaces after all needed module symbols have + been loaded. read_cleanup installs named symtrees for the type-parameter + symbols first. */ + +static void +fixup_pdt_parameter_namespaces (pointer_info *p) +{ + gfc_symbol *sym; + gfc_formal_arglist *f, *fp; + gfc_namespace *ns; + gfc_symbol *super; + + if (p == NULL) + return; + + fixup_pdt_parameter_namespaces (p->left); + fixup_pdt_parameter_namespaces (p->right); + + if (p->type != P_SYMBOL || p->u.rsym.state != USED) + return; + + sym = p->u.rsym.sym; + +/* Transfer the sym_root of the namespace containing locally-declared PDT + type-parameter symbols to that the derived type's namespace. */ + if (sym == NULL + || !sym->attr.pdt_template + || sym->f2k_derived == NULL + || sym->f2k_derived->sym_root != NULL) + return; + + f = sym->formal; + super = gfc_get_derived_super_type (sym); + if (super && super->attr.pdt_template) + for (fp = super->formal; fp && f; fp = fp->next) + f = f->next; + + if (f == NULL || f->sym == NULL || f->sym->ns == NULL + || f->sym->ns->sym_root == NULL) + return; + + ns = f->sym->ns; + sym->f2k_derived->sym_root = ns->sym_root; + ns->sym_root = NULL; + ns->refs++; + gfc_free_namespace (ns); +} + + /* It is not quite enough to check for ambiguity in the symbols by the loaded symbol and the new symbol not being identical. */ static bool @@ -6303,6 +6351,10 @@ read_module (void) to hidden symbols. */ read_cleanup (pi_root); + + /* Reconstruct PDT type-parameter namespaces now that inherited + and local formal parameter lists have been loaded completely. */ + fixup_pdt_parameter_namespaces (pi_root); } diff --git a/gcc/testsuite/gfortran.dg/pdt_93.f90 b/gcc/testsuite/gfortran.dg/pdt_93.f90 new file mode 100644 index 000000000000..c98c50c41ec8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_93.f90 @@ -0,0 +1,165 @@ + ! { dg-do run } +! +! Test the fix for pr104750, in which PDT extension outside the module of the +! parent type led to the errors: +! 52 | integer(IKP) :: ivalc1 +! | 1 +! Error: Parameter ‘ikp’ at (1) has not been declared or is +! a variable, which does not reduce to a constant expression. +! pdt_93_exmodext.f90:47:13: +! +! 54 | real(RKP) :: rvalc1 +! | 1 +! Produces the same error message, followed by the fallout errors. +! +! Contributed by Amir Shahmoradi <[email protected]> +! +module mod_grandparent + + integer, parameter :: IK = kind(1) + integer, parameter :: LK = kind(.true.) + integer, parameter :: RKS = kind(1.e0) + integer, parameter :: RKD = kind(1.d0) + + type, abstract :: pdt_grandparent(LKGP) + integer, kind :: LKGP = kind(.true.) + logical(LKGP) :: lvalgp + end type + +end module + +module mod_parent + + use mod_grandparent, only: pdt_grandparent + use mod_grandparent, only: IK, LK, RKS, RKD + + type, extends(pdt_grandparent) :: pdt_parent(IKP, RKP) + integer, kind :: IKP = IK + integer, kind :: RKP + integer(IKP) :: ivalp + real(RKP) :: rvalp + end type + +end module + +module mod_child + + use mod_parent, only: pdt_parent + use mod_parent, only: IK, LK, RKS, RKD + + type, extends(pdt_parent) :: pdt_child(IKC, RKC) + integer, kind :: IKC, RKC + integer(IKP) :: ivalc1 + integer(IKC) :: ivalc2 + real(RKP) :: rvalc1 + real(RKC) :: rvalc2 + end type + + interface pdt_child + module procedure :: pdt_child_getter + end interface + +contains + + pure function pdt_child_getter(lvalgp, ivalp, rvalp, ivalc1, ivalc2, rvalc1, rvalc2) result(child) + type(pdt_child(RKP = RKS, IKC = IK, RKC = RKD)) :: child + logical(LK), intent(in), optional :: lvalgp + integer(IK), intent(in), optional :: ivalp + real(RKS), intent(in), optional :: rvalp + integer(IK), intent(in), optional :: ivalc1 + integer(IK), intent(in), optional :: ivalc2 + real(RKS), intent(in), optional :: rvalc1 + real(RKD), intent(in), optional :: rvalc2 + if (present(lvalgp)) child%lvalgp = lvalgp + if (present(ivalp)) child%ivalp = ivalp + if (present(rvalp)) child%rvalp = rvalp + if (present(ivalc1)) child%ivalc1 = ivalc1 + if (present(ivalc2)) child%ivalc2 = ivalc2 + if (present(rvalc1)) child%rvalc1 = rvalc1 + if (present(rvalc2)) child%rvalc2 = rvalc2 + end function + +end module + +module mod_grandchild + + use mod_child, only: pdt_child + use mod_child, only: IK, LK, RKS, RKD + + type, extends(pdt_child) :: pdt_grandchild(IKGC, RKGC) + integer, kind :: IKGC, RKGC + integer(IKP) :: ivalgc1 + integer(IKC) :: ivalgc2 + integer(IKGC) :: ivalgc3 + real(RKP) :: rvalgc1 + real(RKC) :: rvalgc2 + real(RKGC) :: rvalgc3 + end type + +end module + +program test_pdt_extension + + use mod_child, only: pdt_child + use mod_grandchild, only: pdt_grandchild + use mod_grandchild, only: IK, LK, RKS, RKD + + implicit none + + type(pdt_grandchild(RKP = RKS, IKC = IK, RKC = RKD, IKGC = IK, RKGC = RKD)) :: gc + + gc%ivalp = 1 + gc%rvalp = 1 + + gc%ivalc1 = 2 + gc%ivalc2 = 2 + gc%rvalc1 = 2 + gc%rvalc2 = 2 + + gc%ivalgc1 = 3 + gc%ivalgc2 = 3 + gc%ivalgc3 = 3 + gc%rvalgc1 = 3 + gc%rvalgc2 = 3 + gc%rvalgc3 = 3 + + !!!! + !!!! Ensure components are assigned correctly. + !!!! + + if (gc%ivalp /= gc%rvalp) stop 1 + + if (gc%ivalc1 /= gc%ivalc2) stop 2 + if (gc%ivalc1 /= gc%rvalc1) stop 3 + if (gc%ivalc1 /= gc%rvalc2) stop 4 + + if (gc%ivalgc1 /= gc%ivalgc2) stop 5 + if (gc%ivalgc1 /= gc%ivalgc3) stop 6 + if (gc%ivalgc1 /= gc%rvalgc1) stop 7 + if (gc%ivalgc1 /= gc%rvalgc2) stop 8 + if (gc%ivalgc1 /= gc%rvalgc3) stop 9 + + block + + use mod_child, only: pdt_child + + !!!! + !!!! Custom Constructor: Ensure whole PDT assignment through parental access works. + !!!! + + gc%pdt_child = pdt_child( ivalc1 = -2_IK & + , lvalgp = .false._LK & + , ivalc2 = -2_IK & + , rvalc1 = -2._RKS & + , rvalc2 = -2._RKD & + ) + + if (gc%pdt_child%lvalgp .neqv. .false.) stop 10 + if (gc%ivalc1 /= -2) stop 11 + if (gc%ivalc2 /= -2) stop 12 + if (gc%rvalc1 /= -2) stop 13 + if (gc%rvalc2 /= -2) stop 14 + + end block + +end program
