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