1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Einfo; use Einfo;
27 with Nlists; use Nlists;
28 with Nmake; use Nmake;
30 with Rtsfind; use Rtsfind;
31 with Sinfo; use Sinfo;
32 with Snames; use Snames;
33 with Stand; use Stand;
34 with Tbuild; use Tbuild;
36 package body Exp_Sel is
38 -----------------------
39 -- Build_Abort_Block --
40 -----------------------
42 function Build_Abort_Block
44 Abr_Blk_Ent : Entity_Id;
45 Cln_Blk_Ent : Entity_Id;
46 Blk : Node_Id) return Node_Id
50 Make_Block_Statement (Loc,
51 Identifier => New_Reference_To (Abr_Blk_Ent, Loc),
53 Declarations => No_List,
55 Handled_Statement_Sequence =>
56 Make_Handled_Sequence_Of_Statements (Loc,
59 Make_Implicit_Label_Declaration (Loc,
60 Defining_Identifier => Cln_Blk_Ent,
61 Label_Construct => Blk),
65 New_List (Build_Abort_Block_Handler (Loc))));
66 end Build_Abort_Block;
68 -------------------------------
69 -- Build_Abort_Block_Handler --
70 -------------------------------
72 function Build_Abort_Block_Handler (Loc : Source_Ptr) return Node_Id is
76 if Exception_Mechanism = Back_End_Exceptions then
78 -- With ZCX, aborts are not defered in handlers
80 Stmt := Make_Null_Statement (Loc);
82 -- With FE SJLJ, aborts are defered at the beginning of Abort_Signal
86 Make_Procedure_Call_Statement (Loc,
87 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc),
88 Parameter_Associations => No_List);
91 return Make_Implicit_Exception_Handler (Loc,
93 New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
94 Statements => New_List (Stmt));
95 end Build_Abort_Block_Handler;
103 Decls : List_Id) return Entity_Id
105 B : constant Entity_Id := Make_Temporary (Loc, 'B');
108 Make_Object_Declaration (Loc,
109 Defining_Identifier => B,
110 Object_Definition => New_Reference_To (Standard_Boolean, Loc),
111 Expression => New_Reference_To (Standard_False, Loc)));
121 Decls : List_Id) return Entity_Id
123 C : constant Entity_Id := Make_Temporary (Loc, 'C');
126 Make_Object_Declaration (Loc,
127 Defining_Identifier => C,
128 Object_Definition => New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));
132 -------------------------
133 -- Build_Cleanup_Block --
134 -------------------------
136 function Build_Cleanup_Block
140 Clean_Ent : Entity_Id) return Node_Id
142 Cleanup_Block : constant Node_Id :=
143 Make_Block_Statement (Loc,
145 New_Reference_To (Blk_Ent, Loc),
146 Declarations => No_List,
147 Handled_Statement_Sequence =>
148 Make_Handled_Sequence_Of_Statements (Loc,
149 Statements => Stmts),
150 Is_Asynchronous_Call_Block => True);
153 Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
155 return Cleanup_Block;
156 end Build_Cleanup_Block;
165 Obj : Entity_Id) return Entity_Id
167 K : constant Entity_Id := Make_Temporary (Loc, 'K');
171 if Tagged_Type_Expansion then
172 Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj);
175 Make_Attribute_Reference (Loc,
177 Attribute_Name => Name_Tag);
181 Make_Object_Declaration (Loc,
182 Defining_Identifier => K,
184 New_Reference_To (RTE (RE_Tagged_Kind), Loc),
186 Make_Function_Call (Loc,
187 Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc),
188 Parameter_Associations => New_List (Tag_Node))));
198 Decls : List_Id) return Entity_Id
200 S : constant Entity_Id := Make_Temporary (Loc, 'S');
203 Make_Object_Declaration (Loc,
204 Defining_Identifier => S,
205 Object_Definition => New_Reference_To (Standard_Integer, Loc)));
209 ------------------------
210 -- Build_S_Assignment --
211 ------------------------
213 function Build_S_Assignment
217 Call_Ent : Entity_Id) return Node_Id
219 Typ : constant Entity_Id := Etype (Obj);
222 if Tagged_Type_Expansion then
224 Make_Assignment_Statement (Loc,
225 Name => New_Reference_To (S, Loc),
227 Make_Function_Call (Loc,
228 Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
229 Parameter_Associations => New_List (
230 Unchecked_Convert_To (RTE (RE_Tag), Obj),
231 Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
237 Make_Assignment_Statement (Loc,
238 Name => New_Reference_To (S, Loc),
240 Make_Function_Call (Loc,
241 Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
243 Parameter_Associations => New_List (
247 Make_Attribute_Reference (Loc,
249 Attribute_Name => Name_Tag),
253 Make_Attribute_Reference (Loc,
254 Prefix => New_Reference_To (Typ, Loc),
255 Attribute_Name => Name_Tag),
259 Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
261 end Build_S_Assignment;