[gcc/devel/omp/gcc-9] backport: re PR fortran/90351 (-fc-prototypes does not dump prototypes for external procedures)
Tobias Burnus
burnus@gcc.gnu.org
Thu Mar 5 13:45:00 GMT 2020
https://gcc.gnu.org/g:10e4cdb5a794c2568b9a27949973d4d3c1933c5b
commit 10e4cdb5a794c2568b9a27949973d4d3c1933c5b
Author: Thomas Koenig <tkoenig@gcc.gnu.org>
Date: Thu May 9 17:40:30 2019 +0000
backport: re PR fortran/90351 (-fc-prototypes does not dump prototypes for external procedures)
2019-05-09 Thomas Koenig <tkoenig@gcc.gnu.org>
Backport from trunk
PR fortran/90351
PR fortran/90329
* gfortran.dg/dump-parse-tree.c: Include version.h.
(gfc_dump_external_c_prototypes): New function.
(get_c_type_name): Select "char" as a name for a simple char.
Adjust to handling external functions. Also handle complex.
(write_decl): Add argument bind_c. Adjust for dumping of external
procedures.
(write_proc): Likewise.
(write_interop_decl): Add bind_c argument to call of write_proc.
* gfortran.h: Add prototype for gfc_dump_external_c_prototypes.
* lang.opt: Add -fc-prototypes-external flag.
* parse.c (gfc_parse_file): Move dumping of BIND(C) prototypes.
Call gfc_dump_external_c_prototypes if option is set.
* invoke.texi: Document -fc-prototypes-external.
From-SVN: r271038
Diff:
---
gcc/fortran/ChangeLog | 19 ++++++++
gcc/fortran/dump-parse-tree.c | 108 ++++++++++++++++++++++++++++++++++--------
gcc/fortran/gfortran.h | 1 +
gcc/fortran/invoke.texi | 30 +++++++++++-
gcc/fortran/lang.opt | 4 ++
gcc/fortran/parse.c | 15 ++++--
6 files changed, 151 insertions(+), 26 deletions(-)
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index fa2d51a..be51d68 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,22 @@
+2019-05-09 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/90351
+ PR fortran/90329
+ * gfortran.dg/dump-parse-tree.c: Include version.h.
+ (gfc_dump_external_c_prototypes): New function.
+ (get_c_type_name): Select "char" as a name for a simple char.
+ Adjust to handling external functions. Also handle complex.
+ (write_decl): Add argument bind_c. Adjust for dumping of external
+ procedures.
+ (write_proc): Likewise.
+ (write_interop_decl): Add bind_c argument to call of write_proc.
+ * gfortran.h: Add prototype for gfc_dump_external_c_prototypes.
+ * lang.opt: Add -fc-prototypes-external flag.
+ * parse.c (gfc_parse_file): Move dumping of BIND(C) prototypes.
+ Call gfc_dump_external_c_prototypes if option is set.
+ * invoke.texi: Document -fc-prototypes-external.
+
2019-05-03 Release Manager
* GCC 9.1.0 released.
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 7a74c31..54af5df 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see
#include "coretypes.h"
#include "gfortran.h"
#include "constructor.h"
+#include "version.h"
/* Keep track of indentation for symbol tree dumps. */
static int show_level = 0;
@@ -3074,6 +3075,7 @@ gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
/* This part writes BIND(C) definition for use in external C programs. */
static void write_interop_decl (gfc_symbol *);
+static void write_proc (gfc_symbol *, bool);
void
gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file)
@@ -3086,6 +3088,33 @@ gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file)
gfc_traverse_ns (ns, write_interop_decl);
}
+/* Loop over all global symbols, writing out their declrations. */
+
+void
+gfc_dump_external_c_prototypes (FILE * file)
+{
+ dumpfile = file;
+ fprintf (dumpfile,
+ _("/* Prototypes for external procedures generated from %s\n"
+ " by GNU Fortran %s%s.\n\n"
+ " Use of this interface is discouraged, consider using the\n"
+ " BIND(C) feature of standard Fortran instead. */\n\n"),
+ gfc_source_file, pkgversion_string, version_string);
+
+ for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
+ gfc_current_ns = gfc_current_ns->sibling)
+ {
+ gfc_symbol *sym = gfc_current_ns->proc_name;
+
+ if (sym == NULL || sym->attr.flavor != FL_PROCEDURE
+ || sym->attr.is_bind_c)
+ continue;
+
+ write_proc (sym, false);
+ }
+ return;
+}
+
enum type_return { T_OK=0, T_WARN, T_ERROR };
/* Return the name of the type for later output. Both function pointers and
@@ -3104,7 +3133,7 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre,
*asterisk = false;
*post = "";
*type_name = "<error>";
- if (ts->type == BT_REAL || ts->type == BT_INTEGER)
+ if (ts->type == BT_REAL || ts->type == BT_INTEGER || ts->type == BT_COMPLEX)
{
if (ts->is_c_interop && ts->interop_kind)
{
@@ -3113,6 +3142,12 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre,
*type_name = "signed char";
else if (strcmp (*type_name, "size_t") == 0)
*type_name = "ssize_t";
+ else if (strcmp (*type_name, "float_complex") == 0)
+ *type_name = "float complex";
+ else if (strcmp (*type_name, "double_complex") == 0)
+ *type_name = "double complex";
+ else if (strcmp (*type_name, "long_double_complex") == 0)
+ *type_name = "long double complex";
ret = T_OK;
}
@@ -3130,6 +3165,12 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre,
*type_name = "signed char";
else if (strcmp (*type_name, "size_t") == 0)
*type_name = "ssize_t";
+ else if (strcmp (*type_name, "float_complex") == 0)
+ *type_name = "float complex";
+ else if (strcmp (*type_name, "double_complex") == 0)
+ *type_name = "double complex";
+ else if (strcmp (*type_name, "long_double_complex") == 0)
+ *type_name = "long double complex";
ret = T_WARN;
break;
@@ -3167,16 +3208,21 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre,
}
else
{
- /* Let's select an appropriate int, with a warning. */
- for (int i = 0; i < ISOCBINDING_NUMBER; i++)
- {
- if (c_interop_kinds_table[i].f90_type == BT_INTEGER
- && c_interop_kinds_table[i].value == ts->kind)
- {
- *type_name = c_interop_kinds_table[i].name + 2;
- ret = T_WARN;
- }
+ if (ts->kind == gfc_default_character_kind)
+ *type_name = "char";
+ else
+ /* Let's select an appropriate int. */
+ for (int i = 0; i < ISOCBINDING_NUMBER; i++)
+ {
+ if (c_interop_kinds_table[i].f90_type == BT_INTEGER
+ && c_interop_kinds_table[i].value == ts->kind)
+ {
+ *type_name = c_interop_kinds_table[i].name + 2;
+ break;
+ }
}
+ ret = T_WARN;
+
}
}
else if (ts->type == BT_DERIVED)
@@ -3200,12 +3246,14 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre,
}
}
*asterisk = true;
+ ret = T_OK;
}
else
*type_name = ts->u.derived->name;
ret = T_OK;
}
+
if (ret != T_ERROR && as)
{
mpz_t sz;
@@ -3222,7 +3270,7 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre,
/* Write out a declaration. */
static void
write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name,
- bool func_ret, locus *where)
+ bool func_ret, locus *where, bool bind_c)
{
const char *pre, *type_name, *post;
bool asterisk;
@@ -3245,7 +3293,7 @@ write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name,
fputs (sym_name, dumpfile);
fputs (post, dumpfile);
- if (rok == T_WARN)
+ if (rok == T_WARN && bind_c)
fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */",
gfc_typename (ts));
}
@@ -3262,7 +3310,7 @@ write_type (gfc_symbol *sym)
for (c = sym->components; c; c = c->next)
{
fputs (" ", dumpfile);
- write_decl (&(c->ts), c->as, c->name, false, &sym->declared_at);
+ write_decl (&(c->ts), c->as, c->name, false, &sym->declared_at, true);
fputs (";\n", dumpfile);
}
@@ -3284,14 +3332,14 @@ write_variable (gfc_symbol *sym)
sym_name = sym->name;
fputs ("extern ", dumpfile);
- write_decl (&(sym->ts), sym->as, sym_name, false, &sym->declared_at);
+ write_decl (&(sym->ts), sym->as, sym_name, false, &sym->declared_at, true);
fputs (";\n", dumpfile);
}
/* Write out a procedure, including its arguments. */
static void
-write_proc (gfc_symbol *sym)
+write_proc (gfc_symbol *sym, bool bind_c)
{
const char *pre, *type_name, *post;
bool asterisk;
@@ -3299,22 +3347,35 @@ write_proc (gfc_symbol *sym)
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)
+ 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);
+ write_decl (&(sym->ts), sym->as, sym_name, true, &sym->declared_at, bind_c);
- fputs (" (", dumpfile);
+ 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)
{
gfc_symbol *s;
@@ -3325,7 +3386,7 @@ write_proc (gfc_symbol *sym)
{
gfc_error_now ("Cannot convert %qs to interoperable type at %L",
gfc_typename (&s->ts), &s->declared_at);
- fprintf (stderr, "/* Cannot convert '%s' to interoperable type */",
+ fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */",
gfc_typename (&s->ts));
return;
}
@@ -3346,12 +3407,17 @@ write_proc (gfc_symbol *sym)
fputs (s->name, dumpfile);
fputs (post, dumpfile);
- if (rok == T_WARN)
+ if (bind_c && rok == T_WARN)
fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile);
if (f->next)
fputs(", ", dumpfile);
}
+ if (!bind_c)
+ for (f = sym->formal; f; f = f->next)
+ if (f->sym->ts.type == BT_CHARACTER)
+ fprintf (dumpfile, ", size_t %s_len", f->sym->name);
+
fputs (");\n", dumpfile);
}
@@ -3375,5 +3441,5 @@ write_interop_decl (gfc_symbol *sym)
else if (sym->attr.flavor == FL_DERIVED)
write_type (sym);
else if (sym->attr.flavor == FL_PROCEDURE)
- write_proc (sym);
+ write_proc (sym, true);
}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 23d01b1..0de375c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3462,6 +3462,7 @@ void gfc_delete_bbt (void *, void *, compare_fn);
/* dump-parse-tree.c */
void gfc_dump_parse_tree (gfc_namespace *, FILE *);
void gfc_dump_c_prototypes (gfc_namespace *, FILE *);
+void gfc_dump_external_c_prototypes (FILE *);
/* parse.c */
bool gfc_parse_file (void);
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index 8364c67..efc7aea 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -176,7 +176,7 @@ and warnings}.
@item Interoperability Options
@xref{Interoperability Options,,Options for interoperability}.
-@gccoptlist{-fc-prototypes}
+@gccoptlist{-fc-prototypes -fc-prototypes-external}
@item Code Generation Options
@xref{Code Gen Options,,Options for code generation conventions}.
@@ -1870,7 +1870,7 @@ shared by @command{gfortran}, @command{gcc}, and other GNU compilers.
@item -fc-prototypes
@opindex @code{c-prototypes}
-@cindex Generating C prototypes from Fortran source code
+@cindex Generating C prototypes from Fortran BIND(C) enteties
This option will generate C prototypes from @code{BIND(C)} variable
declarations, types and procedure interfaces and writes them to
standard output. @code{ENUM} is not yet supported.
@@ -1889,6 +1889,32 @@ $ gfortran -fc-prototypes -fsyntax-only foo.f90 > foo.h
@end smallexample
where the C code intended for interoperating with the Fortran code
then uses @code{#include "foo.h"}.
+
+@item -fc-prototypes-external
+@opindex @code{c-prototypes-external}
+@cindex Generating C prototypes from external procedures
+This option will generate C prototypes from external functions and
+subroutines and write them to standard output. This may be useful for
+making sure that C bindings to Fortran code are correct. This option
+does not generate prototypes for @code{BIND(C)} procedures, use
+@option{-fc-prototypes} for that.
+
+The generated prototypes may need inclusion of an appropriate
+header, such as as @code{<stdint.h>} or @code{<stdlib.h>}.
+
+This is primarily meant for legacy code to ensure that existing C
+bindings match what @command{gfortran} emits. The generated C
+prototypes should be correct for the current version of the compiler,
+but may not match what other compilers or earlier versions of
+@command{gfortran} need. For new developments, use of the
+@code{BIND(C)} features is recommended.
+
+Example of use:
+@smallexample
+$ gfortran -fc-prototypes-external -fsyntax-only foo.f > foo.h
+@end smallexample
+where the C code intended for interoperating with the Fortran code
+then uses @code{#include "foo.h"}.
@end table
@node Environment Variables
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index 9151d02..be722d7 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -428,6 +428,10 @@ fc-prototypes
Fortran Var(flag_c_prototypes)
Generate C prototypes from BIND(C) declarations.
+fc-prototypes-external
+Fortran Var(flag_c_prototypes_external)
+Generate C prototypes from non-BIND(C) external procedure definitions.
+
fd-lines-as-code
Fortran RejectNegative
Ignore 'D' in column one in fixed form.
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 14cda5f..9d69359 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -6278,9 +6278,6 @@ loop:
if (flag_dump_fortran_original)
gfc_dump_parse_tree (gfc_current_ns, stdout);
- if (flag_c_prototypes)
- gfc_dump_c_prototypes (gfc_current_ns, stdout);
-
gfc_get_errors (NULL, &errors);
if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE)
{
@@ -6333,6 +6330,18 @@ done:
fputs ("------------------------------------------\n\n", stdout);
}
+ /* Dump C prototypes. */
+ if (flag_c_prototypes)
+ {
+ for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
+ gfc_current_ns = gfc_current_ns->sibling)
+ gfc_dump_c_prototypes (gfc_current_ns, stdout);
+ }
+
+ /* Dump external prototypes. */
+ if (flag_c_prototypes_external)
+ gfc_dump_external_c_prototypes (stdout);
+
/* Do the translation. */
translate_all_program_units (gfc_global_ns_list);
More information about the Gcc-cvs
mailing list