[Ada] Fix calling convention mistmatch with C++ on Windows

[Eric Botcazou <ebotcazou at adacore dot com>]

This is a long-standing regression present on 32-bit Windows when you try to 
interface a C++ class which contains both virtual and non-virtual methods.
In both cases the C++ side uses the 'thiscall' calling convention, whereas the 
Ada side only uses it for the former methods in this case.

Tested on x86_64-suse-linux and i686-pc-mingw32, applied on the mainline.


2017-02-24  Eric Botcazou  <ebotcazou@adacore.com>

c-family/
	* c-ada-spec.c (dump_ada_function_declaration): Add comment about the
	treatment of parameters with pointer-to-tagged type and tidy up.
	(print_ada_methods): Remove the special treatment of C++ staticmember
	functions.
ada/
	* gcc-interface/decl.c: Include demangle.h.
	(is_cplusplus_method): Return again true for a primitive operation
	only if it is dispatching.  For a subprogram with an interface name,
	call the demangler to get the number of C++ parameters and compare it
	with the number of Ada parameters.

-- 
Eric Botcazou

Index: ada/gcc-interface/decl.c
===================================================================
--- ada/gcc-interface/decl.c	(revision 245625)
+++ ada/gcc-interface/decl.c	(working copy)
@@ -6,7 +6,7 @@
  *                                                                          *
  *                          C Implementation File                           *
  *                                                                          *
- *          Copyright (C) 1992-2016, Free Software Foundation, Inc.         *
+ *          Copyright (C) 1992-2017, Free Software Foundation, Inc.         *
  *                                                                          *
  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  * terms of the  GNU General Public License as published  by the Free Soft- *
@@ -34,6 +34,7 @@
 #include "fold-const.h"
 #include "stor-layout.h"
 #include "tree-inline.h"
+#include "demangle.h"
 
 #include "ada.h"
 #include "types.h"
