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 <tkoe...@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.
Index: decl.c
===================================================================
--- decl.c (Revision 250501)
+++ decl.c (Arbeitskopie)
@@ -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);
Index: dump-parse-tree.c
===================================================================
--- dump-parse-tree.c (Revision 250501)
+++ dump-parse-tree.c (Arbeitskopie)
@@ -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);
+}
Index: gfortran.h
===================================================================
--- gfortran.h (Revision 250501)
+++ gfortran.h (Arbeitskopie)
@@ -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);
Index: invoke.texi
===================================================================
--- invoke.texi (Revision 250501)
+++ invoke.texi (Arbeitskopie)
@@ -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
Index: lang.opt
===================================================================
--- lang.opt (Revision 250501)
+++ lang.opt (Arbeitskopie)
@@ -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.
Index: parse.c
===================================================================
--- parse.c (Revision 250501)
+++ parse.c (Arbeitskopie)
@@ -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)
{
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 *~
program main
use inter
implicit none
type(t) :: myval
integer ::i
call fill_type(myval, 5)
do i=1,size(myval%a)
write (*,*) myval%a(i)
end do
end program main
module inter
use iso_c_binding
implicit none
type, bind(c) :: t
real(c_float), dimension(10) :: a
integer(c_int) :: n
end type t
interface
subroutine fill_type(a, n) bind(c)
import
type(t) :: a
integer(c_int), value :: n
end subroutine fill_type
end interface
contains
subroutine fill_rest(a) bind(c)
type(t), intent(inout) :: a
integer :: i
do i = a%n+1, size(a%a)
a%a(i) = -42. + i**2
end do
end subroutine fill_rest
end module inter
#include "inter.h"
void fill_type (t *a, int n)
{
int i;
for (i=0; i<n; i++)
a->a[i] = i*3.0+1.0;
a->n = n;
fill_rest(a);
}
