}
+/* 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(...). */
}
+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
break;
case 'g':
+ match ("generic", gfc_match_generic, ST_GENERIC);
break;
case 'i':
st = next_statement ();
goto loop;
+ case ST_GENERIC:
+ accept_statement (st);
+ st = next_statement ();
+ goto loop;
+
case ST_ENUM:
accept_statement (st);
parse_enum();
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { dg-do compile }
+!
+! Test the F2018 generic statement error reporting of access and name conflicts.
+!
+! Contributed by Steven Kargl <kargls@comcast.net>
+!
+ 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
--- /dev/null
+! { 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 <kargls@comcast.net>
+!
+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
projects / thirdparty / gcc.git / commitdiff
