From 21ca9153ebe525b077ac96811cfd48be6b259e7e Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Tue, 4 Mar 2025 20:13:19 +0100 Subject: 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. --- gcc/fortran/dump-parse-tree.cc | 114 ++++++++++++++++++++++++++++------------- 1 file changed, 77 insertions(+), 37 deletions(-) (limited to 'gcc/fortran/dump-parse-tree.cc') 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); } -- cgit v1.1