===================================================================
@@ -2631,6 +2631,7 @@ kind_expr:
of the named constants from iso_c_binding. */
ts->is_c_interop = e->ts.is_iso_c;
ts->f90_type = e->ts.f90_type;
+ ts->interop_kind = e->symtree->n.sym;
}
gfc_free_expr (e);
===================================================================
@@ -2891,3 +2891,247 @@ gfc_dump_parse_tree (gfc_namespace *ns, FILE *file
show_namespace (ns);
}
+/* This part writes BIND(C) definition for use in external C programs. */
+
+static void write_interop_decl (gfc_symbol *);
+
+void
+gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file)
+{
+ int error_count;
+ gfc_get_errors (NULL, &error_count);
+ if (error_count != 0)
+ return;
+ dumpfile = file;
+ gfc_traverse_ns (ns, write_interop_decl);
+}
+
+enum type_return { T_OK=0, T_WARN, T_ERROR };
+
+/* Return the name of the type for later output. Both function pointers and
+ void pointers will be mapped to void *. */
+
+static enum type_return
+get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre,
+ const char **type_name, bool *asterisk, const char **post,
+ bool func_ret)
+{
+ static char post_buffer[40];
+ enum type_return ret;
+ ret = T_ERROR;
+
+ *pre = " ";
+ *asterisk = false;
+ *post = "";
+ *type_name = "<error>";
+ if (ts->type == BT_REAL || ts->type == BT_INTEGER)
+ {
+
+ if (ts->is_c_interop && ts->interop_kind)
+ {
+ *type_name = ts->interop_kind->name + 2;
+ if (strcmp (*type_name, "signed_char") == 0)
+ *type_name = "signed char";
+ ret = T_OK;
+ }
+ else
+ {
+ /* The user did not specify a C interop type. Let's look through
+ the available table and use the first one, but warn. */
+ int i;
+ for (i=0; i<ISOCBINDING_NUMBER; i++)
+ {
+ if (c_interop_kinds_table[i].f90_type == ts->type
+ && c_interop_kinds_table[i].value == ts->kind)
+ {
+ *type_name = c_interop_kinds_table[i].name + 2;
+ if (strcmp (*type_name, "signed_char") == 0)
+ *type_name = "signed char";
+ ret = T_WARN;
+ break;
+ }
+ }
+ }
+ }
+ else if (ts->type == BT_DERIVED)
+ {
+ if (ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING)
+ {
+ if (strcmp (ts->u.derived->name, "c_ptr") == 0)
+ *type_name = "void";
+ else if (strcmp (ts->u.derived->name, "c_funptr") == 0)
+ {
+ *type_name = "int ";
+ if (func_ret)
+ {
+ *pre = "(";
+ *post = "())";
+ }
+ else
+ {
+ *pre = "(";
+ *post = ")()";
+ }
+ }
+ *asterisk = true;
+ }
+ else
+ *type_name = ts->u.derived->name;
+
+ ret = T_OK;
+ }
+ if (ret != T_ERROR && as)
+ {
+ mpz_t sz;
+ bool size_ok;
+ size_ok = spec_size (as, &sz);
+ gcc_assert (size_ok == true);
+ gmp_snprintf (post_buffer, sizeof(post_buffer), "[%Zd]", sz);
+ *post = post_buffer;
+ mpz_clear (sz);
+ }
+ return ret;
+}
+
+/* Write out a declaration. */
+static void
+write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name,
+ bool func_ret)
+{
+ const char *pre, *type_name, *post;
+ bool asterisk;
+ enum type_return rok;
+
+ rok = get_c_type_name (ts, as, &pre, &type_name, &asterisk, &post, func_ret);
+ gcc_assert (rok != T_ERROR);
+ fputs (type_name, dumpfile);
+ fputs (pre, dumpfile);
+ if (asterisk)
+ fputs ("*", dumpfile);
+
+ fputs (sym_name, dumpfile);
+ fputs (post, dumpfile);
+
+ if (rok == T_WARN)
+ fputs(" /* WARNING: non-interoperable KIND */", dumpfile);
+}
+
+/* Write out an interoperable type. It will be written as a typedef
+ for a struct. */
+
+static void
+write_type (gfc_symbol *sym)
+{
+ gfc_component *c;
+
+ fprintf (dumpfile, "typedef struct %s {\n", sym->name);
+ for (c = sym->components; c; c = c->next)
+ {
+ fputs (" ", dumpfile);
+ write_decl (&(c->ts), c->as, c->name, false);
+ fputs (";\n", dumpfile);
+ }
+
+ fprintf (dumpfile, "} %s;\n", sym->name);
+}
+
+/* Write out a variable. */
+
+static void
+write_variable (gfc_symbol *sym)
+{
+ const char *sym_name;
+
+ gcc_assert (sym->attr.flavor == FL_VARIABLE);
+
+ if (sym->binding_label)
+ sym_name = sym->binding_label;
+ else
+ sym_name = sym->name;
+
+ fputs ("extern ", dumpfile);
+ write_decl (&(sym->ts), sym->as, sym_name, false);
+ fputs (";\n", dumpfile);
+}
+
+
+/* Write out a procedure, including its arguments. */
+static void
+write_proc (gfc_symbol *sym)
+{
+ const char *pre, *type_name, *post;
+ bool asterisk;
+ enum type_return rok;
+ gfc_formal_arglist *f;
+ const char *sym_name;
+ const char *intent_in;
+
+ if (sym->binding_label)
+ sym_name = sym->binding_label;
+ else
+ sym_name = sym->name;
+
+ if (sym->ts.type == BT_UNKNOWN)
+ {
+ fprintf (dumpfile, "void ");
+ fputs (sym_name, dumpfile);
+ }
+ else
+ write_decl (&(sym->ts), sym->as, sym->name, true);
+
+ fputs (" (", dumpfile);
+
+ for (f = sym->formal; f; f = f->next)
+ {
+ gfc_symbol *s;
+ s = f->sym;
+ rok = get_c_type_name (&(s->ts), NULL, &pre, &type_name, &asterisk,
+ &post, false);
+ gcc_assert (rok != T_ERROR);
+
+ if (!s->attr.value)
+ asterisk = true;
+
+ if (s->attr.intent == INTENT_IN && !s->attr.value)
+ intent_in = "const ";
+ else
+ intent_in = "";
+
+ fputs (intent_in, dumpfile);
+ fputs (type_name, dumpfile);
+ fputs (pre, dumpfile);
+ if (asterisk)
+ fputs ("*", dumpfile);
+
+ fputs (s->name, dumpfile);
+ fputs (post, dumpfile);
+ if (rok == T_WARN)
+ fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile);
+
+ fputs (f->next ? ", " : ")", dumpfile);
+ }
+ fputs (";\n", dumpfile);
+}
+
+
+/* Write a C-interoperable declaration as a C prototype or extern
+ declaration. */
+
+static void
+write_interop_decl (gfc_symbol *sym)
+{
+ /* Only dump bind(c) entities. */
+ if (!sym->attr.is_bind_c)
+ return;
+
+ /* Don't dump our iso c module. */
+ if (sym->from_intmod == INTMOD_ISO_C_BINDING)
+ return;
+
+ if (sym->attr.flavor == FL_VARIABLE)
+ write_variable (sym);
+ else if (sym->attr.flavor == FL_DERIVED)
+ write_type (sym);
+ else if (sym->attr.flavor == FL_PROCEDURE)
+ write_proc (sym);
+}
===================================================================
@@ -1012,6 +1012,7 @@ typedef struct
int is_iso_c;
bt f90_type;
bool deferred;
+ gfc_symbol *interop_kind;
}
gfc_typespec;
@@ -3311,6 +3312,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 *);
/* parse.c */
bool gfc_parse_file (void);
===================================================================
@@ -100,6 +100,8 @@ one is not the default.
* Runtime Options:: Influencing runtime behavior
* Code Gen Options:: Specifying conventions for function calls, data layout
and register usage.
+* Interoperability Options:: Options for interoperability with other
+ languages.
* Environment Variables:: Environment variables that affect @command{gfortran}.
@end menu
@@ -171,6 +173,10 @@ and warnings}.
-frecord-marker=@var{length} -fsign-zero
}
+@item Interoperability Options
+@xref{Interoperability Options,,Options for interoperability}.
+@gccoptlist{-fc-prototypes}
+
@item Code Generation Options
@xref{Code Gen Options,,Options for code generation conventions}.
@gccoptlist{-faggressive-function-elimination -fblas-matmul-limit=@var{n} @gol
@@ -1746,6 +1752,31 @@ shared by @command{gfortran}, @command{gcc}, and o
@c man end
+@node Interoperability Options
+@section Options for interoperability with other languages
+
+@table @asis
+
+@item -fc-prototypes
+@opindex @code{c-prototypes}
+@cindex Generating C prototypes from Fortran source code
+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.
+
+The generated prototypes may need inclusion of an appropriate header,
+such as @code{<stdint.h>} or @code{<stdlib.h>}. For types which are
+not specified using the appropriate kind from the @code{iso_c_binding}
+module, a warning is added as a comment to the code.
+
+Example of use:
+@smallexample
+$ gfortran -fc-prototypes foo.f90 -fsyntax-only > 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
@section Environment variables affecting @command{gfortran}
@cindex environment variable
===================================================================
@@ -416,6 +416,10 @@ fcray-pointer
Fortran Var(flag_cray_pointer)
Use the Cray Pointer extension.
+fc-prototypes
+Fortran Var(flag_c_prototypes)
+Generate C prototypes from BIND(C) declarations.
+
fd-lines-as-code
Fortran RejectNegative
Ignore 'D' in column one in fixed form.
===================================================================
@@ -6218,6 +6218,9 @@ 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)
{
Hello world, the attached patch generates C prototypes from all things BIND(C) that it can find and dumps them to standard output, under control of the appropriate flag. Enums are not yet supported (we translate them to parameters almost immediately, so this will need more work). I have added an example for how this could work. It will likely automate my own C interop work. Doing this the other way, writing Fortran interface blocks from C prototypes, is also an interesting project, but not yet. Regarding the documentation: This option didn't really fit into any other section, which is why I put it into its own. Suggestions are welcome. Currently, it turns code like module x use, intrinsic :: iso_c_binding implicit none type(c_funptr), bind(c) :: funptr type(c_ptr), bind(c) :: vptr type, bind(c) :: t_t integer(c_signed_char) :: i type(c_ptr) :: p end type t_t type(t_t), bind(c,name="yourvar") :: myvar integer(c_int64_t), bind(c) :: a(10,10) double precision, bind(c) :: dob interface function my_memcpy(dest, from, n) bind(c) import type(c_ptr) :: my_memcpy type(c_ptr), intent(out) :: dest type(c_ptr), intent(in) :: from; integer(c_size_t), value :: n end function my_memcpy end interface contains subroutine sub(asub) bind(c) real(c_float), value :: asub end subroutine sub integer(c_int) function func(afunc) bind(c) real(c_float), intent(in) :: afunc end function func subroutine inout_test (a_in, a_out) bind(c) real(c_double), dimension(*), intent(in) :: a_in real(c_double), dimension(*), intent(out) :: a_out end subroutine inout_test function xxx(a) bind(c) integer, intent(in) :: a type(c_funptr) :: xxx end function xxx end module x into typedef struct t_t { signed char i; void *p; } t_t; extern int64_t a[100]; extern double dob /* WARNING: non-interoperable KIND */; int func (const float *afunc); extern int (*funptr)(); void inout_test (const double *a_in, double *a_out); void *my_memcpy (void *dest, const void *from, size_t n); extern t_t yourvar; void sub (float asub); extern void *vptr; int (*xxx()) (const int *a /* WARNING: non-interoperable KIND */ ); Of course, I could also add some boilerplate to the generated code, into comments, such as "generated by gfortran xyz on ... from file ...". I have chosen to turn function pointers into old-style K&R pointers, in the hope that this is the correct thing to do. So, is this approach OK in general? Suggestions? Other ideas? OK for trunk? Regards Thomas 2017-07-28 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/45435 * lang.opt (fc-prototypes): Add option. * gfortran.h (gfc_typespec): Add interop_kind to struct. (gfc_dump_c_prototypes): Add prototype. * decl.c (gfc_match_kind_spec): Copy symbol used for kind to typespec. * parse.c (gfc_parse_file): Call gfc_dump_prototypes. * dump-parse-tree.c (gfc_dump_c_prototypes): New function. (type_return): New enum. (get_c_type_name): New function. (write_decl): New function. (write_type): New function. (write_variable): New function. (write_proc): New function. (write_interop_decl): New function. * invoke.texi: Document -fc-prototypes. FFLAGS = -flto -O2 -Wall CFLAGS = -flto -O2 -Wall LFLAGS = -flto -O2 -Wall OBJS = main.o inter.o cexample.o all: $(OBJS) gfortran $(LFLAGS) -o $@ $(OBJS) inter.h: inter.f90 gfortran -fsyntax-only -fc-prototypes $< > inter.h inter.o inter.mod: inter.f90 gfortran -c $(FFLAGS) inter.f90 cexample.o: cexample.c inter.h gcc -c $(CFLAGS) $< main.o: main.f90 inter.mod gfortran -c $(FFLAGS) $< clean: rm -f $(OBJS) all inter.h inter.mod *~