aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.3.1/gcc/ada/exp_atag.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.3.1/gcc/ada/exp_atag.adb')
-rw-r--r--gcc-4.3.1/gcc/ada/exp_atag.adb526
1 files changed, 526 insertions, 0 deletions
diff --git a/gcc-4.3.1/gcc/ada/exp_atag.adb b/gcc-4.3.1/gcc/ada/exp_atag.adb
new file mode 100644
index 000000000..670ddf8b8
--- /dev/null
+++ b/gcc-4.3.1/gcc/ada/exp_atag.adb
@@ -0,0 +1,526 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- E X P _ A T A G --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2006-2007, 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Exp_Util; use Exp_Util;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Rtsfind; use Rtsfind;
+with Sem_Util; use Sem_Util;
+with Stand; use Stand;
+with Snames; use Snames;
+with Tbuild; use Tbuild;
+
+package body Exp_Atag is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Build_DT
+ (Loc : Source_Ptr;
+ Tag_Node : Node_Id) return Node_Id;
+ -- Build code that displaces the Tag to reference the base of the wrapper
+ -- record
+ --
+ -- Generates:
+ -- 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;
+ -- 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);
+
+ ------------------------------------------------
+ -- Build_Common_Dispatching_Select_Statements --
+ ------------------------------------------------
+
+ procedure Build_Common_Dispatching_Select_Statements
+ (Loc : Source_Ptr;
+ DT_Ptr : Entity_Id;
+ Stmts : List_Id)
+ is
+ begin
+ -- Generate:
+ -- C := get_prim_op_kind (tag! (<type>VP), S);
+
+ -- where C is the out parameter capturing the call kind and S is the
+ -- dispatch table slot number.
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uC),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))));
+
+ -- Generate:
+
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure;
+ -- then
+ -- F := True;
+ -- return;
+
+ -- where F is the out parameter capturing the status of a potential
+ -- entry call.
+
+ Append_To (Stmts,
+ Make_If_Statement (Loc,
+
+ Condition =>
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Identifier (Loc, Name_uC),
+ Right_Opnd =>
+ New_Reference_To (RTE (RE_POK_Procedure), Loc)),
+ Right_Opnd =>
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Identifier (Loc, Name_uC),
+ Right_Opnd =>
+ New_Reference_To (RTE (
+ RE_POK_Protected_Procedure), Loc)),
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Identifier (Loc, Name_uC),
+ Right_Opnd =>
+ New_Reference_To (RTE (
+ RE_POK_Task_Procedure), Loc)))),
+
+ Then_Statements =>
+ New_List (
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_True, Loc)),
+ Make_Simple_Return_Statement (Loc))));
+ end Build_Common_Dispatching_Select_Statements;
+
+ -------------------------
+ -- Build_CW_Membership --
+ -------------------------
+
+ function Build_CW_Membership
+ (Loc : Source_Ptr;
+ Obj_Tag_Node : Node_Id;
+ Typ_Tag_Node : Node_Id) return Node_Id
+ is
+ function Build_Pos return Node_Id;
+ -- Generate TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
+
+ function Build_Pos return Node_Id is
+ begin
+ return
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => Build_TSD (Loc, Duplicate_Subexpr (Obj_Tag_Node)),
+ Selector_Name =>
+ 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
+
+ begin
+ return
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Ge (Loc,
+ Left_Opnd => Build_Pos,
+ Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
+
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Build_TSD (Loc, Obj_Tag_Node),
+ Selector_Name =>
+ New_Reference_To
+ (RTE_Record_Component (RE_Tags_Table), Loc)),
+ Expressions =>
+ New_List (Build_Pos)),
+
+ Right_Opnd => Typ_Tag_Node));
+ end Build_CW_Membership;
+
+ --------------
+ -- Build_DT --
+ --------------
+
+ function Build_DT
+ (Loc : Source_Ptr;
+ Tag_Node : Node_Id) return Node_Id is
+ begin
+ return
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_DT), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag), Tag_Node)));
+ end Build_DT;
+
+ ----------------------------
+ -- Build_Get_Access_Level --
+ ----------------------------
+
+ function Build_Get_Access_Level
+ (Loc : Source_Ptr;
+ Tag_Node : Node_Id) return Node_Id
+ is
+ begin
+ return
+ Make_Selected_Component (Loc,
+ Prefix => Build_TSD (Loc, Tag_Node),
+ Selector_Name =>
+ New_Reference_To
+ (RTE_Record_Component (RE_Access_Level), Loc));
+ end Build_Get_Access_Level;
+
+ ------------------------------------------
+ -- Build_Get_Predefined_Prim_Op_Address --
+ ------------------------------------------
+
+ function Build_Get_Predefined_Prim_Op_Address
+ (Loc : Source_Ptr;
+ Tag_Node : Node_Id;
+ Position : Uint) return Node_Id
+ is
+ begin
+ return
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Build_Predef_Prims (Loc, Tag_Node),
+ Expressions =>
+ New_List (Make_Integer_Literal (Loc, Position)));
+ end Build_Get_Predefined_Prim_Op_Address;
+
+ -------------------------
+ -- Build_Inherit_Prims --
+ -------------------------
+
+ function Build_Inherit_Prims
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Old_Tag_Node : Node_Id;
+ New_Tag_Node : Node_Id;
+ Num_Prims : Nat) return Node_Id
+ is
+ begin
+ if RTE_Available (RE_DT) then
+ return
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Slice (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Build_DT (Loc, New_Tag_Node),
+ Selector_Name =>
+ New_Reference_To
+ (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Discrete_Range =>
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
+
+ Expression =>
+ Make_Slice (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Build_DT (Loc, Old_Tag_Node),
+ Selector_Name =>
+ New_Reference_To
+ (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Discrete_Range =>
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
+ else
+ return
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Slice (Loc,
+ Prefix =>
+ Unchecked_Convert_To
+ (Node (Last_Elmt (Access_Disp_Table (Typ))),
+ New_Tag_Node),
+ Discrete_Range =>
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
+
+ Expression =>
+ Make_Slice (Loc,
+ Prefix =>
+ Unchecked_Convert_To
+ (Node (Last_Elmt (Access_Disp_Table (Typ))),
+ Old_Tag_Node),
+ Discrete_Range =>
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
+ end if;
+ end Build_Inherit_Prims;
+
+ -------------------------------
+ -- Build_Get_Prim_Op_Address --
+ -------------------------------
+
+ function Build_Get_Prim_Op_Address
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Tag_Node : Node_Id;
+ Position : Uint) return Node_Id
+ is
+ begin
+ pragma Assert
+ (Position <= DT_Entry_Count (First_Tag_Component (Typ)));
+
+ -- At the end of the Access_Disp_Table list we have the type
+ -- declaration required to convert the tag into a pointer to
+ -- the prims_ptr table (see Freeze_Record_Type).
+
+ return
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To
+ (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node),
+ Expressions => New_List (Make_Integer_Literal (Loc, Position)));
+ end Build_Get_Prim_Op_Address;
+
+ -----------------------------
+ -- Build_Get_Transportable --
+ -----------------------------
+
+ function Build_Get_Transportable
+ (Loc : Source_Ptr;
+ Tag_Node : Node_Id) return Node_Id
+ is
+ begin
+ return
+ Make_Selected_Component (Loc,
+ Prefix => Build_TSD (Loc, Tag_Node),
+ Selector_Name =>
+ New_Reference_To
+ (RTE_Record_Component (RE_Transportable), Loc));
+ end Build_Get_Transportable;
+
+ ------------------------------------
+ -- Build_Inherit_Predefined_Prims --
+ ------------------------------------
+
+ function Build_Inherit_Predefined_Prims
+ (Loc : Source_Ptr;
+ Old_Tag_Node : Node_Id;
+ New_Tag_Node : Node_Id) return Node_Id
+ is
+ begin
+ if RTE_Available (RE_DT) then
+ return
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Slice (Loc,
+ Prefix =>
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Build_DT (Loc, New_Tag_Node),
+ Selector_Name =>
+ New_Reference_To
+ (RTE_Record_Component (RE_Predef_Prims), Loc)))),
+ Discrete_Range => Make_Range (Loc,
+ Make_Integer_Literal (Loc, Uint_1),
+ New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
+
+ Expression =>
+ Make_Slice (Loc,
+ Prefix =>
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Build_DT (Loc, Old_Tag_Node),
+ Selector_Name =>
+ New_Reference_To
+ (RTE_Record_Component (RE_Predef_Prims), Loc)))),
+
+ Discrete_Range =>
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound =>
+ New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
+ else
+ return
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Slice (Loc,
+ Prefix =>
+ Make_Explicit_Dereference (Loc,
+ Build_Predef_Prims (Loc, New_Tag_Node)),
+ Discrete_Range => Make_Range (Loc,
+ Make_Integer_Literal (Loc, Uint_1),
+ New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
+
+ Expression =>
+ Make_Slice (Loc,
+ Prefix =>
+ Make_Explicit_Dereference (Loc,
+ Build_Predef_Prims (Loc, Old_Tag_Node)),
+ Discrete_Range =>
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound =>
+ New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
+ end if;
+ end Build_Inherit_Predefined_Prims;
+
+ ------------------------
+ -- Build_Predef_Prims --
+ ------------------------
+
+ function Build_Predef_Prims
+ (Loc : Source_Ptr;
+ Tag_Node : Node_Id) return Node_Id
+ is
+ 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)),
+
+ 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;
+
+ ------------------------------------------
+ -- Build_Set_Predefined_Prim_Op_Address --
+ ------------------------------------------
+
+ function Build_Set_Predefined_Prim_Op_Address
+ (Loc : Source_Ptr;
+ Tag_Node : Node_Id;
+ Position : Uint;
+ Address_Node : Node_Id) return Node_Id
+ is
+ begin
+ return
+ Make_Assignment_Statement (Loc,
+ Name => Build_Get_Predefined_Prim_Op_Address (Loc,
+ Tag_Node, Position),
+ Expression => Address_Node);
+ end Build_Set_Predefined_Prim_Op_Address;
+
+ -------------------------------
+ -- Build_Set_Prim_Op_Address --
+ -------------------------------
+
+ function Build_Set_Prim_Op_Address
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Tag_Node : Node_Id;
+ Position : Uint;
+ Address_Node : Node_Id) return Node_Id
+ is
+ begin
+ return
+ Make_Assignment_Statement (Loc,
+ Name => Build_Get_Prim_Op_Address
+ (Loc, Typ, Tag_Node, Position),
+ Expression => Address_Node);
+ end Build_Set_Prim_Op_Address;
+
+ ---------------
+ -- Build_TSD --
+ ---------------
+
+ function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is
+ begin
+ return
+ Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
+ Make_Explicit_Dereference (Loc,
+ Prefix => 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 (
+ Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
+ New_Reference_To
+ (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
+ end Build_TSD;
+
+end Exp_Atag;