FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/90351 (-fc-prototypes does not dump prototypes for external procedures)

Browse source 
2019-05-08  Thomas Koenig  <tkoenig@gcc.gnu.org>

    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: r271018
This commit is contained in:
Thomas Koenig 2019-05-08 21:55:13 +00:00
parent 8ba2bda8e4
commit 6328ce1f83
6 changed files with 150 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
gcc/fortran/ChangeLog
View file

@ -1,3 +1,21 @@
2019-05-08 Thomas Koenig <tkoenig@gcc.gnu.org>
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-06 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/90290

108
gcc/fortran/dump-parse-tree.c
View file

@ -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);
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);
}

1
gcc/fortran/gfortran.h
View file

@ -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);

30
gcc/fortran/invoke.texi
View file

@ -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

4
gcc/fortran/lang.opt
View file

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

15
gcc/fortran/parse.c
View file

@ -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);