File : exp_sel.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ S E L --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Einfo; use Einfo;
27 with Nlists; use Nlists;
28 with Nmake; use Nmake;
29 with Opt; use Opt;
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;
35
36 package body Exp_Sel is
37
38 -----------------------
39 -- Build_Abort_Block --
40 -----------------------
41
42 function Build_Abort_Block
43 (Loc : Source_Ptr;
44 Abr_Blk_Ent : Entity_Id;
45 Cln_Blk_Ent : Entity_Id;
46 Blk : Node_Id) return Node_Id
47 is
48 begin
49 return
50 Make_Block_Statement (Loc,
51 Identifier => New_Occurrence_Of (Abr_Blk_Ent, Loc),
52
53 Declarations => No_List,
54
55 Handled_Statement_Sequence =>
56 Make_Handled_Sequence_Of_Statements (Loc,
57 Statements =>
58 New_List (
59 Make_Implicit_Label_Declaration (Loc,
60 Defining_Identifier => Cln_Blk_Ent,
61 Label_Construct => Blk),
62 Blk),
63
64 Exception_Handlers =>
65 New_List (Build_Abort_Block_Handler (Loc))));
66 end Build_Abort_Block;
67
68 -------------------------------
69 -- Build_Abort_Block_Handler --
70 -------------------------------
71
72 function Build_Abort_Block_Handler (Loc : Source_Ptr) return Node_Id is
73 Stmt : Node_Id;
74
75 begin
76
77 -- With ZCX exceptions, aborts are not defered in handlers. With SJLJ,
78 -- they are deferred at the beginning of Abort_Signal handlers.
79
80 if ZCX_Exceptions then
81 Stmt := Make_Null_Statement (Loc);
82
83 else
84 Stmt :=
85 Make_Procedure_Call_Statement (Loc,
86 Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc),
87 Parameter_Associations => No_List);
88 end if;
89
90 return Make_Implicit_Exception_Handler (Loc,
91 Exception_Choices =>
92 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
93 Statements => New_List (Stmt));
94 end Build_Abort_Block_Handler;
95
96 -------------
97 -- Build_B --
98 -------------
99
100 function Build_B
101 (Loc : Source_Ptr;
102 Decls : List_Id) return Entity_Id
103 is
104 B : constant Entity_Id := Make_Temporary (Loc, 'B');
105 begin
106 Append_To (Decls,
107 Make_Object_Declaration (Loc,
108 Defining_Identifier => B,
109 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
110 Expression => New_Occurrence_Of (Standard_False, Loc)));
111 return B;
112 end Build_B;
113
114 -------------
115 -- Build_C --
116 -------------
117
118 function Build_C
119 (Loc : Source_Ptr;
120 Decls : List_Id) return Entity_Id
121 is
122 C : constant Entity_Id := Make_Temporary (Loc, 'C');
123 begin
124 Append_To (Decls,
125 Make_Object_Declaration (Loc,
126 Defining_Identifier => C,
127 Object_Definition =>
128 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc)));
129 return C;
130 end Build_C;
131
132 -------------------------
133 -- Build_Cleanup_Block --
134 -------------------------
135
136 function Build_Cleanup_Block
137 (Loc : Source_Ptr;
138 Blk_Ent : Entity_Id;
139 Stmts : List_Id;
140 Clean_Ent : Entity_Id) return Node_Id
141 is
142 Cleanup_Block : constant Node_Id :=
143 Make_Block_Statement (Loc,
144 Identifier =>
145 New_Occurrence_Of (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);
151
152 begin
153 Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
154
155 return Cleanup_Block;
156 end Build_Cleanup_Block;
157
158 -------------
159 -- Build_K --
160 -------------
161
162 function Build_K
163 (Loc : Source_Ptr;
164 Decls : List_Id;
165 Obj : Entity_Id) return Entity_Id
166 is
167 K : constant Entity_Id := Make_Temporary (Loc, 'K');
168 Tag_Node : Node_Id;
169
170 begin
171 if Tagged_Type_Expansion then
172 Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj);
173 else
174 Tag_Node :=
175 Make_Attribute_Reference (Loc,
176 Prefix => Obj,
177 Attribute_Name => Name_Tag);
178 end if;
179
180 Append_To (Decls,
181 Make_Object_Declaration (Loc,
182 Defining_Identifier => K,
183 Object_Definition =>
184 New_Occurrence_Of (RTE (RE_Tagged_Kind), Loc),
185 Expression =>
186 Make_Function_Call (Loc,
187 Name => New_Occurrence_Of (RTE (RE_Get_Tagged_Kind), Loc),
188 Parameter_Associations => New_List (Tag_Node))));
189 return K;
190 end Build_K;
191
192 -------------
193 -- Build_S --
194 -------------
195
196 function Build_S
197 (Loc : Source_Ptr;
198 Decls : List_Id) return Entity_Id
199 is
200 S : constant Entity_Id := Make_Temporary (Loc, 'S');
201 begin
202 Append_To (Decls,
203 Make_Object_Declaration (Loc,
204 Defining_Identifier => S,
205 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
206 return S;
207 end Build_S;
208
209 ------------------------
210 -- Build_S_Assignment --
211 ------------------------
212
213 function Build_S_Assignment
214 (Loc : Source_Ptr;
215 S : Entity_Id;
216 Obj : Entity_Id;
217 Call_Ent : Entity_Id) return Node_Id
218 is
219 Typ : constant Entity_Id := Etype (Obj);
220
221 begin
222 if Tagged_Type_Expansion then
223 return
224 Make_Assignment_Statement (Loc,
225 Name => New_Occurrence_Of (S, Loc),
226 Expression =>
227 Make_Function_Call (Loc,
228 Name => New_Occurrence_Of (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)))));
232
233 -- VM targets
234
235 else
236 return
237 Make_Assignment_Statement (Loc,
238 Name => New_Occurrence_Of (S, Loc),
239 Expression =>
240 Make_Function_Call (Loc,
241 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
242
243 Parameter_Associations => New_List (
244
245 -- Obj_Typ
246
247 Make_Attribute_Reference (Loc,
248 Prefix => Obj,
249 Attribute_Name => Name_Tag),
250
251 -- Iface_Typ
252
253 Make_Attribute_Reference (Loc,
254 Prefix => New_Occurrence_Of (Typ, Loc),
255 Attribute_Name => Name_Tag),
256
257 -- Position
258
259 Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
260 end if;
261 end Build_S_Assignment;
262
263 end Exp_Sel;