[gcc r16-8053] Fortran: Add missing deferred type PDT errors in allocate [PR115316]
Paul Thomas
pault@gcc.gnu.org
Thu Mar 12 17:51:07 GMT 2026
https://gcc.gnu.org/g:7efccab92abaa2b31dbe92579505d5c820272eac
commit r16-8053-g7efccab92abaa2b31dbe92579505d5c820272eac
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Thu Mar 12 17:50:55 2026 +0000
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:
---
gcc/fortran/match.cc | 42 +++++++++++++++--
gcc/testsuite/gfortran.dg/pdt_87.f03 | 89 ++++++++++++++++++++++++++++++++++++
2 files changed, 128 insertions(+), 3 deletions(-)
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index b2996759c68e..b37337d505ff 100644
--- 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
index 000000000000..68681a5cb6d3
--- /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
More information about the Gcc-cvs
mailing list