Hi Harald,
Please find attached an updated patch for the generic statement.
The module attribute in real module function realg is required by all other
brands. gfortran compiles happily with it and so I have added it to the
testcase. This is now PR121379. I have also posted a submodule meta-bug
PR12181.
The patch now warns on a repeated access specification and compiles when a
previous access specification is confirmed by a missing one. Additionally,
I have added a warning when access is specified in a generic statement
outside a module context. Neither ifx nor flang-new complain about these
"errors" but nagfor does. This is why I made this a warning rather than an
error. I did not find any steer from the standard either way but it is an
easy fix if somebody comes up with it.
Finally, I have added a generic statement, creating a DTIO interface since
it was a rather important omission.
Apart from the date, the ChangeLogs remain the same.
OK for mainline?
Paul
On Tue, 29 Jul 2025 at 21:29, Harald Anlauf <anl...@gmx.de> wrote:
> Hi Paul!
>
> Am 24.07.25 um 08:07 schrieb Paul Richard Thomas:
> > I forgot to include subroutine tests. Please find attached the patch with
> > updated testcases.
> >
> > Paul
> >
> > On Wed, 23 Jul 2025 at 17:53, Paul Richard Thomas <
> > paul.richard.tho...@gmail.com> wrote:
> >
> >> Hi All,
> >>
> >> The attached implements the F2018 generic statement, which has the same
> >> semantics as the typebound version but can appear in any specification
> >> statement.
> >>
> >> As it says in the first comment in the patch, use is made of the
> existing,
> >> typebound matching functions to obtain access-spec and generic-spec.
> After
> >> this the standard INTERFACE machinery is used.
> >>
> >> I spent a stupidly long time allowing the mixing of generic statements
> >> with generic interfaces until I realised that I was accepting
> ST_GENERIC in
> >> the wrong place in parse_spec :-(
> >>
> >> Regtests on x86_64/FC42 - OK for mainline?
> >>
> >> Paul
> >>
> >>
>
> The patch looks basically OK, although I stumbled across the following:
>
> - testing the testcase with ifx and NAG (both of which required
> commenting the generic within the block, probably a bug in both),
> I needed to change in submodule subm the declaration
>
> real function realg (arg1, arg2)
>
> to
>
> real module function realg (arg1, arg2)
>
> otherwise they both complained. Can you comment?
>
> - I am a little confused about the handling of the access specification.
> After the first "public :: g", NAG complains about the
>
> generic, public :: g ...
>
> and only allows
>
> generic :: g ...
>
> Then duplicate public specifications are not allowed. What do you think?
>
> Thanks,
> Harald
>
>
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index af425754d08..fe70394da0a 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -11710,10 +11710,242 @@ syntax:
}
+/* Match a GENERIC statement.
+F2018 15.4.3.3 GENERIC statement
+
+A GENERIC statement specifies a generic identifier for one or more specific
+procedures, in the same way as a generic interface block that does not contain
+interface bodies.
+
+R1510 generic-stmt is:
+GENERIC [ , access-spec ] :: generic-spec => specific-procedure-list
+
+C1510 (R1510) A specific-procedure in a GENERIC statement shall not specify a
+procedure that was specified previously in any accessible interface with the
+same generic identifier.
+
+If access-spec appears, it specifies the accessibility (8.5.2) of generic-spec.
+
+For GENERIC statements outside of a derived type, use is made of the existing,
+typebound matching functions to obtain access-spec and generic-spec. After
+this the standard INTERFACE machinery is used. */
+
+static match
+match_generic_stmt (void)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
+ gfc_symbol* generic_spec = NULL; /* Generics other than uops */
+ gfc_user_op *generic_uop = NULL; /* Generic uops */
+ gfc_typebound_proc tbattr; /* For the matching calls */
+ gfc_namespace* ns = gfc_current_ns;
+ interface_type op_type;
+ gfc_intrinsic_op op;
+ match m;
+ gfc_symtree* st;
+ gfc_interface *generic = NULL; /* The specific-procedure-list */
+ gfc_interface **generic_tail = NULL; /* The head of the specific-procedure-list */
+
+ memset (&tbattr, 0, sizeof (tbattr));
+ tbattr.where = gfc_current_locus;
+
+ /* See if we get an access-specifier. */
+ m = match_binding_attributes (&tbattr, true, false);
+ if (m == MATCH_ERROR)
+ goto error;
+
+ /* Now the colons, those are required. */
+ if (gfc_match (" ::") != MATCH_YES)
+ {
+ gfc_error ("Expected %<::%> at %C");
+ goto error;
+ }
+
+ /* Match the binding name; depending on type (operator / generic) format
+ it for future error messages into bind_name. */
+
+ m = gfc_match_generic_spec (&op_type, name, &op);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected generic name or operator descriptor at %C");
+ goto error;
+ }
+
+ switch (op_type)
+ {
+ case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
+ snprintf (bind_name, sizeof (bind_name), "%s", name);
+ break;
+
+ case INTERFACE_USER_OP:
+ snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
+ break;
+
+ case INTERFACE_INTRINSIC_OP:
+ snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
+ gfc_op2string (op));
+ break;
+
+ case INTERFACE_NAMELESS:
+ gfc_error ("Malformed GENERIC statement at %C");
+ goto error;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+
+ /* Match the required =>. */
+ if (gfc_match (" =>") != MATCH_YES)
+ {
+ gfc_error ("Expected %<=>%> at %C");
+ goto error;
+ }
+
+
+ if (gfc_current_state () != COMP_MODULE
+ && tbattr.access != ACCESS_UNKNOWN)
+ gfc_warning (0, "The access specification at %C has no effect in the "
+ "current context");
+
+ /* Try to find existing GENERIC binding with this name for this operator;
+ if there is something, check that it is another GENERIC and then extend
+ it rather than building a new node. Otherwise, create it and put it
+ at the right position. */
+
+ switch (op_type)
+ {
+ case INTERFACE_DTIO:
+ case INTERFACE_GENERIC:
+ st = gfc_find_symtree (ns->sym_root, name);
+ generic_spec = st ? st->n.sym : NULL;
+ if (generic_spec)
+ {
+ if (op_type == INTERFACE_GENERIC && !generic_spec->attr.generic)
+ {
+ gfc_error ("There's already a non-generic procedure with "
+ "binding name %qs at %C", generic_spec->name);
+ goto error;
+ }
+
+ if (tbattr.access != ACCESS_UNKNOWN)
+ {
+ if (generic_spec->attr.access != tbattr.access)
+ {
+ gfc_error ("The access specification at %C conflicts with "
+ "that already given to %qs", generic_spec->name);
+ goto error;
+ }
+ else
+ gfc_warning (0, "The access specification at %C repeats that "
+ "already given to %qs", generic_spec->name);
+ }
+ }
+ else
+ {
+ gfc_get_symbol (name, ns, &generic_spec, &gfc_current_locus);
+ generic_spec->refs++;
+ gfc_set_sym_referenced (generic_spec);
+ generic_spec->attr.generic = 1;
+ generic_spec->attr.flavor = FL_PROCEDURE;
+ generic_spec->attr.access = tbattr.access;
+ generic_spec->declared_at = gfc_current_locus;
+ }
+
+ generic = generic_spec->generic;
+ generic_tail = &generic_spec->generic;
+ break;
+
+ case INTERFACE_USER_OP:
+ st = gfc_find_symtree (ns->uop_root, name);
+ generic_uop = st ? st->n.uop : NULL;
+ if (generic_uop && generic_uop->access != tbattr.access)
+ {
+ gfc_error ("Binding at %C must have the same access as already"
+ " defined binding %qs", generic_uop->name);
+ goto error;
+ }
+ else
+ {
+ generic_uop = gfc_get_uop (name);
+ generic_uop->access = tbattr.access;
+ }
+
+ generic = generic_uop->op;
+ generic_tail = &generic_uop->op;
+ break;
+
+ case INTERFACE_INTRINSIC_OP:
+ generic = ns->op[op];
+ generic_tail = &ns->op[op];
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+
+ /* Now, match all following names in the specific-procedure-list. */
+ do
+ {
+ m = gfc_match_name (name);
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected specific binding name at %C");
+ goto error;
+ }
+
+ generic = *generic_tail;
+ for (; generic; generic = generic->next)
+ {
+ if (!strcmp (generic->sym->name, name))
+ {
+ gfc_error ("%qs already defined as specific binding for the"
+ " generic %qs at %C", name, generic_spec->name);
+ goto error;
+ }
+ }
+
+ gfc_find_sym_tree (name, ns, 1, &st);
+ if (!st)
+ {
+ /* This might be a procedure that has not yet been parsed. If
+ so gfc_fixup_sibling_symbols will replace this symbol with
+ that of the procedure. */
+ gfc_get_sym_tree (name, ns, &st, false);
+ st->n.sym->refs++;
+ }
+
+ generic = gfc_get_interface();
+ generic->next = *generic_tail;
+ *generic_tail = generic;
+ generic->where = gfc_current_locus;
+ generic->sym = st->n.sym;
+ }
+ while (gfc_match (" ,") == MATCH_YES);
+
+ if (gfc_match_eos () != MATCH_YES)
+ {
+ gfc_error ("Junk after GENERIC binding at %C");
+ goto error;
+ }
+
+ gfc_commit_symbols ();
+ return MATCH_YES;
+
+error:
+ return MATCH_ERROR;
+}
+
+
/* Match a GENERIC procedure binding inside a derived type. */
-match
-gfc_match_generic (void)
+static match
+match_typebound_generic (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
@@ -11923,6 +12155,17 @@ error:
}
+match
+gfc_match_generic ()
+{
+ if (gfc_option.allow_std & ~GFC_STD_OPT_F08
+ && gfc_current_state () != COMP_DERIVED_CONTAINS)
+ return match_generic_stmt ();
+ else
+ return match_typebound_generic ();
+}
+
+
/* Match a FINAL declaration inside a derived type. */
match
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 847ff37cafd..300a7a36fbd 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -242,6 +242,7 @@ decode_specification_statement (void)
break;
case 'g':
+ match ("generic", gfc_match_generic, ST_GENERIC);
break;
case 'i':
@@ -4534,6 +4535,11 @@ declSt:
st = next_statement ();
goto loop;
+ case ST_GENERIC:
+ accept_statement (st);
+ st = next_statement ();
+ goto loop;
+
case ST_ENUM:
accept_statement (st);
parse_enum();
diff --git a/gcc/testsuite/gfortran.dg/generic_stmt_1.f90 b/gcc/testsuite/gfortran.dg/generic_stmt_1.f90
new file mode 100644
index 00000000000..7a8a347a35d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/generic_stmt_1.f90
@@ -0,0 +1,190 @@
+! { dg-do run }
+!
+! Test the F2018 generic statement
+!
+function cg (arg1, arg2)
+ complex :: cg
+ complex, intent(in) :: arg1, arg2
+ cg = arg1 + arg2
+end
+
+module m
+ implicit none
+
+ type :: t
+ integer :: i
+ end type
+ integer :: tsum = 0
+
+ public g ! The generic statement checks for the same access
+ interface g ! Check generic statement + generic interface works
+ module procedure tg
+ end interface g
+
+ generic, public :: g => ig, rg ! { dg-warning "repeats that already given" }
+ generic :: operator(.plus.) => ig, rg
+ generic, private :: h => ig, rg
+ generic :: WRITE(FORMATTED) => wtarray
+
+ interface g ! Check generic statement + generic interface works
+ function cg (arg1, arg2)
+ complex :: cg
+ complex, intent(in) :: arg1, arg2
+ end
+ end interface g
+
+! Subroutines
+ generic, public :: sg => sig, srg
+
+! Check that we can mix with submodule procedures
+ interface
+ real module function realg (arg1, arg2)
+ real, intent(in) :: arg1, arg2
+ end function
+ end interface
+ generic, public :: subg => ig, realg
+
+contains
+
+ function rg (arg1, arg2)
+ real :: rg
+ real, intent(in) :: arg1, arg2
+ rg = arg1 + arg2
+ end
+ function ig (arg1, arg2)
+ integer :: ig
+ integer, intent(in) :: arg1, arg2
+ ig = arg1 + arg2
+ end
+ function tg (arg1, arg2) result(res)
+ type(t) :: res
+ type(t), intent(in) :: arg1, arg2
+ res%i = arg1%i + arg2%i
+ end
+ subroutine srg (arg1, arg2, arg3)
+ real :: arg3
+ real, intent(in) :: arg1, arg2
+ arg3 = arg1 + arg2
+ end
+ subroutine sig (arg1, arg2, arg3)
+ integer :: arg3
+ integer, intent(in) :: arg1, arg2
+ arg3 = arg1 + arg2
+ end
+
+ SUBROUTINE wtarray (dtv, unit, iotype, v_list, iostat, iomsg)
+ CLASS(t), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER(*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: v_list (:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER(*), INTENT(INOUT) :: iomsg
+ WRITE (unit, FMT=*, iostat=iostat, iomsg=iomsg) dtv%i
+ END SUBROUTINE wtarray
+
+ subroutine foo
+ real :: a = 1.0, b = 2.0, r
+ integer :: c = 3, d = 4
+! private in foo
+ r = h(a,b)
+ if (r /= rg(a,b)) stop 1
+ if (h(c,d) /= ig(c,d)) stop 2
+! operator in foo
+ r = a.plus.b
+ if (r /= rg(a,b)) stop 3
+ if ((c.plus.(2*d)) /= ig(c,2*d)) stop 4
+ end
+end module m
+
+submodule (m) subm
+contains
+ real module function realg (arg1, arg2)
+ real, intent(in) :: arg1, arg2
+ realg = arg1 + arg2
+ end
+end
+
+program p
+ use m
+ implicit none
+ integer :: i, rv
+
+ generic :: operator(.minus.) => pig, prg
+ generic :: operator(*) => times
+ generic :: j => ig, rg
+ generic :: j => mg
+
+ real :: a = 1.0, b = 2.0, s3
+ integer :: c = 3, d = 4, si
+ type(t) :: t1 = t(2), t2 = t(3), tres
+ type(t) :: tarray(5) = [t(5), t(4), t(3), t(2), t(1)]
+
+! module generic in p
+ if (g(2.0*a,2.0*b) /= rg(2.0*a,2.0*b)) stop 5
+ if (g(c,d) /= ig(c,d)) stop 6
+! local generic in p
+ if (j(a,b) /= rg(a,b)) stop 7
+ if (j(c,d) /= ig (c,d)) stop 8
+! local generic in p with different number of arguments
+ if (j(c,d,-1) /= mg(c,d,-1)) stop 9
+! module operator in p
+ if (7*int(a.plus.b) /= 3*(c.plus.d)) stop 10
+! local operator in p
+ if ((a.minus.b) /= prg(a,b)) stop 11
+ if ((c.minus.d) /= pig(c,d)) stop 12
+! local operator in block
+ block
+ generic :: operator(.bminus.) => pig, prg
+ if ((a.bminus.b) /= prg(a,b)) stop 13
+ if ((c.bminus.d) /= pig(c,d)) stop 14
+ end block
+! intrinsic operator in p
+ tres = t1 * t2
+ if (tres%i /= 6) stop 15
+! test private interface in module
+ call foo
+! test mixture of GENERIC statement and generic INTERFACE
+ if (g((1.0,1.0),(2.0,2.0)) /= cg((1.0,1.0),(2.0,2.0))) stop 16
+ tres = g(t1,t2)
+ if (tres%i /= 5) stop 17
+! subroutines
+ call sg(10.0*a, b, s3)
+ if (int(s3) /= 12) stop 18
+ call sg(5*c, d, si)
+ if (si /= 19) stop 19
+! submodule procedures
+ if (subg(20.0*a,2.0*b) /= realg(20.0*a,2.0*b)) stop 20
+! check DTIO
+ open (10,status='scratch')
+ WRITE(10, '(DT)') tarray
+ rewind(10)
+ do i = 1,5
+ read(10, *) rv
+ tsum = tsum + rv
+ end do
+ close(10)
+ if (tsum /= 15) stop 21
+contains
+
+ function pig (arg1, arg2)
+ integer :: pig
+ integer, intent(in) :: arg1, arg2
+ pig = arg1 - arg2
+ end
+ function prg (arg1, arg2)
+ real :: prg
+ real, intent(in) :: arg1, arg2
+ prg = arg1 - arg2
+ end
+ function times (arg1, arg2) result(res)
+ type(t) :: res
+ type(t), intent(in) :: arg1, arg2
+ res%i = arg1%i * arg2%i
+ end
+ function mg (arg1, arg2, arg3)
+ integer :: mg
+ integer, intent(in) :: arg1, arg2, arg3
+ mg = arg1 - arg2 * arg3
+ end
+end
+
diff --git a/gcc/testsuite/gfortran.dg/generic_stmt_2.f90 b/gcc/testsuite/gfortran.dg/generic_stmt_2.f90
new file mode 100644
index 00000000000..e4e9a08f0ac
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/generic_stmt_2.f90
@@ -0,0 +1,84 @@
+! { dg-do compile }
+!
+! Test the F2018 generic statement error reporting using the module from
+! generic_stmt_1.f90
+!
+function cg (arg1, arg2)
+ complex :: cg
+ complex, intent(in) :: arg1, arg2
+ cg = arg1 + arg2
+end
+
+module m1
+ implicit none
+
+ type :: t
+ integer :: i
+ end type
+
+ public g
+ interface g ! Check generic statement + generic interface works
+ module procedure tg
+ end interface g
+
+ generic, public :: g => ig ! { dg-warning "repeats that already given" }
+ generic, private :: g => rg ! { dg-error "conflicts with that already" }
+ generic :: operator(.plus.) => ig, rg, gg ! { dg-error "did you mean|must be a FUNCTION" }
+ generic, private :: h => ig, rg
+ generic :: => ig, rg ! { dg-error "Malformed GENERIC statement" }
+ generic :: wron ng => ig, rg ! { dg-error "Expected .=>." }
+ generic :: #!& => ig, rg ! { dg-error "Malformed GENERIC statement" }
+
+ interface g ! Check generic statement + generic interface works
+ function cg (arg1, arg2)
+ complex :: cg
+ complex, intent(in) :: arg1, arg2
+ end
+ end interface g
+
+ generic, public :: sg => sig, srg
+ generic, public :: sg2 => sig, srg, rg ! Error at 'srg' declaration
+
+contains
+
+ function rg (arg1, arg2)
+ real :: rg
+ real, intent(in) :: arg1, arg2
+ rg = arg1 + arg2
+ end
+ function ig (arg1, arg2)
+ integer :: ig
+ integer, intent(in) :: arg1, arg2
+ ig = arg1 + arg2
+ end
+ function tg (arg1, arg2) result(res)
+ type(t) :: res
+ type(t), intent(in) :: arg1, arg2
+ res%i = arg1%i + arg2%i
+ end
+ subroutine srg (arg1, arg2, arg3) ! { dg-error "procedures must be either all SUBROUTINEs" }
+ real :: arg3
+ real, intent(in) :: arg1, arg2
+ arg3 = arg1 + arg2
+ end
+ subroutine sig (arg1, arg2, arg3)
+ integer :: arg3
+ integer, intent(in) :: arg1, arg2
+ arg3 = arg1 + arg2
+ end
+ subroutine foo
+ real :: a = 1.0, b = 2.0, r
+ integer :: c = 3, d = 4
+ generic, public :: sg => sig, srg ! { dg-warning "no effect in the current context" }
+ r = h(a,d) ! { dg-error "There is no specific function" }
+ if (r /= rg(a,b)) stop 1
+ if (h(c,d) /= ig(c,d)) stop 2
+
+ generic :: wrong => ig, rg ! { dg-error "Unexpected GENERIC statement" }
+
+! operator in foo
+ r = c.plus.b ! { dg-error "Unknown operator" }
+ if (r /= rg(a,b)) stop 3
+ if ((c.plus.(2*d)) /= ig(c,2*d)) stop 4
+ end
+end module m1
