Fortran: Add missing deferred type PDT errors in allocate [PR115316]

2026-03-12  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/115316
	* match.cc (spec_list_type): A version of gfc_spec_list_type,
	which returns true if any of the LEN parameters are deferred.
	(gfc_match_allocate): Use it to set saw_deferred if any of the
	parameters of the allocate object are deferred.

gcc/testsuite/
	PR fortran/115316
	* gfortran.dg/pdt_87.f03: New test.

diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index b2996759c68e1d3b32400885b629ef004821d279..b37337d505ff3e9af61bc8e6d6c363dbc5f8716c 100644 (file)
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -4973,6 +4973,25 @@ cleanup:
 }
 
 
+/* A reduced version of gfc_spec_list_type, which only looks for deferred
+   type spec list parameters.  */
+
+static gfc_param_spec_type
+spec_list_type (gfc_actual_arglist *param_list)
+{
+  gfc_param_spec_type res = SPEC_EXPLICIT;
+
+  for (; param_list; param_list = param_list->next)
+    if (param_list->spec_type == SPEC_DEFERRED)
+      {
+       res = param_list->spec_type;
+       break;
+      }
+
+  return res;
+}
+
+
 /* Frees a list of gfc_alloc structures.  */
 
 void
@@ -4998,6 +5017,7 @@ gfc_match_allocate (void)
   gfc_expr *stat, *errmsg, *tmp, *source, *mold;
   gfc_typespec ts;
   gfc_symbol *sym;
+  gfc_ref *ref;
   match m;
   locus old_locus, deferred_locus, assumed_locus;
   bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
@@ -5057,8 +5077,7 @@ gfc_match_allocate (void)
            }
 
          if (type_param_spec_list
-             && gfc_spec_list_type (type_param_spec_list, NULL)
-                == SPEC_DEFERRED)
+             && spec_list_type (type_param_spec_list) == SPEC_DEFERRED)
            {
              gfc_error ("The type parameter spec list in the type-spec at "
                         "%L cannot contain DEFERRED parameters", &old_locus);
@@ -5120,11 +5139,28 @@ gfc_match_allocate (void)
          goto cleanup;
        }
 
-      if (tail->expr->ts.deferred)
+      if (tail->expr->ts.deferred
+         || (tail->expr->symtree->n.sym->param_list
+             && spec_list_type (tail->expr->symtree->n.sym->param_list)
+                                == SPEC_DEFERRED))
        {
          saw_deferred = true;
          deferred_locus = tail->expr->where;
        }
+      else if ((tail->expr->ts.type == BT_DERIVED
+               || tail->expr->ts.type == BT_CLASS)
+              && tail->expr->ref)
+       {
+         for (ref = tail->expr->ref; ref; ref = ref->next)
+           if (ref->type == REF_COMPONENT
+               && ref->u.c.component->param_list
+               && spec_list_type (ref->u.c.component->param_list)
+                                  == SPEC_DEFERRED)
+           {
+             saw_deferred = true;
+             deferred_locus = tail->expr->where;
+           }
+       }
 
       if (gfc_find_state (COMP_DO_CONCURRENT)
          || gfc_find_state (COMP_CRITICAL))

