Hello world,
this patch is a bit more complicated than originally envisioned.
The problem was that we were not handling external dummy arguments
with -fc-prototypes-external. In looking at this, I found that we
were not warning about external procedures with different argument
lists. This can actually be legal (see the two test cases) but
creates a problem for the C prototypes: If we have something like
subroutine foo(a,n)
external a
if (n == 1) call a(1)
if (n == 2) call a(2,3)
end subroutine foo
then, pre-C23, we could just have written out the prototype as
void foo_ (void (*a) (), int *n);
but this is illegal in C23. What to do? I finally chose to warn
about the argument mismatch, with a new option. Warn only because the
code above is legal, but include in -Wall because such code seems highly
suspect. This option is also implied in -fc-prototypes-external. I also
put a warning in the generated header file in that case, so users
have a chance to see what is going on (especially since gcc now
defaults to C23).
Regression-tested.
Comments? Suggestions for better wordings? Is -Wall too strong,
should this be -Wextra (but then nobody would see it, probably...)?
OK for trunk?
Best regards
Thomas
gcc/fortran/ChangeLog:
PR fortran/119049
PR fortran/119074
* dump-parse-tree.cc (seen_conflict): New static varaible.
(gfc_dump_external_c_prototypes): Initialize it. If it was
set, write out a warning that -std=c23 will not work.
(write_proc): Move the work of actually writing out the
formal arglist to...
(write_formal_arglist): New function. Handle external dummy
parameters and their argument lists. If there were mismatched
arguments, output an empty argument list in pre-C23 style.
* gfortran.h (struct gfc_symbol): Add ext_dummy_arglist_mismatch
flag and formal_at.
* invoke.texi: Document -Wexternal-argument-mismatch.
* lang.opt: Put it in.
* resolve.cc (resolve_function): If warning about external
argument mismatches, build a formal from actual arglist the
first time around, and later compare and warn.
(resolve_call): Likewise
gcc/testsuite/ChangeLog:
PR fortran/119049
PR fortran/119074
* gfortran.dg/interface_55.f90: New test.
* gfortran.dg/interface_56.f90: New test.
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 7726b708ad8..1a15757b57b 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -4108,6 +4108,8 @@ gfc_dump_c_prototypes (FILE *file)
/* Loop over all external symbols, writing out their declarations. */
+static bool seen_conflict;
+
void
gfc_dump_external_c_prototypes (FILE * file)
{
@@ -4119,6 +4121,7 @@ gfc_dump_external_c_prototypes (FILE * file)
return;
dumpfile = file;
+ seen_conflict = false;
fprintf (dumpfile,
_("/* Prototypes for external procedures generated from %s\n"
" by GNU Fortran %s%s.\n\n"
@@ -4130,6 +4133,11 @@ gfc_dump_external_c_prototypes (FILE * file)
return;
gfc_traverse_gsymbol (gfc_gsym_root, show_external_symbol, (void *) &bind_c);
+ if (seen_conflict)
+ fprintf (dumpfile,
+ _("\n\n/* WARNING: Because of differing arguments to an external\n"
+ " procedure, this header file is not compatible with -std=c23."
+ "\n\n Use another -std option to compile. */\n"));
}
/* Callback function for dumping external symbols, be they BIND(C) or
@@ -4406,52 +4414,35 @@ write_variable (gfc_symbol *sym)
fputs (";\n", dumpfile);
}
-
-/* Write out a procedure, including its arguments. */
static void
-write_proc (gfc_symbol *sym, bool bind_c)
+write_formal_arglist (gfc_symbol *sym, bool bind_c)
{
- const char *pre, *type_name, *post;
- bool asterisk;
- enum type_return rok;
gfc_formal_arglist *f;
- const char *sym_name;
- const char *intent_in;
- bool external_character;
-
- external_character = sym->ts.type == BT_CHARACTER && !bind_c;
-
- if (sym->binding_label)
- sym_name = sym->binding_label;
- else
- sym_name = sym->name;
-
- if (sym->ts.type == BT_UNKNOWN || external_character)
- {
- fprintf (dumpfile, "void ");
- fputs (sym_name, dumpfile);
- }
- else
- write_decl (&(sym->ts), sym->as, sym_name, true, &sym->declared_at, bind_c);
-
- if (!bind_c)
- fputs ("_", dumpfile);
- fputs (" (", dumpfile);
- if (external_character)
- {
- fprintf (dumpfile, "char *result_%s, size_t result_%s_len",
- sym_name, sym_name);
- if (sym->formal)
- fputs (", ", dumpfile);
- }
-
- for (f = sym->formal; f; f = f->next)
+ for (f = sym->formal; f != NULL; f = f->next)
{
+ enum type_return rok;
+ const char *intent_in;
gfc_symbol *s;
+ const char *pre, *type_name, *post;
+ bool asterisk;
+
s = f->sym;
rok = get_c_type_name (&(s->ts), s->as, &pre, &type_name, &asterisk,
&post, false);
+ /* Procedure arguments have to be converted to function pointers. */
+ if (s->attr.subroutine)
+ {
+ fprintf (dumpfile, "void (*%s) (", s->name);
+ if (s->ext_dummy_arglist_mismatch)
+ seen_conflict = true;
+ else
+ write_formal_arglist (s, bind_c);
+
+ fputc (')', dumpfile);
+ goto next;
+ }
+
if (rok == T_ERROR)
{
gfc_error_now ("Cannot convert %qs to interoperable type at %L",
@@ -4461,6 +4452,18 @@ write_proc (gfc_symbol *sym, bool bind_c)
return;
}
+ if (s->attr.function)
+ {
+ fprintf (dumpfile, "%s (*%s) (", type_name, s->name);
+ if (s->ext_dummy_arglist_mismatch)
+ seen_conflict = true;
+ else
+ write_formal_arglist (s, bind_c);
+
+ fputc (')',dumpfile);
+ goto next;
+ }
+
/* For explicit arrays, we already set the asterisk above. */
if (!s->attr.value && !(s->as && s->as->type == AS_EXPLICIT))
asterisk = true;
@@ -4481,6 +4484,7 @@ write_proc (gfc_symbol *sym, bool bind_c)
if (bind_c && rok == T_WARN)
fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile);
+ next:
if (f->next)
fputs(", ", dumpfile);
}
@@ -4489,6 +4493,42 @@ write_proc (gfc_symbol *sym, bool bind_c)
if (f->sym->ts.type == BT_CHARACTER)
fprintf (dumpfile, ", size_t %s_len", f->sym->name);
+}
+
+/* Write out a procedure, including its arguments. */
+static void
+write_proc (gfc_symbol *sym, bool bind_c)
+{
+ const char *sym_name;
+ bool external_character;
+
+ external_character = sym->ts.type == BT_CHARACTER && !bind_c;
+
+ if (sym->binding_label)
+ sym_name = sym->binding_label;
+ else
+ sym_name = sym->name;
+
+ if (sym->ts.type == BT_UNKNOWN || external_character)
+ {
+ fprintf (dumpfile, "void ");
+ fputs (sym_name, dumpfile);
+ }
+ else
+ write_decl (&(sym->ts), sym->as, sym_name, true, &sym->declared_at, bind_c);
+
+ if (!bind_c)
+ fputs ("_", dumpfile);
+
+ fputs (" (", dumpfile);
+ if (external_character)
+ {
+ fprintf (dumpfile, "char *result_%s, size_t result_%s_len",
+ sym_name, sym_name);
+ if (sym->formal)
+ fputs (", ", dumpfile);
+ }
+ write_formal_arglist (sym, bind_c);
fputs (");\n", dumpfile);
}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 425454be7b4..927f22cffd1 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2023,6 +2023,10 @@ typedef struct gfc_symbol
scope. Used in the suppression of uninitialized warnings in reallocation
on assignment. */
unsigned allocated_in_scope:1;
+ /* Set if an external dummy argument is called with different argument lists.
+ This is legal in Fortran, but can cause problems with autogenerated
+ C prototypes for C23. */
+ unsigned ext_dummy_arglist_mismatch;
/* Reference counter, used for memory management.
@@ -2068,6 +2072,10 @@ typedef struct gfc_symbol
/* Link to next entry in derived type list */
struct gfc_symbol *dt_next;
+
+ /* This is for determining where the symbol has been used first, for better
+ location of error messages. */
+ locus formal_at;
}
gfc_symbol;
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index 0b50508dd1c..da085d124f9 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -242,6 +242,7 @@ is ignored and no user-defined procedure with the same name as any
intrinsic is called except when it is explicitly declared @code{EXTERNAL}.
@opindex fallow-argument-mismatch
+@cindex argument mismatch
@item -fallow-argument-mismatch
Some code contains calls to external procedures with mismatches
between the calls and the procedure definition, or with mismatches
@@ -1068,6 +1069,15 @@ the expression after conversion. Implied by @option{-Wall}.
Warn about implicit conversions between different types and kinds. This
option does @emph{not} imply @option{-Wconversion}.
+@opindex Wexternal-argument-mismatch
+@cindex warnings, argument mismatch
+@cindex argment mismatch, warnings
+@item -Wexternal-argument-mismatch
+Warn about argument mismatches for dummy external procedures. This is
+implied by @option{-fc-prototypes-external} because generation of a
+valid C23 interface is not possible in such a case. Also implied
+by @option{-Wall}.
+
@opindex Wextra
@cindex extra warnings
@cindex warnings, extra
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index 1824c1d953b..7826a1ab5fa 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -241,6 +241,10 @@ Wdo-subscript
Fortran Var(warn_do_subscript) Warning LangEnabledBy(Fortran,Wextra)
Warn about possibly incorrect subscripts in do loops.
+Wexternal-argument-mismatch
+Fortran Var(warn_external_argument_mismatch) Warning LangEnabledBy(Fortran,Wall || fc-prototypes-external)
+Warn when arguments of external procedures do not match.
+
Wextra
Fortran Warning
; Documented in common
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index f83d122a3a2..0773d05bfc6 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -3427,6 +3427,32 @@ resolve_function (gfc_expr *expr)
return false;
}
+ /* Add and check formal interface when -fc-prototypes-external is in
+ force, see comment in resolve_call(). */
+
+ if (warn_external_argument_mismatch && sym && sym->attr.dummy
+ && sym->attr.external)
+ {
+ if (sym->formal)
+ {
+ bool conflict;
+ conflict = !gfc_compare_actual_formal (&expr->value.function.actual,
+ sym->formal, 0, 0, 0, NULL);
+ if (conflict)
+ {
+ sym->ext_dummy_arglist_mismatch = 1;
+ gfc_warning (OPT_Wexternal_argument_mismatch,
+ "Different argument lists in external dummy "
+ "function %s at %L and %L", sym->name,
+ &expr->where, &sym->formal_at);
+ }
+ }
+ else
+ {
+ gfc_get_formal_from_actual_arglist (sym, expr->value.function.actual);
+ sym->formal_at = expr->where;
+ }
+ }
/* See if function is already resolved. */
if (expr->value.function.name != NULL
@@ -3939,6 +3965,43 @@ resolve_call (gfc_code *c)
if (csym && is_external_proc (csym))
resolve_global_procedure (csym, &c->loc, 1);
+ /* If we have an external dummy argument, we want to write out its arguments
+ with -fc-prototypes-external. Code like
+
+ subroutine foo(a,n)
+ external a
+ if (n == 1) call a(1)
+ if (n == 2) call a(2,3)
+ end subroutine foo
+
+ is actually legal Fortran, but it is not possible to generate a C23-
+ compliant prototype for this, so we just record the fact here and
+ handle that during -fc-prototypes-external processing. */
+
+ if (warn_external_argument_mismatch && csym && csym->attr.dummy
+ && csym->attr.external)
+ {
+ if (csym->formal)
+ {
+ bool conflict;
+ conflict = !gfc_compare_actual_formal (&c->ext.actual, csym->formal,
+ 0, 0, 0, NULL);
+ if (conflict)
+ {
+ csym->ext_dummy_arglist_mismatch = 1;
+ gfc_warning (OPT_Wexternal_argument_mismatch,
+ "Different argument lists in external dummy "
+ "subroutine %s at %L and %L", csym->name,
+ &c->loc, &csym->formal_at);
+ }
+ }
+ else
+ {
+ gfc_get_formal_from_actual_arglist (csym, c->ext.actual);
+ csym->formal_at = c->loc;
+ }
+ }
+
t = true;
if (c->resolved_sym == NULL)
{
diff --git a/gcc/testsuite/gfortran.dg/interface_55.f90 b/gcc/testsuite/gfortran.dg/interface_55.f90
new file mode 100644
index 00000000000..7016a56ed64
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_55.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+! { dg-additional-options "-Wexternal-argument-mismatch" }
+! PR 119074 - the code is legal, but it makes sense to warn anyway.
+
+program main
+ external ex1,ex2
+ call foo(ex1,1)
+ call foo(ex2,2)
+end program main
+
+subroutine ex1(n)
+ integer :: n
+ if (n /= 1) error stop
+end subroutine ex1
+
+subroutine ex2(n,m)
+ integer :: n,m
+ if (n /= 2) error stop
+ if (m /= 3) error stop
+end subroutine ex2
+
+subroutine foo(a,n)
+ external a
+ if (n == 1) call a(1) ! { dg-warning "Different argument lists" }
+ if (n == 2) call a(2,3) ! { dg-warning "Different argument lists" }
+end subroutine foo
diff --git a/gcc/testsuite/gfortran.dg/interface_56.f90 b/gcc/testsuite/gfortran.dg/interface_56.f90
new file mode 100644
index 00000000000..c736c81e9eb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_56.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+! PR 119074 - the code is legal, but it makes sense to warn anyway.
+! { dg-additional-options "-Wall" }
+
+program memain
+ external i1, i2
+ integer i1, i2
+ call foo (i1,1)
+ call foo (i2,2)
+end program memain
+
+integer function i1(n)
+ i1 = n + 1
+end function i1
+
+integer function i2(n,m)
+ i2 = n + m + 1
+end function i2
+
+subroutine foo(f,n)
+ integer, external :: f
+ integer :: n
+ integer :: s
+ if (n == 1) then
+ s = f(1) ! { dg-warning "Different argument lists" }
+ if (s /= 2) error stop
+ end if
+ if (n == 2) then
+ s = f(2,3) ! { dg-warning "Different argument lists" }
+ if (s /= 6) error stop
+ end if
+end subroutine foo
