[patch, fortran] C prototype writing improvements for gfortran

[Thomas Koenig <tkoenig at netcologne dot de>]

Hello world,

the attached patch fixes PR 90351 (not all prototypes were written
to standard output with -fc-prototypes) and introduces new
functionality to also write C prototypes for external functions,
at the same time discouraging their use (because BIND(C) is really
the better, standard-conforming and portable way).  While looking
at the code, I also noticed that COMPLEX was not handled before,
so I added that, too.

Example:

$ cat c.f90
integer function r(i)
end

subroutine foo(a,b,c)
  character*(*) a
  real b
  complex c
end

character*(*) function x(r, c1,c2)
  real r
  character*(*) c1,c2
end
$ gfortran -fsyntax-only -fc-prototypes-external c.f90
/* Prototypes for external procedures generated from c.f90
   by GNU Fortran (GCC) 10.0.0 20190427 (experimental).

   Use of this interface is dicsouraged, consider using the
   BIND(C) feature of standard Fortran instead.  */

int r_ (int *i);
void foo_ (char *a, float *b, float complex *c, size_t a_len);
void x_ (char *result_x, size_t result_x_len, float *r, char *c1, char 
*c2, size_t c1_len, size_t c2_len);

I'd like to commit this to trunk and to gcc-9, to help users of
old-fashioned Lapack bindings, such as R, with their transition
to something that does not violate gfortran's ABI.

Tested with "make dvi" and "make info".  Otherwise, since these flags
are not tested in the testsuite (maybe they should be, I just don't
know how), regression test passed.

OK?

2019-05-08  Thomas Koenig  <tkoenig@gcc.gnu.org>

        PR fortran/90351
        PR fortran/90329
        * gfortran.dg/dump-parse-tree.c: Include version.h.
        (gfc_dump_external_c_prototypes): New function.
        (get_c_type_name): Select "char" as a name for a simple char.
        Adjust to handling external functions. Also handle complex.
        (write_decl): Add argument bind_c. Adjust for dumping of external
        procedures.
        (write_proc): Likewise.
        (write_interop_decl): Add bind_c argument to call of write_proc.
        * gfortran.h: Add prototype for gfc_dump_external_c_prototypes.
        * lang.opt: Add -fc-prototypes-external flag.
        * parse.c (gfc_parse_file): Move dumping of BIND(C) prototypes.
        Call gfc_dump_external_c_prototypes if option is set.
        * invoke.texi: Document -fc-prototypes-external.


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 = "<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)
 	{
@@ -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{<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
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);