@@ -5093,10 +5094,6 @@ get_unpadded_type (Entity_Id gnat_entity
 bool
 is_cplusplus_method (Entity_Id gnat_entity)
 {
-  /* Check that the subprogram has C++ convention.  */
-  if (Convention (gnat_entity) != Convention_CPP)
-    return false;
-
   /* A constructor is a method on the C++ side.  We deal with it now because
      it is declared without the 'this' parameter in the sources and, although
      the front-end will create a version with the 'this' parameter for code
@@ -5104,6 +5101,10 @@ is_cplusplus_method (Entity_Id gnat_enti
   if (Is_Constructor (gnat_entity))
     return true;
 
+  /* Check that the subprogram has C++ convention.  */
+  if (Convention (gnat_entity) != Convention_CPP)
+    return false;
+
   /* And that the type of the first parameter (indirectly) has it too.  */
   Entity_Id gnat_first = First_Formal (gnat_entity);
   if (No (gnat_first))
@@ -5115,19 +5116,75 @@ is_cplusplus_method (Entity_Id gnat_enti
   if (Convention (gnat_type) != Convention_CPP)
     return false;
 
-  /* This is the main case: C++ method imported as a primitive operation.
-     Note that a C++ class with no virtual functions can be imported as a
-     limited record type so the operation is not necessarily dispatching.  */
-  if (Is_Primitive (gnat_entity))
+  /* This is the main case: a C++ virtual method imported as a primitive
+     operation of a tagged type.  */
+  if (Is_Dispatching_Operation (gnat_entity))
+    return true;
+
+  /* This is set on the E_Subprogram_Type built for a dispatching call.  */
+  if (Is_Dispatch_Table_Entity (gnat_entity))
     return true;
 
   /* A thunk needs to be handled like its associated primitive operation.  */
   if (Is_Subprogram (gnat_entity) && Is_Thunk (gnat_entity))
     return true;
 
-  /* This is set on the E_Subprogram_Type built for a dispatching call.  */
-  if (Is_Dispatch_Table_Entity (gnat_entity))
-    return true;
+  /* Now on to the annoying case: a C++ non-virtual method, imported either
+     as a non-primitive operation of a tagged type or as a primitive operation
+     of an untagged type.  We cannot reliably differentiate these cases from
+     their static member or regular function equivalents in Ada, so we ask
+     the C++ side through the mangled name of the function, as the implicit
+     'this' parameter is not encoded in the mangled name of a method.  */
+  if (Is_Subprogram (gnat_entity) && Present (Interface_Name (gnat_entity)))
+    {
+      String_Pointer sp = { NULL, NULL };
+      Get_External_Name (gnat_entity, false, sp);
+
+      void *mem;
+      struct demangle_component *cmp
+	= cplus_demangle_v3_components (Name_Buffer,
+					DMGL_GNU_V3
+					| DMGL_TYPES
+					| DMGL_PARAMS
+					| DMGL_RET_DROP,
+					&mem);
+      if (!cmp)
+	return false;
+
+      /* We need to release MEM once we have a successful demangling.  */
+      bool ret = false;
+
+      if (cmp->type == DEMANGLE_COMPONENT_TYPED_NAME
+	  && cmp->u.s_binary.right->type == DEMANGLE_COMPONENT_FUNCTION_TYPE
+	  && (cmp = cmp->u.s_binary.right->u.s_binary.right) != NULL
+	  && cmp->type == DEMANGLE_COMPONENT_ARGLIST)
+	{
+	  /* Make sure there is at least one parameter in C++ too.  */
+	  if (cmp->u.s_binary.left)
+	    {
+	      unsigned int n_ada_args = 0;
+	      do {
+		n_ada_args++;
+		gnat_first = Next_Formal (gnat_first);
+	      } while (Present (gnat_first));
+
+	      unsigned int n_cpp_args = 0;
+	      do {
+		n_cpp_args++;
+		cmp = cmp->u.s_binary.right;
+	      } while (cmp);
+
+	      if (n_cpp_args < n_ada_args)
+		ret = true;
+	    }
+	  else
+	    ret = true;
+	}
+
+      free (mem);
+
+      return ret;
+    }
 
   return false;
 }
Index: c-family/c-ada-spec.c
===================================================================
--- c-family/c-ada-spec.c	(revision 245625)
+++ c-family/c-ada-spec.c	(working copy)
@@ -1683,13 +1683,18 @@ dump_ada_function_declaration (pretty_pr
 	  dump_generic_ada_node (buffer, TREE_VALUE (arg), node, spc, 0, true);
 	}
 
-      if (TREE_TYPE (arg) && TREE_TYPE (TREE_TYPE (arg))
-	  && is_tagged_type (TREE_TYPE (TREE_TYPE (arg))))
-	{
-	  if (!is_method
-	      || (num != 1 || (!DECL_VINDEX (func) && !is_constructor)))
-	    pp_string (buffer, "'Class");
-	}
+      /* If the type is a pointer to a tagged type, we need to differentiate
+	 virtual methods from the rest (non-virtual methods, static member
+	 or regular functions) and import only them as primitive operations,
+	 because they make up the virtual table which is mirrored on the Ada
+	 side by the dispatch table.  So we add 'Class to the type of every
+	 parameter that is not the first one of a method which either has a
+	 slot in the virtual table or is a constructor.  */
+      if (TREE_TYPE (arg)
+	  && POINTER_TYPE_P (TREE_TYPE (arg))
+	  && is_tagged_type (TREE_TYPE (TREE_TYPE (arg)))
+	  && !(num == 1 && is_method && (DECL_VINDEX (func) || is_constructor)))
+	pp_string (buffer, "'Class");
 
       arg = TREE_CHAIN (arg);
 
@@ -2432,25 +2437,11 @@ dump_generic_ada_node (pretty_printer *b
 }
 
 /* Dump in BUFFER NODE's methods.  SPC is the indentation level.  Return 1 if
-   methods were printed, 0 otherwise.
-
-   We do it in 2 passes: first, the regular methods, i.e. non-static member
-   functions, are output immediately within the package created for the class
-   so that they are considered as primitive operations in Ada; second, the
-   static member functions are output in a nested package so that they are
-   _not_ considered as primitive operations in Ada.
-
-   This approach is necessary because the formers have the implicit 'this'
-   pointer whereas the latters don't and, on 32-bit x86/Windows, the calling
-   conventions for the 'this' pointer are special.  Therefore, the compiler
-   needs to be able to differentiate regular methods (with 'this' pointer)
-   from static member functions that take a pointer to the class as first
-   parameter.  */
+   methods were printed, 0 otherwise.  */
 
 static int
 print_ada_methods (pretty_printer *buffer, tree node, int spc)
 {
-  bool has_static_methods = false;
   tree t;
   int res;
 
@@ -2459,42 +2450,9 @@ print_ada_methods (pretty_printer *buffe
 
   pp_semicolon (buffer);
 
-  /* First pass: the regular methods.  */
   res = 1;
   for (t = TYPE_METHODS (node); t; t = TREE_CHAIN (t))
     {
-      if (TREE_CODE (TREE_TYPE (t)) != METHOD_TYPE)
-	{
-	  has_static_methods = true;
-	  continue;
-	}
-
-      if (res)
-	{
-	  pp_newline (buffer);
-	  pp_newline (buffer);
-	}
-
-      res = print_ada_declaration (buffer, t, node, spc);
-    }
-
-  if (!has_static_methods)
-    return 1;
-
-  pp_newline (buffer);
-  newline_and_indent (buffer, spc);
-
-  /* Second pass: the static member functions.  */
-  pp_string (buffer, "package Static is");
-  pp_newline (buffer);
-  spc += INDENT_INCR;
-
-  res = 0;
-  for (t = TYPE_METHODS (node); t; t = TREE_CHAIN (t))
-    {
-      if (TREE_CODE (TREE_TYPE (t)) == METHOD_TYPE)
-	continue;
-
       if (res)
 	{
 	  pp_newline (buffer);
@@ -2504,49 +2462,6 @@ print_ada_methods (pretty_printer *buffe
       res = print_ada_declaration (buffer, t, node, spc);
     }
 
-  spc -= INDENT_INCR;
-  newline_and_indent (buffer, spc);
-  pp_string (buffer, "end;");
-
-  /* In order to save the clients from adding a second use clause for the
-     nested package, we generate renamings for the static member functions
-     in the package created for the class.  */
-  for (t = TYPE_METHODS (node); t; t = TREE_CHAIN (t))
-    {
-      bool is_function;
-
-      if (TREE_CODE (TREE_TYPE (t)) == METHOD_TYPE)
-	continue;
-
-      pp_newline (buffer);
-      newline_and_indent (buffer, spc);
-
-      if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t))))
-	{
-	  pp_string (buffer, "procedure ");
-	  is_function = false;
-	}
-      else
-	{
-	  pp_string (buffer, "function ");
-	  is_function = true;
-	}
-
-      dump_ada_decl_name (buffer, t, false);
-      dump_ada_function_declaration (buffer, t, false, false, false, spc);
-
-      if (is_function)
-	{
-	  pp_string (buffer, " return ");
-	  dump_generic_ada_node (buffer, TREE_TYPE (TREE_TYPE (t)), node,
-				 spc, false, true);
-	}
-
-       pp_string (buffer, " renames Static.");
-       dump_ada_decl_name (buffer, t, false);
-       pp_semicolon (buffer);
-    }
-
   return 1;
 }