C prototypes for external arguments; add warning for mismatch.

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).

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.

1 files changed, 77 insertions, 37 deletions

diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 7726b70..1a15757 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);
 }