From: Paul Thomas Date: Sat, 9 Aug 2025 10:40:09 +0000 (+0100) Subject: Fortran: F2018 GENERIC statement is missing [PR121182] X-Git-Url: http://git.ipfire.org/gitweb/gitweb.cgi?a=commitdiff_plain;h=9e584501f6cc5a571b5f89972a1f458394c92f58;p=thirdparty%2Fgcc.git Fortran: F2018 GENERIC statement is missing [PR121182] 2025-08-09 Paul Thomas gcc/fortran PR fortran/121182 * decl.cc (match_generic_stmt): New function based on original gfc_match_generic but feeding namespace rather than typebound generics. (match_typebound_generic): Renamed original gfc_match_generic. (gfc_match_generic): New function that selects between type bound generic and other generic statements and calls one of the above two functions as appropriate. * parse.cc (decode_specification_statement): Allow generic statements. (parse_spec): Accept a generic statement in a specification block. gcc/testsuite/ PR fortran/121182 * gfortran.dg/generic_stmt_1.f90: New test. * gfortran.dg/generic_stmt_2.f90: New test. * gfortran.dg/generic_stmt_3.f90: New test. * gfortran.dg/generic_stmt_4.f90: New test. --- diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index af425754d08..5146731d454 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -11710,10 +11710,308 @@ 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]; + /* Allow space for OPERATOR(...). */ + char generic_spec_name[GFC_MAX_SYMBOL_LEN + 16]; + /* Generics other than uops */ + gfc_symbol* generic_spec = NULL; + /* Generic uops */ + gfc_user_op *generic_uop = NULL; + /* For the matching calls */ + gfc_typebound_proc tbattr; + gfc_namespace* ns = gfc_current_ns; + interface_type op_type; + gfc_intrinsic_op op; + match m; + gfc_symtree* st; + /* The specific-procedure-list */ + gfc_interface *generic = NULL; + /* The head of the specific-procedure-list */ + gfc_interface **generic_tail = NULL; + + memset (&tbattr, 0, sizeof (tbattr)); + tbattr.where = gfc_current_locus; + + /* See if we get an access-specifier. */ + m = match_binding_attributes (&tbattr, true, false); + tbattr.where = gfc_current_locus; + 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 generic-spec name; depending on type (operator / generic) format + it for future error messages in 'generic_spec_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 (generic_spec_name, sizeof (generic_spec_name), "%s", name); + break; + + case INTERFACE_USER_OP: + snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(.%s.)", name); + break; + + case INTERFACE_INTRINSIC_OP: + snprintf (generic_spec_name, sizeof (generic_spec_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_error ("The access specification at %L not in a module", + &tbattr.where); + goto error; + } + + /* Try to find existing generic-spec with this name for this operator; + if there is something, check that it is another generic-spec and then + extend it rather than building a new symbol. Otherwise, create a new + one with the right attributes. */ + + 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 (generic_spec->attr.flavor != FL_PROCEDURE + && generic_spec->attr.flavor != FL_UNKNOWN) + { + gfc_error ("The generic-spec name %qs at %C clashes with the " + "name of an entity declared at %L that is not a " + "procedure", name, &generic_spec->declared_at); + goto error; + } + + if (op_type == INTERFACE_GENERIC && !generic_spec->attr.generic + && generic_spec->attr.flavor != FL_UNKNOWN) + { + gfc_error ("There's already a non-generic procedure with " + "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 %L conflicts with " + "that already given to %qs", &tbattr.where, + generic_spec->name); + goto error; + } + else + { + gfc_error ("The access specification at %L repeats that " + "already given to %qs", &tbattr.where, + generic_spec->name); + goto error; + } + } + + if (generic_spec->ts.type != BT_UNKNOWN) + { + gfc_error ("The generic-spec in the generic statement at %C " + "has a type from the declaration at %L", + &generic_spec->declared_at); + goto error; + } + } + + /* Now create the generic_spec if it doesn't already exist and provide + is with the appropriate attributes. */ + if (!generic_spec || generic_spec->attr.flavor != FL_PROCEDURE) + { + if (!generic_spec) + { + gfc_get_symbol (name, ns, &generic_spec, &gfc_current_locus); + gfc_set_sym_referenced (generic_spec); + generic_spec->attr.access = tbattr.access; + } + else if (generic_spec->attr.access == ACCESS_UNKNOWN) + generic_spec->attr.access = tbattr.access; + generic_spec->refs++; + generic_spec->attr.generic = 1; + generic_spec->attr.flavor = FL_PROCEDURE; + + generic_spec->declared_at = gfc_current_locus; + } + + /* Prepare to add the specific procedures. */ + 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) + { + if (generic_uop->access != ACCESS_UNKNOWN + && tbattr.access != ACCESS_UNKNOWN) + { + if (generic_uop->access != tbattr.access) + { + gfc_error ("The user operator at %L must have the same " + "access specification as already defined user " + "operator %qs", &tbattr.where, generic_spec_name); + goto error; + } + else + { + gfc_error ("The user operator at %L repeats the access " + "specification of already defined user operator " "%qs", &tbattr.where, generic_spec_name); + goto error; + } + } + else if (generic_uop->access == ACCESS_UNKNOWN) + generic_uop->access = tbattr.access; + } + else + { + generic_uop = gfc_get_uop (name); + generic_uop->access = tbattr.access; + } + + /* Prepare to add the specific procedures. */ + 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 procedure name at %C"); + goto error; + } + + if (op_type == INTERFACE_GENERIC + && !strcmp (generic_spec->name, name)) + { + gfc_error ("The name %qs of the specific procedure at %C conflicts " + "with that of the generic-spec", name); + goto error; + } + + generic = *generic_tail; + for (; generic; generic = generic->next) + { + if (!strcmp (generic->sym->name, name)) + { + gfc_error ("%qs already defined as a specific procedure 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 statement 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 +12221,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..57d0abadda0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_stmt_1.f90 @@ -0,0 +1,194 @@ +! { 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 + interface g ! Check generic statement + generic interface works + module procedure tg + end interface g + + generic :: g => ig, rg + 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 + type(t) :: tres + generic :: operator(+) => tg +! 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 +! check intrinsic operator + tres = t(21) + t(21) + if (tres%i /= 42) stop 5 + 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 6 + if (g(c,d) /= ig(c,d)) stop 7 +! local generic in p + if (j(a,b) /= rg(a,b)) stop 8 + if (j(c,d) /= ig (c,d)) stop 9 +! local generic in p with different number of arguments + if (j(c,d,-1) /= mg(c,d,-1)) stop 10 +! module operator in p + if (7*int(a.plus.b) /= 3*(c.plus.d)) stop 11 +! local operator in p + if ((a.minus.b) /= prg(a,b)) stop 12 + if ((c.minus.d) /= pig(c,d)) stop 13 +! local operator in block + block + generic :: operator(.bminus.) => pig, prg + if ((a.bminus.b) /= prg(a,b)) stop 14 + if ((c.bminus.d) /= pig(c,d)) stop 15 + end block +! intrinsic operator in p + tres = t1 * t2 + if (tres%i /= 6) stop 16 +! 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 17 + tres = g(t1,t2) + if (tres%i /= 5) stop 18 +! subroutines + call sg(10.0*a, b, s3) + if (int(s3) /= 12) stop 19 + call sg(5*c, d, si) + if (si /= 19) stop 20 +! submodule procedures + if (subg(20.0*a,2.0*b) /= realg(20.0*a,2.0*b)) stop 21 +! 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 22 +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..f698012e052 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_stmt_2.f90 @@ -0,0 +1,87 @@ +! { 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-error "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" } + generic, private :: operator(.plusplus.) => ig + generic, private :: operator(.plusplus.) => rg ! { dg-error "repeats the access specification" } + generic, PUBLIC :: operator(.plusplus.) => tg ! { dg-error "must have the same access" } + + 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 appears 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-error "not in a module" } + generic :: operator(+) => rg ! { dg-error "conflicts with intrinsic interface" } + 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 diff --git a/gcc/testsuite/gfortran.dg/generic_stmt_3.f90 b/gcc/testsuite/gfortran.dg/generic_stmt_3.f90 new file mode 100644 index 00000000000..543c63f1aeb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_stmt_3.f90 @@ -0,0 +1,96 @@ +! { dg-do compile } +! +! Test the F2018 generic statement error reporting of access and name conflicts. +! +! Contributed by Steven Kargl +! + module foo1 + + implicit none + private + + public bah + generic :: bah => bah, bak ! { dg-error "conflicts with that" } + + public bar + generic :: bar => bah, bak ! OK - checked that 'bar' is not a procedure + + contains + integer function bah(i) + integer, intent(in) :: i + bah = i + end function bah + real function bak(x) + real, intent(in) :: x + bak = 42.5 + end function bak + end module foo1 + + module foo2 + + implicit none + private + + generic :: bah => bah, bak ! { dg-error "conflicts with that" } + public bah + + generic :: bar => bah, bak ! OK - checked that 'bar' is not a procedure + public bar + + contains + integer function bah(i) + integer, intent(in) :: i + bah = i + end function bah + real function bak(x) + real, intent(in) :: x + bak = 42.5 + end function bak + end module foo2 + + module foo3 ! { dg-error "clashes with the name of an entity" } + + implicit none + private + + integer :: bar = 10 ! { dg-error "has a type" } + generic :: bar => bah, bak ! { dg-error "has a type" } + + generic :: foo3 => bah, bak ! { dg-error "clashes with the name of an entity" } + + contains + integer function bah(i) + integer, intent(in) :: i + bah = i + end function bah + real function bak(x) + real, intent(in) :: x + bak = 42.5 + end function bak + end module foo3 + + module foo4 + implicit none + private + public bak + + generic :: bak => bar, bah + + contains + function bar(i) + real bar + integer, intent(in) :: i + bar = i + end function bar + function bah(x) + real bah + real, intent(in) :: x + bah = x + end function bah + end module foo4 + + program snooze + use foo4 + print *, bak(42) ! Public statement for 'bak' exposes the + print *, bak(43.5) ! specific procedures 'bar' and 'bah' here. + end program snooze diff --git a/gcc/testsuite/gfortran.dg/generic_stmt_4.f90 b/gcc/testsuite/gfortran.dg/generic_stmt_4.f90 new file mode 100644 index 00000000000..24e814a7637 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_stmt_4.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! +! Test the correct processing of public generic statements and verify that they +! behave in the same way as public interfaces. +! +! Contributed by Steven Kargl +! +module foo + + implicit none + + private + public bak1, bak2 + + + generic :: bak1 => bar, bah + + ! Should be equivalent to above. + + interface bak2 + module procedure bar + module procedure bah + end interface bak2 + + + contains + function bar(i) + real bar + integer, intent(in) :: i + bar = i + end function bar + function bah(x) + real bah + real, intent(in) :: x + bah = x + end function bah +end module foo + +program snooze + use foo + if (bak1(42) /= bak2(42)) stop 1 + if (bak1(43.5) /= bak2(43.5)) stop 2 +end program snooze