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-2011, 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_Reference_To (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_Reference_To (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_Reference_To (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_Reference_To (Standard_Boolean, Loc),
111          Expression          => New_Reference_To (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 => New_Reference_To (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_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);
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_Reference_To (RTE (RE_Tagged_Kind), Loc),
185          Expression          =>
186            Make_Function_Call (Loc,
187              Name => New_Reference_To (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_Reference_To (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_Reference_To (S, Loc),
226             Expression =>
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)))));
232
233      --  VM targets
234
235      else
236         return
237           Make_Assignment_Statement (Loc,
238             Name       => New_Reference_To (S, Loc),
239             Expression =>
240               Make_Function_Call (Loc,
241                 Name => New_Reference_To (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_Reference_To (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
263end Exp_Sel;
264