From f4023ab4230e1ae7d8f6187107a5dfbce7d67451 Mon Sep 17 00:00:00 2001 From: Amir Shahmoradi Date: Sun, 30 Aug 2026 00:03:17 -0600 Subject: [PATCH] fortran: Fix ex-module inherited PDT parameter namespaces [PR104750] Inherited KIND/LEN type parameters of parameterized derived types (PDTs) currently become unavailable after USE association. This patch delays reconstruction of PDT parameter namespaces until module loading is complete. The named symtree entries for PDT parameters are restored, and inherited formal parameters are correctly skipped when locating parameters declared by an extended PDT. PR fortran/104750 gcc/fortran/ChangeLog: New functions: + module.cc - transfer_pdt_parameter_namespace: A new helper function that transfers the namespace of locally declared PDT type parameters to the derived-type namespace after skipping inherited parameters, while preserving the existing namespace ownership and reference-counting semantics. + module.cc - fixup_pdt_parameter_namespaces: A new helper function that traverses the loaded module symbols and reconstructs missing PDT parameter namespaces after symbol cleanup, invoking the transfer step only for used PDT templates that still require it. Enhancements: + module.cc - mio_full_f2k_derived: Defer the PDT parameter-namespace reconstruction during module deserialization, allowing all required symbols and references to be fully loaded before the namespace is restored. + module.cc - read_cleanup: Restore named symtree entries for referenced PDT KIND and LEN parameters during module cleanup, while preserving existing handling for ordinary hidden symbols and safely ignoring formal parameters without namespaces. + module.cc - read_module: Invoke PDT parameter-namespace reconstruction after read_cleanup(), ensuring the required symbol and formal-parameter information has been fully reconstructed first. gcc/testsuite/ChangeLog: New files: + gfortran.dg/pdt_93_exmodext.f90: New test. Signed-off-by: Amir Shahmoradi --- gcc/fortran/module.cc | 121 ++++++++-- gcc/testsuite/gfortran.dg/pdt_93_exmodext.f90 | 226 ++++++++++++++---- 2 files changed, 283 insertions(+), 64 deletions(-) diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc index b79db02a30c..512c54eb7f6 100644 --- a/gcc/fortran/module.cc +++ b/gcc/fortran/module.cc @@ -4353,6 +4353,38 @@ mio_f2k_derived (gfc_namespace *f2k) mio_rparen (); } +/* Transfer the namespace containing locally-declared PDT type-parameter + symbols to the namespace used for F2003+ derived-type information. */ + +static void +transfer_pdt_parameter_namespace (gfc_symbol *sym) +{ + gfc_formal_arglist *f, *p; + gfc_namespace *ns; + gfc_symbol *super; + + 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 (p = super->formal; p && f; p = p->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); +} + + static void mio_full_f2k_derived (gfc_symbol *sym) { @@ -4367,24 +4399,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 +5729,48 @@ 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 to the symtree. PDT parameters are formal + arguments and are normally marked as referenced, which suppresses + the generic hidden-symbol path. They nevertheless need a symtree + under their actual source name so that the PDT template can use them + in specification and constant expressions after USE association. */ 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 + /* Some formal arguments deliberately have no namespace. The old + referenced-symbol path skipped those nodes entirely; preserve that + behavior for PDT parameters rather than dereferencing a null + namespace. */ + 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 +5787,35 @@ 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; + + 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; + if (sym == NULL + || !sym->attr.pdt_template + || sym->f2k_derived == NULL + || sym->f2k_derived->sym_root != NULL) + return; + + transfer_pdt_parameter_namespace (sym); +} + + /* 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 +6373,11 @@ 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_exmodext.f90 b/gcc/testsuite/gfortran.dg/pdt_93_exmodext.f90 index bacc96609d5..7bf5a327d7c 100644 --- a/gcc/testsuite/gfortran.dg/pdt_93_exmodext.f90 +++ b/gcc/testsuite/gfortran.dg/pdt_93_exmodext.f90 @@ -1,42 +1,186 @@ ! { dg-do run } - -module pdt_parent - - implicit none - - type :: parent_type(k) - integer, kind :: k = kind (1.0) - real(k) :: a - end type parent_type - -end module pdt_parent - - -module pdt_child - - use pdt_parent, only: parent_type - - implicit none - - type, extends(parent_type) :: child_type - real(k) :: b - end type child_type - -end module pdt_child - - -program main - - use pdt_child, only: child_type - - implicit none - - type(child_type(kind(1.0))) :: x - - x%a = 1.0 - x%b = 2.0 - - if (x%a /= 1.0) stop 1 - if (x%b /= 2.0) stop 2 - -end program main +! +! Test the fix for GCC Bugzilla – Bug 104750, in which PDT +! extension outside the origin module led to the following error: +! +! pdt_93_exmodext.f90:45:16: +! +! 45 | 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: +! +! 47 | real(RKP) :: rvalc1 +! | 1 +! Error: Parameter ‘rkp’ at (1) has not been declared or is +! a variable, which does not reduce to a constant expression +! pdt_93_exmodext.f90:69:30: +! +! 69 | if (present(ivalc1)) child%ivalc1 = ivalc1 +! | 1 +! Error: Syntax error in IF-clause after (1) +! pdt_93_exmodext.f90:71:30: +! +! 71 | if (present(rvalc1)) child%rvalc1 = rvalc1 +! | 1 +! Error: Syntax error in IF-clause after (1) +! pdt_93_exmodext.f90:79:9: +! +! 79 | use mod_child, only: pdt_child +! | 1 +! Fatal Error: Cannot open module file ‘mod_child.mod’ +! for reading at (1): No such file or directory +! compilation terminated. +! +! Contributed by Amir Shahmoradi +! +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 \ No newline at end of file -- 2.34.1