Index: dump-parse-tree.c =================================================================== --- dump-parse-tree.c (Revision 270622) +++ dump-parse-tree.c (Arbeitskopie) @@ -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 *fi 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 dicsouraged, 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 *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 *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 *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 } 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,6 +3246,7 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec } } *asterisk = true; + ret = T_OK; } else *type_name = ts->u.derived->name; @@ -3206,6 +3253,7 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec 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 /* 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, 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,7 +3332,7 @@ 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); } @@ -3291,7 +3339,7 @@ write_variable (gfc_symbol *sym) /* 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 @@ static void 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 @@ static void { 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 @@ static void 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); } Index: gfortran.h =================================================================== --- gfortran.h (Revision 270622) +++ gfortran.h (Arbeitskopie) @@ -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); Index: invoke.texi =================================================================== --- invoke.texi (Revision 270622) +++ invoke.texi (Arbeitskopie) @@ -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 o @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 > @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 Index: lang.opt =================================================================== --- lang.opt (Revision 270622) +++ lang.opt (Arbeitskopie) @@ -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. Index: parse.c =================================================================== --- parse.c (Revision 270622) +++ parse.c (Arbeitskopie) @@ -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);