#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;
/* 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)
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
*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)
{
*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;
}
*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;
}
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)
}
}
*asterisk = true;
+ ret = T_OK;
}
else
*type_name = ts->u.derived->name;
ret = T_OK;
}
+
if (ret != T_ERROR && as)
{
mpz_t sz;
/* 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;
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));
}
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);
}
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;
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;
{
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;
}
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);
}
else if (sym->attr.flavor == FL_DERIVED)
write_type (sym);
else if (sym->attr.flavor == FL_PROCEDURE)
- write_proc (sym);
+ write_proc (sym, true);
}
@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}.
@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.
@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
projects / gcc.git / commitdiff