diff options
Diffstat (limited to 'gcc-4.8.3/gcc/ada/exp_sel.adb')
| -rw-r--r-- | gcc-4.8.3/gcc/ada/exp_sel.adb | 263 |
1 files changed, 263 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/exp_sel.adb b/gcc-4.8.3/gcc/ada/exp_sel.adb new file mode 100644 index 000000000..27245cff5 --- /dev/null +++ b/gcc-4.8.3/gcc/ada/exp_sel.adb @@ -0,0 +1,263 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S E L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2011, 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 Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; + +package body Exp_Sel is + + ----------------------- + -- Build_Abort_Block -- + ----------------------- + + function Build_Abort_Block + (Loc : Source_Ptr; + Abr_Blk_Ent : Entity_Id; + Cln_Blk_Ent : Entity_Id; + Blk : Node_Id) return Node_Id + is + begin + return + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Abr_Blk_Ent, Loc), + + Declarations => No_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => + New_List ( + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Cln_Blk_Ent, + Label_Construct => Blk), + Blk), + + Exception_Handlers => + New_List (Build_Abort_Block_Handler (Loc)))); + end Build_Abort_Block; + + ------------------------------- + -- Build_Abort_Block_Handler -- + ------------------------------- + + function Build_Abort_Block_Handler (Loc : Source_Ptr) return Node_Id is + Stmt : Node_Id; + + begin + if Exception_Mechanism = Back_End_Exceptions then + + -- With ZCX, aborts are not defered in handlers + + Stmt := Make_Null_Statement (Loc); + else + -- With FE SJLJ, aborts are defered at the beginning of Abort_Signal + -- handlers. + + Stmt := + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc), + Parameter_Associations => No_List); + end if; + + return Make_Implicit_Exception_Handler (Loc, + Exception_Choices => + New_List (New_Reference_To (Stand.Abort_Signal, Loc)), + Statements => New_List (Stmt)); + end Build_Abort_Block_Handler; + + ------------- + -- Build_B -- + ------------- + + function Build_B + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id + is + B : constant Entity_Id := Make_Temporary (Loc, 'B'); + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => B, + Object_Definition => New_Reference_To (Standard_Boolean, Loc), + Expression => New_Reference_To (Standard_False, Loc))); + return B; + end Build_B; + + ------------- + -- Build_C -- + ------------- + + function Build_C + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id + is + C : constant Entity_Id := Make_Temporary (Loc, 'C'); + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => C, + Object_Definition => New_Reference_To (RTE (RE_Prim_Op_Kind), Loc))); + return C; + end Build_C; + + ------------------------- + -- Build_Cleanup_Block -- + ------------------------- + + function Build_Cleanup_Block + (Loc : Source_Ptr; + Blk_Ent : Entity_Id; + Stmts : List_Id; + Clean_Ent : Entity_Id) return Node_Id + is + Cleanup_Block : constant Node_Id := + Make_Block_Statement (Loc, + Identifier => + New_Reference_To (Blk_Ent, Loc), + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts), + Is_Asynchronous_Call_Block => True); + + begin + Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent); + + return Cleanup_Block; + end Build_Cleanup_Block; + + ------------- + -- Build_K -- + ------------- + + function Build_K + (Loc : Source_Ptr; + Decls : List_Id; + Obj : Entity_Id) return Entity_Id + is + K : constant Entity_Id := Make_Temporary (Loc, 'K'); + Tag_Node : Node_Id; + + begin + if Tagged_Type_Expansion then + Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj); + else + Tag_Node := + Make_Attribute_Reference (Loc, + Prefix => Obj, + Attribute_Name => Name_Tag); + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => K, + Object_Definition => + New_Reference_To (RTE (RE_Tagged_Kind), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc), + Parameter_Associations => New_List (Tag_Node)))); + return K; + end Build_K; + + ------------- + -- Build_S -- + ------------- + + function Build_S + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id + is + S : constant Entity_Id := Make_Temporary (Loc, 'S'); + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => S, + Object_Definition => New_Reference_To (Standard_Integer, Loc))); + return S; + end Build_S; + + ------------------------ + -- Build_S_Assignment -- + ------------------------ + + function Build_S_Assignment + (Loc : Source_Ptr; + S : Entity_Id; + Obj : Entity_Id; + Call_Ent : Entity_Id) return Node_Id + is + Typ : constant Entity_Id := Etype (Obj); + + begin + if Tagged_Type_Expansion then + return + Make_Assignment_Statement (Loc, + Name => New_Reference_To (S, Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), Obj), + Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); + + -- VM targets + + else + return + Make_Assignment_Statement (Loc, + Name => New_Reference_To (S, Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc), + + Parameter_Associations => New_List ( + + -- Obj_Typ + + Make_Attribute_Reference (Loc, + Prefix => Obj, + Attribute_Name => Name_Tag), + + -- Iface_Typ + + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Tag), + + -- Position + + Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); + end if; + end Build_S_Assignment; + +end Exp_Sel; |