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;
----------------------------------
Body_Node : Node_Id;
Func_Id : Entity_Id;
Spec_Node : Node_Id;
+ Acc_Type : Entity_Id;
begin
Func_Id := Make_Temporary (Loc, 'F');
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));
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 (
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)))));
#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
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);
(&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
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;
}
}
+/* 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
OSDN Git Service
