Hi Jerry, Steve and co., Thanks for the reviews.
I have made extensive changes to this patch. Relative to the original
submission, the changes are:
(i) Cleaned up the comments in decl.cc. 'binding' removed from generic
statement comments;
(ii) 'generic_spec_name' used for formatted name instead of binding_name;
(iii) Handling of access specification corrected and tidied;
(iv) Warnings turned into errors, where appropriate;
(v) In generic_stmt_1.f90 have added checks that specific functions are
correctly identified;
(vi) Also in generic_stmt_1.f90 have added DTIO and intrinsic operator
tests;
(vii) In generic_stmt_2.f90 have changed error messages as appropriate and
checks on user defined and intrinsic operator errors; and
(viii) Have added generic_stmt_3.f90, which incorporates Steve's tests and
erroneous typing and name clashes with other entities.
(ix) Also, the problem with the public interface for 'bak' not exposing the
specific interfaces in 'snooze' has been resolved and is tested in
generic_stmt_4.f90.
Regtests OK. The patch adds 46 expected passes.
Good for mainline?
Paul
On Mon, 4 Aug 2025 at 18:20, Jerry D <jvdelis...@gmail.com> wrote:
> With your updated patch addressing Steve's comments OK.
>
> We have time for minor tweaks if necessary.
>
> On 8/3/25 11:06 AM, Steve Kargl wrote:
> > On Sun, Aug 03, 2025 at 12:20:24PM +0100, Paul Richard Thomas wrote:
> >
> > First, the easy one:
> >
> >> + /* Match the binding name; depending on type (operator / generic)
> format
> >> + it for future error messages into bind_name. */
> >
> > This comment looks muddled.
> >
> >> + 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;
> >
> > The contraction should probably be expanded to make
> > translation to other languages easier. I also find
> > the error message to be unclear for
> >
> > module foo
> > implicit none
> > private
> >
> > ! F2023:C815 An entity shall not be explicitly given any
> > ! attribute more than once in a scoping unit.
> > public bar
> > generic, public :: bar => bah, bak
> >
> > contains
> > integer function bah(i)
> > integer, intent(in) :: i
> > bah = i
> > end function bah
> > real function bak(x)
> > real, intent(in) :: x
> > bak = x
> > end function bak
> > end module foo
> >
> > % gfcx -c -fmax-errors=1 generic_stmt_3.F90
> > generic_stmt_3.F90:7:32:
> >
> > 7 | generic, public :: bar => bah, bak
> > | 1
> > Error: There's already a non-generic procedure with binding name 'bar'
> at (1)
> >
> > If you invert the statements to
> >
> > generic, public :: bar => bah, bak
> > public bar
> >
> > % gfcx -c -fmax-errors=1 generic_stmt_3.F90
> > generic_stmt_3.F90:7:16:
> >
> > 7 | public bar
> > | 1
> > Error: ACCESS specification at (1) was already specified
> >
> > The error is quite clear. This also generates an error
> >
> > public bar
> > generic :: bar => bah, bak
> >
> > while
> >
> > generic :: bar => bah, bak
> > public bar
> >
> > compiles without error.
> >
>
>
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
Change.Logs
Description: Binary data
