[fortran] C prototype writing improvements for gfortran

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