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
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index af425754d08..7f42a0aed44 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..17b55c84bb5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/generic_stmt_1.f90
@@ -0,0 +1,130 @@
+! { 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
+
+
+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 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
+
+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
+ integer :: c = 3, d = 4
+ 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
+
+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..0b3ae0bff8f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/generic_stmt_2.f90
@@ -0,0 +1,70 @@
+! { 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
+
+
+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 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
