Fortran: gfortran PDT component access [PR84122, PR85942]

2025-08-21  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/84122
	* parse.cc (parse_derived): PDT type parameters are not allowed
	an explicit access specification and must appear before a
	PRIVATE statement. If a PRIVATE statement is seen, mark all the
	other components as PRIVATE.

	PR fortran/85942
	* simplify.cc (get_kind): Convert a PDT KIND component into a
	specification expression using the default initializer.

gcc/testsuite/
	PR fortran/84122
	* gfortran.dg/pdt_38.f03: New test.

	PR fortran/85942
	* gfortran.dg/pdt_39.f03: New test.

diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 300a7a36fbdd0dc214cf9b812b155533319691ea..b29f69008417d77e20d632501dbd7a2d10f16729 100644 (file)
--- 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 b25cd2c2388beafefd30b1316e7dc8749ae77665..00b02f341206546c6f29dfa15190273c3f23efae 100644 (file)
--- 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 (file)
index 0000000..4eb8a41
--- /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.carlson@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 (file)
index 0000000..7378cf5
--- /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.reuter@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