1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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;
29 with Rtsfind; use Rtsfind;
30 with Stand; use Stand;
31 with Tbuild; use Tbuild;
33 package body Exp_Sel is
35 -----------------------
36 -- Build_Abort_Block --
37 -----------------------
39 function Build_Abort_Block
41 Abr_Blk_Ent : Entity_Id;
42 Cln_Blk_Ent : Entity_Id;
43 Blk : Node_Id) return Node_Id
47 Make_Block_Statement (Loc,
48 Identifier => New_Reference_To (Abr_Blk_Ent, Loc),
50 Declarations => No_List,
52 Handled_Statement_Sequence =>
53 Make_Handled_Sequence_Of_Statements (Loc,
56 Make_Implicit_Label_Declaration (Loc,
57 Defining_Identifier =>
65 Make_Implicit_Exception_Handler (Loc,
68 New_Reference_To (Stand.Abort_Signal, Loc)),
71 Make_Procedure_Call_Statement (Loc,
73 New_Reference_To (RTE (
74 RE_Abort_Undefer), Loc),
75 Parameter_Associations => No_List))))));
76 end Build_Abort_Block;
84 Decls : List_Id) return Entity_Id
86 B : constant Entity_Id := Make_Defining_Identifier (Loc,
87 Chars => New_Internal_Name ('B'));
91 Make_Object_Declaration (Loc,
92 Defining_Identifier =>
95 New_Reference_To (Standard_Boolean, Loc),
97 New_Reference_To (Standard_False, Loc)));
108 Decls : List_Id) return Entity_Id
110 C : constant Entity_Id := Make_Defining_Identifier (Loc,
111 Chars => New_Internal_Name ('C'));
115 Make_Object_Declaration (Loc,
116 Defining_Identifier =>
119 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));
124 -------------------------
125 -- Build_Cleanup_Block --
126 -------------------------
128 function Build_Cleanup_Block
132 Clean_Ent : Entity_Id) return Node_Id
134 Cleanup_Block : constant Node_Id :=
135 Make_Block_Statement (Loc,
136 Identifier => New_Reference_To (Blk_Ent, Loc),
137 Declarations => No_List,
138 Handled_Statement_Sequence =>
139 Make_Handled_Sequence_Of_Statements (Loc,
140 Statements => Stmts),
141 Is_Asynchronous_Call_Block => True);
144 Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
146 return Cleanup_Block;
147 end Build_Cleanup_Block;
156 Obj : Entity_Id) return Entity_Id
158 K : constant Entity_Id := Make_Defining_Identifier (Loc,
159 Chars => New_Internal_Name ('K'));
163 Make_Object_Declaration (Loc,
164 Defining_Identifier => K,
166 New_Reference_To (RTE (RE_Tagged_Kind), Loc),
168 Make_Function_Call (Loc,
169 Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc),
170 Parameter_Associations => New_List (
171 Unchecked_Convert_To (RTE (RE_Tag), Obj)))));
182 Decls : List_Id) return Entity_Id
184 S : constant Entity_Id := Make_Defining_Identifier (Loc,
185 Chars => New_Internal_Name ('S'));
189 Make_Object_Declaration (Loc,
190 Defining_Identifier => S,
192 New_Reference_To (Standard_Integer, Loc)));
197 ------------------------
198 -- Build_S_Assignment --
199 ------------------------
201 function Build_S_Assignment
205 Call_Ent : Entity_Id) return Node_Id
209 Make_Assignment_Statement (Loc,
210 Name => New_Reference_To (S, Loc),
212 Make_Function_Call (Loc,
213 Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
214 Parameter_Associations => New_List (
215 Unchecked_Convert_To (RTE (RE_Tag), Obj),
216 Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
217 end Build_S_Assignment;