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-2013, 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
26with Einfo;   use Einfo;
27with Nlists;  use Nlists;
28with Nmake;   use Nmake;
29with Opt;     use Opt;
30with Rtsfind; use Rtsfind;
31with Sinfo;   use Sinfo;
32with Snames;  use Snames;
33with Stand;   use Stand;
34with Tbuild;  use Tbuild;
35
36package 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      if Exception_Mechanism = Back_End_Exceptions then
77
78         --  With ZCX, aborts are not defered in handlers
79
80         Stmt := Make_Null_Statement (Loc);
81      else
82         --  With FE SJLJ, aborts are defered at the beginning of Abort_Signal
83         --  handlers.
84
85         Stmt :=
86           Make_Procedure_Call_Statement (Loc,
87             Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc),
88             Parameter_Associations => No_List);
89      end if;
90
91      return Make_Implicit_Exception_Handler (Loc,
92        Exception_Choices =>
93          New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
94        Statements        => New_List (Stmt));
95   end Build_Abort_Block_Handler;
96
97   -------------
98   -- Build_B --
99   -------------
100
101   function Build_B
102     (Loc   : Source_Ptr;
103      Decls : List_Id) return Entity_Id
104   is
105      B : constant Entity_Id := Make_Temporary (Loc, 'B');
106   begin
107      Append_To (Decls,
108        Make_Object_Declaration (Loc,
109          Defining_Identifier => B,
110          Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc),
111          Expression          => New_Occurrence_Of (Standard_False, Loc)));
112      return B;
113   end Build_B;
114
115   -------------
116   -- Build_C --
117   -------------
118
119   function Build_C
120     (Loc   : Source_Ptr;
121      Decls : List_Id) return Entity_Id
122   is
123      C : constant Entity_Id := Make_Temporary (Loc, 'C');
124   begin
125      Append_To (Decls,
126        Make_Object_Declaration (Loc,
127          Defining_Identifier => C,
128          Object_Definition   =>
129            New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc)));
130      return C;
131   end Build_C;
132
133   -------------------------
134   -- Build_Cleanup_Block --
135   -------------------------
136
137   function Build_Cleanup_Block
138     (Loc       : Source_Ptr;
139      Blk_Ent   : Entity_Id;
140      Stmts     : List_Id;
141      Clean_Ent : Entity_Id) return Node_Id
142   is
143      Cleanup_Block : constant Node_Id :=
144                        Make_Block_Statement (Loc,
145                          Identifier                 =>
146                            New_Occurrence_Of (Blk_Ent, Loc),
147                          Declarations               => No_List,
148                          Handled_Statement_Sequence =>
149                            Make_Handled_Sequence_Of_Statements (Loc,
150                              Statements => Stmts),
151                          Is_Asynchronous_Call_Block => True);
152
153   begin
154      Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
155
156      return Cleanup_Block;
157   end Build_Cleanup_Block;
158
159   -------------
160   -- Build_K --
161   -------------
162
163   function Build_K
164     (Loc   : Source_Ptr;
165      Decls : List_Id;
166      Obj   : Entity_Id) return Entity_Id
167   is
168      K        : constant Entity_Id := Make_Temporary (Loc, 'K');
169      Tag_Node : Node_Id;
170
171   begin
172      if Tagged_Type_Expansion then
173         Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj);
174      else
175         Tag_Node :=
176           Make_Attribute_Reference (Loc,
177             Prefix         => Obj,
178             Attribute_Name => Name_Tag);
179      end if;
180
181      Append_To (Decls,
182        Make_Object_Declaration (Loc,
183          Defining_Identifier => K,
184          Object_Definition   =>
185            New_Occurrence_Of (RTE (RE_Tagged_Kind), Loc),
186          Expression          =>
187            Make_Function_Call (Loc,
188              Name => New_Occurrence_Of (RTE (RE_Get_Tagged_Kind), Loc),
189              Parameter_Associations => New_List (Tag_Node))));
190      return K;
191   end Build_K;
192
193   -------------
194   -- Build_S --
195   -------------
196
197   function Build_S
198     (Loc   : Source_Ptr;
199      Decls : List_Id) return Entity_Id
200   is
201      S : constant Entity_Id := Make_Temporary (Loc, 'S');
202   begin
203      Append_To (Decls,
204        Make_Object_Declaration (Loc,
205          Defining_Identifier => S,
206          Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc)));
207      return S;
208   end Build_S;
209
210   ------------------------
211   -- Build_S_Assignment --
212   ------------------------
213
214   function Build_S_Assignment
215     (Loc      : Source_Ptr;
216      S        : Entity_Id;
217      Obj      : Entity_Id;
218      Call_Ent : Entity_Id) return Node_Id
219   is
220      Typ : constant Entity_Id := Etype (Obj);
221
222   begin
223      if Tagged_Type_Expansion then
224         return
225           Make_Assignment_Statement (Loc,
226             Name       => New_Occurrence_Of (S, Loc),
227             Expression =>
228               Make_Function_Call (Loc,
229                 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
230                 Parameter_Associations => New_List (
231                   Unchecked_Convert_To (RTE (RE_Tag), Obj),
232                   Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
233
234      --  VM targets
235
236      else
237         return
238           Make_Assignment_Statement (Loc,
239             Name       => New_Occurrence_Of (S, Loc),
240             Expression =>
241               Make_Function_Call (Loc,
242                 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
243
244                 Parameter_Associations => New_List (
245
246                     --  Obj_Typ
247
248                   Make_Attribute_Reference (Loc,
249                     Prefix => Obj,
250                     Attribute_Name => Name_Tag),
251
252                     --  Iface_Typ
253
254                   Make_Attribute_Reference (Loc,
255                     Prefix => New_Occurrence_Of (Typ, Loc),
256                     Attribute_Name => Name_Tag),
257
258                     --  Position
259
260                   Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
261      end if;
262   end Build_S_Assignment;
263
264end Exp_Sel;
265