diff --git a/gcc/testsuite/gfortran.dg/pdt_87.f03 b/gcc/testsuite/gfortran.dg/pdt_87.f03
new file mode 100644 (file)
index 0000000..68681a5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_87.f03
@@ -0,0 +1,89 @@
+! { dg-do compile }
+!
+! Test the fix for pr115316, in which none of the deferred type PDT errors were caught.
+! Note the exclusion of the old-style character length at line 62. This compiles OK
+! but causes an excess errors message in the testsuite.
+!
+! Contributed by David Binderman  <dcb314@hotmail.com>
+!
+subroutine C933_a(b1, ca3, ca4, cp3, cp3mold, cp4, cp7, cp8, bsrc)
+! If any allocate-object has a deferred type parameter, is unlimited polymorphic,
+! or is of abstract type, either type-spec or source-expr shall appear.
+  type SomeType(k, l1, l2)
+    integer, kind :: k = 1
+    integer, len :: l1
+    integer, len :: l2 = 3
+    character(len=l2+l1) str
+  end type
+
+  type B(l)
+    integer, len :: l
+    character(:), allocatable :: msg
+    type(SomeType(4, l, :)), pointer :: something
+  end type
+  character(len=:), allocatable :: ca1, ca2(:)
+  character(len=*), allocatable :: ca3, ca4(:)
+  character(len=2), allocatable :: ca5, ca6(:)
+  character(len=5) mold
+
+  type(SomeType(l1=:,l2=:)), pointer :: cp1, cp2(:)
+  type(SomeType(l1=3,l2=4)) cp1mold
+  type(SomeType(1,*,:)), pointer :: cp3, cp4(:)
+  type(SomeType(1,*,5)) cp3mold
+  type(SomeType(l1=:)), pointer :: cp5, cp6(:)
+  type(SomeType(l1=6)) cp5mold
+  type(SomeType(1,*,*)), pointer :: cp7, cp8(:)
+  type(SomeType(1, l1=3)), pointer :: cp9, cp10(:)
+
+  type(B(*)) b1
+  type(B(:)), allocatable :: b2
+  type(B(5)) b3
+
+  type(SomeType(4, *, 8)) bsrc
+
+  allocate(ca1)          ! { dg-error "requires either a type-spec or SOURCE tag or a MOLD tag" }
+  allocate(ca2(4))       ! { dg-error "requires either a type-spec or SOURCE tag or a MOLD tag" }
+  allocate(cp1)          ! { dg-error "requires either a type-spec or SOURCE tag or a MOLD tag" }
+  allocate(cp2(2))       ! { dg-error "requires either a type-spec or SOURCE tag or a MOLD tag" }
+  allocate(cp3)          ! { dg-error "requires either a type-spec or SOURCE tag or a MOLD tag" }
+  allocate(cp4(2))       ! { dg-error "requires either a type-spec or SOURCE tag or a MOLD tag" }
+  allocate(cp5)          ! { dg-error "requires either a type-spec or SOURCE tag or a MOLD tag" }
+  allocate(cp6(2))       ! { dg-error "requires either a type-spec or SOURCE tag or a MOLD tag" }
+  allocate(b1%msg)       ! { dg-error "requires either a type-spec or SOURCE tag or a MOLD tag" }
+  allocate(b1%something) ! { dg-error "requires either a type-spec or SOURCE tag or a MOLD tag" }
+  allocate(b2%msg)       ! { dg-error "requires either a type-spec or SOURCE tag or a MOLD tag" }
+  allocate(b2%something) ! { dg-error "requires either a type-spec or SOURCE tag or a MOLD tag" }
+  allocate(b3%msg)       ! { dg-error "requires either a type-spec or SOURCE tag or a MOLD tag" }
+  allocate(b3%something) ! { dg-error "requires either a type-spec or SOURCE tag or a MOLD tag" } 
+
+  ! Nominal cases, expecting no errors
+  allocate(character(len=5):: ca2(4))
+  allocate(character(len=5):: ca1)
+!  allocate(character*5:: ca1)
+  allocate(ca2(4), MOLD = "abcde")
+  allocate(ca2(2), MOLD = (/"abcde", "fghij"/))
+  allocate(ca1, MOLD = mold)
+  allocate(ca2(4), SOURCE = "abcde")
+  allocate(ca2(2), SOURCE = (/"abcde", "fghij"/))
+  allocate(ca1, SOURCE = mold)
+  allocate(SomeType(l1=1, l2=2):: cp1, cp2(2))
+  allocate(SomeType(1,*,5):: cp3, cp4(2))
+  allocate(SomeType(l1=1):: cp5, cp6(2))
+  allocate(cp1, cp2(2), mold = cp1mold)
+  allocate(cp3, cp4(2), mold = cp3mold)
+  allocate(cp5, cp6(2), mold = cp5mold)
+  allocate(cp1, cp2(2), source = cp1mold)
+  allocate(cp3, cp4(2), source = cp3mold)
+  allocate(cp5, cp6(2), source = cp5mold)
+  allocate(character(len=10):: b1%msg, b2%msg, b3%msg)
+  allocate(SomeType(4, b1%l, 9):: b1%something)
+  allocate(b2%something, source=bsrc)
+  allocate(SomeType(4, 5, 8):: b3%something)
+
+  ! assumed/explicit length do not need type-spec/mold
+  allocate(ca3, ca4(4))
+  allocate(ca5, ca6(4))
+  allocate(cp7, cp8(2))
+  allocate(cp9, cp10(2))
+
+end subroutine