-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2009, 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- --
-- --
------------------------------------------------------------------------------
+with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Util; use Exp_Util;
+with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
+with Sinfo; use Sinfo;
+with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Stand; use Stand;
with Snames; use Snames;
-- To_Dispatch_Table_Ptr
-- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);
- function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id;
+ function Build_TSD
+ (Loc : Source_Ptr;
+ Tag_Node_Addr : Node_Id) return Node_Id;
-- Build code that retrieves the address of the record containing the Type
-- Specific Data generated by GNAT.
--
-- Generate: To_Type_Specific_Data_Ptr
- -- (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all);
-
- function Build_Predef_Prims
- (Loc : Source_Ptr;
- Tag_Node : Node_Id) return Node_Id;
- -- Build code that retrieves the address of the dispatch table containing
- -- the predefined Ada primitives:
- --
- -- Generate: To_Predef_Prims_Table_Ptr
- -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
+ -- (To_Addr_Ptr (Tag_Node_Addr - Typeinfo_Offset).all);
------------------------------------------------
-- Build_Common_Dispatching_Select_Statements --
-- Build_CW_Membership --
-------------------------
- function Build_CW_Membership
+ procedure Build_CW_Membership
(Loc : Source_Ptr;
- Obj_Tag_Node : Node_Id;
- Typ_Tag_Node : Node_Id) return Node_Id
+ Obj_Tag_Node : in out Node_Id;
+ Typ_Tag_Node : Node_Id;
+ Related_Nod : Node_Id;
+ New_Node : out Node_Id)
is
- function Build_Pos return Node_Id;
- -- Generate TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
+ Tag_Addr : constant Entity_Id := Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D'));
+ Obj_TSD : constant Entity_Id := Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D'));
+ Typ_TSD : constant Entity_Id := Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D'));
+ Index : constant Entity_Id := Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D'));
- function Build_Pos return Node_Id is
- begin
- return
+ begin
+ -- Generate:
+
+ -- Tag_Addr : constant Tag := Address!(Obj_Tag);
+ -- Obj_TSD : constant Type_Specific_Data_Ptr
+ -- := Build_TSD (Tag_Addr);
+ -- Typ_TSD : constant Type_Specific_Data_Ptr
+ -- := Build_TSD (Address!(Typ_Tag));
+ -- Index : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth
+ -- Index > 0 and then Obj_TSD.Tags_Table (Index) = Typ'Tag
+
+ Insert_Action (Related_Nod,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tag_Addr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (RTE (RE_Address), Loc),
+ Expression => Unchecked_Convert_To
+ (RTE (RE_Address), Obj_Tag_Node)));
+
+ -- Unchecked_Convert_To relocates Obj_Tag_Node and therefore we must
+ -- update it.
+
+ Obj_Tag_Node := Expression (Expression (Parent (Tag_Addr)));
+
+ Insert_Action (Related_Nod,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Obj_TSD,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To
+ (RTE (RE_Type_Specific_Data_Ptr), Loc),
+ Expression => Build_TSD (Loc, New_Reference_To (Tag_Addr, Loc))));
+
+ Insert_Action (Related_Nod,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Typ_TSD,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To
+ (RTE (RE_Type_Specific_Data_Ptr), Loc),
+ Expression => Build_TSD (Loc,
+ Unchecked_Convert_To (RTE (RE_Address),
+ Typ_Tag_Node))));
+
+ Insert_Action (Related_Nod,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Index,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
+ Expression =>
Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
- Prefix => Build_TSD (Loc, Duplicate_Subexpr (Obj_Tag_Node)),
+ Prefix => New_Reference_To (Obj_TSD, Loc),
Selector_Name =>
- New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)),
+ New_Reference_To
+ (RTE_Record_Component (RE_Idepth), Loc)),
- Right_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => Build_TSD (Loc, Duplicate_Subexpr (Typ_Tag_Node)),
- Selector_Name =>
- New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)));
- end Build_Pos;
-
- -- Start of processing for Build_CW_Membership
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Typ_TSD, Loc),
+ Selector_Name =>
+ New_Reference_To
+ (RTE_Record_Component (RE_Idepth), Loc)))));
- begin
- return
+ New_Node :=
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ge (Loc,
- Left_Opnd => Build_Pos,
+ Left_Opnd => New_Occurrence_Of (Index, Loc),
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
Right_Opnd =>
Make_Indexed_Component (Loc,
Prefix =>
Make_Selected_Component (Loc,
- Prefix => Build_TSD (Loc, Obj_Tag_Node),
+ Prefix => New_Reference_To (Obj_TSD, Loc),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)),
Expressions =>
- New_List (Build_Pos)),
+ New_List (New_Occurrence_Of (Index, Loc))),
Right_Opnd => Typ_Tag_Node));
end Build_CW_Membership;
function Build_DT
(Loc : Source_Ptr;
- Tag_Node : Node_Id) return Node_Id is
+ Tag_Node : Node_Id) return Node_Id
+ is
begin
return
Make_Function_Call (Loc,
begin
return
Make_Selected_Component (Loc,
- Prefix => Build_TSD (Loc, Tag_Node),
+ Prefix =>
+ Build_TSD (Loc,
+ Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Access_Level), Loc));
-- Build_Get_Predefined_Prim_Op_Address --
------------------------------------------
- function Build_Get_Predefined_Prim_Op_Address
+ procedure Build_Get_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
- Tag_Node : Node_Id;
- Position : Uint) return Node_Id
+ Position : Uint;
+ Tag_Node : in out Node_Id;
+ New_Node : out Node_Id)
is
+ Ctrl_Tag : Node_Id;
+
begin
- return
+ Ctrl_Tag := Unchecked_Convert_To (RTE (RE_Address), Tag_Node);
+
+ -- Unchecked_Convert_To relocates the controlling tag node and therefore
+ -- we must update it.
+
+ Tag_Node := Expression (Ctrl_Tag);
+
+ -- Build code that retrieves the address of the dispatch table
+ -- containing the predefined Ada primitives:
+ --
+ -- Generate:
+ -- To_Predef_Prims_Table_Ptr
+ -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
+
+ New_Node :=
Make_Indexed_Component (Loc,
Prefix =>
- Build_Predef_Prims (Loc, Tag_Node),
+ Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Addr_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Expanded_Name (Loc,
+ Chars => Name_Op_Subtract,
+ Prefix =>
+ New_Reference_To
+ (RTU_Entity (System_Storage_Elements), Loc),
+ Selector_Name =>
+ Make_Identifier (Loc,
+ Chars => Name_Op_Subtract)),
+ Parameter_Associations => New_List (
+ Ctrl_Tag,
+ New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
+ Loc)))))),
Expressions =>
New_List (Make_Integer_Literal (Loc, Position)));
end Build_Get_Predefined_Prim_Op_Address;
-- Build_Get_Prim_Op_Address --
-------------------------------
- function Build_Get_Prim_Op_Address
+ procedure Build_Get_Prim_Op_Address
(Loc : Source_Ptr;
Typ : Entity_Id;
- Tag_Node : Node_Id;
- Position : Uint) return Node_Id
+ Position : Uint;
+ Tag_Node : in out Node_Id;
+ New_Node : out Node_Id)
is
+ New_Prefix : Node_Id;
+
begin
pragma Assert
(Position <= DT_Entry_Count (First_Tag_Component (Typ)));
-- declaration required to convert the tag into a pointer to
-- the prims_ptr table (see Freeze_Record_Type).
- return
+ New_Prefix :=
+ Unchecked_Convert_To
+ (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node);
+
+ -- Unchecked_Convert_To relocates the controlling tag node and therefore
+ -- we must update it.
+
+ Tag_Node := Expression (New_Prefix);
+
+ New_Node :=
Make_Indexed_Component (Loc,
- Prefix =>
- Unchecked_Convert_To
- (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node),
+ Prefix => New_Prefix,
Expressions => New_List (Make_Integer_Literal (Loc, Position)));
end Build_Get_Prim_Op_Address;
begin
return
Make_Selected_Component (Loc,
- Prefix => Build_TSD (Loc, Tag_Node),
+ Prefix =>
+ Build_TSD (Loc,
+ Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Transportable), Loc));
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
end Build_Inherit_Predefined_Prims;
- ------------------------
- -- Build_Predef_Prims --
- ------------------------
+ -------------------------
+ -- Build_Offset_To_Top --
+ -------------------------
- function Build_Predef_Prims
- (Loc : Source_Ptr;
- Tag_Node : Node_Id) return Node_Id
+ function Build_Offset_To_Top
+ (Loc : Source_Ptr;
+ This_Node : Node_Id) return Node_Id
is
+ Tag_Node : Node_Id;
+
begin
- return
- Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
- Make_Explicit_Dereference (Loc,
- Unchecked_Convert_To (RTE (RE_Addr_Ptr),
- Make_Function_Call (Loc,
- Name =>
- Make_Expanded_Name (Loc,
- Chars => Name_Op_Subtract,
- Prefix =>
- New_Reference_To
- (RTU_Entity (System_Storage_Elements), Loc),
- Selector_Name =>
- Make_Identifier (Loc,
- Chars => Name_Op_Subtract)),
+ Tag_Node :=
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node));
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
- New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
- Loc))))));
- end Build_Predef_Prims;
+ return
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Expanded_Name (Loc,
+ Chars => Name_Op_Subtract,
+ Prefix => New_Reference_To
+ (RTU_Entity (System_Storage_Elements), Loc),
+ Selector_Name => Make_Identifier (Loc,
+ Chars => Name_Op_Subtract)),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
+ New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
+ Loc)))));
+ end Build_Offset_To_Top;
------------------------------------------
-- Build_Set_Predefined_Prim_Op_Address --
Position : Uint;
Address_Node : Node_Id) return Node_Id
is
+ Ctrl_Tag : Node_Id := Tag_Node;
+ New_Node : Node_Id;
+
begin
+ Build_Get_Prim_Op_Address (Loc, Typ, Position, Ctrl_Tag, New_Node);
+
return
Make_Assignment_Statement (Loc,
- Name => Build_Get_Prim_Op_Address
- (Loc, Typ, Tag_Node, Position),
+ Name => New_Node,
Expression => Address_Node);
end Build_Set_Prim_Op_Address;
+ -----------------------------
+ -- Build_Set_Size_Function --
+ -----------------------------
+
+ function Build_Set_Size_Function
+ (Loc : Source_Ptr;
+ Tag_Node : Node_Id;
+ Size_Func : Entity_Id) return Node_Id is
+ begin
+ pragma Assert (Chars (Size_Func) = Name_uSize
+ and then RTE_Record_Component_Available (RE_Size_Func));
+ return
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Build_TSD (Loc,
+ Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
+ Selector_Name =>
+ New_Reference_To
+ (RTE_Record_Component (RE_Size_Func), Loc)),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Size_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Size_Func, Loc),
+ Attribute_Name => Name_Unrestricted_Access)));
+ end Build_Set_Size_Function;
+
+ ------------------------------------
+ -- Build_Set_Static_Offset_To_Top --
+ ------------------------------------
+
+ function Build_Set_Static_Offset_To_Top
+ (Loc : Source_Ptr;
+ Iface_Tag : Node_Id;
+ Offset_Value : Node_Id) return Node_Id is
+ begin
+ return
+ Make_Assignment_Statement (Loc,
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Expanded_Name (Loc,
+ Chars => Name_Op_Subtract,
+ Prefix => New_Reference_To
+ (RTU_Entity (System_Storage_Elements), Loc),
+ Selector_Name => Make_Identifier (Loc,
+ Chars => Name_Op_Subtract)),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address), Iface_Tag),
+ New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
+ Loc))))),
+ Offset_Value);
+ end Build_Set_Static_Offset_To_Top;
+
---------------
-- Build_TSD --
---------------
- function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is
+ function Build_TSD
+ (Loc : Source_Ptr;
+ Tag_Node_Addr : Node_Id) return Node_Id is
begin
return
Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
Chars => Name_Op_Subtract)),
Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
- New_Reference_To
- (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
+ Tag_Node_Addr,
+ New_Reference_To
+ (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
end Build_TSD;
end Exp_Atag;
OSDN Git Service
