Hi Jerry, The attached patch fixes both pr84122 and pr85942. Beyond the more elaborate chunk in parse.cc, a new chunk was required in simplify.cc(get_kind) to convert KIND expressions involving PDT kind parameters into viable initialization expressions. Both are straight forward.
The patch regtests on FC42/x86_64. OK for mainline? The next PDT patch, to be posted tomorrow, corrects the invalid PDT constructors present in pft_22/23.f03. The change is from my_pdt (all components) to my_pdt (type parms)(the rest of the components). Following this will be a patch to fix list directed IO of a PDT object so that the type parameters do not appear. A few more parse errors will be fixed before I hit the representation of PDTs(pr82649). Cheers Paul On Tue, 19 Aug 2025 at 17:23, Paul Richard Thomas < paul.richard.tho...@gmail.com> wrote: > Hi Jerry, > > Thanks for taking a look at it but I have to withdraw this patch for a > short while. It suppresses legal declarations like(pr85942): > type, public :: mat_t(k,c,r) > !.. type parameters > integer, kind :: k = r4 > integer, len :: c = 1 > integer, len :: r = 1 > private > !.. private by default > !.. type data > real(kind=k) :: m_a(c,r) > end type mat_t > > Sorry about that. > > Thanks again > > Paul >
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 300a7a36fbd..b29f6900841 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -3938,6 +3938,7 @@ parse_derived (void)
gfc_state_data s;
gfc_symbol *sym;
gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
+ bool pdt_parameters;
accept_statement (ST_DERIVED_DECL);
push_state (&s, COMP_DERIVED, gfc_new_block);
@@ -3946,9 +3947,11 @@ parse_derived (void)
seen_private = 0;
seen_sequence = 0;
seen_component = 0;
+ pdt_parameters = false;
compiling_type = 1;
+
while (compiling_type)
{
st = next_statement ();
@@ -3961,6 +3964,31 @@ parse_derived (void)
case ST_PROCEDURE:
accept_statement (st);
seen_component = 1;
+ /* Type parameters must not have an explicit access specification
+ and must be placed before a PRIVATE statement. If a PRIVATE
+ statement is encountered after type parameters, mark the remaining
+ components as PRIVATE. */
+ for (c = gfc_current_block ()->components; c; c = c->next)
+ if (!c->next && (c->attr.pdt_kind || c->attr.pdt_len))
+ {
+ pdt_parameters = true;
+ if (c->attr.access != ACCESS_UNKNOWN)
+ {
+ gfc_error ("Access specification of a type parameter at "
+ "%C is not allowed");
+ c->attr.access = ACCESS_PUBLIC;
+ break;
+ }
+ if (seen_private)
+ {
+ gfc_error ("The type parameter at %C must come before a "
+ "PRIVATE statement");
+ break;
+ }
+ }
+ else if (pdt_parameters && seen_private
+ && !(c->attr.pdt_kind || c->attr.pdt_len))
+ c->attr.access = ACCESS_PRIVATE;
break;
case ST_FINAL:
@@ -3986,7 +4014,7 @@ endType:
break;
}
- if (seen_component)
+ if (seen_component && !pdt_parameters)
{
gfc_error ("PRIVATE statement at %C must precede "
"structure components");
@@ -3996,7 +4024,10 @@ endType:
if (seen_private)
gfc_error ("Duplicate PRIVATE statement at %C");
- s.sym->component_access = ACCESS_PRIVATE;
+ if (pdt_parameters)
+ s.sym->component_access = ACCESS_PUBLIC;
+ else
+ s.sym->component_access = ACCESS_PRIVATE;
accept_statement (ST_PRIVATE);
seen_private = 1;
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index b25cd2c2388..00b02f34120 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -120,10 +120,26 @@ static int
get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
{
int kind;
+ gfc_expr *tmp;
if (k == NULL)
return default_kind;
+ if (k->expr_type == EXPR_VARIABLE
+ && k->symtree->n.sym->ts.type == BT_DERIVED
+ && k->symtree->n.sym->ts.u.derived->attr.pdt_type)
+ {
+ gfc_ref *ref;
+ for (ref = k->ref; ref; ref = ref->next)
+ if (!ref->next && ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.pdt_kind
+ && ref->u.c.component->initializer)
+ {
+ tmp = gfc_copy_expr (ref->u.c.component->initializer);
+ gfc_replace_expr (k, tmp);
+ }
+ }
+
if (k->expr_type != EXPR_CONSTANT)
{
gfc_error ("KIND parameter of %s at %L must be an initialization "
diff --git a/gcc/testsuite/gfortran.dg/pdt_38.f03 b/gcc/testsuite/gfortran.dg/pdt_38.f03
new file mode 100644
index 00000000000..4eb8a411c57
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_38.f03
@@ -0,0 +1,21 @@
+! { dg-do compile )
+!
+! Test the fix for pr84122
+!
+! Contributed by Neil Carlson <neil.n.carl...@gmail.com>
+!
+module mod
+type foo(idim)
+ integer, len, PUBLIC :: idim ! { dg-error "is not allowed" }
+ private
+ integer :: array(idim)
+end type
+end module
+
+module bar
+type foo(idim)
+ private
+ integer,len :: idim ! { dg-error "must come before a PRIVATE statement" }
+ integer :: array(idim)
+end type
+end module
diff --git a/gcc/testsuite/gfortran.dg/pdt_39.f03 b/gcc/testsuite/gfortran.dg/pdt_39.f03
new file mode 100644
index 00000000000..7378cf50983
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_39.f03
@@ -0,0 +1,123 @@
+! { dg-do run }
+!
+! Test the fix for pr95541.
+!
+! Contributed by Juergen Reuter <juergen.reu...@desy.de>
+!
+module mykinds
+ use, intrinsic :: iso_fortran_env, only : i4 => int32, r4 => real32, r8 => real64
+ implicit none
+ private
+ public :: i4, r4, r8
+end module mykinds
+
+module matrix
+ use mykinds, only : r4, r8
+ implicit none
+ private
+
+ type, public :: mat_t(k,c,r)
+ !.. type parameters
+ integer, kind :: k = r4
+ integer, len :: c = 1
+ integer, len :: r = 1
+ private
+ !.. private by default
+ !.. type data
+ real(kind=k) :: m_a(c,r)
+ end type mat_t
+
+ interface assignment(=)
+ module procedure geta_r4
+ module procedure seta_r4
+ module procedure geta_r8
+ module procedure seta_r8
+ !.. additional bindings elided
+ end interface assignment(=)
+
+ public :: assignment(=)
+
+contains
+
+ subroutine geta_r4(a_lhs, t_rhs)
+ real(r4), allocatable, intent(out) :: a_lhs(:,:)
+ class(mat_t(k=r4,c=*,r=*)), intent(in) :: t_rhs
+ a_lhs = t_rhs%m_a
+ return
+ end subroutine geta_r4
+
+ subroutine geta_r8(a_lhs, t_rhs)
+ real(r8), allocatable, intent(out) :: a_lhs(:,:)
+ class(mat_t(k=r8,c=*,r=*)), intent(in) :: t_rhs
+ a_lhs = t_rhs%m_a
+ return
+ end subroutine geta_r8
+
+ subroutine seta_r4(t_lhs, a_rhs)
+ class(mat_t(k=r4,c=*,r=*)), intent(inout) :: t_lhs
+ real(r4), intent(in) :: a_rhs(:,:)
+ !.. checks on size elided
+ t_lhs%m_a = a_rhs
+ return
+ end subroutine seta_r4
+
+ subroutine seta_r8(t_lhs, a_rhs)
+ class(mat_t(k=r8,c=*,r=*)), intent(inout) :: t_lhs
+ real(r8), intent(in) :: a_rhs(:,:)
+ !.. checks on size elided
+ t_lhs%m_a = a_rhs
+ return
+ end subroutine seta_r8
+
+end module matrix
+
+program p
+ use mykinds, only : r4, r8
+ use matrix, only : mat_t, assignment(=)
+ implicit none
+ type(mat_t(k=r4,c=:,r=:)), allocatable :: mat_r4
+ type(mat_t(k=r8,c=:,r=:)), allocatable :: mat_r8
+ real(r4), allocatable :: a_r4(:,:)
+ real(r8), allocatable :: a_r8(:,:)
+ integer :: N
+ integer :: M
+ integer :: i
+ integer :: istat
+ N = 2
+ M = 3
+ allocate( mat_t(k=r4,c=N,r=M) :: mat_r4, stat=istat )
+ if ( istat /= 0 ) then
+ print *, " error allocating mat_r4: stat = ", istat
+ stop
+ end if
+ if (mat_r4%k /= r4) stop 1
+ if (mat_r4%c /= N) stop 2
+ if (mat_r4%r /= M) stop 3
+ mat_r4 = reshape( [ (real(i, kind=mat_r4%k), i=1,N*M) ], [ N, M ] )
+ a_r4 = mat_r4
+ if (int (sum (a_r4)) /= 21) stop 4
+ N = 4
+ M = 4
+ allocate( mat_t(k=r8,c=N,r=M) :: mat_r8, stat=istat )
+ if ( istat /= 0 ) then
+ print *, " error allocating mat_r4: stat = ", istat
+ stop
+ end if
+ if (mat_r8%k /= r8) stop 5
+ if (mat_r8%c /= N) stop 6
+ if (mat_r8%r /= M) stop 7
+ mat_r8 = reshape( [ (real(i, kind=mat_r8%k), i=1,N*M) ], [ N, M ] )
+ a_r8 = mat_r8
+ if (int (sum (a_r8)) /= 136) stop 8
+ deallocate( mat_r4, stat=istat )
+ if ( istat /= 0 ) then
+ print *, " error deallocating mat_r4: stat = ", istat
+ stop
+ end if
+ deallocate( mat_r8, stat=istat )
+ if ( istat /= 0 ) then
+ print *, " error deallocating mat_r4: stat = ", istat
+ stop
+ end if
+ stop
+end program p
