2012-05-19 Eric Botcazou <ebotcazou@adacore.com>

	* gcc-interface/decl.c (Has_Thiscall_Convention): New macro.
	(gnat_to_gnu_entity) <E_Subprogram_Type>: Test it to set the thiscall
	calling convention
	(get_minimal_subprog_decl): Likewise.
	(gnat_first_param_is_class): New predicate.

	Backport from mainline
	2012-05-15  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Build_Offset_To_Top): Modify the
	expansion of the offset_to_top functions to ensure that their
	profile is conformant with the profile specified in Ada.Tags. No
	change in functionality.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-4_7-branch@187677 138bc75d-0d04-0410-961f-82ee72b054a4

3 files changed, 111 insertions, 8 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 293ee33a71a..abc566858a3 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,19 @@
+2012-05-19  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gcc-interface/decl.c (Has_Thiscall_Convention): New macro.
+	(gnat_to_gnu_entity) <E_Subprogram_Type>: Test it to set the thiscall
+	calling convention
+	(get_minimal_subprog_decl): Likewise.
+	(gnat_first_param_is_class): New predicate.
+
+	Backport from mainline
+	2012-05-15  Javier Miranda  <miranda@adacore.com>
+
+	* exp_ch3.adb (Build_Offset_To_Top): Modify the
+	expansion of the offset_to_top functions to ensure that their
+	profile is conformant with the profile specified in Ada.Tags. No
+	change in functionality.
+
 2012-05-18  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gcc-interface/decl.c (gnat_to_gnu_entity) <object>: For an object at
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index d1865038361..0feaaf30f6d 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -1883,9 +1883,10 @@ package body Exp_Ch3 is
 
          procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id);
          --  Generate:
-         --    function Fxx (O : in Rec_Typ) return Storage_Offset is
+         --    function Fxx (O : Address) return Storage_Offset is
+         --       type Acc is access all <Typ>;
          --    begin
-         --       return O.Iface_Comp'Position;
+         --       return Acc!(O).Iface_Comp'Position;
          --    end Fxx;
 
          ----------------------------------
@@ -1896,6 +1897,7 @@ package body Exp_Ch3 is
             Body_Node : Node_Id;
             Func_Id   : Entity_Id;
             Spec_Node : Node_Id;
+            Acc_Type  : Entity_Id;
 
          begin
             Func_Id := Make_Temporary (Loc, 'F');
@@ -1912,7 +1914,7 @@ package body Exp_Ch3 is
                   Make_Defining_Identifier (Loc, Name_uO),
                 In_Present          => True,
                 Parameter_Type      =>
-                  New_Reference_To (Rec_Type, Loc))));
+                  New_Reference_To (RTE (RE_Address), Loc))));
             Set_Result_Definition (Spec_Node,
               New_Reference_To (RTE (RE_Storage_Offset), Loc));
 
@@ -1924,7 +1926,19 @@ package body Exp_Ch3 is
 
             Body_Node := New_Node (N_Subprogram_Body, Loc);
             Set_Specification (Body_Node, Spec_Node);
-            Set_Declarations (Body_Node, New_List);
+
+            Acc_Type := Make_Temporary (Loc, 'T');
+            Set_Declarations (Body_Node, New_List (
+              Make_Full_Type_Declaration (Loc,
+                Defining_Identifier => Acc_Type,
+                Type_Definition     =>
+                  Make_Access_To_Object_Definition (Loc,
+                    All_Present            => True,
+                    Null_Exclusion_Present => False,
+                    Constant_Present       => False,
+                    Subtype_Indication     =>
+                      New_Reference_To (Rec_Type, Loc)))));
+
             Set_Handled_Statement_Sequence (Body_Node,
               Make_Handled_Sequence_Of_Statements (Loc,
                 Statements     => New_List (
@@ -1933,7 +1947,9 @@ package body Exp_Ch3 is
                       Make_Attribute_Reference (Loc,
                         Prefix         =>
                           Make_Selected_Component (Loc,
-                            Prefix        => Make_Identifier (Loc, Name_uO),
+                            Prefix        =>
+                              Unchecked_Convert_To (Acc_Type,
+                                Make_Identifier (Loc, Name_uO)),
                             Selector_Name =>
                               New_Reference_To (Iface_Comp, Loc)),
                         Attribute_Name => Name_Position)))));
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 122fdd397ed..1fae317f99c 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -50,19 +50,23 @@
 #include "ada-tree.h"
 #include "gigi.h"
 
-/* Convention_Stdcall should be processed in a specific way on 32 bits
-   Windows targets only.  The macro below is a helper to avoid having to
-   check for a Windows specific attribute throughout this unit.  */
+/* "stdcall" and "thiscall" conventions should be processed in a specific way
+   on 32-bit x86/Windows only.  The macros below are helpers to avoid having
+   to check for a Windows specific attribute throughout this unit.  */
 
 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
 #ifdef TARGET_64BIT
 #define Has_Stdcall_Convention(E) \
   (!TARGET_64BIT && Convention (E) == Convention_Stdcall)
