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 <
[email protected]> 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
>
>
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index af425754d08..8c05aaee937 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -11710,10 +11710,230 @@ 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;
+ }
+
+ /* 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 (generic_spec->attr.access != tbattr.access)
+ {
+ gfc_error ("Binding at %C must have the same access as already"
+ " defined binding %qs", generic_spec->name);
+ goto error;
+ }
+ }
+ 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 +12143,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..687c421f757
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/generic_stmt_1.f90
@@ -0,0 +1,166 @@
+! { 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
+
+ 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
+ generic :: operator(.plus.) => ig, rg
+ generic, private :: h => ig, rg
+
+ 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 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 function realg (arg1, arg2)
+ real, intent(in) :: arg1, arg2
+ realg = arg1 + arg2
+ end
+end
+
+program p
+ use m
+ implicit none
+
+ 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
+
+! 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
+
+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..d393205fd22
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/generic_stmt_2.f90
@@ -0,0 +1,82 @@
+! { 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
+
+ interface g ! Check generic statement + generic interface works
+ module procedure tg
+ end interface g
+
+ generic, public :: g => ig, rg ! { dg-error "must have the same access" }
+ 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
+
+ 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
