From 6328ce1f83c260ac7728f9490870c326944b17d8 Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Wed, 8 May 2019 21:55:13 +0000 Subject: [PATCH] re PR fortran/90351 (-fc-prototypes does not dump prototypes for external procedures) 2019-05-08 Thomas Koenig 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 --- gcc/fortran/ChangeLog | 18 ++++++ 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, 150 insertions(+), 26 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5aaa52eb302..c910af439cf 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +2019-05-08 Thomas Koenig + + 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 PR fortran/90290 diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 7a74c317fd5..54af5dfd50d 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 = ""; - 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 23d01b10728..0de375cf0bb 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 8364c67b2df..efc7aea588a 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{} or @code{}. + +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 9151d02c491..be722d7e183 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 14cda5f9fba..9d693595e20 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); -- 2.30.2