+#define Has_Thiscall_Convention(E) \
+  (!TARGET_64BIT && gnat_first_param_is_class (E))
 #else
 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
+#define Has_Thiscall_Convention(E) (gnat_first_param_is_class (E))
 #endif
 #else
 #define Has_Stdcall_Convention(E) 0
+#define Has_Thiscall_Convention(E) 0
 #endif
 
 /* Stack realignment is necessary for functions with foreign conventions when
@@ -140,6 +144,7 @@ enum alias_set_op
 
 static void relate_alias_sets (tree, tree, enum alias_set_op);
 
+static bool gnat_first_param_is_class (Entity_Id) ATTRIBUTE_UNUSED;
 static bool allocatable_size_p (tree, bool);
 static void prepend_one_attribute_to (struct attrib **,
 				      enum attr_type, tree, tree, Node_Id);
@@ -4410,6 +4415,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	    (&attr_list, ATTR_MACHINE_ATTRIBUTE,
 	     get_identifier ("stdcall"), NULL_TREE,
 	     gnat_entity);
+	else if (Has_Thiscall_Convention (gnat_entity))
+	  prepend_one_attribute_to
+	    (&attr_list, ATTR_MACHINE_ATTRIBUTE,
+	     get_identifier ("thiscall"), NULL_TREE,
+	     gnat_entity);
 
 	/* If we should request stack realignment for a foreign convention
 	   subprogram, do so.  Note that this applies to task entry points in
@@ -5290,6 +5300,10 @@ get_minimal_subprog_decl (Entity_Id gnat_entity)
     prepend_one_attribute_to (&attr_list, ATTR_MACHINE_ATTRIBUTE,
 			      get_identifier ("stdcall"), NULL_TREE,
 			      gnat_entity);
+  else if (Has_Thiscall_Convention (gnat_entity))
+    prepend_one_attribute_to (&attr_list, ATTR_MACHINE_ATTRIBUTE,
+			      get_identifier ("thiscall"), NULL_TREE,
+			      gnat_entity);
 
   if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_name)
     gnu_ext_name = NULL_TREE;
@@ -5338,6 +5352,63 @@ rest_of_type_decl_compilation_no_defer (tree decl)
     }
 }
 
+/* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY has
+   a first parameter with a class or equivalent type.
+
+   We use the predicate on 32-bit x86/Windows to find out whether we need to
+   use the "thiscall" calling convention for GNAT_ENTITY.  This convention is
+   the one set for C++ methods (functions with METHOD_TYPE) by the back-end.
+   Now in Ada primitive operations are regular subprograms (e.g. you can have
+   common pointers to both) so we cannot compute an equivalent of METHOD_TYPE
+   and so we set the calling convention in an uniform way.  */
+
+static bool
+gnat_first_param_is_class (Entity_Id gnat_entity)
+{
+  Entity_Id gnat_param = First_Formal_With_Extras (gnat_entity);
+  Entity_Id gnat_type;
+  Node_Id node;
+
+  if (No (gnat_param))
+    return false;
+
+  gnat_type = Underlying_Type (Etype (gnat_param));
+
+  /* This is the main case.  Note that we must return the same value for
+     regular tagged types and CW types since dispatching calls have a CW
+     type on the caller side and a tagged type on the callee side.  */
+  if (Is_Tagged_Type (gnat_type))
+    return True;
+
+  /* C++ classes with no virtual functions can be imported as limited
+     record types, but we need to return true for the constructors.  */
+  if (Is_CPP_Class (gnat_type))
+    return True;
+
+  /* The language-level "protected" calling convention doesn't distinguish
+     tagged protected types from non-tagged protected types (e.g. you can
+     have common pointers to both) so we must use a single low-level calling
+     convention for it.  Since tagged protected types can be derived from
+     simple limited interfaces, we need to pick the calling convention of
+     the latters.  */
+  if (Is_Protected_Record_Type (gnat_type))
+    return True;
+
+  /* If this is the special E_Subprogram_Type built for the declaration of
+     an access to protected subprogram type, the first parameter will have
+     type Address, but we must return true to be consistent with above.  */
+  if (Is_Itype (gnat_entity)
+      && Present (node = Associated_Node_For_Itype (gnat_entity))
+      && Nkind (node) == N_Full_Type_Declaration
+      && Ekind (Defining_Identifier (node)) == E_Access_Subprogram_Type
+      && Present (node = Original_Access_Type (Defining_Identifier (node)))
+      && (Ekind (node) == E_Access_Protected_Subprogram_Type
+	  || Ekind (node) == E_Anonymous_Access_Protected_Subprogram_Type))
+    return True;
+
+  return False;
+}
+
 /* Finalize the processing of From_With_Type incomplete types.  */
 
 void