re PR fortran/45435 (Automatically generate C interop interface blocks from C code)

2017-08-01  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.

From-SVN: r250791

gcc/fortran/ChangeLog

+2017-08-01  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.
+
 2017-08-01  Dominique d'Humieres  <dominiq@lps.ens.fr>
 
 	PR fortran/53542

gcc/fortran/decl.c

@@ -2631,6 +2631,8 @@ 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;
+      if (e->symtree)
+	ts->interop_kind = e->symtree->n.sym;
     }
 
   gfc_free_expr (e);

gcc/fortran/dump-parse-tree.c

@@ -2891,3 +2891,253 @@ 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";
+	  else if (strcmp (*type_name, "size_t") == 0)
+	    *type_name = "ssize_t";
+
+	  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";
+		  else if (strcmp (*type_name, "size_t") == 0)
+		    *type_name = "ssize_t";
+
+		  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);
+}

gcc/fortran/gfortran.h

@@ -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);

gcc/fortran/invoke.texi

@@ -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,34 @@ shared by @command{gfortran}, @command{gcc}, and other GNU compilers.
 
 @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.
+
+For function pointers, a pointer to a function returning @code{int}
+without an explicit argument list is generated.
+
+Example of use:
+@smallexample
+$ 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"}.
+@end table
+
 @node Environment Variables
 @section Environment variables affecting @command{gfortran}
 @cindex environment variable

gcc/fortran/lang.opt

@@ -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.

gcc/fortran/parse.c

@@ -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)
     {