[Patch, Fortran] C prototypes for functions returning C function pointers

[Thomas Koenig]

Hello world,

the attached patch handles dumping prototypes for C functions returning
function pointers.  For the test case

MODULE test
   USE, INTRINSIC :: ISO_C_BINDING
CONTAINS
   FUNCTION lookup(idx) BIND(C)
     type(C_FUNPTR) :: lookup
     integer(C_INT), VALUE :: idx
     lookup = C_FUNLOC(x1)
   END FUNCTION lookup

   subroutine x1()
   end subroutine x1
 END MODULE test

the prototype is

void (*lookup (int idx)) ();

Regression-tested.  Again no test case because I don't know
how.  During testing, I also found that vtabs were dumped,
this is also corrected.

OK for trunk?

Best regards

        Thomas

gcc/fortran/ChangeLog:

        PR fortran/119419
        * dump-parse-tree.cc (write_funptr_fcn): New function.
        (write_type): Invoke it for C_FUNPTR.
        (write_interop_decl): Do not dump vtabs.


diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 1a15757b57b..837469c8aae 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -4038,6 +4038,7 @@ static void write_interop_decl (gfc_symbol *);
 static void write_proc (gfc_symbol *, bool);
 static void show_external_symbol (gfc_gsymbol *, void *);
 static void write_type (gfc_symbol *sym);
+static void write_funptr_fcn (gfc_symbol *);
 
 /* Do we need to write out an #include <ISO_Fortran_binding.h> or not?  */
 
@@ -4379,9 +4380,10 @@ write_type (gfc_symbol *sym)
 {
   gfc_component *c;
 
-  /* Don't dump our iso c module.  */
+  /* Don't dump our iso c module, nor vtypes.  */
 
-  if (sym->from_intmod == INTMOD_ISO_C_BINDING || sym->attr.flavor != FL_DERIVED)
+  if (sym->from_intmod == INTMOD_ISO_C_BINDING || sym->attr.flavor != FL_DERIVED
+      || sym->attr.vtype)
     return;
 
   fprintf (dumpfile, "typedef struct %s {\n", sym->name);
@@ -4495,6 +4497,18 @@ write_formal_arglist (gfc_symbol *sym, bool bind_c)
 
 }
 
+/* Write out an interoperable function returning a function pointer.  Better
+   handled separately.  As we know nothing about the type, assume
+   a C default return of int.  */
+
+static void
+write_funptr_fcn (gfc_symbol *sym)
+{
+  fprintf (dumpfile, "int (*%s (", sym->binding_label);
+  write_formal_arglist (sym, 1);
+  fputs (")) ();\n", dumpfile);
+}
+
 /* Write out a procedure, including its arguments.  */
 static void
 write_proc (gfc_symbol *sym, bool bind_c)
@@ -4552,7 +4566,13 @@ 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, true);
+    {
+      if (sym->ts.type == BT_DERIVED
+	  && strcmp (sym->ts.u.derived->name, "c_funptr") == 0)
+	write_funptr_fcn (sym);
+      else
+	write_proc (sym, true);
+    }
 }
 
 /* This section deals with dumping the global symbol tree.  */
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 34c8210f66a..efc059908f7 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -12187,6 +12187,34 @@ caf_possible_reallocate (gfc_expr *e)
   return last_arr_ref && last_arr_ref->u.ar.type == AR_FULL;
 }
 
+/*  Handle C_FUNPTR assignments, for generating C prototypes and for warning if
+    pointers are assigned to procedures with different interfaces.  */
+
+static void
+check_c_funptr_assign_interface (gfc_expr *lhs, gfc_expr *rhs)
+{
+  gfc_symbol *lsym, *l_derived_sym, *rsym;
+  if (lhs->expr_type != EXPR_VARIABLE)
+    return;
+
+  lsym = lhs->symtree->n.sym;
+  if (lsym->ts.type != BT_DERIVED || !lsym->attr.is_bind_c)
+    return;
+
+  l_derived_sym = lsym->ts.u.derived;
+
+  if (!l_derived_sym->attr.is_c_interop
+      || strcmp (l_derived_sym->name, "c_funptr") != 0)
+    return;
+
+  if (rhs->expr_type != EXPR_FUNCTION || !rhs->is_c_interop)
+    return;
+
+  rsym = rhs->symtree->n.sym;
+
+  fprintf (stderr,"%p %p\n", (void *) lhs, (void *) rhs);
+}
+
 /* Does everything to resolve an ordinary assignment.  Returns true
    if this is an interface assignment.  */
 static bool
@@ -12437,6 +12465,9 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
 
   gfc_check_assign (lhs, rhs, 1);
 
+  if (warn_external_argument_mismatch)
+    check_c_funptr_assign_interface (lhs, rhs);
+      
   return false;
 }