summaryrefslogtreecommitdiff
path: root/gcc/ada/exp_ch8.adb
blob: dfd1796ac77a6453ef34dae7fe70b553e74c62d7 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              E X P _ C H 8                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Atree;    use Atree;
with Einfo;    use Einfo;
with Exp_Ch4;  use Exp_Ch4;
with Exp_Ch6;  use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug;
with Exp_Util; use Exp_Util;
with Freeze;   use Freeze;
with Ghost;    use Ghost;
with Namet;    use Namet;
with Nmake;    use Nmake;
with Nlists;   use Nlists;
with Opt;      use Opt;
with Sem;      use Sem;
with Sem_Ch8;  use Sem_Ch8;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Snames;   use Snames;
with Stand;    use Stand;
with Tbuild;   use Tbuild;

package body Exp_Ch8 is

   ---------------------------------------------
   -- Expand_N_Exception_Renaming_Declaration --
   ---------------------------------------------

   procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is
      Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;

      Decl : Node_Id;

   begin
      --  The exception renaming declaration is Ghost when it is subject to
      --  pragma Ghost or renames a Ghost entity. To accomodate both cases, set
      --  the mode now to ensure that any nodes generated during expansion are
      --  properly marked as Ghost.

      Set_Ghost_Mode (N);

      Decl := Debug_Renaming_Declaration (N);

      if Present (Decl) then
         Insert_Action (N, Decl);
      end if;

      Ghost_Mode := Save_Ghost_Mode;
   end Expand_N_Exception_Renaming_Declaration;

   ------------------------------------------
   -- Expand_N_Object_Renaming_Declaration --
   ------------------------------------------

   --  Most object renaming cases can be done by just capturing the address
   --  of the renamed object. The cases in which this is not true are when
   --  this address is not computable, since it involves extraction of a
   --  packed array element, or of a record component to which a component
   --  clause applies (that can specify an arbitrary bit boundary), or where
   --  the enclosing record itself has a non-standard representation.

   --  In these two cases, we pre-evaluate the renaming expression, by
   --  extracting and freezing the values of any subscripts, and then we
   --  set the flag Is_Renaming_Of_Object which means that any reference
   --  to the object will be handled by macro substitution in the front
   --  end, and the back end will know to ignore the renaming declaration.

   --  An additional odd case that requires processing by expansion is
   --  the renaming of a discriminant of a mutable record type. The object
   --  is a constant because it renames something that cannot be assigned to,
   --  but in fact the underlying value can change and must be reevaluated
   --  at each reference. Gigi does have a notion of a "constant view" of
   --  an object, and therefore the front-end must perform the expansion.
   --  For simplicity, and to bypass some obscure code-generation problem,
   --  we use macro substitution for all renamed discriminants, whether the
   --  enclosing type is constrained or not.

   --  The other special processing required is for the case of renaming
   --  of an object of a class wide type, where it is necessary to build
   --  the appropriate subtype for the renamed object.
   --  More comments needed for this para ???

   procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is
      Nam  : constant Node_Id := Name (N);
      Decl : Node_Id;
      T    : Entity_Id;

      function Evaluation_Required (Nam : Node_Id) return Boolean;
      --  Determines whether it is necessary to do static name evaluation for
      --  renaming of Nam. It is considered necessary if evaluating the name
      --  involves indexing a packed array, or extracting a component of a
      --  record to which a component clause applies. Note that we are only
      --  interested in these operations if they occur as part of the name
      --  itself, subscripts are just values that are computed as part of the
      --  evaluation, so their form is unimportant.

      -------------------------
      -- Evaluation_Required --
      -------------------------

      function Evaluation_Required (Nam : Node_Id) return Boolean is
      begin
         if Nkind_In (Nam, N_Indexed_Component, N_Slice) then
            if Is_Packed (Etype (Prefix (Nam))) then
               return True;
            else
               return Evaluation_Required (Prefix (Nam));
            end if;

         elsif Nkind (Nam) = N_Selected_Component then
            declare
               Rec_Type : constant Entity_Id := Etype (Prefix (Nam));

            begin
               if Present (Component_Clause (Entity (Selector_Name (Nam))))
                 or else Has_Non_Standard_Rep (Rec_Type)
               then
                  return True;

               elsif Ekind (Entity (Selector_Name (Nam))) = E_Discriminant
                 and then Is_Record_Type (Rec_Type)
                 and then not Is_Concurrent_Record_Type (Rec_Type)
               then
                  return True;

               else
                  return Evaluation_Required (Prefix (Nam));
               end if;
            end;

         else
            return False;
         end if;
      end Evaluation_Required;

      --  Local variables

      Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;

   --  Start of processing for Expand_N_Object_Renaming_Declaration

   begin
      --  The object renaming declaration is Ghost when it is subject to pragma
      --  Ghost or renames a Ghost entity. To accomodate both cases, set the
      --  mode now to ensure that any nodes generated during expansion are
      --  properly marked as Ghost.

      Set_Ghost_Mode (N);

      --  Perform name evaluation if required

      if Evaluation_Required (Nam) then
         Evaluate_Name (Nam);
         Set_Is_Renaming_Of_Object (Defining_Identifier (N));
      end if;

      --  Deal with construction of subtype in class-wide case

      T := Etype (Defining_Identifier (N));

      if Is_Class_Wide_Type (T) then
         Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N));
         Find_Type (Subtype_Mark (N));
         Set_Etype (Defining_Identifier (N), Entity (Subtype_Mark (N)));

         --  Freeze the class-wide subtype here to ensure that the subtype
         --  and equivalent type are frozen before the renaming.

         Freeze_Before (N, Entity (Subtype_Mark (N)));
      end if;

      --  Ada 2005 (AI-318-02): If the renamed object is a call to a build-in-
      --  place function, then a temporary return object needs to be created
      --  and access to it must be passed to the function. Currently we limit
      --  such functions to those with inherently limited result subtypes, but
      --  eventually we plan to expand the functions that are treated as
      --  build-in-place to include other composite result types.

      if Ada_Version >= Ada_2005
        and then Is_Build_In_Place_Function_Call (Nam)
      then
         Make_Build_In_Place_Call_In_Anonymous_Context (Nam);
      end if;

      --  Create renaming entry for debug information

      Decl := Debug_Renaming_Declaration (N);

      if Present (Decl) then
         Insert_Action (N, Decl);
      end if;

      Ghost_Mode := Save_Ghost_Mode;
   end Expand_N_Object_Renaming_Declaration;

   -------------------------------------------
   -- Expand_N_Package_Renaming_Declaration --
   -------------------------------------------

   procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is
      Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;

      Decl : Node_Id;

   begin
      --  The package renaming declaration is Ghost when it is subject to
      --  pragma Ghost or renames a Ghost entity. To accomodate both cases,
      --  set the mode now to ensure that any nodes generated during expansion
      --  are properly marked as Ghost.

      Set_Ghost_Mode (N);

      Decl := Debug_Renaming_Declaration (N);

      if Present (Decl) then

         --  If we are in a compilation unit, then this is an outer
         --  level declaration, and must have a scope of Standard

         if Nkind (Parent (N)) = N_Compilation_Unit then
            declare
               Aux : constant Node_Id := Aux_Decls_Node (Parent (N));

            begin
               Push_Scope (Standard_Standard);

               if No (Actions (Aux)) then
                  Set_Actions (Aux, New_List (Decl));
               else
                  Append (Decl, Actions (Aux));
               end if;

               Analyze (Decl);

               --  Enter the debug variable in the qualification list, which
               --  must be done at this point because auxiliary declarations
               --  occur at the library level and aren't associated with a
               --  normal scope.

               Qualify_Entity_Names (Decl);

               Pop_Scope;
            end;

         --  Otherwise, just insert after the package declaration

         else
            Insert_Action (N, Decl);
         end if;
      end if;

      Ghost_Mode := Save_Ghost_Mode;
   end Expand_N_Package_Renaming_Declaration;

   ----------------------------------------------
   -- Expand_N_Subprogram_Renaming_Declaration --
   ----------------------------------------------

   procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is
      Loc : constant Source_Ptr := Sloc (N);
      Id  : constant Entity_Id  := Defining_Entity (N);

      function Build_Body_For_Renaming return Node_Id;
      --  Build and return the body for the renaming declaration of an equality
      --  or inequality operator.

      -----------------------------
      -- Build_Body_For_Renaming --
      -----------------------------

      function Build_Body_For_Renaming return Node_Id is
         Body_Id : Entity_Id;
         Decl    : Node_Id;

      begin
         Set_Alias (Id, Empty);
         Set_Has_Completion (Id, False);
         Rewrite (N,
           Make_Subprogram_Declaration (Sloc (N),
             Specification => Specification (N)));
         Set_Has_Delayed_Freeze (Id);

         Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id));
         Set_Debug_Info_Needed (Body_Id);

         Decl :=
           Make_Subprogram_Body (Loc,
             Specification              =>
               Make_Function_Specification (Loc,
                 Defining_Unit_Name       => Body_Id,
                 Parameter_Specifications => Copy_Parameter_List (Id),
                 Result_Definition        =>
                   New_Occurrence_Of (Standard_Boolean, Loc)),
             Declarations               => Empty_List,
             Handled_Statement_Sequence => Empty);

         return Decl;
      end Build_Body_For_Renaming;

      --  Local variables

      Nam             : constant Node_Id         := Name (N);
      Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;

   --  Start of processing for Expand_N_Subprogram_Renaming_Declaration

   begin
      --  The subprogram renaming declaration is Ghost when it is subject to
      --  pragma Ghost or renames a Ghost entity. To accomodate both cases, set
      --  the mode now to ensure that any nodes created during expansion are
      --  properly flagged as ignored Ghost.

      Set_Ghost_Mode (N);

      --  When the prefix of the name is a function call, we must force the
      --  call to be made by removing side effects from the call, since we
      --  must only call the function once.

      if Nkind (Nam) = N_Selected_Component
        and then Nkind (Prefix (Nam)) = N_Function_Call
      then
         Remove_Side_Effects (Prefix (Nam));

      --  For an explicit dereference, the prefix must be captured to prevent
      --  reevaluation on calls through the renaming, which could result in
      --  calling the wrong subprogram if the access value were to be changed.

      elsif Nkind (Nam) = N_Explicit_Dereference then
         Force_Evaluation (Prefix (Nam));
      end if;

      --  Handle cases where we build a body for a renamed equality

      if Is_Entity_Name (Nam)
        and then Chars (Entity (Nam)) = Name_Op_Eq
        and then Scope (Entity (Nam)) = Standard_Standard
      then
         declare
            Left  : constant Entity_Id := First_Formal (Id);
            Right : constant Entity_Id := Next_Formal (Left);
            Typ   : constant Entity_Id := Etype (Left);
            Decl  : Node_Id;

         begin
            --  Check whether this is a renaming of a predefined equality on an
            --  untagged record type (AI05-0123).

            if Ada_Version >= Ada_2012
              and then Is_Record_Type (Typ)
              and then not Is_Tagged_Type (Typ)
              and then not Is_Frozen (Typ)
            then
               --  Build body for renamed equality, to capture its current
               --  meaning. It may be redefined later, but the renaming is
               --  elaborated where it occurs. This is technically known as
               --  Squirreling semantics. Renaming is rewritten as a subprogram
               --  declaration, and the generated  body is inserted into the
               --  freeze actions for the subprogram.

               Decl := Build_Body_For_Renaming;

               Set_Handled_Statement_Sequence (Decl,
                 Make_Handled_Sequence_Of_Statements (Loc,
                   Statements => New_List (
                     Make_Simple_Return_Statement (Loc,
                       Expression =>
                         Expand_Record_Equality
                           (Id,
                            Typ    => Typ,
                            Lhs    => Make_Identifier (Loc, Chars (Left)),
                            Rhs    => Make_Identifier (Loc, Chars (Right)),
                            Bodies => Declarations (Decl))))));

               Append_Freeze_Action (Id, Decl);
            end if;
         end;
      end if;

      Ghost_Mode := Save_Ghost_Mode;
   end Expand_N_Subprogram_Renaming_Declaration;

end Exp_Ch8;