/* Loop over all external symbols, writing out their declarations. */
+static bool seen_conflict;
+
void
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"
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
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",
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;
if (bind_c && rok == T_WARN)
fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile);
+ next:
if (f->next)
fputs(", ", dumpfile);
}
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);
}
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.
/* 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;
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
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
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
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
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)
{
--- /dev/null
+! { 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
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
