1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Einfo; use Einfo;
28 with Nlists; use Nlists;
29 with Nmake; use Nmake;
30 with Rtsfind; use Rtsfind;
31 with Stand; use Stand;
32 with Tbuild; use Tbuild;
34 package body Exp_Sel is
36 -----------------------
37 -- Build_Abort_Block --
38 -----------------------
40 function Build_Abort_Block
42 Abr_Blk_Ent : Entity_Id;
43 Cln_Blk_Ent : Entity_Id;
44 Blk : Node_Id) return Node_Id
48 Make_Block_Statement (Loc,
49 Identifier => New_Reference_To (Abr_Blk_Ent, Loc),
51 Declarations => No_List,
53 Handled_Statement_Sequence =>
54 Make_Handled_Sequence_Of_Statements (Loc,
57 Make_Implicit_Label_Declaration (Loc,
58 Defining_Identifier =>
66 Make_Implicit_Exception_Handler (Loc,
69 New_Reference_To (Stand.Abort_Signal, Loc)),
72 Make_Procedure_Call_Statement (Loc,
74 New_Reference_To (RTE (
75 RE_Abort_Undefer), Loc),
76 Parameter_Associations => No_List))))));
77 end Build_Abort_Block;
85 Decls : List_Id) return Entity_Id
87 B : constant Entity_Id := Make_Defining_Identifier (Loc,
88 Chars => New_Internal_Name ('B'));
92 Make_Object_Declaration (Loc,
93 Defining_Identifier =>
96 New_Reference_To (Standard_Boolean, Loc),
98 New_Reference_To (Standard_False, Loc)));
109 Decls : List_Id) return Entity_Id
111 C : constant Entity_Id := Make_Defining_Identifier (Loc,
112 Chars => New_Internal_Name ('C'));
116 Make_Object_Declaration (Loc,
117 Defining_Identifier =>
120 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));
125 -------------------------
126 -- Build_Cleanup_Block --
127 -------------------------
129 function Build_Cleanup_Block
133 Clean_Ent : Entity_Id) return Node_Id
135 Cleanup_Block : constant Node_Id :=
136 Make_Block_Statement (Loc,
137 Identifier => New_Reference_To (Blk_Ent, Loc),
138 Declarations => No_List,
139 Handled_Statement_Sequence =>
140 Make_Handled_Sequence_Of_Statements (Loc,
141 Statements => Stmts),
142 Is_Asynchronous_Call_Block => True);
145 Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
147 return Cleanup_Block;
148 end Build_Cleanup_Block;
157 Obj : Entity_Id) return Entity_Id
159 K : constant Entity_Id := Make_Defining_Identifier (Loc,
160 Chars => New_Internal_Name ('K'));
164 Make_Object_Declaration (Loc,
165 Defining_Identifier => K,
167 New_Reference_To (RTE (RE_Tagged_Kind), Loc),
169 Make_Function_Call (Loc,
170 Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc),
171 Parameter_Associations => New_List (
172 Unchecked_Convert_To (RTE (RE_Tag), Obj)))));
183 Decls : List_Id) return Entity_Id
185 S : constant Entity_Id := Make_Defining_Identifier (Loc,
186 Chars => New_Internal_Name ('S'));
190 Make_Object_Declaration (Loc,
191 Defining_Identifier => S,
193 New_Reference_To (Standard_Integer, Loc)));
198 ------------------------
199 -- Build_S_Assignment --
200 ------------------------
202 function Build_S_Assignment
206 Call_Ent : Entity_Id) return Node_Id
210 Make_Assignment_Statement (Loc,
211 Name => New_Reference_To (S, Loc),
213 Make_Function_Call (Loc,
214 Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
215 Parameter_Associations => New_List (
216 Unchecked_Convert_To (RTE (RE_Tag), Obj),
217 Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
218 end Build_S_Assignment;