OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [exp_attr.adb] - Blame information for rev 717

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                             E X P _ A T T R                              --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2012, 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 Atree;    use Atree;
27
with Checks;   use Checks;
28
with Einfo;    use Einfo;
29
with Elists;   use Elists;
30
with Exp_Atag; use Exp_Atag;
31
with Exp_Ch2;  use Exp_Ch2;
32
with Exp_Ch3;  use Exp_Ch3;
33
with Exp_Ch6;  use Exp_Ch6;
34
with Exp_Ch9;  use Exp_Ch9;
35
with Exp_Dist; use Exp_Dist;
36
with Exp_Imgv; use Exp_Imgv;
37
with Exp_Pakd; use Exp_Pakd;
38
with Exp_Strm; use Exp_Strm;
39
with Exp_Tss;  use Exp_Tss;
40
with Exp_Util; use Exp_Util;
41
with Exp_VFpt; use Exp_VFpt;
42
with Fname;    use Fname;
43
with Freeze;   use Freeze;
44
with Gnatvsn;  use Gnatvsn;
45
with Itypes;   use Itypes;
46
with Lib;      use Lib;
47
with Namet;    use Namet;
48
with Nmake;    use Nmake;
49
with Nlists;   use Nlists;
50
with Opt;      use Opt;
51
with Restrict; use Restrict;
52
with Rident;   use Rident;
53
with Rtsfind;  use Rtsfind;
54
with Sem;      use Sem;
55
with Sem_Aux;  use Sem_Aux;
56
with Sem_Ch6;  use Sem_Ch6;
57
with Sem_Ch7;  use Sem_Ch7;
58
with Sem_Ch8;  use Sem_Ch8;
59
with Sem_Eval; use Sem_Eval;
60
with Sem_Res;  use Sem_Res;
61
with Sem_Util; use Sem_Util;
62
with Sinfo;    use Sinfo;
63
with Snames;   use Snames;
64
with Stand;    use Stand;
65
with Stringt;  use Stringt;
66
with Targparm; use Targparm;
67
with Tbuild;   use Tbuild;
68
with Ttypes;   use Ttypes;
69
with Uintp;    use Uintp;
70
with Uname;    use Uname;
71
with Validsw;  use Validsw;
72
 
73
package body Exp_Attr is
74
 
75
   -----------------------
76
   -- Local Subprograms --
77
   -----------------------
78
 
79
   procedure Compile_Stream_Body_In_Scope
80
     (N     : Node_Id;
81
      Decl  : Node_Id;
82
      Arr   : Entity_Id;
83
      Check : Boolean);
84
   --  The body for a stream subprogram may be generated outside of the scope
85
   --  of the type. If the type is fully private, it may depend on the full
86
   --  view of other types (e.g. indexes) that are currently private as well.
87
   --  We install the declarations of the package in which the type is declared
88
   --  before compiling the body in what is its proper environment. The Check
89
   --  parameter indicates if checks are to be suppressed for the stream body.
90
   --  We suppress checks for array/record reads, since the rule is that these
91
   --  are like assignments, out of range values due to uninitialized storage,
92
   --  or other invalid values do NOT cause a Constraint_Error to be raised.
93
 
94
   procedure Expand_Access_To_Protected_Op
95
     (N    : Node_Id;
96
      Pref : Node_Id;
97
      Typ  : Entity_Id);
98
   --  An attribute reference to a protected subprogram is transformed into
99
   --  a pair of pointers: one to the object, and one to the operations.
100
   --  This expansion is performed for 'Access and for 'Unrestricted_Access.
101
 
102
   procedure Expand_Fpt_Attribute
103
     (N    : Node_Id;
104
      Pkg  : RE_Id;
105
      Nam  : Name_Id;
106
      Args : List_Id);
107
   --  This procedure expands a call to a floating-point attribute function.
108
   --  N is the attribute reference node, and Args is a list of arguments to
109
   --  be passed to the function call. Pkg identifies the package containing
110
   --  the appropriate instantiation of System.Fat_Gen. Float arguments in Args
111
   --  have already been converted to the floating-point type for which Pkg was
112
   --  instantiated. The Nam argument is the relevant attribute processing
113
   --  routine to be called. This is the same as the attribute name, except in
114
   --  the Unaligned_Valid case.
115
 
116
   procedure Expand_Fpt_Attribute_R (N : Node_Id);
117
   --  This procedure expands a call to a floating-point attribute function
118
   --  that takes a single floating-point argument. The function to be called
119
   --  is always the same as the attribute name.
120
 
121
   procedure Expand_Fpt_Attribute_RI (N : Node_Id);
122
   --  This procedure expands a call to a floating-point attribute function
123
   --  that takes one floating-point argument and one integer argument. The
124
   --  function to be called is always the same as the attribute name.
125
 
126
   procedure Expand_Fpt_Attribute_RR (N : Node_Id);
127
   --  This procedure expands a call to a floating-point attribute function
128
   --  that takes two floating-point arguments. The function to be called
129
   --  is always the same as the attribute name.
130
 
131
   procedure Expand_Pred_Succ (N : Node_Id);
132
   --  Handles expansion of Pred or Succ attributes for case of non-real
133
   --  operand with overflow checking required.
134
 
135
   function Get_Index_Subtype (N : Node_Id) return Entity_Id;
136
   --  Used for Last, Last, and Length, when the prefix is an array type.
137
   --  Obtains the corresponding index subtype.
138
 
139
   procedure Find_Fat_Info
140
     (T        : Entity_Id;
141
      Fat_Type : out Entity_Id;
142
      Fat_Pkg  : out RE_Id);
143
   --  Given a floating-point type T, identifies the package containing the
144
   --  attributes for this type (returned in Fat_Pkg), and the corresponding
145
   --  type for which this package was instantiated from Fat_Gen. Error if T
146
   --  is not a floating-point type.
147
 
148
   function Find_Stream_Subprogram
149
     (Typ : Entity_Id;
150
      Nam : TSS_Name_Type) return Entity_Id;
151
   --  Returns the stream-oriented subprogram attribute for Typ. For tagged
152
   --  types, the corresponding primitive operation is looked up, else the
153
   --  appropriate TSS from the type itself, or from its closest ancestor
154
   --  defining it, is returned. In both cases, inheritance of representation
155
   --  aspects is thus taken into account.
156
 
157
   function Full_Base (T : Entity_Id) return Entity_Id;
158
   --  The stream functions need to examine the underlying representation of
159
   --  composite types. In some cases T may be non-private but its base type
160
   --  is, in which case the function returns the corresponding full view.
161
 
162
   function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;
163
   --  Given a type, find a corresponding stream convert pragma that applies to
164
   --  the implementation base type of this type (Typ). If found, return the
165
   --  pragma node, otherwise return Empty if no pragma is found.
166
 
167
   function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
168
   --  Utility for array attributes, returns true on packed constrained
169
   --  arrays, and on access to same.
170
 
171
   function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean;
172
   --  Returns true iff the given node refers to an attribute call that
173
   --  can be expanded directly by the back end and does not need front end
174
   --  expansion. Typically used for rounding and truncation attributes that
175
   --  appear directly inside a conversion to integer.
176
 
177
   ----------------------------------
178
   -- Compile_Stream_Body_In_Scope --
179
   ----------------------------------
180
 
181
   procedure Compile_Stream_Body_In_Scope
182
     (N     : Node_Id;
183
      Decl  : Node_Id;
184
      Arr   : Entity_Id;
185
      Check : Boolean)
186
   is
187
      Installed : Boolean := False;
188
      Scop      : constant Entity_Id := Scope (Arr);
189
      Curr      : constant Entity_Id := Current_Scope;
190
 
191
   begin
192
      if Is_Hidden (Arr)
193
        and then not In_Open_Scopes (Scop)
194
        and then Ekind (Scop) = E_Package
195
      then
196
         Push_Scope (Scop);
197
         Install_Visible_Declarations (Scop);
198
         Install_Private_Declarations (Scop);
199
         Installed := True;
200
 
201
         --  The entities in the package are now visible, but the generated
202
         --  stream entity must appear in the current scope (usually an
203
         --  enclosing stream function) so that itypes all have their proper
204
         --  scopes.
205
 
206
         Push_Scope (Curr);
207
      end if;
208
 
209
      if Check then
210
         Insert_Action (N, Decl);
211
      else
212
         Insert_Action (N, Decl, Suppress => All_Checks);
213
      end if;
214
 
215
      if Installed then
216
 
217
         --  Remove extra copy of current scope, and package itself
218
 
219
         Pop_Scope;
220
         End_Package_Scope (Scop);
221
      end if;
222
   end Compile_Stream_Body_In_Scope;
223
 
224
   -----------------------------------
225
   -- Expand_Access_To_Protected_Op --
226
   -----------------------------------
227
 
228
   procedure Expand_Access_To_Protected_Op
229
     (N    : Node_Id;
230
      Pref : Node_Id;
231
      Typ  : Entity_Id)
232
   is
233
      --  The value of the attribute_reference is a record containing two
234
      --  fields: an access to the protected object, and an access to the
235
      --  subprogram itself. The prefix is a selected component.
236
 
237
      Loc     : constant Source_Ptr := Sloc (N);
238
      Agg     : Node_Id;
239
      Btyp    : constant Entity_Id := Base_Type (Typ);
240
      Sub     : Entity_Id;
241
      Sub_Ref : Node_Id;
242
      E_T     : constant Entity_Id := Equivalent_Type (Btyp);
243
      Acc     : constant Entity_Id :=
244
                  Etype (Next_Component (First_Component (E_T)));
245
      Obj_Ref : Node_Id;
246
      Curr    : Entity_Id;
247
 
248
      function May_Be_External_Call return Boolean;
249
      --  If the 'Access is to a local operation, but appears in a context
250
      --  where it may lead to a call from outside the object, we must treat
251
      --  this as an external call. Clearly we cannot tell without full
252
      --  flow analysis, and a subsequent call that uses this 'Access may
253
      --  lead to a bounded error (trying to seize locks twice, e.g.). For
254
      --  now we treat 'Access as a potential external call if it is an actual
255
      --  in a call to an outside subprogram.
256
 
257
      --------------------------
258
      -- May_Be_External_Call --
259
      --------------------------
260
 
261
      function May_Be_External_Call return Boolean is
262
         Subp : Entity_Id;
263
         Par  : Node_Id := Parent (N);
264
 
265
      begin
266
         --  Account for the case where the Access attribute is part of a
267
         --  named parameter association.
268
 
269
         if Nkind (Par) = N_Parameter_Association then
270
            Par := Parent (Par);
271
         end if;
272
 
273
         if Nkind_In (Par, N_Procedure_Call_Statement, N_Function_Call)
274
            and then Is_Entity_Name (Name (Par))
275
         then
276
            Subp := Entity (Name (Par));
277
            return not In_Open_Scopes (Scope (Subp));
278
         else
279
            return False;
280
         end if;
281
      end May_Be_External_Call;
282
 
283
   --  Start of processing for Expand_Access_To_Protected_Op
284
 
285
   begin
286
      --  Within the body of the protected type, the prefix designates a local
287
      --  operation, and the object is the first parameter of the corresponding
288
      --  protected body of the current enclosing operation.
289
 
290
      if Is_Entity_Name (Pref) then
291
         if May_Be_External_Call then
292
            Sub :=
293
              New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc);
294
         else
295
            Sub :=
296
              New_Occurrence_Of
297
                (Protected_Body_Subprogram (Entity (Pref)), Loc);
298
         end if;
299
 
300
         --  Don't traverse the scopes when the attribute occurs within an init
301
         --  proc, because we directly use the _init formal of the init proc in
302
         --  that case.
303
 
304
         Curr := Current_Scope;
305
         if not Is_Init_Proc (Curr) then
306
            pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
307
 
308
            while Scope (Curr) /= Scope (Entity (Pref)) loop
309
               Curr := Scope (Curr);
310
            end loop;
311
         end if;
312
 
313
         --  In case of protected entries the first formal of its Protected_
314
         --  Body_Subprogram is the address of the object.
315
 
316
         if Ekind (Curr) = E_Entry then
317
            Obj_Ref :=
318
               New_Occurrence_Of
319
                 (First_Formal
320
                   (Protected_Body_Subprogram (Curr)), Loc);
321
 
322
         --  If the current scope is an init proc, then use the address of the
323
         --  _init formal as the object reference.
324
 
325
         elsif Is_Init_Proc (Curr) then
326
            Obj_Ref :=
327
              Make_Attribute_Reference (Loc,
328
                Prefix         => New_Occurrence_Of (First_Formal (Curr), Loc),
329
                Attribute_Name => Name_Address);
330
 
331
         --  In case of protected subprograms the first formal of its
332
         --  Protected_Body_Subprogram is the object and we get its address.
333
 
334
         else
335
            Obj_Ref :=
336
              Make_Attribute_Reference (Loc,
337
                Prefix =>
338
                   New_Occurrence_Of
339
                     (First_Formal
340
                        (Protected_Body_Subprogram (Curr)), Loc),
341
                Attribute_Name => Name_Address);
342
         end if;
343
 
344
      --  Case where the prefix is not an entity name. Find the
345
      --  version of the protected operation to be called from
346
      --  outside the protected object.
347
 
348
      else
349
         Sub :=
350
           New_Occurrence_Of
351
             (External_Subprogram
352
               (Entity (Selector_Name (Pref))), Loc);
353
 
354
         Obj_Ref :=
355
           Make_Attribute_Reference (Loc,
356
             Prefix => Relocate_Node (Prefix (Pref)),
357
               Attribute_Name => Name_Address);
358
      end if;
359
 
360
      Sub_Ref :=
361
        Make_Attribute_Reference (Loc,
362
          Prefix         => Sub,
363
          Attribute_Name => Name_Access);
364
 
365
      --  We set the type of the access reference to the already generated
366
      --  access_to_subprogram type, and declare the reference analyzed, to
367
      --  prevent further expansion when the enclosing aggregate is analyzed.
368
 
369
      Set_Etype (Sub_Ref, Acc);
370
      Set_Analyzed (Sub_Ref);
371
 
372
      Agg :=
373
        Make_Aggregate (Loc,
374
          Expressions => New_List (Obj_Ref, Sub_Ref));
375
 
376
      --  Sub_Ref has been marked as analyzed, but we still need to make sure
377
      --  Sub is correctly frozen.
378
 
379
      Freeze_Before (N, Entity (Sub));
380
 
381
      Rewrite (N, Agg);
382
      Analyze_And_Resolve (N, E_T);
383
 
384
      --  For subsequent analysis, the node must retain its type. The backend
385
      --  will replace it with the equivalent type where needed.
386
 
387
      Set_Etype (N, Typ);
388
   end Expand_Access_To_Protected_Op;
389
 
390
   --------------------------
391
   -- Expand_Fpt_Attribute --
392
   --------------------------
393
 
394
   procedure Expand_Fpt_Attribute
395
     (N    : Node_Id;
396
      Pkg  : RE_Id;
397
      Nam  : Name_Id;
398
      Args : List_Id)
399
   is
400
      Loc : constant Source_Ptr := Sloc (N);
401
      Typ : constant Entity_Id  := Etype (N);
402
      Fnm : Node_Id;
403
 
404
   begin
405
      --  The function name is the selected component Attr_xxx.yyy where
406
      --  Attr_xxx is the package name, and yyy is the argument Nam.
407
 
408
      --  Note: it would be more usual to have separate RE entries for each
409
      --  of the entities in the Fat packages, but first they have identical
410
      --  names (so we would have to have lots of renaming declarations to
411
      --  meet the normal RE rule of separate names for all runtime entities),
412
      --  and second there would be an awful lot of them!
413
 
414
      Fnm :=
415
        Make_Selected_Component (Loc,
416
          Prefix        => New_Reference_To (RTE (Pkg), Loc),
417
          Selector_Name => Make_Identifier (Loc, Nam));
418
 
419
      --  The generated call is given the provided set of parameters, and then
420
      --  wrapped in a conversion which converts the result to the target type
421
      --  We use the base type as the target because a range check may be
422
      --  required.
423
 
424
      Rewrite (N,
425
        Unchecked_Convert_To (Base_Type (Etype (N)),
426
          Make_Function_Call (Loc,
427
            Name                   => Fnm,
428
            Parameter_Associations => Args)));
429
 
430
      Analyze_And_Resolve (N, Typ);
431
   end Expand_Fpt_Attribute;
432
 
433
   ----------------------------
434
   -- Expand_Fpt_Attribute_R --
435
   ----------------------------
436
 
437
   --  The single argument is converted to its root type to call the
438
   --  appropriate runtime function, with the actual call being built
439
   --  by Expand_Fpt_Attribute
440
 
441
   procedure Expand_Fpt_Attribute_R (N : Node_Id) is
442
      E1  : constant Node_Id    := First (Expressions (N));
443
      Ftp : Entity_Id;
444
      Pkg : RE_Id;
445
   begin
446
      Find_Fat_Info (Etype (E1), Ftp, Pkg);
447
      Expand_Fpt_Attribute
448
        (N, Pkg, Attribute_Name (N),
449
         New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1))));
450
   end Expand_Fpt_Attribute_R;
451
 
452
   -----------------------------
453
   -- Expand_Fpt_Attribute_RI --
454
   -----------------------------
455
 
456
   --  The first argument is converted to its root type and the second
457
   --  argument is converted to standard long long integer to call the
458
   --  appropriate runtime function, with the actual call being built
459
   --  by Expand_Fpt_Attribute
460
 
461
   procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
462
      E1  : constant Node_Id   := First (Expressions (N));
463
      Ftp : Entity_Id;
464
      Pkg : RE_Id;
465
      E2  : constant Node_Id   := Next (E1);
466
   begin
467
      Find_Fat_Info (Etype (E1), Ftp, Pkg);
468
      Expand_Fpt_Attribute
469
        (N, Pkg, Attribute_Name (N),
470
         New_List (
471
           Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
472
           Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
473
   end Expand_Fpt_Attribute_RI;
474
 
475
   -----------------------------
476
   -- Expand_Fpt_Attribute_RR --
477
   -----------------------------
478
 
479
   --  The two arguments are converted to their root types to call the
480
   --  appropriate runtime function, with the actual call being built
481
   --  by Expand_Fpt_Attribute
482
 
483
   procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
484
      E1  : constant Node_Id   := First (Expressions (N));
485
      Ftp : Entity_Id;
486
      Pkg : RE_Id;
487
      E2  : constant Node_Id   := Next (E1);
488
   begin
489
      Find_Fat_Info (Etype (E1), Ftp, Pkg);
490
      Expand_Fpt_Attribute
491
        (N, Pkg, Attribute_Name (N),
492
         New_List (
493
           Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
494
           Unchecked_Convert_To (Ftp, Relocate_Node (E2))));
495
   end Expand_Fpt_Attribute_RR;
496
 
497
   ----------------------------------
498
   -- Expand_N_Attribute_Reference --
499
   ----------------------------------
500
 
501
   procedure Expand_N_Attribute_Reference (N : Node_Id) is
502
      Loc   : constant Source_Ptr   := Sloc (N);
503
      Typ   : constant Entity_Id    := Etype (N);
504
      Btyp  : constant Entity_Id    := Base_Type (Typ);
505
      Pref  : constant Node_Id      := Prefix (N);
506
      Ptyp  : constant Entity_Id    := Etype (Pref);
507
      Exprs : constant List_Id      := Expressions (N);
508
      Id    : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
509
 
510
      procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
511
      --  Rewrites a stream attribute for Read, Write or Output with the
512
      --  procedure call. Pname is the entity for the procedure to call.
513
 
514
      ------------------------------
515
      -- Rewrite_Stream_Proc_Call --
516
      ------------------------------
517
 
518
      procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
519
         Item       : constant Node_Id   := Next (First (Exprs));
520
         Formal     : constant Entity_Id := Next_Formal (First_Formal (Pname));
521
         Formal_Typ : constant Entity_Id := Etype (Formal);
522
         Is_Written : constant Boolean   := (Ekind (Formal) /= E_In_Parameter);
523
 
524
      begin
525
         --  The expansion depends on Item, the second actual, which is
526
         --  the object being streamed in or out.
527
 
528
         --  If the item is a component of a packed array type, and
529
         --  a conversion is needed on exit, we introduce a temporary to
530
         --  hold the value, because otherwise the packed reference will
531
         --  not be properly expanded.
532
 
533
         if Nkind (Item) = N_Indexed_Component
534
           and then Is_Packed (Base_Type (Etype (Prefix (Item))))
535
           and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
536
           and then Is_Written
537
         then
538
            declare
539
               Temp : constant Entity_Id := Make_Temporary (Loc, 'V');
540
               Decl : Node_Id;
541
               Assn : Node_Id;
542
 
543
            begin
544
               Decl :=
545
                 Make_Object_Declaration (Loc,
546
                   Defining_Identifier => Temp,
547
                   Object_Definition    =>
548
                     New_Occurrence_Of (Formal_Typ, Loc));
549
               Set_Etype (Temp, Formal_Typ);
550
 
551
               Assn :=
552
                 Make_Assignment_Statement (Loc,
553
                   Name => New_Copy_Tree (Item),
554
                   Expression =>
555
                     Unchecked_Convert_To
556
                       (Etype (Item), New_Occurrence_Of (Temp, Loc)));
557
 
558
               Rewrite (Item, New_Occurrence_Of (Temp, Loc));
559
               Insert_Actions (N,
560
                 New_List (
561
                   Decl,
562
                   Make_Procedure_Call_Statement (Loc,
563
                     Name => New_Occurrence_Of (Pname, Loc),
564
                     Parameter_Associations => Exprs),
565
                   Assn));
566
 
567
               Rewrite (N, Make_Null_Statement (Loc));
568
               return;
569
            end;
570
         end if;
571
 
572
         --  For the class-wide dispatching cases, and for cases in which
573
         --  the base type of the second argument matches the base type of
574
         --  the corresponding formal parameter (that is to say the stream
575
         --  operation is not inherited), we are all set, and can use the
576
         --  argument unchanged.
577
 
578
         --  For all other cases we do an unchecked conversion of the second
579
         --  parameter to the type of the formal of the procedure we are
580
         --  calling. This deals with the private type cases, and with going
581
         --  to the root type as required in elementary type case.
582
 
583
         if not Is_Class_Wide_Type (Entity (Pref))
584
           and then not Is_Class_Wide_Type (Etype (Item))
585
           and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
586
         then
587
            Rewrite (Item,
588
              Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
589
 
590
            --  For untagged derived types set Assignment_OK, to prevent
591
            --  copies from being created when the unchecked conversion
592
            --  is expanded (which would happen in Remove_Side_Effects
593
            --  if Expand_N_Unchecked_Conversion were allowed to call
594
            --  Force_Evaluation). The copy could violate Ada semantics
595
            --  in cases such as an actual that is an out parameter.
596
            --  Note that this approach is also used in exp_ch7 for calls
597
            --  to controlled type operations to prevent problems with
598
            --  actuals wrapped in unchecked conversions.
599
 
600
            if Is_Untagged_Derivation (Etype (Expression (Item))) then
601
               Set_Assignment_OK (Item);
602
            end if;
603
         end if;
604
 
605
         --  The stream operation to call maybe a renaming created by
606
         --  an attribute definition clause, and may not be frozen yet.
607
         --  Ensure that it has the necessary extra formals.
608
 
609
         if not Is_Frozen (Pname) then
610
            Create_Extra_Formals (Pname);
611
         end if;
612
 
613
         --  And now rewrite the call
614
 
615
         Rewrite (N,
616
           Make_Procedure_Call_Statement (Loc,
617
             Name => New_Occurrence_Of (Pname, Loc),
618
             Parameter_Associations => Exprs));
619
 
620
         Analyze (N);
621
      end Rewrite_Stream_Proc_Call;
622
 
623
   --  Start of processing for Expand_N_Attribute_Reference
624
 
625
   begin
626
      --  Do required validity checking, if enabled. Do not apply check to
627
      --  output parameters of an Asm instruction, since the value of this
628
      --  is not set till after the attribute has been elaborated, and do
629
      --  not apply the check to the arguments of a 'Read or 'Input attribute
630
      --  reference since the scalar argument is an OUT scalar.
631
 
632
      if Validity_Checks_On and then Validity_Check_Operands
633
        and then Id /= Attribute_Asm_Output
634
        and then Id /= Attribute_Read
635
        and then Id /= Attribute_Input
636
      then
637
         declare
638
            Expr : Node_Id;
639
         begin
640
            Expr := First (Expressions (N));
641
            while Present (Expr) loop
642
               Ensure_Valid (Expr);
643
               Next (Expr);
644
            end loop;
645
         end;
646
      end if;
647
 
648
      --  Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
649
      --  place function, then a temporary return object needs to be created
650
      --  and access to it must be passed to the function. Currently we limit
651
      --  such functions to those with inherently limited result subtypes, but
652
      --  eventually we plan to expand the functions that are treated as
653
      --  build-in-place to include other composite result types.
654
 
655
      if Ada_Version >= Ada_2005
656
        and then Is_Build_In_Place_Function_Call (Pref)
657
      then
658
         Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
659
      end if;
660
 
661
      --  If prefix is a protected type name, this is a reference to the
662
      --  current instance of the type. For a component definition, nothing
663
      --  to do (expansion will occur in the init proc). In other contexts,
664
      --  rewrite into reference to current instance.
665
 
666
      if Is_Protected_Self_Reference (Pref)
667
           and then not
668
             (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,
669
                                    N_Discriminant_Association)
670
                and then Nkind (Parent (Parent (Parent (Parent (N))))) =
671
                                                      N_Component_Definition)
672
      then
673
         Rewrite (Pref, Concurrent_Ref (Pref));
674
         Analyze (Pref);
675
      end if;
676
 
677
      --  Remaining processing depends on specific attribute
678
 
679
      case Id is
680
 
681
         --  Attributes related to Ada 2012 iterators (placeholder ???)
682
 
683
         when Attribute_Constant_Indexing    => null;
684
         when Attribute_Default_Iterator     => null;
685
         when Attribute_Implicit_Dereference => null;
686
         when Attribute_Iterator_Element     => null;
687
         when Attribute_Variable_Indexing    => null;
688
 
689
      ------------
690
      -- Access --
691
      ------------
692
 
693
      when Attribute_Access              |
694
           Attribute_Unchecked_Access    |
695
           Attribute_Unrestricted_Access =>
696
 
697
         Access_Cases : declare
698
            Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
699
            Btyp_DDT   : Entity_Id;
700
 
701
            function Enclosing_Object (N : Node_Id) return Node_Id;
702
            --  If N denotes a compound name (selected component, indexed
703
            --  component, or slice), returns the name of the outermost such
704
            --  enclosing object. Otherwise returns N. If the object is a
705
            --  renaming, then the renamed object is returned.
706
 
707
            ----------------------
708
            -- Enclosing_Object --
709
            ----------------------
710
 
711
            function Enclosing_Object (N : Node_Id) return Node_Id is
712
               Obj_Name : Node_Id;
713
 
714
            begin
715
               Obj_Name := N;
716
               while Nkind_In (Obj_Name, N_Selected_Component,
717
                                         N_Indexed_Component,
718
                                         N_Slice)
719
               loop
720
                  Obj_Name := Prefix (Obj_Name);
721
               end loop;
722
 
723
               return Get_Referenced_Object (Obj_Name);
724
            end Enclosing_Object;
725
 
726
            --  Local declarations
727
 
728
            Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
729
 
730
         --  Start of processing for Access_Cases
731
 
732
         begin
733
            Btyp_DDT := Designated_Type (Btyp);
734
 
735
            --  Handle designated types that come from the limited view
736
 
737
            if Ekind (Btyp_DDT) = E_Incomplete_Type
738
              and then From_With_Type (Btyp_DDT)
739
              and then Present (Non_Limited_View (Btyp_DDT))
740
            then
741
               Btyp_DDT := Non_Limited_View (Btyp_DDT);
742
 
743
            elsif Is_Class_Wide_Type (Btyp_DDT)
744
               and then Ekind (Etype (Btyp_DDT)) = E_Incomplete_Type
745
               and then From_With_Type (Etype (Btyp_DDT))
746
               and then Present (Non_Limited_View (Etype (Btyp_DDT)))
747
               and then Present (Class_Wide_Type
748
                                  (Non_Limited_View (Etype (Btyp_DDT))))
749
            then
750
               Btyp_DDT :=
751
                 Class_Wide_Type (Non_Limited_View (Etype (Btyp_DDT)));
752
            end if;
753
 
754
            --  In order to improve the text of error messages, the designated
755
            --  type of access-to-subprogram itypes is set by the semantics as
756
            --  the associated subprogram entity (see sem_attr). Now we replace
757
            --  such node with the proper E_Subprogram_Type itype.
758
 
759
            if Id = Attribute_Unrestricted_Access
760
              and then Is_Subprogram (Directly_Designated_Type (Typ))
761
            then
762
               --  The following conditions ensure that this special management
763
               --  is done only for "Address!(Prim'Unrestricted_Access)" nodes.
764
               --  At this stage other cases in which the designated type is
765
               --  still a subprogram (instead of an E_Subprogram_Type) are
766
               --  wrong because the semantics must have overridden the type of
767
               --  the node with the type imposed by the context.
768
 
769
               if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
770
                 and then Etype (Parent (N)) = RTE (RE_Prim_Ptr)
771
               then
772
                  Set_Etype (N, RTE (RE_Prim_Ptr));
773
 
774
               else
775
                  declare
776
                     Subp       : constant Entity_Id :=
777
                                    Directly_Designated_Type (Typ);
778
                     Etyp       : Entity_Id;
779
                     Extra      : Entity_Id := Empty;
780
                     New_Formal : Entity_Id;
781
                     Old_Formal : Entity_Id := First_Formal (Subp);
782
                     Subp_Typ   : Entity_Id;
783
 
784
                  begin
785
                     Subp_Typ := Create_Itype (E_Subprogram_Type, N);
786
                     Set_Etype (Subp_Typ, Etype (Subp));
787
                     Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
788
 
789
                     if Present (Old_Formal) then
790
                        New_Formal := New_Copy (Old_Formal);
791
                        Set_First_Entity (Subp_Typ, New_Formal);
792
 
793
                        loop
794
                           Set_Scope (New_Formal, Subp_Typ);
795
                           Etyp := Etype (New_Formal);
796
 
797
                           --  Handle itypes. There is no need to duplicate
798
                           --  here the itypes associated with record types
799
                           --  (i.e the implicit full view of private types).
800
 
801
                           if Is_Itype (Etyp)
802
                             and then Ekind (Base_Type (Etyp)) /= E_Record_Type
803
                           then
804
                              Extra := New_Copy (Etyp);
805
                              Set_Parent (Extra, New_Formal);
806
                              Set_Etype (New_Formal, Extra);
807
                              Set_Scope (Extra, Subp_Typ);
808
                           end if;
809
 
810
                           Extra := New_Formal;
811
                           Next_Formal (Old_Formal);
812
                           exit when No (Old_Formal);
813
 
814
                           Set_Next_Entity (New_Formal,
815
                             New_Copy (Old_Formal));
816
                           Next_Entity (New_Formal);
817
                        end loop;
818
 
819
                        Set_Next_Entity (New_Formal, Empty);
820
                        Set_Last_Entity (Subp_Typ, Extra);
821
                     end if;
822
 
823
                     --  Now that the explicit formals have been duplicated,
824
                     --  any extra formals needed by the subprogram must be
825
                     --  created.
826
 
827
                     if Present (Extra) then
828
                        Set_Extra_Formal (Extra, Empty);
829
                     end if;
830
 
831
                     Create_Extra_Formals (Subp_Typ);
832
                     Set_Directly_Designated_Type (Typ, Subp_Typ);
833
                  end;
834
               end if;
835
            end if;
836
 
837
            if Is_Access_Protected_Subprogram_Type (Btyp) then
838
               Expand_Access_To_Protected_Op (N, Pref, Typ);
839
 
840
            --  If prefix is a type name, this is a reference to the current
841
            --  instance of the type, within its initialization procedure.
842
 
843
            elsif Is_Entity_Name (Pref)
844
              and then Is_Type (Entity (Pref))
845
            then
846
               declare
847
                  Par    : Node_Id;
848
                  Formal : Entity_Id;
849
 
850
               begin
851
                  --  If the current instance name denotes a task type, then
852
                  --  the access attribute is rewritten to be the name of the
853
                  --  "_task" parameter associated with the task type's task
854
                  --  procedure. An unchecked conversion is applied to ensure
855
                  --  a type match in cases of expander-generated calls (e.g.
856
                  --  init procs).
857
 
858
                  if Is_Task_Type (Entity (Pref)) then
859
                     Formal :=
860
                       First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
861
                     while Present (Formal) loop
862
                        exit when Chars (Formal) = Name_uTask;
863
                        Next_Entity (Formal);
864
                     end loop;
865
 
866
                     pragma Assert (Present (Formal));
867
 
868
                     Rewrite (N,
869
                       Unchecked_Convert_To (Typ,
870
                         New_Occurrence_Of (Formal, Loc)));
871
                     Set_Etype (N, Typ);
872
 
873
                     --  The expression must appear in a default expression,
874
                     --  (which in the initialization procedure is the
875
                     --  right-hand side of an assignment), and not in a
876
                     --  discriminant constraint.
877
 
878
                  else
879
                     Par := Parent (N);
880
                     while Present (Par) loop
881
                        exit when Nkind (Par) = N_Assignment_Statement;
882
 
883
                        if Nkind (Par) = N_Component_Declaration then
884
                           return;
885
                        end if;
886
 
887
                        Par := Parent (Par);
888
                     end loop;
889
 
890
                     if Present (Par) then
891
                        Rewrite (N,
892
                          Make_Attribute_Reference (Loc,
893
                            Prefix => Make_Identifier (Loc, Name_uInit),
894
                            Attribute_Name  => Attribute_Name (N)));
895
 
896
                        Analyze_And_Resolve (N, Typ);
897
                     end if;
898
                  end if;
899
               end;
900
 
901
            --  If the prefix of an Access attribute is a dereference of an
902
            --  access parameter (or a renaming of such a dereference, or a
903
            --  subcomponent of such a dereference) and the context is a
904
            --  general access type (including the type of an object or
905
            --  component with an access_definition, but not the anonymous
906
            --  type of an access parameter or access discriminant), then
907
            --  apply an accessibility check to the access parameter. We used
908
            --  to rewrite the access parameter as a type conversion, but that
909
            --  could only be done if the immediate prefix of the Access
910
            --  attribute was the dereference, and didn't handle cases where
911
            --  the attribute is applied to a subcomponent of the dereference,
912
            --  since there's generally no available, appropriate access type
913
            --  to convert to in that case. The attribute is passed as the
914
            --  point to insert the check, because the access parameter may
915
            --  come from a renaming, possibly in a different scope, and the
916
            --  check must be associated with the attribute itself.
917
 
918
            elsif Id = Attribute_Access
919
              and then Nkind (Enc_Object) = N_Explicit_Dereference
920
              and then Is_Entity_Name (Prefix (Enc_Object))
921
              and then (Ekind (Btyp) = E_General_Access_Type
922
                         or else Is_Local_Anonymous_Access (Btyp))
923
              and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind
924
              and then Ekind (Etype (Entity (Prefix (Enc_Object))))
925
                         = E_Anonymous_Access_Type
926
              and then Present (Extra_Accessibility
927
                                (Entity (Prefix (Enc_Object))))
928
            then
929
               Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
930
 
931
            --  Ada 2005 (AI-251): If the designated type is an interface we
932
            --  add an implicit conversion to force the displacement of the
933
            --  pointer to reference the secondary dispatch table.
934
 
935
            elsif Is_Interface (Btyp_DDT)
936
              and then (Comes_From_Source (N)
937
                         or else Comes_From_Source (Ref_Object)
938
                         or else (Nkind (Ref_Object) in N_Has_Chars
939
                                   and then Chars (Ref_Object) = Name_uInit))
940
            then
941
               if Nkind (Ref_Object) /= N_Explicit_Dereference then
942
 
943
                  --  No implicit conversion required if types match, or if
944
                  --  the prefix is the class_wide_type of the interface. In
945
                  --  either case passing an object of the interface type has
946
                  --  already set the pointer correctly.
947
 
948
                  if Btyp_DDT = Etype (Ref_Object)
949
                    or else (Is_Class_Wide_Type (Etype (Ref_Object))
950
                              and then
951
                               Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object))
952
                  then
953
                     null;
954
 
955
                  else
956
                     Rewrite (Prefix (N),
957
                       Convert_To (Btyp_DDT,
958
                         New_Copy_Tree (Prefix (N))));
959
 
960
                     Analyze_And_Resolve (Prefix (N), Btyp_DDT);
961
                  end if;
962
 
963
               --  When the object is an explicit dereference, convert the
964
               --  dereference's prefix.
965
 
966
               else
967
                  declare
968
                     Obj_DDT : constant Entity_Id :=
969
                                 Base_Type
970
                                   (Directly_Designated_Type
971
                                     (Etype (Prefix (Ref_Object))));
972
                  begin
973
                     --  No implicit conversion required if designated types
974
                     --  match, or if we have an unrestricted access.
975
 
976
                     if Obj_DDT /= Btyp_DDT
977
                       and then Id /= Attribute_Unrestricted_Access
978
                       and then not (Is_Class_Wide_Type (Obj_DDT)
979
                                      and then Etype (Obj_DDT) = Btyp_DDT)
980
                     then
981
                        Rewrite (N,
982
                          Convert_To (Typ,
983
                            New_Copy_Tree (Prefix (Ref_Object))));
984
                        Analyze_And_Resolve (N, Typ);
985
                     end if;
986
                  end;
987
               end if;
988
            end if;
989
         end Access_Cases;
990
 
991
      --------------
992
      -- Adjacent --
993
      --------------
994
 
995
      --  Transforms 'Adjacent into a call to the floating-point attribute
996
      --  function Adjacent in Fat_xxx (where xxx is the root type)
997
 
998
      when Attribute_Adjacent =>
999
         Expand_Fpt_Attribute_RR (N);
1000
 
1001
      -------------
1002
      -- Address --
1003
      -------------
1004
 
1005
      when Attribute_Address => Address : declare
1006
         Task_Proc : Entity_Id;
1007
 
1008
      begin
1009
         --  If the prefix is a task or a task type, the useful address is that
1010
         --  of the procedure for the task body, i.e. the actual program unit.
1011
         --  We replace the original entity with that of the procedure.
1012
 
1013
         if Is_Entity_Name (Pref)
1014
           and then Is_Task_Type (Entity (Pref))
1015
         then
1016
            Task_Proc := Next_Entity (Root_Type (Ptyp));
1017
 
1018
            while Present (Task_Proc) loop
1019
               exit when Ekind (Task_Proc) = E_Procedure
1020
                 and then Etype (First_Formal (Task_Proc)) =
1021
                                  Corresponding_Record_Type (Ptyp);
1022
               Next_Entity (Task_Proc);
1023
            end loop;
1024
 
1025
            if Present (Task_Proc) then
1026
               Set_Entity (Pref, Task_Proc);
1027
               Set_Etype  (Pref, Etype (Task_Proc));
1028
            end if;
1029
 
1030
         --  Similarly, the address of a protected operation is the address
1031
         --  of the corresponding protected body, regardless of the protected
1032
         --  object from which it is selected.
1033
 
1034
         elsif Nkind (Pref) = N_Selected_Component
1035
           and then Is_Subprogram (Entity (Selector_Name (Pref)))
1036
           and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref))))
1037
         then
1038
            Rewrite (Pref,
1039
              New_Occurrence_Of (
1040
                External_Subprogram (Entity (Selector_Name (Pref))), Loc));
1041
 
1042
         elsif Nkind (Pref) = N_Explicit_Dereference
1043
           and then Ekind (Ptyp) = E_Subprogram_Type
1044
           and then Convention (Ptyp) = Convention_Protected
1045
         then
1046
            --  The prefix is be a dereference of an access_to_protected_
1047
            --  subprogram. The desired address is the second component of
1048
            --  the record that represents the access.
1049
 
1050
            declare
1051
               Addr : constant Entity_Id := Etype (N);
1052
               Ptr  : constant Node_Id   := Prefix (Pref);
1053
               T    : constant Entity_Id :=
1054
                        Equivalent_Type (Base_Type (Etype (Ptr)));
1055
 
1056
            begin
1057
               Rewrite (N,
1058
                 Unchecked_Convert_To (Addr,
1059
                   Make_Selected_Component (Loc,
1060
                     Prefix => Unchecked_Convert_To (T, Ptr),
1061
                     Selector_Name => New_Occurrence_Of (
1062
                       Next_Entity (First_Entity (T)), Loc))));
1063
 
1064
               Analyze_And_Resolve (N, Addr);
1065
            end;
1066
 
1067
         --  Ada 2005 (AI-251): Class-wide interface objects are always
1068
         --  "displaced" to reference the tag associated with the interface
1069
         --  type. In order to obtain the real address of such objects we
1070
         --  generate a call to a run-time subprogram that returns the base
1071
         --  address of the object.
1072
 
1073
         --  This processing is not needed in the VM case, where dispatching
1074
         --  issues are taken care of by the virtual machine.
1075
 
1076
         elsif Is_Class_Wide_Type (Ptyp)
1077
           and then Is_Interface (Ptyp)
1078
           and then Tagged_Type_Expansion
1079
           and then not (Nkind (Pref) in N_Has_Entity
1080
                          and then Is_Subprogram (Entity (Pref)))
1081
         then
1082
            Rewrite (N,
1083
              Make_Function_Call (Loc,
1084
                Name => New_Reference_To (RTE (RE_Base_Address), Loc),
1085
                Parameter_Associations => New_List (
1086
                  Relocate_Node (N))));
1087
            Analyze (N);
1088
            return;
1089
         end if;
1090
 
1091
         --  Deal with packed array reference, other cases are handled by
1092
         --  the back end.
1093
 
1094
         if Involves_Packed_Array_Reference (Pref) then
1095
            Expand_Packed_Address_Reference (N);
1096
         end if;
1097
      end Address;
1098
 
1099
      ---------------
1100
      -- Alignment --
1101
      ---------------
1102
 
1103
      when Attribute_Alignment => Alignment : declare
1104
         New_Node : Node_Id;
1105
 
1106
      begin
1107
         --  For class-wide types, X'Class'Alignment is transformed into a
1108
         --  direct reference to the Alignment of the class type, so that the
1109
         --  back end does not have to deal with the X'Class'Alignment
1110
         --  reference.
1111
 
1112
         if Is_Entity_Name (Pref)
1113
           and then Is_Class_Wide_Type (Entity (Pref))
1114
         then
1115
            Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
1116
            return;
1117
 
1118
         --  For x'Alignment applied to an object of a class wide type,
1119
         --  transform X'Alignment into a call to the predefined primitive
1120
         --  operation _Alignment applied to X.
1121
 
1122
         elsif Is_Class_Wide_Type (Ptyp) then
1123
            New_Node :=
1124
              Make_Attribute_Reference (Loc,
1125
                Prefix         => Pref,
1126
                Attribute_Name => Name_Tag);
1127
 
1128
            if VM_Target = No_VM then
1129
               New_Node := Build_Get_Alignment (Loc, New_Node);
1130
            else
1131
               New_Node :=
1132
                 Make_Function_Call (Loc,
1133
                   Name => New_Reference_To (RTE (RE_Get_Alignment), Loc),
1134
                   Parameter_Associations => New_List (New_Node));
1135
            end if;
1136
 
1137
            --  Case where the context is a specific integer type with which
1138
            --  the original attribute was compatible. The function has a
1139
            --  specific type as well, so to preserve the compatibility we
1140
            --  must convert explicitly.
1141
 
1142
            if Typ /= Standard_Integer then
1143
               New_Node := Convert_To (Typ, New_Node);
1144
            end if;
1145
 
1146
            Rewrite (N, New_Node);
1147
            Analyze_And_Resolve (N, Typ);
1148
            return;
1149
 
1150
         --  For all other cases, we just have to deal with the case of
1151
         --  the fact that the result can be universal.
1152
 
1153
         else
1154
            Apply_Universal_Integer_Attribute_Checks (N);
1155
         end if;
1156
      end Alignment;
1157
 
1158
      ---------------
1159
      -- AST_Entry --
1160
      ---------------
1161
 
1162
      when Attribute_AST_Entry => AST_Entry : declare
1163
         Ttyp : Entity_Id;
1164
         T_Id : Node_Id;
1165
         Eent : Entity_Id;
1166
 
1167
         Entry_Ref : Node_Id;
1168
         --  The reference to the entry or entry family
1169
 
1170
         Index : Node_Id;
1171
         --  The index expression for an entry family reference, or
1172
         --  the Empty if Entry_Ref references a simple entry.
1173
 
1174
      begin
1175
         if Nkind (Pref) = N_Indexed_Component then
1176
            Entry_Ref := Prefix (Pref);
1177
            Index := First (Expressions (Pref));
1178
         else
1179
            Entry_Ref := Pref;
1180
            Index := Empty;
1181
         end if;
1182
 
1183
         --  Get expression for Task_Id and the entry entity
1184
 
1185
         if Nkind (Entry_Ref) = N_Selected_Component then
1186
            T_Id :=
1187
              Make_Attribute_Reference (Loc,
1188
                Attribute_Name => Name_Identity,
1189
                Prefix         => Prefix (Entry_Ref));
1190
 
1191
            Ttyp := Etype (Prefix (Entry_Ref));
1192
            Eent := Entity (Selector_Name (Entry_Ref));
1193
 
1194
         else
1195
            T_Id :=
1196
              Make_Function_Call (Loc,
1197
                Name => New_Occurrence_Of (RTE (RE_Current_Task), Loc));
1198
 
1199
            Eent  := Entity (Entry_Ref);
1200
 
1201
            --  We have to find the enclosing task to get the task type
1202
            --  There must be one, since we already validated this earlier
1203
 
1204
            Ttyp := Current_Scope;
1205
            while not Is_Task_Type (Ttyp) loop
1206
               Ttyp := Scope (Ttyp);
1207
            end loop;
1208
         end if;
1209
 
1210
         --  Now rewrite the attribute with a call to Create_AST_Handler
1211
 
1212
         Rewrite (N,
1213
           Make_Function_Call (Loc,
1214
             Name => New_Occurrence_Of (RTE (RE_Create_AST_Handler), Loc),
1215
             Parameter_Associations => New_List (
1216
               T_Id,
1217
               Entry_Index_Expression (Loc, Eent, Index, Ttyp))));
1218
 
1219
         Analyze_And_Resolve (N, RTE (RE_AST_Handler));
1220
      end AST_Entry;
1221
 
1222
      ---------
1223
      -- Bit --
1224
      ---------
1225
 
1226
      --  We compute this if a packed array reference was present, otherwise we
1227
      --  leave the computation up to the back end.
1228
 
1229
      when Attribute_Bit =>
1230
         if Involves_Packed_Array_Reference (Pref) then
1231
            Expand_Packed_Bit_Reference (N);
1232
         else
1233
            Apply_Universal_Integer_Attribute_Checks (N);
1234
         end if;
1235
 
1236
      ------------------
1237
      -- Bit_Position --
1238
      ------------------
1239
 
1240
      --  We compute this if a component clause was present, otherwise we leave
1241
      --  the computation up to the back end, since we don't know what layout
1242
      --  will be chosen.
1243
 
1244
      --  Note that the attribute can apply to a naked record component
1245
      --  in generated code (i.e. the prefix is an identifier that
1246
      --  references the component or discriminant entity).
1247
 
1248
      when Attribute_Bit_Position => Bit_Position : declare
1249
         CE : Entity_Id;
1250
 
1251
      begin
1252
         if Nkind (Pref) = N_Identifier then
1253
            CE := Entity (Pref);
1254
         else
1255
            CE := Entity (Selector_Name (Pref));
1256
         end if;
1257
 
1258
         if Known_Static_Component_Bit_Offset (CE) then
1259
            Rewrite (N,
1260
              Make_Integer_Literal (Loc,
1261
                Intval => Component_Bit_Offset (CE)));
1262
            Analyze_And_Resolve (N, Typ);
1263
 
1264
         else
1265
            Apply_Universal_Integer_Attribute_Checks (N);
1266
         end if;
1267
      end Bit_Position;
1268
 
1269
      ------------------
1270
      -- Body_Version --
1271
      ------------------
1272
 
1273
      --  A reference to P'Body_Version or P'Version is expanded to
1274
 
1275
      --     Vnn : Unsigned;
1276
      --     pragma Import (C, Vnn, "uuuuT");
1277
      --     ...
1278
      --     Get_Version_String (Vnn)
1279
 
1280
      --  where uuuu is the unit name (dots replaced by double underscore)
1281
      --  and T is B for the cases of Body_Version, or Version applied to a
1282
      --  subprogram acting as its own spec, and S for Version applied to a
1283
      --  subprogram spec or package. This sequence of code references the
1284
      --  unsigned constant created in the main program by the binder.
1285
 
1286
      --  A special exception occurs for Standard, where the string returned
1287
      --  is a copy of the library string in gnatvsn.ads.
1288
 
1289
      when Attribute_Body_Version | Attribute_Version => Version : declare
1290
         E    : constant Entity_Id := Make_Temporary (Loc, 'V');
1291
         Pent : Entity_Id;
1292
         S    : String_Id;
1293
 
1294
      begin
1295
         --  If not library unit, get to containing library unit
1296
 
1297
         Pent := Entity (Pref);
1298
         while Pent /= Standard_Standard
1299
           and then Scope (Pent) /= Standard_Standard
1300
           and then not Is_Child_Unit (Pent)
1301
         loop
1302
            Pent := Scope (Pent);
1303
         end loop;
1304
 
1305
         --  Special case Standard and Standard.ASCII
1306
 
1307
         if Pent = Standard_Standard or else Pent = Standard_ASCII then
1308
            Rewrite (N,
1309
              Make_String_Literal (Loc,
1310
                Strval => Verbose_Library_Version));
1311
 
1312
         --  All other cases
1313
 
1314
         else
1315
            --  Build required string constant
1316
 
1317
            Get_Name_String (Get_Unit_Name (Pent));
1318
 
1319
            Start_String;
1320
            for J in 1 .. Name_Len - 2 loop
1321
               if Name_Buffer (J) = '.' then
1322
                  Store_String_Chars ("__");
1323
               else
1324
                  Store_String_Char (Get_Char_Code (Name_Buffer (J)));
1325
               end if;
1326
            end loop;
1327
 
1328
            --  Case of subprogram acting as its own spec, always use body
1329
 
1330
            if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
1331
              and then Nkind (Parent (Declaration_Node (Pent))) =
1332
                                                          N_Subprogram_Body
1333
              and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
1334
            then
1335
               Store_String_Chars ("B");
1336
 
1337
            --  Case of no body present, always use spec
1338
 
1339
            elsif not Unit_Requires_Body (Pent) then
1340
               Store_String_Chars ("S");
1341
 
1342
            --  Otherwise use B for Body_Version, S for spec
1343
 
1344
            elsif Id = Attribute_Body_Version then
1345
               Store_String_Chars ("B");
1346
            else
1347
               Store_String_Chars ("S");
1348
            end if;
1349
 
1350
            S := End_String;
1351
            Lib.Version_Referenced (S);
1352
 
1353
            --  Insert the object declaration
1354
 
1355
            Insert_Actions (N, New_List (
1356
              Make_Object_Declaration (Loc,
1357
                Defining_Identifier => E,
1358
                Object_Definition   =>
1359
                  New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
1360
 
1361
            --  Set entity as imported with correct external name
1362
 
1363
            Set_Is_Imported (E);
1364
            Set_Interface_Name (E, Make_String_Literal (Loc, S));
1365
 
1366
            --  Set entity as internal to ensure proper Sprint output of its
1367
            --  implicit importation.
1368
 
1369
            Set_Is_Internal (E);
1370
 
1371
            --  And now rewrite original reference
1372
 
1373
            Rewrite (N,
1374
              Make_Function_Call (Loc,
1375
                Name => New_Reference_To (RTE (RE_Get_Version_String), Loc),
1376
                Parameter_Associations => New_List (
1377
                  New_Occurrence_Of (E, Loc))));
1378
         end if;
1379
 
1380
         Analyze_And_Resolve (N, RTE (RE_Version_String));
1381
      end Version;
1382
 
1383
      -------------
1384
      -- Ceiling --
1385
      -------------
1386
 
1387
      --  Transforms 'Ceiling into a call to the floating-point attribute
1388
      --  function Ceiling in Fat_xxx (where xxx is the root type)
1389
 
1390
      when Attribute_Ceiling =>
1391
         Expand_Fpt_Attribute_R (N);
1392
 
1393
      --------------
1394
      -- Callable --
1395
      --------------
1396
 
1397
      --  Transforms 'Callable attribute into a call to the Callable function
1398
 
1399
      when Attribute_Callable => Callable :
1400
      begin
1401
         --  We have an object of a task interface class-wide type as a prefix
1402
         --  to Callable. Generate:
1403
         --    callable (Task_Id (Pref._disp_get_task_id));
1404
 
1405
         if Ada_Version >= Ada_2005
1406
           and then Ekind (Ptyp) = E_Class_Wide_Type
1407
           and then Is_Interface (Ptyp)
1408
           and then Is_Task_Interface (Ptyp)
1409
         then
1410
            Rewrite (N,
1411
              Make_Function_Call (Loc,
1412
                Name =>
1413
                  New_Reference_To (RTE (RE_Callable), Loc),
1414
                Parameter_Associations => New_List (
1415
                  Make_Unchecked_Type_Conversion (Loc,
1416
                    Subtype_Mark =>
1417
                      New_Reference_To (RTE (RO_ST_Task_Id), Loc),
1418
                    Expression =>
1419
                      Make_Selected_Component (Loc,
1420
                        Prefix =>
1421
                          New_Copy_Tree (Pref),
1422
                        Selector_Name =>
1423
                          Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
1424
 
1425
         else
1426
            Rewrite (N,
1427
              Build_Call_With_Task (Pref, RTE (RE_Callable)));
1428
         end if;
1429
 
1430
         Analyze_And_Resolve (N, Standard_Boolean);
1431
      end Callable;
1432
 
1433
      ------------
1434
      -- Caller --
1435
      ------------
1436
 
1437
      --  Transforms 'Caller attribute into a call to either the
1438
      --  Task_Entry_Caller or the Protected_Entry_Caller function.
1439
 
1440
      when Attribute_Caller => Caller : declare
1441
         Id_Kind    : constant Entity_Id := RTE (RO_AT_Task_Id);
1442
         Ent        : constant Entity_Id := Entity (Pref);
1443
         Conctype   : constant Entity_Id := Scope (Ent);
1444
         Nest_Depth : Integer := 0;
1445
         Name       : Node_Id;
1446
         S          : Entity_Id;
1447
 
1448
      begin
1449
         --  Protected case
1450
 
1451
         if Is_Protected_Type (Conctype) then
1452
            case Corresponding_Runtime_Package (Conctype) is
1453
               when System_Tasking_Protected_Objects_Entries =>
1454
                  Name :=
1455
                    New_Reference_To
1456
                      (RTE (RE_Protected_Entry_Caller), Loc);
1457
 
1458
               when System_Tasking_Protected_Objects_Single_Entry =>
1459
                  Name :=
1460
                    New_Reference_To
1461
                      (RTE (RE_Protected_Single_Entry_Caller), Loc);
1462
 
1463
               when others =>
1464
                  raise Program_Error;
1465
            end case;
1466
 
1467
            Rewrite (N,
1468
              Unchecked_Convert_To (Id_Kind,
1469
                Make_Function_Call (Loc,
1470
                  Name => Name,
1471
                  Parameter_Associations => New_List (
1472
                    New_Reference_To
1473
                      (Find_Protection_Object (Current_Scope), Loc)))));
1474
 
1475
         --  Task case
1476
 
1477
         else
1478
            --  Determine the nesting depth of the E'Caller attribute, that
1479
            --  is, how many accept statements are nested within the accept
1480
            --  statement for E at the point of E'Caller. The runtime uses
1481
            --  this depth to find the specified entry call.
1482
 
1483
            for J in reverse 0 .. Scope_Stack.Last loop
1484
               S := Scope_Stack.Table (J).Entity;
1485
 
1486
               --  We should not reach the scope of the entry, as it should
1487
               --  already have been checked in Sem_Attr that this attribute
1488
               --  reference is within a matching accept statement.
1489
 
1490
               pragma Assert (S /= Conctype);
1491
 
1492
               if S = Ent then
1493
                  exit;
1494
 
1495
               elsif Is_Entry (S) then
1496
                  Nest_Depth := Nest_Depth + 1;
1497
               end if;
1498
            end loop;
1499
 
1500
            Rewrite (N,
1501
              Unchecked_Convert_To (Id_Kind,
1502
                Make_Function_Call (Loc,
1503
                  Name =>
1504
                    New_Reference_To (RTE (RE_Task_Entry_Caller), Loc),
1505
                  Parameter_Associations => New_List (
1506
                    Make_Integer_Literal (Loc,
1507
                      Intval => Int (Nest_Depth))))));
1508
         end if;
1509
 
1510
         Analyze_And_Resolve (N, Id_Kind);
1511
      end Caller;
1512
 
1513
      -------------
1514
      -- Compose --
1515
      -------------
1516
 
1517
      --  Transforms 'Compose into a call to the floating-point attribute
1518
      --  function Compose in Fat_xxx (where xxx is the root type)
1519
 
1520
      --  Note: we strictly should have special code here to deal with the
1521
      --  case of absurdly negative arguments (less than Integer'First)
1522
      --  which will return a (signed) zero value, but it hardly seems
1523
      --  worth the effort. Absurdly large positive arguments will raise
1524
      --  constraint error which is fine.
1525
 
1526
      when Attribute_Compose =>
1527
         Expand_Fpt_Attribute_RI (N);
1528
 
1529
      -----------------
1530
      -- Constrained --
1531
      -----------------
1532
 
1533
      when Attribute_Constrained => Constrained : declare
1534
         Formal_Ent : constant Entity_Id := Param_Entity (Pref);
1535
 
1536
         function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
1537
         --  Ada 2005 (AI-363): Returns True if the object name Obj denotes a
1538
         --  view of an aliased object whose subtype is constrained.
1539
 
1540
         ---------------------------------
1541
         -- Is_Constrained_Aliased_View --
1542
         ---------------------------------
1543
 
1544
         function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
1545
            E : Entity_Id;
1546
 
1547
         begin
1548
            if Is_Entity_Name (Obj) then
1549
               E := Entity (Obj);
1550
 
1551
               if Present (Renamed_Object (E)) then
1552
                  return Is_Constrained_Aliased_View (Renamed_Object (E));
1553
               else
1554
                  return Is_Aliased (E) and then Is_Constrained (Etype (E));
1555
               end if;
1556
 
1557
            else
1558
               return Is_Aliased_View (Obj)
1559
                        and then
1560
                      (Is_Constrained (Etype (Obj))
1561
                         or else
1562
                           (Nkind (Obj) = N_Explicit_Dereference
1563
                              and then
1564
                                not Effectively_Has_Constrained_Partial_View
1565
                                      (Typ  => Base_Type (Etype (Obj)),
1566
                                       Scop => Current_Scope)));
1567
            end if;
1568
         end Is_Constrained_Aliased_View;
1569
 
1570
      --  Start of processing for Constrained
1571
 
1572
      begin
1573
         --  Reference to a parameter where the value is passed as an extra
1574
         --  actual, corresponding to the extra formal referenced by the
1575
         --  Extra_Constrained field of the corresponding formal. If this
1576
         --  is an entry in-parameter, it is replaced by a constant renaming
1577
         --  for which Extra_Constrained is never created.
1578
 
1579
         if Present (Formal_Ent)
1580
           and then Ekind (Formal_Ent) /= E_Constant
1581
           and then Present (Extra_Constrained (Formal_Ent))
1582
         then
1583
            Rewrite (N,
1584
              New_Occurrence_Of
1585
                (Extra_Constrained (Formal_Ent), Sloc (N)));
1586
 
1587
         --  For variables with a Extra_Constrained field, we use the
1588
         --  corresponding entity.
1589
 
1590
         elsif Nkind (Pref) = N_Identifier
1591
           and then Ekind (Entity (Pref)) = E_Variable
1592
           and then Present (Extra_Constrained (Entity (Pref)))
1593
         then
1594
            Rewrite (N,
1595
              New_Occurrence_Of
1596
                (Extra_Constrained (Entity (Pref)), Sloc (N)));
1597
 
1598
         --  For all other entity names, we can tell at compile time
1599
 
1600
         elsif Is_Entity_Name (Pref) then
1601
            declare
1602
               Ent : constant Entity_Id   := Entity (Pref);
1603
               Res : Boolean;
1604
 
1605
            begin
1606
               --  (RM J.4) obsolescent cases
1607
 
1608
               if Is_Type (Ent) then
1609
 
1610
                  --  Private type
1611
 
1612
                  if Is_Private_Type (Ent) then
1613
                     Res := not Has_Discriminants (Ent)
1614
                              or else Is_Constrained (Ent);
1615
 
1616
                  --  It not a private type, must be a generic actual type
1617
                  --  that corresponded to a private type. We know that this
1618
                  --  correspondence holds, since otherwise the reference
1619
                  --  within the generic template would have been illegal.
1620
 
1621
                  else
1622
                     if Is_Composite_Type (Underlying_Type (Ent)) then
1623
                        Res := Is_Constrained (Ent);
1624
                     else
1625
                        Res := True;
1626
                     end if;
1627
                  end if;
1628
 
1629
               --  If the prefix is not a variable or is aliased, then
1630
               --  definitely true; if it's a formal parameter without an
1631
               --  associated extra formal, then treat it as constrained.
1632
 
1633
               --  Ada 2005 (AI-363): An aliased prefix must be known to be
1634
               --  constrained in order to set the attribute to True.
1635
 
1636
               elsif not Is_Variable (Pref)
1637
                 or else Present (Formal_Ent)
1638
                 or else (Ada_Version < Ada_2005
1639
                            and then Is_Aliased_View (Pref))
1640
                 or else (Ada_Version >= Ada_2005
1641
                            and then Is_Constrained_Aliased_View (Pref))
1642
               then
1643
                  Res := True;
1644
 
1645
               --  Variable case, look at type to see if it is constrained.
1646
               --  Note that the one case where this is not accurate (the
1647
               --  procedure formal case), has been handled above.
1648
 
1649
               --  We use the Underlying_Type here (and below) in case the
1650
               --  type is private without discriminants, but the full type
1651
               --  has discriminants. This case is illegal, but we generate it
1652
               --  internally for passing to the Extra_Constrained parameter.
1653
 
1654
               else
1655
                  --  In Ada 2012, test for case of a limited tagged type, in
1656
                  --  which case the attribute is always required to return
1657
                  --  True. The underlying type is tested, to make sure we also
1658
                  --  return True for cases where there is an unconstrained
1659
                  --  object with an untagged limited partial view which has
1660
                  --  defaulted discriminants (such objects always produce a
1661
                  --  False in earlier versions of Ada). (Ada 2012: AI05-0214)
1662
 
1663
                  Res := Is_Constrained (Underlying_Type (Etype (Ent)))
1664
                           or else
1665
                             (Ada_Version >= Ada_2012
1666
                               and then Is_Tagged_Type (Underlying_Type (Ptyp))
1667
                               and then Is_Limited_Type (Ptyp));
1668
               end if;
1669
 
1670
               Rewrite (N, New_Reference_To (Boolean_Literals (Res), Loc));
1671
            end;
1672
 
1673
         --  Prefix is not an entity name. These are also cases where we can
1674
         --  always tell at compile time by looking at the form and type of the
1675
         --  prefix. If an explicit dereference of an object with constrained
1676
         --  partial view, this is unconstrained (Ada 2005: AI95-0363). If the
1677
         --  underlying type is a limited tagged type, then Constrained is
1678
         --  required to always return True (Ada 2012: AI05-0214).
1679
 
1680
         else
1681
            Rewrite (N,
1682
              New_Reference_To (
1683
                Boolean_Literals (
1684
                  not Is_Variable (Pref)
1685
                    or else
1686
                     (Nkind (Pref) = N_Explicit_Dereference
1687
                       and then
1688
                         not Effectively_Has_Constrained_Partial_View
1689
                               (Typ  => Base_Type (Ptyp),
1690
                                Scop => Current_Scope))
1691
                    or else Is_Constrained (Underlying_Type (Ptyp))
1692
                    or else (Ada_Version >= Ada_2012
1693
                              and then Is_Tagged_Type (Underlying_Type (Ptyp))
1694
                              and then Is_Limited_Type (Ptyp))),
1695
                Loc));
1696
         end if;
1697
 
1698
         Analyze_And_Resolve (N, Standard_Boolean);
1699
      end Constrained;
1700
 
1701
      ---------------
1702
      -- Copy_Sign --
1703
      ---------------
1704
 
1705
      --  Transforms 'Copy_Sign into a call to the floating-point attribute
1706
      --  function Copy_Sign in Fat_xxx (where xxx is the root type)
1707
 
1708
      when Attribute_Copy_Sign =>
1709
         Expand_Fpt_Attribute_RR (N);
1710
 
1711
      -----------
1712
      -- Count --
1713
      -----------
1714
 
1715
      --  Transforms 'Count attribute into a call to the Count function
1716
 
1717
      when Attribute_Count => Count : declare
1718
         Call     : Node_Id;
1719
         Conctyp  : Entity_Id;
1720
         Entnam   : Node_Id;
1721
         Entry_Id : Entity_Id;
1722
         Index    : Node_Id;
1723
         Name     : Node_Id;
1724
 
1725
      begin
1726
         --  If the prefix is a member of an entry family, retrieve both
1727
         --  entry name and index. For a simple entry there is no index.
1728
 
1729
         if Nkind (Pref) = N_Indexed_Component then
1730
            Entnam := Prefix (Pref);
1731
            Index := First (Expressions (Pref));
1732
         else
1733
            Entnam := Pref;
1734
            Index := Empty;
1735
         end if;
1736
 
1737
         Entry_Id := Entity (Entnam);
1738
 
1739
         --  Find the concurrent type in which this attribute is referenced
1740
         --  (there had better be one).
1741
 
1742
         Conctyp := Current_Scope;
1743
         while not Is_Concurrent_Type (Conctyp) loop
1744
            Conctyp := Scope (Conctyp);
1745
         end loop;
1746
 
1747
         --  Protected case
1748
 
1749
         if Is_Protected_Type (Conctyp) then
1750
            case Corresponding_Runtime_Package (Conctyp) is
1751
               when System_Tasking_Protected_Objects_Entries =>
1752
                  Name := New_Reference_To (RTE (RE_Protected_Count), Loc);
1753
 
1754
                  Call :=
1755
                    Make_Function_Call (Loc,
1756
                      Name => Name,
1757
                      Parameter_Associations => New_List (
1758
                        New_Reference_To
1759
                          (Find_Protection_Object (Current_Scope), Loc),
1760
                        Entry_Index_Expression
1761
                          (Loc, Entry_Id, Index, Scope (Entry_Id))));
1762
 
1763
               when System_Tasking_Protected_Objects_Single_Entry =>
1764
                  Name :=
1765
                    New_Reference_To (RTE (RE_Protected_Count_Entry), Loc);
1766
 
1767
                  Call :=
1768
                    Make_Function_Call (Loc,
1769
                      Name => Name,
1770
                      Parameter_Associations => New_List (
1771
                        New_Reference_To
1772
                          (Find_Protection_Object (Current_Scope), Loc)));
1773
 
1774
               when others =>
1775
                  raise Program_Error;
1776
            end case;
1777
 
1778
         --  Task case
1779
 
1780
         else
1781
            Call :=
1782
              Make_Function_Call (Loc,
1783
                Name => New_Reference_To (RTE (RE_Task_Count), Loc),
1784
                Parameter_Associations => New_List (
1785
                  Entry_Index_Expression (Loc,
1786
                    Entry_Id, Index, Scope (Entry_Id))));
1787
         end if;
1788
 
1789
         --  The call returns type Natural but the context is universal integer
1790
         --  so any integer type is allowed. The attribute was already resolved
1791
         --  so its Etype is the required result type. If the base type of the
1792
         --  context type is other than Standard.Integer we put in a conversion
1793
         --  to the required type. This can be a normal typed conversion since
1794
         --  both input and output types of the conversion are integer types
1795
 
1796
         if Base_Type (Typ) /= Base_Type (Standard_Integer) then
1797
            Rewrite (N, Convert_To (Typ, Call));
1798
         else
1799
            Rewrite (N, Call);
1800
         end if;
1801
 
1802
         Analyze_And_Resolve (N, Typ);
1803
      end Count;
1804
 
1805
      ---------------------
1806
      -- Descriptor_Size --
1807
      ---------------------
1808
 
1809
      when Attribute_Descriptor_Size =>
1810
 
1811
         --  Attribute Descriptor_Size is handled by the back end when applied
1812
         --  to an unconstrained array type.
1813
 
1814
         if Is_Array_Type (Ptyp)
1815
           and then not Is_Constrained (Ptyp)
1816
         then
1817
            Apply_Universal_Integer_Attribute_Checks (N);
1818
 
1819
         --  For any other type, the descriptor size is 0 because there is no
1820
         --  actual descriptor, but the result is not formally static.
1821
 
1822
         else
1823
            Rewrite (N, Make_Integer_Literal (Loc, 0));
1824
            Analyze (N);
1825
            Set_Is_Static_Expression (N, False);
1826
         end if;
1827
 
1828
      ---------------
1829
      -- Elab_Body --
1830
      ---------------
1831
 
1832
      --  This processing is shared by Elab_Spec
1833
 
1834
      --  What we do is to insert the following declarations
1835
 
1836
      --     procedure tnn;
1837
      --     pragma Import (C, enn, "name___elabb/s");
1838
 
1839
      --  and then the Elab_Body/Spec attribute is replaced by a reference
1840
      --  to this defining identifier.
1841
 
1842
      when Attribute_Elab_Body      |
1843
           Attribute_Elab_Spec      =>
1844
 
1845
         --  Leave attribute unexpanded in CodePeer mode: the gnat2scil
1846
         --  back-end knows how to handle these attributes directly.
1847
 
1848
         if CodePeer_Mode then
1849
            return;
1850
         end if;
1851
 
1852
         Elab_Body : declare
1853
            Ent  : constant Entity_Id := Make_Temporary (Loc, 'E');
1854
            Str  : String_Id;
1855
            Lang : Node_Id;
1856
 
1857
            procedure Make_Elab_String (Nod : Node_Id);
1858
            --  Given Nod, an identifier, or a selected component, put the
1859
            --  image into the current string literal, with double underline
1860
            --  between components.
1861
 
1862
            ----------------------
1863
            -- Make_Elab_String --
1864
            ----------------------
1865
 
1866
            procedure Make_Elab_String (Nod : Node_Id) is
1867
            begin
1868
               if Nkind (Nod) = N_Selected_Component then
1869
                  Make_Elab_String (Prefix (Nod));
1870
 
1871
                  case VM_Target is
1872
                     when JVM_Target =>
1873
                        Store_String_Char ('$');
1874
                     when CLI_Target =>
1875
                        Store_String_Char ('.');
1876
                     when No_VM =>
1877
                        Store_String_Char ('_');
1878
                        Store_String_Char ('_');
1879
                  end case;
1880
 
1881
                  Get_Name_String (Chars (Selector_Name (Nod)));
1882
 
1883
               else
1884
                  pragma Assert (Nkind (Nod) = N_Identifier);
1885
                  Get_Name_String (Chars (Nod));
1886
               end if;
1887
 
1888
               Store_String_Chars (Name_Buffer (1 .. Name_Len));
1889
            end Make_Elab_String;
1890
 
1891
         --  Start of processing for Elab_Body/Elab_Spec
1892
 
1893
         begin
1894
            --  First we need to prepare the string literal for the name of
1895
            --  the elaboration routine to be referenced.
1896
 
1897
            Start_String;
1898
            Make_Elab_String (Pref);
1899
 
1900
            if VM_Target = No_VM then
1901
               Store_String_Chars ("___elab");
1902
               Lang := Make_Identifier (Loc, Name_C);
1903
            else
1904
               Store_String_Chars ("._elab");
1905
               Lang := Make_Identifier (Loc, Name_Ada);
1906
            end if;
1907
 
1908
            if Id = Attribute_Elab_Body then
1909
               Store_String_Char ('b');
1910
            else
1911
               Store_String_Char ('s');
1912
            end if;
1913
 
1914
            Str := End_String;
1915
 
1916
            Insert_Actions (N, New_List (
1917
              Make_Subprogram_Declaration (Loc,
1918
                Specification =>
1919
                  Make_Procedure_Specification (Loc,
1920
                    Defining_Unit_Name => Ent)),
1921
 
1922
              Make_Pragma (Loc,
1923
                Chars => Name_Import,
1924
                Pragma_Argument_Associations => New_List (
1925
                  Make_Pragma_Argument_Association (Loc, Expression => Lang),
1926
 
1927
                  Make_Pragma_Argument_Association (Loc,
1928
                    Expression => Make_Identifier (Loc, Chars (Ent))),
1929
 
1930
                  Make_Pragma_Argument_Association (Loc,
1931
                    Expression => Make_String_Literal (Loc, Str))))));
1932
 
1933
            Set_Entity (N, Ent);
1934
            Rewrite (N, New_Occurrence_Of (Ent, Loc));
1935
         end Elab_Body;
1936
 
1937
      --------------------
1938
      -- Elab_Subp_Body --
1939
      --------------------
1940
 
1941
      --  Always ignored. In CodePeer mode, gnat2scil knows how to handle
1942
      --  this attribute directly, and if we are not in CodePeer mode it is
1943
      --  entirely ignored ???
1944
 
1945
      when Attribute_Elab_Subp_Body =>
1946
         return;
1947
 
1948
      ----------------
1949
      -- Elaborated --
1950
      ----------------
1951
 
1952
      --  Elaborated is always True for preelaborated units, predefined units,
1953
      --  pure units and units which have Elaborate_Body pragmas. These units
1954
      --  have no elaboration entity.
1955
 
1956
      --  Note: The Elaborated attribute is never passed to the back end
1957
 
1958
      when Attribute_Elaborated => Elaborated : declare
1959
         Ent : constant Entity_Id := Entity (Pref);
1960
 
1961
      begin
1962
         if Present (Elaboration_Entity (Ent)) then
1963
            Rewrite (N,
1964
              Make_Op_Ne (Loc,
1965
                Left_Opnd =>
1966
                  New_Occurrence_Of (Elaboration_Entity (Ent), Loc),
1967
                Right_Opnd =>
1968
                  Make_Integer_Literal (Loc, Uint_0)));
1969
            Analyze_And_Resolve (N, Typ);
1970
         else
1971
            Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
1972
         end if;
1973
      end Elaborated;
1974
 
1975
      --------------
1976
      -- Enum_Rep --
1977
      --------------
1978
 
1979
      when Attribute_Enum_Rep => Enum_Rep :
1980
      begin
1981
         --  X'Enum_Rep (Y) expands to
1982
 
1983
         --    target-type (Y)
1984
 
1985
         --  This is simply a direct conversion from the enumeration type to
1986
         --  the target integer type, which is treated by the back end as a
1987
         --  normal integer conversion, treating the enumeration type as an
1988
         --  integer, which is exactly what we want! We set Conversion_OK to
1989
         --  make sure that the analyzer does not complain about what otherwise
1990
         --  might be an illegal conversion.
1991
 
1992
         if Is_Non_Empty_List (Exprs) then
1993
            Rewrite (N,
1994
              OK_Convert_To (Typ, Relocate_Node (First (Exprs))));
1995
 
1996
         --  X'Enum_Rep where X is an enumeration literal is replaced by
1997
         --  the literal value.
1998
 
1999
         elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then
2000
            Rewrite (N,
2001
              Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref))));
2002
 
2003
         --  If this is a renaming of a literal, recover the representation
2004
         --  of the original.
2005
 
2006
         elsif Ekind (Entity (Pref)) = E_Constant
2007
           and then Present (Renamed_Object (Entity (Pref)))
2008
           and then
2009
             Ekind (Entity (Renamed_Object (Entity (Pref))))
2010
               = E_Enumeration_Literal
2011
         then
2012
            Rewrite (N,
2013
              Make_Integer_Literal (Loc,
2014
                Enumeration_Rep (Entity (Renamed_Object (Entity (Pref))))));
2015
 
2016
         --  X'Enum_Rep where X is an object does a direct unchecked conversion
2017
         --  of the object value, as described for the type case above.
2018
 
2019
         else
2020
            Rewrite (N,
2021
              OK_Convert_To (Typ, Relocate_Node (Pref)));
2022
         end if;
2023
 
2024
         Set_Etype (N, Typ);
2025
         Analyze_And_Resolve (N, Typ);
2026
      end Enum_Rep;
2027
 
2028
      --------------
2029
      -- Enum_Val --
2030
      --------------
2031
 
2032
      when Attribute_Enum_Val => Enum_Val : declare
2033
         Expr : Node_Id;
2034
         Btyp : constant Entity_Id  := Base_Type (Ptyp);
2035
 
2036
      begin
2037
         --  X'Enum_Val (Y) expands to
2038
 
2039
         --    [constraint_error when _rep_to_pos (Y, False) = -1, msg]
2040
         --    X!(Y);
2041
 
2042
         Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
2043
 
2044
         Insert_Action (N,
2045
           Make_Raise_Constraint_Error (Loc,
2046
             Condition =>
2047
               Make_Op_Eq (Loc,
2048
                 Left_Opnd =>
2049
                   Make_Function_Call (Loc,
2050
                     Name =>
2051
                       New_Reference_To (TSS (Btyp, TSS_Rep_To_Pos), Loc),
2052
                     Parameter_Associations => New_List (
2053
                       Relocate_Node (Duplicate_Subexpr (Expr)),
2054
                         New_Occurrence_Of (Standard_False, Loc))),
2055
 
2056
                 Right_Opnd => Make_Integer_Literal (Loc, -1)),
2057
             Reason => CE_Range_Check_Failed));
2058
 
2059
         Rewrite (N, Expr);
2060
         Analyze_And_Resolve (N, Ptyp);
2061
      end Enum_Val;
2062
 
2063
      --------------
2064
      -- Exponent --
2065
      --------------
2066
 
2067
      --  Transforms 'Exponent into a call to the floating-point attribute
2068
      --  function Exponent in Fat_xxx (where xxx is the root type)
2069
 
2070
      when Attribute_Exponent =>
2071
         Expand_Fpt_Attribute_R (N);
2072
 
2073
      ------------------
2074
      -- External_Tag --
2075
      ------------------
2076
 
2077
      --  transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
2078
 
2079
      when Attribute_External_Tag => External_Tag :
2080
      begin
2081
         Rewrite (N,
2082
           Make_Function_Call (Loc,
2083
             Name => New_Reference_To (RTE (RE_External_Tag), Loc),
2084
             Parameter_Associations => New_List (
2085
               Make_Attribute_Reference (Loc,
2086
                 Attribute_Name => Name_Tag,
2087
                 Prefix => Prefix (N)))));
2088
 
2089
         Analyze_And_Resolve (N, Standard_String);
2090
      end External_Tag;
2091
 
2092
      -----------
2093
      -- First --
2094
      -----------
2095
 
2096
      when Attribute_First =>
2097
 
2098
         --  If the prefix type is a constrained packed array type which
2099
         --  already has a Packed_Array_Type representation defined, then
2100
         --  replace this attribute with a direct reference to 'First of the
2101
         --  appropriate index subtype (since otherwise the back end will try
2102
         --  to give us the value of 'First for this implementation type).
2103
 
2104
         if Is_Constrained_Packed_Array (Ptyp) then
2105
            Rewrite (N,
2106
              Make_Attribute_Reference (Loc,
2107
                Attribute_Name => Name_First,
2108
                Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
2109
            Analyze_And_Resolve (N, Typ);
2110
 
2111
         elsif Is_Access_Type (Ptyp) then
2112
            Apply_Access_Check (N);
2113
         end if;
2114
 
2115
      ---------------
2116
      -- First_Bit --
2117
      ---------------
2118
 
2119
      --  Compute this if component clause was present, otherwise we leave the
2120
      --  computation to be completed in the back-end, since we don't know what
2121
      --  layout will be chosen.
2122
 
2123
      when Attribute_First_Bit => First_Bit_Attr : declare
2124
         CE : constant Entity_Id := Entity (Selector_Name (Pref));
2125
 
2126
      begin
2127
         --  In Ada 2005 (or later) if we have the standard nondefault
2128
         --  bit order, then we return the original value as given in
2129
         --  the component clause (RM 2005 13.5.2(3/2)).
2130
 
2131
         if Present (Component_Clause (CE))
2132
           and then Ada_Version >= Ada_2005
2133
           and then not Reverse_Bit_Order (Scope (CE))
2134
         then
2135
            Rewrite (N,
2136
              Make_Integer_Literal (Loc,
2137
                Intval => Expr_Value (First_Bit (Component_Clause (CE)))));
2138
            Analyze_And_Resolve (N, Typ);
2139
 
2140
         --  Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order),
2141
         --  rewrite with normalized value if we know it statically.
2142
 
2143
         elsif Known_Static_Component_Bit_Offset (CE) then
2144
            Rewrite (N,
2145
              Make_Integer_Literal (Loc,
2146
                Component_Bit_Offset (CE) mod System_Storage_Unit));
2147
            Analyze_And_Resolve (N, Typ);
2148
 
2149
         --  Otherwise left to back end, just do universal integer checks
2150
 
2151
         else
2152
            Apply_Universal_Integer_Attribute_Checks (N);
2153
         end if;
2154
      end First_Bit_Attr;
2155
 
2156
      -----------------
2157
      -- Fixed_Value --
2158
      -----------------
2159
 
2160
      --  We transform:
2161
 
2162
      --     fixtype'Fixed_Value (integer-value)
2163
 
2164
      --  into
2165
 
2166
      --     fixtype(integer-value)
2167
 
2168
      --  We do all the required analysis of the conversion here, because we do
2169
      --  not want this to go through the fixed-point conversion circuits. Note
2170
      --  that the back end always treats fixed-point as equivalent to the
2171
      --  corresponding integer type anyway.
2172
 
2173
      when Attribute_Fixed_Value => Fixed_Value :
2174
      begin
2175
         Rewrite (N,
2176
           Make_Type_Conversion (Loc,
2177
             Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
2178
             Expression   => Relocate_Node (First (Exprs))));
2179
         Set_Etype (N, Entity (Pref));
2180
         Set_Analyzed (N);
2181
 
2182
      --  Note: it might appear that a properly analyzed unchecked conversion
2183
      --  would be just fine here, but that's not the case, since the full
2184
      --  range checks performed by the following call are critical!
2185
 
2186
         Apply_Type_Conversion_Checks (N);
2187
      end Fixed_Value;
2188
 
2189
      -----------
2190
      -- Floor --
2191
      -----------
2192
 
2193
      --  Transforms 'Floor into a call to the floating-point attribute
2194
      --  function Floor in Fat_xxx (where xxx is the root type)
2195
 
2196
      when Attribute_Floor =>
2197
         Expand_Fpt_Attribute_R (N);
2198
 
2199
      ----------
2200
      -- Fore --
2201
      ----------
2202
 
2203
      --  For the fixed-point type Typ:
2204
 
2205
      --    Typ'Fore
2206
 
2207
      --  expands into
2208
 
2209
      --    Result_Type (System.Fore (Universal_Real (Type'First)),
2210
      --                              Universal_Real (Type'Last))
2211
 
2212
      --  Note that we know that the type is a non-static subtype, or Fore
2213
      --  would have itself been computed dynamically in Eval_Attribute.
2214
 
2215
      when Attribute_Fore => Fore : begin
2216
         Rewrite (N,
2217
           Convert_To (Typ,
2218
             Make_Function_Call (Loc,
2219
               Name => New_Reference_To (RTE (RE_Fore), Loc),
2220
 
2221
               Parameter_Associations => New_List (
2222
                 Convert_To (Universal_Real,
2223
                   Make_Attribute_Reference (Loc,
2224
                     Prefix => New_Reference_To (Ptyp, Loc),
2225
                     Attribute_Name => Name_First)),
2226
 
2227
                 Convert_To (Universal_Real,
2228
                   Make_Attribute_Reference (Loc,
2229
                     Prefix => New_Reference_To (Ptyp, Loc),
2230
                     Attribute_Name => Name_Last))))));
2231
 
2232
         Analyze_And_Resolve (N, Typ);
2233
      end Fore;
2234
 
2235
      --------------
2236
      -- Fraction --
2237
      --------------
2238
 
2239
      --  Transforms 'Fraction into a call to the floating-point attribute
2240
      --  function Fraction in Fat_xxx (where xxx is the root type)
2241
 
2242
      when Attribute_Fraction =>
2243
         Expand_Fpt_Attribute_R (N);
2244
 
2245
      --------------
2246
      -- From_Any --
2247
      --------------
2248
 
2249
      when Attribute_From_Any => From_Any : declare
2250
         P_Type : constant Entity_Id := Etype (Pref);
2251
         Decls  : constant List_Id   := New_List;
2252
      begin
2253
         Rewrite (N,
2254
           Build_From_Any_Call (P_Type,
2255
             Relocate_Node (First (Exprs)),
2256
             Decls));
2257
         Insert_Actions (N, Decls);
2258
         Analyze_And_Resolve (N, P_Type);
2259
      end From_Any;
2260
 
2261
      --------------
2262
      -- Identity --
2263
      --------------
2264
 
2265
      --  For an exception returns a reference to the exception data:
2266
      --      Exception_Id!(Prefix'Reference)
2267
 
2268
      --  For a task it returns a reference to the _task_id component of
2269
      --  corresponding record:
2270
 
2271
      --    taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
2272
 
2273
      --  in Ada.Task_Identification
2274
 
2275
      when Attribute_Identity => Identity : declare
2276
         Id_Kind : Entity_Id;
2277
 
2278
      begin
2279
         if Ptyp = Standard_Exception_Type then
2280
            Id_Kind := RTE (RE_Exception_Id);
2281
 
2282
            if Present (Renamed_Object (Entity (Pref))) then
2283
               Set_Entity (Pref, Renamed_Object (Entity (Pref)));
2284
            end if;
2285
 
2286
            Rewrite (N,
2287
              Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
2288
         else
2289
            Id_Kind := RTE (RO_AT_Task_Id);
2290
 
2291
            --  If the prefix is a task interface, the Task_Id is obtained
2292
            --  dynamically through a dispatching call, as for other task
2293
            --  attributes applied to interfaces.
2294
 
2295
            if Ada_Version >= Ada_2005
2296
              and then Ekind (Ptyp) = E_Class_Wide_Type
2297
              and then Is_Interface (Ptyp)
2298
              and then Is_Task_Interface (Ptyp)
2299
            then
2300
               Rewrite (N,
2301
                 Unchecked_Convert_To (Id_Kind,
2302
                   Make_Selected_Component (Loc,
2303
                     Prefix =>
2304
                       New_Copy_Tree (Pref),
2305
                     Selector_Name =>
2306
                       Make_Identifier (Loc, Name_uDisp_Get_Task_Id))));
2307
 
2308
            else
2309
               Rewrite (N,
2310
                 Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
2311
            end if;
2312
         end if;
2313
 
2314
         Analyze_And_Resolve (N, Id_Kind);
2315
      end Identity;
2316
 
2317
      -----------
2318
      -- Image --
2319
      -----------
2320
 
2321
      --  Image attribute is handled in separate unit Exp_Imgv
2322
 
2323
      when Attribute_Image =>
2324
         Exp_Imgv.Expand_Image_Attribute (N);
2325
 
2326
      ---------
2327
      -- Img --
2328
      ---------
2329
 
2330
      --  X'Img is expanded to typ'Image (X), where typ is the type of X
2331
 
2332
      when Attribute_Img => Img :
2333
      begin
2334
         Rewrite (N,
2335
           Make_Attribute_Reference (Loc,
2336
             Prefix => New_Reference_To (Ptyp, Loc),
2337
             Attribute_Name => Name_Image,
2338
             Expressions => New_List (Relocate_Node (Pref))));
2339
 
2340
         Analyze_And_Resolve (N, Standard_String);
2341
      end Img;
2342
 
2343
      -----------
2344
      -- Input --
2345
      -----------
2346
 
2347
      when Attribute_Input => Input : declare
2348
         P_Type : constant Entity_Id := Entity (Pref);
2349
         B_Type : constant Entity_Id := Base_Type (P_Type);
2350
         U_Type : constant Entity_Id := Underlying_Type (P_Type);
2351
         Strm   : constant Node_Id   := First (Exprs);
2352
         Fname  : Entity_Id;
2353
         Decl   : Node_Id;
2354
         Call   : Node_Id;
2355
         Prag   : Node_Id;
2356
         Arg2   : Node_Id;
2357
         Rfunc  : Node_Id;
2358
 
2359
         Cntrl  : Node_Id := Empty;
2360
         --  Value for controlling argument in call. Always Empty except in
2361
         --  the dispatching (class-wide type) case, where it is a reference
2362
         --  to the dummy object initialized to the right internal tag.
2363
 
2364
         procedure Freeze_Stream_Subprogram (F : Entity_Id);
2365
         --  The expansion of the attribute reference may generate a call to
2366
         --  a user-defined stream subprogram that is frozen by the call. This
2367
         --  can lead to access-before-elaboration problem if the reference
2368
         --  appears in an object declaration and the subprogram body has not
2369
         --  been seen. The freezing of the subprogram requires special code
2370
         --  because it appears in an expanded context where expressions do
2371
         --  not freeze their constituents.
2372
 
2373
         ------------------------------
2374
         -- Freeze_Stream_Subprogram --
2375
         ------------------------------
2376
 
2377
         procedure Freeze_Stream_Subprogram (F : Entity_Id) is
2378
            Decl : constant Node_Id := Unit_Declaration_Node (F);
2379
            Bod  : Node_Id;
2380
 
2381
         begin
2382
            --  If this is user-defined subprogram, the corresponding
2383
            --  stream function appears as a renaming-as-body, and the
2384
            --  user subprogram must be retrieved by tree traversal.
2385
 
2386
            if Present (Decl)
2387
              and then Nkind (Decl) = N_Subprogram_Declaration
2388
              and then Present (Corresponding_Body (Decl))
2389
            then
2390
               Bod := Corresponding_Body (Decl);
2391
 
2392
               if Nkind (Unit_Declaration_Node (Bod)) =
2393
                 N_Subprogram_Renaming_Declaration
2394
               then
2395
                  Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod))));
2396
               end if;
2397
            end if;
2398
         end Freeze_Stream_Subprogram;
2399
 
2400
      --  Start of processing for Input
2401
 
2402
      begin
2403
         --  If no underlying type, we have an error that will be diagnosed
2404
         --  elsewhere, so here we just completely ignore the expansion.
2405
 
2406
         if No (U_Type) then
2407
            return;
2408
         end if;
2409
 
2410
         --  If there is a TSS for Input, just call it
2411
 
2412
         Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
2413
 
2414
         if Present (Fname) then
2415
            null;
2416
 
2417
         else
2418
            --  If there is a Stream_Convert pragma, use it, we rewrite
2419
 
2420
            --     sourcetyp'Input (stream)
2421
 
2422
            --  as
2423
 
2424
            --     sourcetyp (streamread (strmtyp'Input (stream)));
2425
 
2426
            --  where streamread is the given Read function that converts an
2427
            --  argument of type strmtyp to type sourcetyp or a type from which
2428
            --  it is derived (extra conversion required for the derived case).
2429
 
2430
            Prag := Get_Stream_Convert_Pragma (P_Type);
2431
 
2432
            if Present (Prag) then
2433
               Arg2  := Next (First (Pragma_Argument_Associations (Prag)));
2434
               Rfunc := Entity (Expression (Arg2));
2435
 
2436
               Rewrite (N,
2437
                 Convert_To (B_Type,
2438
                   Make_Function_Call (Loc,
2439
                     Name => New_Occurrence_Of (Rfunc, Loc),
2440
                     Parameter_Associations => New_List (
2441
                       Make_Attribute_Reference (Loc,
2442
                         Prefix =>
2443
                           New_Occurrence_Of
2444
                             (Etype (First_Formal (Rfunc)), Loc),
2445
                         Attribute_Name => Name_Input,
2446
                         Expressions => Exprs)))));
2447
 
2448
               Analyze_And_Resolve (N, B_Type);
2449
               return;
2450
 
2451
            --  Elementary types
2452
 
2453
            elsif Is_Elementary_Type (U_Type) then
2454
 
2455
               --  A special case arises if we have a defined _Read routine,
2456
               --  since in this case we are required to call this routine.
2457
 
2458
               if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
2459
                  Build_Record_Or_Elementary_Input_Function
2460
                    (Loc, U_Type, Decl, Fname);
2461
                  Insert_Action (N, Decl);
2462
 
2463
               --  For normal cases, we call the I_xxx routine directly
2464
 
2465
               else
2466
                  Rewrite (N, Build_Elementary_Input_Call (N));
2467
                  Analyze_And_Resolve (N, P_Type);
2468
                  return;
2469
               end if;
2470
 
2471
            --  Array type case
2472
 
2473
            elsif Is_Array_Type (U_Type) then
2474
               Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
2475
               Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
2476
 
2477
            --  Dispatching case with class-wide type
2478
 
2479
            elsif Is_Class_Wide_Type (P_Type) then
2480
 
2481
               --  No need to do anything else compiling under restriction
2482
               --  No_Dispatching_Calls. During the semantic analysis we
2483
               --  already notified such violation.
2484
 
2485
               if Restriction_Active (No_Dispatching_Calls) then
2486
                  return;
2487
               end if;
2488
 
2489
               declare
2490
                  Rtyp : constant Entity_Id := Root_Type (P_Type);
2491
                  Dnn  : Entity_Id;
2492
                  Decl : Node_Id;
2493
                  Expr : Node_Id;
2494
 
2495
               begin
2496
                  --  Read the internal tag (RM 13.13.2(34)) and use it to
2497
                  --  initialize a dummy tag object:
2498
 
2499
                  --    Dnn : Ada.Tags.Tag :=
2500
                  --            Descendant_Tag (String'Input (Strm), P_Type);
2501
 
2502
                  --  This dummy object is used only to provide a controlling
2503
                  --  argument for the eventual _Input call. Descendant_Tag is
2504
                  --  called rather than Internal_Tag to ensure that we have a
2505
                  --  tag for a type that is descended from the prefix type and
2506
                  --  declared at the same accessibility level (the exception
2507
                  --  Tag_Error will be raised otherwise). The level check is
2508
                  --  required for Ada 2005 because tagged types can be
2509
                  --  extended in nested scopes (AI-344).
2510
 
2511
                  Expr :=
2512
                    Make_Function_Call (Loc,
2513
                      Name =>
2514
                        New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
2515
                      Parameter_Associations => New_List (
2516
                        Make_Attribute_Reference (Loc,
2517
                          Prefix => New_Occurrence_Of (Standard_String, Loc),
2518
                          Attribute_Name => Name_Input,
2519
                          Expressions => New_List (
2520
                            Relocate_Node (Duplicate_Subexpr (Strm)))),
2521
                        Make_Attribute_Reference (Loc,
2522
                          Prefix => New_Reference_To (P_Type, Loc),
2523
                          Attribute_Name => Name_Tag)));
2524
 
2525
                  Dnn := Make_Temporary (Loc, 'D', Expr);
2526
 
2527
                  Decl :=
2528
                    Make_Object_Declaration (Loc,
2529
                      Defining_Identifier => Dnn,
2530
                      Object_Definition   =>
2531
                        New_Occurrence_Of (RTE (RE_Tag), Loc),
2532
                      Expression          => Expr);
2533
 
2534
                  Insert_Action (N, Decl);
2535
 
2536
                  --  Now we need to get the entity for the call, and construct
2537
                  --  a function call node, where we preset a reference to Dnn
2538
                  --  as the controlling argument (doing an unchecked convert
2539
                  --  to the class-wide tagged type to make it look like a real
2540
                  --  tagged object).
2541
 
2542
                  Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
2543
                  Cntrl :=
2544
                    Unchecked_Convert_To (P_Type,
2545
                      New_Occurrence_Of (Dnn, Loc));
2546
                  Set_Etype (Cntrl, P_Type);
2547
                  Set_Parent (Cntrl, N);
2548
               end;
2549
 
2550
            --  For tagged types, use the primitive Input function
2551
 
2552
            elsif Is_Tagged_Type (U_Type) then
2553
               Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
2554
 
2555
            --  All other record type cases, including protected records. The
2556
            --  latter only arise for expander generated code for handling
2557
            --  shared passive partition access.
2558
 
2559
            else
2560
               pragma Assert
2561
                 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
2562
 
2563
               --  Ada 2005 (AI-216): Program_Error is raised executing default
2564
               --  implementation of the Input attribute of an unchecked union
2565
               --  type if the type lacks default discriminant values.
2566
 
2567
               if Is_Unchecked_Union (Base_Type (U_Type))
2568
                 and then No (Discriminant_Constraint (U_Type))
2569
               then
2570
                  Insert_Action (N,
2571
                    Make_Raise_Program_Error (Loc,
2572
                      Reason => PE_Unchecked_Union_Restriction));
2573
 
2574
                  return;
2575
               end if;
2576
 
2577
               --  Build the type's Input function, passing the subtype rather
2578
               --  than its base type, because checks are needed in the case of
2579
               --  constrained discriminants (see Ada 2012 AI05-0192).
2580
 
2581
               Build_Record_Or_Elementary_Input_Function
2582
                 (Loc, U_Type, Decl, Fname);
2583
               Insert_Action (N, Decl);
2584
 
2585
               if Nkind (Parent (N)) = N_Object_Declaration
2586
                 and then Is_Record_Type (U_Type)
2587
               then
2588
                  --  The stream function may contain calls to user-defined
2589
                  --  Read procedures for individual components.
2590
 
2591
                  declare
2592
                     Comp : Entity_Id;
2593
                     Func : Entity_Id;
2594
 
2595
                  begin
2596
                     Comp := First_Component (U_Type);
2597
                     while Present (Comp) loop
2598
                        Func :=
2599
                          Find_Stream_Subprogram
2600
                            (Etype (Comp), TSS_Stream_Read);
2601
 
2602
                        if Present (Func) then
2603
                           Freeze_Stream_Subprogram (Func);
2604
                        end if;
2605
 
2606
                        Next_Component (Comp);
2607
                     end loop;
2608
                  end;
2609
               end if;
2610
            end if;
2611
         end if;
2612
 
2613
         --  If we fall through, Fname is the function to be called. The result
2614
         --  is obtained by calling the appropriate function, then converting
2615
         --  the result. The conversion does a subtype check.
2616
 
2617
         Call :=
2618
           Make_Function_Call (Loc,
2619
             Name => New_Occurrence_Of (Fname, Loc),
2620
             Parameter_Associations => New_List (
2621
                Relocate_Node (Strm)));
2622
 
2623
         Set_Controlling_Argument (Call, Cntrl);
2624
         Rewrite (N, Unchecked_Convert_To (P_Type, Call));
2625
         Analyze_And_Resolve (N, P_Type);
2626
 
2627
         if Nkind (Parent (N)) = N_Object_Declaration then
2628
            Freeze_Stream_Subprogram (Fname);
2629
         end if;
2630
      end Input;
2631
 
2632
      -------------------
2633
      -- Integer_Value --
2634
      -------------------
2635
 
2636
      --  We transform
2637
 
2638
      --    inttype'Fixed_Value (fixed-value)
2639
 
2640
      --  into
2641
 
2642
      --    inttype(integer-value))
2643
 
2644
      --  we do all the required analysis of the conversion here, because we do
2645
      --  not want this to go through the fixed-point conversion circuits. Note
2646
      --  that the back end always treats fixed-point as equivalent to the
2647
      --  corresponding integer type anyway.
2648
 
2649
      when Attribute_Integer_Value => Integer_Value :
2650
      begin
2651
         Rewrite (N,
2652
           Make_Type_Conversion (Loc,
2653
             Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
2654
             Expression   => Relocate_Node (First (Exprs))));
2655
         Set_Etype (N, Entity (Pref));
2656
         Set_Analyzed (N);
2657
 
2658
      --  Note: it might appear that a properly analyzed unchecked conversion
2659
      --  would be just fine here, but that's not the case, since the full
2660
      --  range checks performed by the following call are critical!
2661
 
2662
         Apply_Type_Conversion_Checks (N);
2663
      end Integer_Value;
2664
 
2665
      -------------------
2666
      -- Invalid_Value --
2667
      -------------------
2668
 
2669
      when Attribute_Invalid_Value =>
2670
         Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
2671
 
2672
      ----------
2673
      -- Last --
2674
      ----------
2675
 
2676
      when Attribute_Last =>
2677
 
2678
         --  If the prefix type is a constrained packed array type which
2679
         --  already has a Packed_Array_Type representation defined, then
2680
         --  replace this attribute with a direct reference to 'Last of the
2681
         --  appropriate index subtype (since otherwise the back end will try
2682
         --  to give us the value of 'Last for this implementation type).
2683
 
2684
         if Is_Constrained_Packed_Array (Ptyp) then
2685
            Rewrite (N,
2686
              Make_Attribute_Reference (Loc,
2687
                Attribute_Name => Name_Last,
2688
                Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
2689
            Analyze_And_Resolve (N, Typ);
2690
 
2691
         elsif Is_Access_Type (Ptyp) then
2692
            Apply_Access_Check (N);
2693
         end if;
2694
 
2695
      --------------
2696
      -- Last_Bit --
2697
      --------------
2698
 
2699
      --  We compute this if a component clause was present, otherwise we leave
2700
      --  the computation up to the back end, since we don't know what layout
2701
      --  will be chosen.
2702
 
2703
      when Attribute_Last_Bit => Last_Bit_Attr : declare
2704
         CE : constant Entity_Id := Entity (Selector_Name (Pref));
2705
 
2706
      begin
2707
         --  In Ada 2005 (or later) if we have the standard nondefault
2708
         --  bit order, then we return the original value as given in
2709
         --  the component clause (RM 2005 13.5.2(4/2)).
2710
 
2711
         if Present (Component_Clause (CE))
2712
           and then Ada_Version >= Ada_2005
2713
           and then not Reverse_Bit_Order (Scope (CE))
2714
         then
2715
            Rewrite (N,
2716
              Make_Integer_Literal (Loc,
2717
                Intval => Expr_Value (Last_Bit (Component_Clause (CE)))));
2718
            Analyze_And_Resolve (N, Typ);
2719
 
2720
         --  Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order),
2721
         --  rewrite with normalized value if we know it statically.
2722
 
2723
         elsif Known_Static_Component_Bit_Offset (CE)
2724
           and then Known_Static_Esize (CE)
2725
         then
2726
            Rewrite (N,
2727
              Make_Integer_Literal (Loc,
2728
               Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
2729
                                + Esize (CE) - 1));
2730
            Analyze_And_Resolve (N, Typ);
2731
 
2732
         --  Otherwise leave to back end, just apply universal integer checks
2733
 
2734
         else
2735
            Apply_Universal_Integer_Attribute_Checks (N);
2736
         end if;
2737
      end Last_Bit_Attr;
2738
 
2739
      ------------------
2740
      -- Leading_Part --
2741
      ------------------
2742
 
2743
      --  Transforms 'Leading_Part into a call to the floating-point attribute
2744
      --  function Leading_Part in Fat_xxx (where xxx is the root type)
2745
 
2746
      --  Note: strictly, we should generate special case code to deal with
2747
      --  absurdly large positive arguments (greater than Integer'Last), which
2748
      --  result in returning the first argument unchanged, but it hardly seems
2749
      --  worth the effort. We raise constraint error for absurdly negative
2750
      --  arguments which is fine.
2751
 
2752
      when Attribute_Leading_Part =>
2753
         Expand_Fpt_Attribute_RI (N);
2754
 
2755
      ------------
2756
      -- Length --
2757
      ------------
2758
 
2759
      when Attribute_Length => declare
2760
         Ityp : Entity_Id;
2761
         Xnum : Uint;
2762
 
2763
      begin
2764
         --  Processing for packed array types
2765
 
2766
         if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
2767
            Ityp := Get_Index_Subtype (N);
2768
 
2769
            --  If the index type, Ityp, is an enumeration type with holes,
2770
            --  then we calculate X'Length explicitly using
2771
 
2772
            --     Typ'Max
2773
            --       (0, Ityp'Pos (X'Last  (N)) -
2774
            --           Ityp'Pos (X'First (N)) + 1);
2775
 
2776
            --  Since the bounds in the template are the representation values
2777
            --  and the back end would get the wrong value.
2778
 
2779
            if Is_Enumeration_Type (Ityp)
2780
              and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
2781
            then
2782
               if No (Exprs) then
2783
                  Xnum := Uint_1;
2784
               else
2785
                  Xnum := Expr_Value (First (Expressions (N)));
2786
               end if;
2787
 
2788
               Rewrite (N,
2789
                 Make_Attribute_Reference (Loc,
2790
                   Prefix         => New_Occurrence_Of (Typ, Loc),
2791
                   Attribute_Name => Name_Max,
2792
                   Expressions    => New_List
2793
                     (Make_Integer_Literal (Loc, 0),
2794
 
2795
                      Make_Op_Add (Loc,
2796
                        Left_Opnd =>
2797
                          Make_Op_Subtract (Loc,
2798
                            Left_Opnd =>
2799
                              Make_Attribute_Reference (Loc,
2800
                                Prefix => New_Occurrence_Of (Ityp, Loc),
2801
                                Attribute_Name => Name_Pos,
2802
 
2803
                                Expressions => New_List (
2804
                                  Make_Attribute_Reference (Loc,
2805
                                    Prefix => Duplicate_Subexpr (Pref),
2806
                                   Attribute_Name => Name_Last,
2807
                                    Expressions => New_List (
2808
                                      Make_Integer_Literal (Loc, Xnum))))),
2809
 
2810
                            Right_Opnd =>
2811
                              Make_Attribute_Reference (Loc,
2812
                                Prefix => New_Occurrence_Of (Ityp, Loc),
2813
                                Attribute_Name => Name_Pos,
2814
 
2815
                                Expressions => New_List (
2816
                                  Make_Attribute_Reference (Loc,
2817
                                    Prefix =>
2818
                                      Duplicate_Subexpr_No_Checks (Pref),
2819
                                   Attribute_Name => Name_First,
2820
                                    Expressions => New_List (
2821
                                      Make_Integer_Literal (Loc, Xnum)))))),
2822
 
2823
                        Right_Opnd => Make_Integer_Literal (Loc, 1)))));
2824
 
2825
               Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
2826
               return;
2827
 
2828
            --  If the prefix type is a constrained packed array type which
2829
            --  already has a Packed_Array_Type representation defined, then
2830
            --  replace this attribute with a direct reference to 'Range_Length
2831
            --  of the appropriate index subtype (since otherwise the back end
2832
            --  will try to give us the value of 'Length for this
2833
            --  implementation type).
2834
 
2835
            elsif Is_Constrained (Ptyp) then
2836
               Rewrite (N,
2837
                 Make_Attribute_Reference (Loc,
2838
                   Attribute_Name => Name_Range_Length,
2839
                   Prefix => New_Reference_To (Ityp, Loc)));
2840
               Analyze_And_Resolve (N, Typ);
2841
            end if;
2842
 
2843
         --  Access type case
2844
 
2845
         elsif Is_Access_Type (Ptyp) then
2846
            Apply_Access_Check (N);
2847
 
2848
            --  If the designated type is a packed array type, then we convert
2849
            --  the reference to:
2850
 
2851
            --    typ'Max (0, 1 +
2852
            --                xtyp'Pos (Pref'Last (Expr)) -
2853
            --                xtyp'Pos (Pref'First (Expr)));
2854
 
2855
            --  This is a bit complex, but it is the easiest thing to do that
2856
            --  works in all cases including enum types with holes xtyp here
2857
            --  is the appropriate index type.
2858
 
2859
            declare
2860
               Dtyp : constant Entity_Id := Designated_Type (Ptyp);
2861
               Xtyp : Entity_Id;
2862
 
2863
            begin
2864
               if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
2865
                  Xtyp := Get_Index_Subtype (N);
2866
 
2867
                  Rewrite (N,
2868
                    Make_Attribute_Reference (Loc,
2869
                      Prefix         => New_Occurrence_Of (Typ, Loc),
2870
                      Attribute_Name => Name_Max,
2871
                      Expressions    => New_List (
2872
                        Make_Integer_Literal (Loc, 0),
2873
 
2874
                        Make_Op_Add (Loc,
2875
                          Make_Integer_Literal (Loc, 1),
2876
                          Make_Op_Subtract (Loc,
2877
                            Left_Opnd =>
2878
                              Make_Attribute_Reference (Loc,
2879
                                Prefix => New_Occurrence_Of (Xtyp, Loc),
2880
                                Attribute_Name => Name_Pos,
2881
                                Expressions    => New_List (
2882
                                  Make_Attribute_Reference (Loc,
2883
                                    Prefix => Duplicate_Subexpr (Pref),
2884
                                    Attribute_Name => Name_Last,
2885
                                    Expressions =>
2886
                                      New_Copy_List (Exprs)))),
2887
 
2888
                            Right_Opnd =>
2889
                              Make_Attribute_Reference (Loc,
2890
                                Prefix => New_Occurrence_Of (Xtyp, Loc),
2891
                                Attribute_Name => Name_Pos,
2892
                                Expressions    => New_List (
2893
                                  Make_Attribute_Reference (Loc,
2894
                                    Prefix =>
2895
                                      Duplicate_Subexpr_No_Checks (Pref),
2896
                                    Attribute_Name => Name_First,
2897
                                    Expressions =>
2898
                                      New_Copy_List (Exprs)))))))));
2899
 
2900
                  Analyze_And_Resolve (N, Typ);
2901
               end if;
2902
            end;
2903
 
2904
         --  Otherwise leave it to the back end
2905
 
2906
         else
2907
            Apply_Universal_Integer_Attribute_Checks (N);
2908
         end if;
2909
      end;
2910
 
2911
      -------------
2912
      -- Machine --
2913
      -------------
2914
 
2915
      --  Transforms 'Machine into a call to the floating-point attribute
2916
      --  function Machine in Fat_xxx (where xxx is the root type)
2917
 
2918
      when Attribute_Machine =>
2919
         Expand_Fpt_Attribute_R (N);
2920
 
2921
      ----------------------
2922
      -- Machine_Rounding --
2923
      ----------------------
2924
 
2925
      --  Transforms 'Machine_Rounding into a call to the floating-point
2926
      --  attribute function Machine_Rounding in Fat_xxx (where xxx is the root
2927
      --  type). Expansion is avoided for cases the back end can handle
2928
      --  directly.
2929
 
2930
      when Attribute_Machine_Rounding =>
2931
         if not Is_Inline_Floating_Point_Attribute (N) then
2932
            Expand_Fpt_Attribute_R (N);
2933
         end if;
2934
 
2935
      ------------------
2936
      -- Machine_Size --
2937
      ------------------
2938
 
2939
      --  Machine_Size is equivalent to Object_Size, so transform it into
2940
      --  Object_Size and that way the back end never sees Machine_Size.
2941
 
2942
      when Attribute_Machine_Size =>
2943
         Rewrite (N,
2944
           Make_Attribute_Reference (Loc,
2945
             Prefix => Prefix (N),
2946
             Attribute_Name => Name_Object_Size));
2947
 
2948
         Analyze_And_Resolve (N, Typ);
2949
 
2950
      --------------
2951
      -- Mantissa --
2952
      --------------
2953
 
2954
      --  The only case that can get this far is the dynamic case of the old
2955
      --  Ada 83 Mantissa attribute for the fixed-point case. For this case,
2956
      --  we expand:
2957
 
2958
      --    typ'Mantissa
2959
 
2960
      --  into
2961
 
2962
      --    ityp (System.Mantissa.Mantissa_Value
2963
      --           (Integer'Integer_Value (typ'First),
2964
      --            Integer'Integer_Value (typ'Last)));
2965
 
2966
      when Attribute_Mantissa => Mantissa : begin
2967
         Rewrite (N,
2968
           Convert_To (Typ,
2969
             Make_Function_Call (Loc,
2970
               Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
2971
 
2972
               Parameter_Associations => New_List (
2973
 
2974
                 Make_Attribute_Reference (Loc,
2975
                   Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2976
                   Attribute_Name => Name_Integer_Value,
2977
                   Expressions => New_List (
2978
 
2979
                     Make_Attribute_Reference (Loc,
2980
                       Prefix => New_Occurrence_Of (Ptyp, Loc),
2981
                       Attribute_Name => Name_First))),
2982
 
2983
                 Make_Attribute_Reference (Loc,
2984
                   Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2985
                   Attribute_Name => Name_Integer_Value,
2986
                   Expressions => New_List (
2987
 
2988
                     Make_Attribute_Reference (Loc,
2989
                       Prefix => New_Occurrence_Of (Ptyp, Loc),
2990
                       Attribute_Name => Name_Last)))))));
2991
 
2992
         Analyze_And_Resolve (N, Typ);
2993
      end Mantissa;
2994
 
2995
      ----------------------------------
2996
      -- Max_Size_In_Storage_Elements --
2997
      ----------------------------------
2998
 
2999
      when Attribute_Max_Size_In_Storage_Elements =>
3000
         Apply_Universal_Integer_Attribute_Checks (N);
3001
 
3002
         --  Heap-allocated controlled objects contain two extra pointers which
3003
         --  are not part of the actual type. Transform the attribute reference
3004
         --  into a runtime expression to add the size of the hidden header.
3005
 
3006
         --  Do not perform this expansion on .NET/JVM targets because the
3007
         --  two pointers are already present in the type.
3008
 
3009
         if VM_Target = No_VM
3010
           and then Nkind (N) = N_Attribute_Reference
3011
           and then Needs_Finalization (Ptyp)
3012
           and then not Header_Size_Added (N)
3013
         then
3014
            Set_Header_Size_Added (N);
3015
 
3016
            --  Generate:
3017
            --    P'Max_Size_In_Storage_Elements +
3018
            --      Universal_Integer
3019
            --        (Header_Size_With_Padding (Ptyp'Alignment))
3020
 
3021
            Rewrite (N,
3022
              Make_Op_Add (Loc,
3023
                Left_Opnd  => Relocate_Node (N),
3024
                Right_Opnd =>
3025
                  Convert_To (Universal_Integer,
3026
                    Make_Function_Call (Loc,
3027
                      Name                   =>
3028
                        New_Reference_To
3029
                          (RTE (RE_Header_Size_With_Padding), Loc),
3030
 
3031
                      Parameter_Associations => New_List (
3032
                        Make_Attribute_Reference (Loc,
3033
                          Prefix         =>
3034
                            New_Reference_To (Ptyp, Loc),
3035
                          Attribute_Name => Name_Alignment))))));
3036
 
3037
            Analyze (N);
3038
            return;
3039
         end if;
3040
 
3041
      --------------------
3042
      -- Mechanism_Code --
3043
      --------------------
3044
 
3045
      when Attribute_Mechanism_Code =>
3046
 
3047
         --  We must replace the prefix in the renamed case
3048
 
3049
         if Is_Entity_Name (Pref)
3050
           and then Present (Alias (Entity (Pref)))
3051
         then
3052
            Set_Renamed_Subprogram (Pref, Alias (Entity (Pref)));
3053
         end if;
3054
 
3055
      ---------
3056
      -- Mod --
3057
      ---------
3058
 
3059
      when Attribute_Mod => Mod_Case : declare
3060
         Arg  : constant Node_Id := Relocate_Node (First (Exprs));
3061
         Hi   : constant Node_Id := Type_High_Bound (Etype (Arg));
3062
         Modv : constant Uint    := Modulus (Btyp);
3063
 
3064
      begin
3065
 
3066
         --  This is not so simple. The issue is what type to use for the
3067
         --  computation of the modular value.
3068
 
3069
         --  The easy case is when the modulus value is within the bounds
3070
         --  of the signed integer type of the argument. In this case we can
3071
         --  just do the computation in that signed integer type, and then
3072
         --  do an ordinary conversion to the target type.
3073
 
3074
         if Modv <= Expr_Value (Hi) then
3075
            Rewrite (N,
3076
              Convert_To (Btyp,
3077
                Make_Op_Mod (Loc,
3078
                  Left_Opnd  => Arg,
3079
                  Right_Opnd => Make_Integer_Literal (Loc, Modv))));
3080
 
3081
         --  Here we know that the modulus is larger than type'Last of the
3082
         --  integer type. There are two cases to consider:
3083
 
3084
         --    a) The integer value is non-negative. In this case, it is
3085
         --    returned as the result (since it is less than the modulus).
3086
 
3087
         --    b) The integer value is negative. In this case, we know that the
3088
         --    result is modulus + value, where the value might be as small as
3089
         --    -modulus. The trouble is what type do we use to do the subtract.
3090
         --    No type will do, since modulus can be as big as 2**64, and no
3091
         --    integer type accommodates this value. Let's do bit of algebra
3092
 
3093
         --         modulus + value
3094
         --      =  modulus - (-value)
3095
         --      =  (modulus - 1) - (-value - 1)
3096
 
3097
         --    Now modulus - 1 is certainly in range of the modular type.
3098
         --    -value is in the range 1 .. modulus, so -value -1 is in the
3099
         --    range 0 .. modulus-1 which is in range of the modular type.
3100
         --    Furthermore, (-value - 1) can be expressed as -(value + 1)
3101
         --    which we can compute using the integer base type.
3102
 
3103
         --  Once this is done we analyze the conditional expression without
3104
         --  range checks, because we know everything is in range, and we
3105
         --  want to prevent spurious warnings on either branch.
3106
 
3107
         else
3108
            Rewrite (N,
3109
              Make_Conditional_Expression (Loc,
3110
                Expressions => New_List (
3111
                  Make_Op_Ge (Loc,
3112
                    Left_Opnd  => Duplicate_Subexpr (Arg),
3113
                    Right_Opnd => Make_Integer_Literal (Loc, 0)),
3114
 
3115
                  Convert_To (Btyp,
3116
                    Duplicate_Subexpr_No_Checks (Arg)),
3117
 
3118
                  Make_Op_Subtract (Loc,
3119
                    Left_Opnd =>
3120
                      Make_Integer_Literal (Loc,
3121
                        Intval => Modv - 1),
3122
                    Right_Opnd =>
3123
                      Convert_To (Btyp,
3124
                        Make_Op_Minus (Loc,
3125
                          Right_Opnd =>
3126
                            Make_Op_Add (Loc,
3127
                              Left_Opnd  => Duplicate_Subexpr_No_Checks (Arg),
3128
                              Right_Opnd =>
3129
                                Make_Integer_Literal (Loc,
3130
                                  Intval => 1))))))));
3131
 
3132
         end if;
3133
 
3134
         Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
3135
      end Mod_Case;
3136
 
3137
      -----------
3138
      -- Model --
3139
      -----------
3140
 
3141
      --  Transforms 'Model into a call to the floating-point attribute
3142
      --  function Model in Fat_xxx (where xxx is the root type)
3143
 
3144
      when Attribute_Model =>
3145
         Expand_Fpt_Attribute_R (N);
3146
 
3147
      -----------------
3148
      -- Object_Size --
3149
      -----------------
3150
 
3151
      --  The processing for Object_Size shares the processing for Size
3152
 
3153
      ---------
3154
      -- Old --
3155
      ---------
3156
 
3157
      when Attribute_Old => Old : declare
3158
         Tnn     : constant Entity_Id := Make_Temporary (Loc, 'T', Pref);
3159
         Subp    : Node_Id;
3160
         Asn_Stm : Node_Id;
3161
 
3162
      begin
3163
         --  Find the nearest subprogram body, ignoring _Preconditions
3164
 
3165
         Subp := N;
3166
         loop
3167
            Subp := Parent (Subp);
3168
            exit when Nkind (Subp) = N_Subprogram_Body
3169
              and then Chars (Defining_Entity (Subp)) /= Name_uPostconditions;
3170
         end loop;
3171
 
3172
         --  Insert the initialized object declaration at the start of the
3173
         --  subprogram's declarations.
3174
 
3175
         Asn_Stm :=
3176
           Make_Object_Declaration (Loc,
3177
             Defining_Identifier => Tnn,
3178
             Constant_Present    => True,
3179
             Object_Definition   => New_Occurrence_Of (Etype (N), Loc),
3180
             Expression          => Pref);
3181
 
3182
         --  Push the subprogram's scope, so that the object will be analyzed
3183
         --  in that context (rather than the context of the Precondition
3184
         --  subprogram) and will have its Scope set properly.
3185
 
3186
         if Present (Corresponding_Spec (Subp)) then
3187
            Push_Scope (Corresponding_Spec (Subp));
3188
         else
3189
            Push_Scope (Defining_Entity (Subp));
3190
         end if;
3191
 
3192
         if Is_Empty_List (Declarations (Subp)) then
3193
            Set_Declarations (Subp, New_List (Asn_Stm));
3194
            Analyze (Asn_Stm);
3195
         else
3196
            Insert_Action (First (Declarations (Subp)), Asn_Stm);
3197
         end if;
3198
 
3199
         Pop_Scope;
3200
 
3201
         Rewrite (N, New_Occurrence_Of (Tnn, Loc));
3202
      end Old;
3203
 
3204
      ----------------------
3205
      -- Overlaps_Storage --
3206
      ----------------------
3207
 
3208
      when Attribute_Overlaps_Storage => Overlaps_Storage : declare
3209
         Loc : constant Source_Ptr := Sloc (N);
3210
 
3211
         X   : constant Node_Id := Prefix (N);
3212
         Y   : constant Node_Id := First (Expressions (N));
3213
         --  The argumens
3214
 
3215
         X_Addr, Y_Addr : Node_Id;
3216
         --  the expressions for their integer addresses
3217
 
3218
         X_Size, Y_Size : Node_Id;
3219
         --  the expressions for their sizes
3220
 
3221
         Cond : Node_Id;
3222
 
3223
      begin
3224
         --  Attribute expands into:
3225
 
3226
         --    if X'Address < Y'address then
3227
         --      (X'address + X'Size - 1) >= Y'address
3228
         --    else
3229
         --      (Y'address + Y'size - 1) >= X'Address
3230
         --    end if;
3231
 
3232
         --  with the proper address operations. We convert addresses to
3233
         --  integer addresses to use predefined arithmetic. The size is
3234
         --  expressed in storage units.
3235
 
3236
         X_Addr :=
3237
           Unchecked_Convert_To (RTE (RE_Integer_Address),
3238
             Make_Attribute_Reference (Loc,
3239
               Attribute_Name => Name_Address,
3240
               Prefix         => New_Copy_Tree (X)));
3241
 
3242
         Y_Addr :=
3243
           Unchecked_Convert_To (RTE (RE_Integer_Address),
3244
             Make_Attribute_Reference (Loc,
3245
               Attribute_Name => Name_Address,
3246
               Prefix         => New_Copy_Tree (Y)));
3247
 
3248
         X_Size :=
3249
           Make_Op_Divide (Loc,
3250
             Left_Opnd  =>
3251
               Make_Attribute_Reference (Loc,
3252
                 Attribute_Name => Name_Size,
3253
                 Prefix         => New_Copy_Tree (X)),
3254
             Right_Opnd =>
3255
               Make_Integer_Literal (Loc, System_Storage_Unit));
3256
 
3257
         Y_Size :=
3258
           Make_Op_Divide (Loc,
3259
             Left_Opnd  =>
3260
               Make_Attribute_Reference (Loc,
3261
                 Attribute_Name => Name_Size,
3262
                 Prefix         => New_Copy_Tree (Y)),
3263
             Right_Opnd =>
3264
               Make_Integer_Literal (Loc, System_Storage_Unit));
3265
 
3266
         Cond :=
3267
            Make_Op_Le (Loc,
3268
              Left_Opnd  => X_Addr,
3269
              Right_Opnd => Y_Addr);
3270
 
3271
         Rewrite (N,
3272
           Make_Conditional_Expression (Loc,
3273
             New_List (
3274
               Cond,
3275
 
3276
               Make_Op_Ge (Loc,
3277
                  Left_Opnd   =>
3278
                   Make_Op_Add (Loc,
3279
                     Left_Opnd  => X_Addr,
3280
                     Right_Opnd =>
3281
                       Make_Op_Subtract (Loc,
3282
                         Left_Opnd  => X_Size,
3283
                         Right_Opnd => Make_Integer_Literal (Loc, 1))),
3284
                  Right_Opnd => Y_Addr),
3285
 
3286
               Make_Op_Ge (Loc,
3287
                   Make_Op_Add (Loc,
3288
                     Left_Opnd  => Y_Addr,
3289
                     Right_Opnd =>
3290
                       Make_Op_Subtract (Loc,
3291
                         Left_Opnd  => Y_Size,
3292
                         Right_Opnd => Make_Integer_Literal (Loc, 1))),
3293
                  Right_Opnd => X_Addr))));
3294
 
3295
         Analyze_And_Resolve (N, Standard_Boolean);
3296
      end Overlaps_Storage;
3297
 
3298
      ------------
3299
      -- Output --
3300
      ------------
3301
 
3302
      when Attribute_Output => Output : declare
3303
         P_Type : constant Entity_Id := Entity (Pref);
3304
         U_Type : constant Entity_Id := Underlying_Type (P_Type);
3305
         Pname  : Entity_Id;
3306
         Decl   : Node_Id;
3307
         Prag   : Node_Id;
3308
         Arg3   : Node_Id;
3309
         Wfunc  : Node_Id;
3310
 
3311
      begin
3312
         --  If no underlying type, we have an error that will be diagnosed
3313
         --  elsewhere, so here we just completely ignore the expansion.
3314
 
3315
         if No (U_Type) then
3316
            return;
3317
         end if;
3318
 
3319
         --  If TSS for Output is present, just call it
3320
 
3321
         Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
3322
 
3323
         if Present (Pname) then
3324
            null;
3325
 
3326
         else
3327
            --  If there is a Stream_Convert pragma, use it, we rewrite
3328
 
3329
            --     sourcetyp'Output (stream, Item)
3330
 
3331
            --  as
3332
 
3333
            --     strmtyp'Output (Stream, strmwrite (acttyp (Item)));
3334
 
3335
            --  where strmwrite is the given Write function that converts an
3336
            --  argument of type sourcetyp or a type acctyp, from which it is
3337
            --  derived to type strmtyp. The conversion to acttyp is required
3338
            --  for the derived case.
3339
 
3340
            Prag := Get_Stream_Convert_Pragma (P_Type);
3341
 
3342
            if Present (Prag) then
3343
               Arg3 :=
3344
                 Next (Next (First (Pragma_Argument_Associations (Prag))));
3345
               Wfunc := Entity (Expression (Arg3));
3346
 
3347
               Rewrite (N,
3348
                 Make_Attribute_Reference (Loc,
3349
                   Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
3350
                   Attribute_Name => Name_Output,
3351
                   Expressions => New_List (
3352
                   Relocate_Node (First (Exprs)),
3353
                     Make_Function_Call (Loc,
3354
                       Name => New_Occurrence_Of (Wfunc, Loc),
3355
                       Parameter_Associations => New_List (
3356
                         OK_Convert_To (Etype (First_Formal (Wfunc)),
3357
                           Relocate_Node (Next (First (Exprs)))))))));
3358
 
3359
               Analyze (N);
3360
               return;
3361
 
3362
            --  For elementary types, we call the W_xxx routine directly.
3363
            --  Note that the effect of Write and Output is identical for
3364
            --  the case of an elementary type, since there are no
3365
            --  discriminants or bounds.
3366
 
3367
            elsif Is_Elementary_Type (U_Type) then
3368
 
3369
               --  A special case arises if we have a defined _Write routine,
3370
               --  since in this case we are required to call this routine.
3371
 
3372
               if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
3373
                  Build_Record_Or_Elementary_Output_Procedure
3374
                    (Loc, U_Type, Decl, Pname);
3375
                  Insert_Action (N, Decl);
3376
 
3377
               --  For normal cases, we call the W_xxx routine directly
3378
 
3379
               else
3380
                  Rewrite (N, Build_Elementary_Write_Call (N));
3381
                  Analyze (N);
3382
                  return;
3383
               end if;
3384
 
3385
            --  Array type case
3386
 
3387
            elsif Is_Array_Type (U_Type) then
3388
               Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
3389
               Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3390
 
3391
            --  Class-wide case, first output external tag, then dispatch
3392
            --  to the appropriate primitive Output function (RM 13.13.2(31)).
3393
 
3394
            elsif Is_Class_Wide_Type (P_Type) then
3395
 
3396
               --  No need to do anything else compiling under restriction
3397
               --  No_Dispatching_Calls. During the semantic analysis we
3398
               --  already notified such violation.
3399
 
3400
               if Restriction_Active (No_Dispatching_Calls) then
3401
                  return;
3402
               end if;
3403
 
3404
               Tag_Write : declare
3405
                  Strm : constant Node_Id := First (Exprs);
3406
                  Item : constant Node_Id := Next (Strm);
3407
 
3408
               begin
3409
                  --  Ada 2005 (AI-344): Check that the accessibility level
3410
                  --  of the type of the output object is not deeper than
3411
                  --  that of the attribute's prefix type.
3412
 
3413
                  --  if Get_Access_Level (Item'Tag)
3414
                  --       /= Get_Access_Level (P_Type'Tag)
3415
                  --  then
3416
                  --     raise Tag_Error;
3417
                  --  end if;
3418
 
3419
                  --  String'Output (Strm, External_Tag (Item'Tag));
3420
 
3421
                  --  We cannot figure out a practical way to implement this
3422
                  --  accessibility check on virtual machines, so we omit it.
3423
 
3424
                  if Ada_Version >= Ada_2005
3425
                    and then Tagged_Type_Expansion
3426
                  then
3427
                     Insert_Action (N,
3428
                       Make_Implicit_If_Statement (N,
3429
                         Condition =>
3430
                           Make_Op_Ne (Loc,
3431
                             Left_Opnd  =>
3432
                               Build_Get_Access_Level (Loc,
3433
                                 Make_Attribute_Reference (Loc,
3434
                                   Prefix         =>
3435
                                     Relocate_Node (
3436
                                       Duplicate_Subexpr (Item,
3437
                                         Name_Req => True)),
3438
                                   Attribute_Name => Name_Tag)),
3439
 
3440
                             Right_Opnd =>
3441
                               Make_Integer_Literal (Loc,
3442
                                 Type_Access_Level (P_Type))),
3443
 
3444
                         Then_Statements =>
3445
                           New_List (Make_Raise_Statement (Loc,
3446
                                       New_Occurrence_Of (
3447
                                         RTE (RE_Tag_Error), Loc)))));
3448
                  end if;
3449
 
3450
                  Insert_Action (N,
3451
                    Make_Attribute_Reference (Loc,
3452
                      Prefix => New_Occurrence_Of (Standard_String, Loc),
3453
                      Attribute_Name => Name_Output,
3454
                      Expressions => New_List (
3455
                        Relocate_Node (Duplicate_Subexpr (Strm)),
3456
                        Make_Function_Call (Loc,
3457
                          Name =>
3458
                            New_Occurrence_Of (RTE (RE_External_Tag), Loc),
3459
                          Parameter_Associations => New_List (
3460
                           Make_Attribute_Reference (Loc,
3461
                             Prefix =>
3462
                               Relocate_Node
3463
                                 (Duplicate_Subexpr (Item, Name_Req => True)),
3464
                             Attribute_Name => Name_Tag))))));
3465
               end Tag_Write;
3466
 
3467
               Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
3468
 
3469
            --  Tagged type case, use the primitive Output function
3470
 
3471
            elsif Is_Tagged_Type (U_Type) then
3472
               Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
3473
 
3474
            --  All other record type cases, including protected records.
3475
            --  The latter only arise for expander generated code for
3476
            --  handling shared passive partition access.
3477
 
3478
            else
3479
               pragma Assert
3480
                 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3481
 
3482
               --  Ada 2005 (AI-216): Program_Error is raised when executing
3483
               --  the default implementation of the Output attribute of an
3484
               --  unchecked union type if the type lacks default discriminant
3485
               --  values.
3486
 
3487
               if Is_Unchecked_Union (Base_Type (U_Type))
3488
                 and then No (Discriminant_Constraint (U_Type))
3489
               then
3490
                  Insert_Action (N,
3491
                    Make_Raise_Program_Error (Loc,
3492
                      Reason => PE_Unchecked_Union_Restriction));
3493
 
3494
                  return;
3495
               end if;
3496
 
3497
               Build_Record_Or_Elementary_Output_Procedure
3498
                 (Loc, Base_Type (U_Type), Decl, Pname);
3499
               Insert_Action (N, Decl);
3500
            end if;
3501
         end if;
3502
 
3503
         --  If we fall through, Pname is the name of the procedure to call
3504
 
3505
         Rewrite_Stream_Proc_Call (Pname);
3506
      end Output;
3507
 
3508
      ---------
3509
      -- Pos --
3510
      ---------
3511
 
3512
      --  For enumeration types with a standard representation, Pos is
3513
      --  handled by the back end.
3514
 
3515
      --  For enumeration types, with a non-standard representation we generate
3516
      --  a call to the _Rep_To_Pos function created when the type was frozen.
3517
      --  The call has the form
3518
 
3519
      --    _rep_to_pos (expr, flag)
3520
 
3521
      --  The parameter flag is True if range checks are enabled, causing
3522
      --  Program_Error to be raised if the expression has an invalid
3523
      --  representation, and False if range checks are suppressed.
3524
 
3525
      --  For integer types, Pos is equivalent to a simple integer
3526
      --  conversion and we rewrite it as such
3527
 
3528
      when Attribute_Pos => Pos :
3529
      declare
3530
         Etyp : Entity_Id := Base_Type (Entity (Pref));
3531
 
3532
      begin
3533
         --  Deal with zero/non-zero boolean values
3534
 
3535
         if Is_Boolean_Type (Etyp) then
3536
            Adjust_Condition (First (Exprs));
3537
            Etyp := Standard_Boolean;
3538
            Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
3539
         end if;
3540
 
3541
         --  Case of enumeration type
3542
 
3543
         if Is_Enumeration_Type (Etyp) then
3544
 
3545
            --  Non-standard enumeration type (generate call)
3546
 
3547
            if Present (Enum_Pos_To_Rep (Etyp)) then
3548
               Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
3549
               Rewrite (N,
3550
                 Convert_To (Typ,
3551
                   Make_Function_Call (Loc,
3552
                     Name =>
3553
                       New_Reference_To (TSS (Etyp, TSS_Rep_To_Pos), Loc),
3554
                     Parameter_Associations => Exprs)));
3555
 
3556
               Analyze_And_Resolve (N, Typ);
3557
 
3558
            --  Standard enumeration type (do universal integer check)
3559
 
3560
            else
3561
               Apply_Universal_Integer_Attribute_Checks (N);
3562
            end if;
3563
 
3564
         --  Deal with integer types (replace by conversion)
3565
 
3566
         elsif Is_Integer_Type (Etyp) then
3567
            Rewrite (N, Convert_To (Typ, First (Exprs)));
3568
            Analyze_And_Resolve (N, Typ);
3569
         end if;
3570
 
3571
      end Pos;
3572
 
3573
      --------------
3574
      -- Position --
3575
      --------------
3576
 
3577
      --  We compute this if a component clause was present, otherwise we leave
3578
      --  the computation up to the back end, since we don't know what layout
3579
      --  will be chosen.
3580
 
3581
      when Attribute_Position => Position_Attr :
3582
      declare
3583
         CE : constant Entity_Id := Entity (Selector_Name (Pref));
3584
 
3585
      begin
3586
         if Present (Component_Clause (CE)) then
3587
 
3588
            --  In Ada 2005 (or later) if we have the standard nondefault
3589
            --  bit order, then we return the original value as given in
3590
            --  the component clause (RM 2005 13.5.2(2/2)).
3591
 
3592
            if Ada_Version >= Ada_2005
3593
              and then not Reverse_Bit_Order (Scope (CE))
3594
            then
3595
               Rewrite (N,
3596
                  Make_Integer_Literal (Loc,
3597
                    Intval => Expr_Value (Position (Component_Clause (CE)))));
3598
 
3599
            --  Otherwise (Ada 83 or 95, or reverse bit order specified in
3600
            --  later Ada version), return the normalized value.
3601
 
3602
            else
3603
               Rewrite (N,
3604
                 Make_Integer_Literal (Loc,
3605
                   Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
3606
            end if;
3607
 
3608
            Analyze_And_Resolve (N, Typ);
3609
 
3610
         --  If back end is doing things, just apply universal integer checks
3611
 
3612
         else
3613
            Apply_Universal_Integer_Attribute_Checks (N);
3614
         end if;
3615
      end Position_Attr;
3616
 
3617
      ----------
3618
      -- Pred --
3619
      ----------
3620
 
3621
      --  1. Deal with enumeration types with holes
3622
      --  2. For floating-point, generate call to attribute function
3623
      --  3. For other cases, deal with constraint checking
3624
 
3625
      when Attribute_Pred => Pred :
3626
      declare
3627
         Etyp : constant Entity_Id := Base_Type (Ptyp);
3628
 
3629
      begin
3630
 
3631
         --  For enumeration types with non-standard representations, we
3632
         --  expand typ'Pred (x) into
3633
 
3634
         --    Pos_To_Rep (Rep_To_Pos (x) - 1)
3635
 
3636
         --    If the representation is contiguous, we compute instead
3637
         --    Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
3638
         --    The conversion function Enum_Pos_To_Rep is defined on the
3639
         --    base type, not the subtype, so we have to use the base type
3640
         --    explicitly for this and other enumeration attributes.
3641
 
3642
         if Is_Enumeration_Type (Ptyp)
3643
           and then Present (Enum_Pos_To_Rep (Etyp))
3644
         then
3645
            if Has_Contiguous_Rep (Etyp) then
3646
               Rewrite (N,
3647
                  Unchecked_Convert_To (Ptyp,
3648
                     Make_Op_Add (Loc,
3649
                        Left_Opnd  =>
3650
                         Make_Integer_Literal (Loc,
3651
                           Enumeration_Rep (First_Literal (Ptyp))),
3652
                        Right_Opnd =>
3653
                          Make_Function_Call (Loc,
3654
                            Name =>
3655
                              New_Reference_To
3656
                               (TSS (Etyp, TSS_Rep_To_Pos), Loc),
3657
 
3658
                            Parameter_Associations =>
3659
                              New_List (
3660
                                Unchecked_Convert_To (Ptyp,
3661
                                  Make_Op_Subtract (Loc,
3662
                                    Left_Opnd =>
3663
                                     Unchecked_Convert_To (Standard_Integer,
3664
                                       Relocate_Node (First (Exprs))),
3665
                                    Right_Opnd =>
3666
                                      Make_Integer_Literal (Loc, 1))),
3667
                                Rep_To_Pos_Flag (Ptyp, Loc))))));
3668
 
3669
            else
3670
               --  Add Boolean parameter True, to request program errror if
3671
               --  we have a bad representation on our hands. If checks are
3672
               --  suppressed, then add False instead
3673
 
3674
               Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
3675
               Rewrite (N,
3676
                 Make_Indexed_Component (Loc,
3677
                   Prefix =>
3678
                     New_Reference_To
3679
                       (Enum_Pos_To_Rep (Etyp), Loc),
3680
                   Expressions => New_List (
3681
                     Make_Op_Subtract (Loc,
3682
                    Left_Opnd =>
3683
                      Make_Function_Call (Loc,
3684
                        Name =>
3685
                          New_Reference_To
3686
                            (TSS (Etyp, TSS_Rep_To_Pos), Loc),
3687
                          Parameter_Associations => Exprs),
3688
                    Right_Opnd => Make_Integer_Literal (Loc, 1)))));
3689
            end if;
3690
 
3691
            Analyze_And_Resolve (N, Typ);
3692
 
3693
         --  For floating-point, we transform 'Pred into a call to the Pred
3694
         --  floating-point attribute function in Fat_xxx (xxx is root type)
3695
 
3696
         elsif Is_Floating_Point_Type (Ptyp) then
3697
            Expand_Fpt_Attribute_R (N);
3698
            Analyze_And_Resolve (N, Typ);
3699
 
3700
         --  For modular types, nothing to do (no overflow, since wraps)
3701
 
3702
         elsif Is_Modular_Integer_Type (Ptyp) then
3703
            null;
3704
 
3705
         --  For other types, if argument is marked as needing a range check or
3706
         --  overflow checking is enabled, we must generate a check.
3707
 
3708
         elsif not Overflow_Checks_Suppressed (Ptyp)
3709
           or else Do_Range_Check (First (Exprs))
3710
         then
3711
            Set_Do_Range_Check (First (Exprs), False);
3712
            Expand_Pred_Succ (N);
3713
         end if;
3714
      end Pred;
3715
 
3716
      --------------
3717
      -- Priority --
3718
      --------------
3719
 
3720
      --  Ada 2005 (AI-327): Dynamic ceiling priorities
3721
 
3722
      --  We rewrite X'Priority as the following run-time call:
3723
 
3724
      --     Get_Ceiling (X._Object)
3725
 
3726
      --  Note that although X'Priority is notionally an object, it is quite
3727
      --  deliberately not defined as an aliased object in the RM. This means
3728
      --  that it works fine to rewrite it as a call, without having to worry
3729
      --  about complications that would other arise from X'Priority'Access,
3730
      --  which is illegal, because of the lack of aliasing.
3731
 
3732
      when Attribute_Priority =>
3733
         declare
3734
            Call           : Node_Id;
3735
            Conctyp        : Entity_Id;
3736
            Object_Parm    : Node_Id;
3737
            Subprg         : Entity_Id;
3738
            RT_Subprg_Name : Node_Id;
3739
 
3740
         begin
3741
            --  Look for the enclosing concurrent type
3742
 
3743
            Conctyp := Current_Scope;
3744
            while not Is_Concurrent_Type (Conctyp) loop
3745
               Conctyp := Scope (Conctyp);
3746
            end loop;
3747
 
3748
            pragma Assert (Is_Protected_Type (Conctyp));
3749
 
3750
            --  Generate the actual of the call
3751
 
3752
            Subprg := Current_Scope;
3753
            while not Present (Protected_Body_Subprogram (Subprg)) loop
3754
               Subprg := Scope (Subprg);
3755
            end loop;
3756
 
3757
            --  Use of 'Priority inside protected entries and barriers (in
3758
            --  both cases the type of the first formal of their expanded
3759
            --  subprogram is Address)
3760
 
3761
            if Etype (First_Entity (Protected_Body_Subprogram (Subprg)))
3762
              = RTE (RE_Address)
3763
            then
3764
               declare
3765
                  New_Itype : Entity_Id;
3766
 
3767
               begin
3768
                  --  In the expansion of protected entries the type of the
3769
                  --  first formal of the Protected_Body_Subprogram is an
3770
                  --  Address. In order to reference the _object component
3771
                  --  we generate:
3772
 
3773
                  --    type T is access p__ptTV;
3774
                  --    freeze T []
3775
 
3776
                  New_Itype := Create_Itype (E_Access_Type, N);
3777
                  Set_Etype (New_Itype, New_Itype);
3778
                  Set_Directly_Designated_Type (New_Itype,
3779
                    Corresponding_Record_Type (Conctyp));
3780
                  Freeze_Itype (New_Itype, N);
3781
 
3782
                  --  Generate:
3783
                  --    T!(O)._object'unchecked_access
3784
 
3785
                  Object_Parm :=
3786
                    Make_Attribute_Reference (Loc,
3787
                      Prefix =>
3788
                        Make_Selected_Component (Loc,
3789
                          Prefix =>
3790
                            Unchecked_Convert_To (New_Itype,
3791
                              New_Reference_To
3792
                                (First_Entity
3793
                                  (Protected_Body_Subprogram (Subprg)),
3794
                                 Loc)),
3795
                          Selector_Name =>
3796
                            Make_Identifier (Loc, Name_uObject)),
3797
                       Attribute_Name => Name_Unchecked_Access);
3798
               end;
3799
 
3800
            --  Use of 'Priority inside a protected subprogram
3801
 
3802
            else
3803
               Object_Parm :=
3804
                 Make_Attribute_Reference (Loc,
3805
                    Prefix =>
3806
                      Make_Selected_Component (Loc,
3807
                        Prefix => New_Reference_To
3808
                                    (First_Entity
3809
                                      (Protected_Body_Subprogram (Subprg)),
3810
                                       Loc),
3811
                        Selector_Name => Make_Identifier (Loc, Name_uObject)),
3812
                    Attribute_Name => Name_Unchecked_Access);
3813
            end if;
3814
 
3815
            --  Select the appropriate run-time subprogram
3816
 
3817
            if Number_Entries (Conctyp) = 0 then
3818
               RT_Subprg_Name :=
3819
                 New_Reference_To (RTE (RE_Get_Ceiling), Loc);
3820
            else
3821
               RT_Subprg_Name :=
3822
                 New_Reference_To (RTE (RO_PE_Get_Ceiling), Loc);
3823
            end if;
3824
 
3825
            Call :=
3826
              Make_Function_Call (Loc,
3827
                Name => RT_Subprg_Name,
3828
                Parameter_Associations => New_List (Object_Parm));
3829
 
3830
            Rewrite (N, Call);
3831
 
3832
            --  Avoid the generation of extra checks on the pointer to the
3833
            --  protected object.
3834
 
3835
            Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
3836
         end;
3837
 
3838
      ------------------
3839
      -- Range_Length --
3840
      ------------------
3841
 
3842
      when Attribute_Range_Length => Range_Length : begin
3843
 
3844
         --  The only special processing required is for the case where
3845
         --  Range_Length is applied to an enumeration type with holes.
3846
         --  In this case we transform
3847
 
3848
         --     X'Range_Length
3849
 
3850
         --  to
3851
 
3852
         --     X'Pos (X'Last) - X'Pos (X'First) + 1
3853
 
3854
         --  So that the result reflects the proper Pos values instead
3855
         --  of the underlying representations.
3856
 
3857
         if Is_Enumeration_Type (Ptyp)
3858
           and then Has_Non_Standard_Rep (Ptyp)
3859
         then
3860
            Rewrite (N,
3861
              Make_Op_Add (Loc,
3862
                Left_Opnd =>
3863
                  Make_Op_Subtract (Loc,
3864
                    Left_Opnd =>
3865
                      Make_Attribute_Reference (Loc,
3866
                        Attribute_Name => Name_Pos,
3867
                        Prefix => New_Occurrence_Of (Ptyp, Loc),
3868
                        Expressions => New_List (
3869
                          Make_Attribute_Reference (Loc,
3870
                            Attribute_Name => Name_Last,
3871
                            Prefix => New_Occurrence_Of (Ptyp, Loc)))),
3872
 
3873
                    Right_Opnd =>
3874
                      Make_Attribute_Reference (Loc,
3875
                        Attribute_Name => Name_Pos,
3876
                        Prefix => New_Occurrence_Of (Ptyp, Loc),
3877
                        Expressions => New_List (
3878
                          Make_Attribute_Reference (Loc,
3879
                            Attribute_Name => Name_First,
3880
                            Prefix => New_Occurrence_Of (Ptyp, Loc))))),
3881
 
3882
                Right_Opnd => Make_Integer_Literal (Loc, 1)));
3883
 
3884
            Analyze_And_Resolve (N, Typ);
3885
 
3886
         --  For all other cases, the attribute is handled by the back end, but
3887
         --  we need to deal with the case of the range check on a universal
3888
         --  integer.
3889
 
3890
         else
3891
            Apply_Universal_Integer_Attribute_Checks (N);
3892
         end if;
3893
      end Range_Length;
3894
 
3895
      ----------
3896
      -- Read --
3897
      ----------
3898
 
3899
      when Attribute_Read => Read : declare
3900
         P_Type : constant Entity_Id := Entity (Pref);
3901
         B_Type : constant Entity_Id := Base_Type (P_Type);
3902
         U_Type : constant Entity_Id := Underlying_Type (P_Type);
3903
         Pname  : Entity_Id;
3904
         Decl   : Node_Id;
3905
         Prag   : Node_Id;
3906
         Arg2   : Node_Id;
3907
         Rfunc  : Node_Id;
3908
         Lhs    : Node_Id;
3909
         Rhs    : Node_Id;
3910
 
3911
      begin
3912
         --  If no underlying type, we have an error that will be diagnosed
3913
         --  elsewhere, so here we just completely ignore the expansion.
3914
 
3915
         if No (U_Type) then
3916
            return;
3917
         end if;
3918
 
3919
         --  The simple case, if there is a TSS for Read, just call it
3920
 
3921
         Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
3922
 
3923
         if Present (Pname) then
3924
            null;
3925
 
3926
         else
3927
            --  If there is a Stream_Convert pragma, use it, we rewrite
3928
 
3929
            --     sourcetyp'Read (stream, Item)
3930
 
3931
            --  as
3932
 
3933
            --     Item := sourcetyp (strmread (strmtyp'Input (Stream)));
3934
 
3935
            --  where strmread is the given Read function that converts an
3936
            --  argument of type strmtyp to type sourcetyp or a type from which
3937
            --  it is derived. The conversion to sourcetyp is required in the
3938
            --  latter case.
3939
 
3940
            --  A special case arises if Item is a type conversion in which
3941
            --  case, we have to expand to:
3942
 
3943
            --     Itemx := typex (strmread (strmtyp'Input (Stream)));
3944
 
3945
            --  where Itemx is the expression of the type conversion (i.e.
3946
            --  the actual object), and typex is the type of Itemx.
3947
 
3948
            Prag := Get_Stream_Convert_Pragma (P_Type);
3949
 
3950
            if Present (Prag) then
3951
               Arg2  := Next (First (Pragma_Argument_Associations (Prag)));
3952
               Rfunc := Entity (Expression (Arg2));
3953
               Lhs := Relocate_Node (Next (First (Exprs)));
3954
               Rhs :=
3955
                 OK_Convert_To (B_Type,
3956
                   Make_Function_Call (Loc,
3957
                     Name => New_Occurrence_Of (Rfunc, Loc),
3958
                     Parameter_Associations => New_List (
3959
                       Make_Attribute_Reference (Loc,
3960
                         Prefix =>
3961
                           New_Occurrence_Of
3962
                             (Etype (First_Formal (Rfunc)), Loc),
3963
                         Attribute_Name => Name_Input,
3964
                         Expressions => New_List (
3965
                           Relocate_Node (First (Exprs)))))));
3966
 
3967
               if Nkind (Lhs) = N_Type_Conversion then
3968
                  Lhs := Expression (Lhs);
3969
                  Rhs := Convert_To (Etype (Lhs), Rhs);
3970
               end if;
3971
 
3972
               Rewrite (N,
3973
                 Make_Assignment_Statement (Loc,
3974
                   Name       => Lhs,
3975
                   Expression => Rhs));
3976
               Set_Assignment_OK (Lhs);
3977
               Analyze (N);
3978
               return;
3979
 
3980
            --  For elementary types, we call the I_xxx routine using the first
3981
            --  parameter and then assign the result into the second parameter.
3982
            --  We set Assignment_OK to deal with the conversion case.
3983
 
3984
            elsif Is_Elementary_Type (U_Type) then
3985
               declare
3986
                  Lhs : Node_Id;
3987
                  Rhs : Node_Id;
3988
 
3989
               begin
3990
                  Lhs := Relocate_Node (Next (First (Exprs)));
3991
                  Rhs := Build_Elementary_Input_Call (N);
3992
 
3993
                  if Nkind (Lhs) = N_Type_Conversion then
3994
                     Lhs := Expression (Lhs);
3995
                     Rhs := Convert_To (Etype (Lhs), Rhs);
3996
                  end if;
3997
 
3998
                  Set_Assignment_OK (Lhs);
3999
 
4000
                  Rewrite (N,
4001
                    Make_Assignment_Statement (Loc,
4002
                      Name       => Lhs,
4003
                      Expression => Rhs));
4004
 
4005
                  Analyze (N);
4006
                  return;
4007
               end;
4008
 
4009
            --  Array type case
4010
 
4011
            elsif Is_Array_Type (U_Type) then
4012
               Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
4013
               Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
4014
 
4015
            --  Tagged type case, use the primitive Read function. Note that
4016
            --  this will dispatch in the class-wide case which is what we want
4017
 
4018
            elsif Is_Tagged_Type (U_Type) then
4019
               Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
4020
 
4021
            --  All other record type cases, including protected records. The
4022
            --  latter only arise for expander generated code for handling
4023
            --  shared passive partition access.
4024
 
4025
            else
4026
               pragma Assert
4027
                 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
4028
 
4029
               --  Ada 2005 (AI-216): Program_Error is raised when executing
4030
               --  the default implementation of the Read attribute of an
4031
               --  Unchecked_Union type.
4032
 
4033
               if Is_Unchecked_Union (Base_Type (U_Type)) then
4034
                  Insert_Action (N,
4035
                    Make_Raise_Program_Error (Loc,
4036
                      Reason => PE_Unchecked_Union_Restriction));
4037
               end if;
4038
 
4039
               if Has_Discriminants (U_Type)
4040
                 and then Present
4041
                   (Discriminant_Default_Value (First_Discriminant (U_Type)))
4042
               then
4043
                  Build_Mutable_Record_Read_Procedure
4044
                    (Loc, Full_Base (U_Type), Decl, Pname);
4045
               else
4046
                  Build_Record_Read_Procedure
4047
                    (Loc, Full_Base (U_Type), Decl, Pname);
4048
               end if;
4049
 
4050
               --  Suppress checks, uninitialized or otherwise invalid
4051
               --  data does not cause constraint errors to be raised for
4052
               --  a complete record read.
4053
 
4054
               Insert_Action (N, Decl, All_Checks);
4055
            end if;
4056
         end if;
4057
 
4058
         Rewrite_Stream_Proc_Call (Pname);
4059
      end Read;
4060
 
4061
      ---------
4062
      -- Ref --
4063
      ---------
4064
 
4065
      --  Ref is identical to To_Address, see To_Address for processing
4066
 
4067
      ---------------
4068
      -- Remainder --
4069
      ---------------
4070
 
4071
      --  Transforms 'Remainder into a call to the floating-point attribute
4072
      --  function Remainder in Fat_xxx (where xxx is the root type)
4073
 
4074
      when Attribute_Remainder =>
4075
         Expand_Fpt_Attribute_RR (N);
4076
 
4077
      ------------
4078
      -- Result --
4079
      ------------
4080
 
4081
      --  Transform 'Result into reference to _Result formal. At the point
4082
      --  where a legal 'Result attribute is expanded, we know that we are in
4083
      --  the context of a _Postcondition function with a _Result parameter.
4084
 
4085
      when Attribute_Result =>
4086
         Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult));
4087
         Analyze_And_Resolve (N, Typ);
4088
 
4089
      -----------
4090
      -- Round --
4091
      -----------
4092
 
4093
      --  The handling of the Round attribute is quite delicate. The processing
4094
      --  in Sem_Attr introduced a conversion to universal real, reflecting the
4095
      --  semantics of Round, but we do not want anything to do with universal
4096
      --  real at runtime, since this corresponds to using floating-point
4097
      --  arithmetic.
4098
 
4099
      --  What we have now is that the Etype of the Round attribute correctly
4100
      --  indicates the final result type. The operand of the Round is the
4101
      --  conversion to universal real, described above, and the operand of
4102
      --  this conversion is the actual operand of Round, which may be the
4103
      --  special case of a fixed point multiplication or division (Etype =
4104
      --  universal fixed)
4105
 
4106
      --  The exapander will expand first the operand of the conversion, then
4107
      --  the conversion, and finally the round attribute itself, since we
4108
      --  always work inside out. But we cannot simply process naively in this
4109
      --  order. In the semantic world where universal fixed and real really
4110
      --  exist and have infinite precision, there is no problem, but in the
4111
      --  implementation world, where universal real is a floating-point type,
4112
      --  we would get the wrong result.
4113
 
4114
      --  So the approach is as follows. First, when expanding a multiply or
4115
      --  divide whose type is universal fixed, we do nothing at all, instead
4116
      --  deferring the operation till later.
4117
 
4118
      --  The actual processing is done in Expand_N_Type_Conversion which
4119
      --  handles the special case of Round by looking at its parent to see if
4120
      --  it is a Round attribute, and if it is, handling the conversion (or
4121
      --  its fixed multiply/divide child) in an appropriate manner.
4122
 
4123
      --  This means that by the time we get to expanding the Round attribute
4124
      --  itself, the Round is nothing more than a type conversion (and will
4125
      --  often be a null type conversion), so we just replace it with the
4126
      --  appropriate conversion operation.
4127
 
4128
      when Attribute_Round =>
4129
         Rewrite (N,
4130
           Convert_To (Etype (N), Relocate_Node (First (Exprs))));
4131
         Analyze_And_Resolve (N);
4132
 
4133
      --------------
4134
      -- Rounding --
4135
      --------------
4136
 
4137
      --  Transforms 'Rounding into a call to the floating-point attribute
4138
      --  function Rounding in Fat_xxx (where xxx is the root type)
4139
 
4140
      when Attribute_Rounding =>
4141
         Expand_Fpt_Attribute_R (N);
4142
 
4143
      ------------------
4144
      -- Same_Storage --
4145
      ------------------
4146
 
4147
      when Attribute_Same_Storage => Same_Storage : declare
4148
         Loc : constant Source_Ptr := Sloc (N);
4149
 
4150
         X   : constant Node_Id := Prefix (N);
4151
         Y   : constant Node_Id := First (Expressions (N));
4152
         --  The arguments
4153
 
4154
         X_Addr, Y_Addr : Node_Id;
4155
         --  Rhe expressions for their addresses
4156
 
4157
         X_Size, Y_Size : Node_Id;
4158
         --  Rhe expressions for their sizes
4159
 
4160
      begin
4161
         --  The attribute is expanded as:
4162
 
4163
         --    (X'address = Y'address)
4164
         --      and then (X'Size = Y'Size)
4165
 
4166
         --  If both arguments have the same Etype the second conjunct can be
4167
         --  omitted.
4168
 
4169
         X_Addr :=
4170
           Make_Attribute_Reference (Loc,
4171
             Attribute_Name => Name_Address,
4172
             Prefix         => New_Copy_Tree (X));
4173
 
4174
         Y_Addr :=
4175
           Make_Attribute_Reference (Loc,
4176
             Attribute_Name => Name_Address,
4177
             Prefix         => New_Copy_Tree (Y));
4178
 
4179
         X_Size :=
4180
           Make_Attribute_Reference (Loc,
4181
             Attribute_Name => Name_Size,
4182
             Prefix         => New_Copy_Tree (X));
4183
 
4184
         Y_Size :=
4185
           Make_Attribute_Reference (Loc,
4186
             Attribute_Name => Name_Size,
4187
             Prefix         => New_Copy_Tree (Y));
4188
 
4189
         if Etype (X) = Etype (Y) then
4190
            Rewrite (N,
4191
              (Make_Op_Eq (Loc,
4192
                 Left_Opnd  => X_Addr,
4193
                 Right_Opnd => Y_Addr)));
4194
         else
4195
            Rewrite (N,
4196
              Make_Op_And (Loc,
4197
                Left_Opnd  =>
4198
                  Make_Op_Eq (Loc,
4199
                    Left_Opnd  => X_Addr,
4200
                    Right_Opnd => Y_Addr),
4201
                Right_Opnd =>
4202
                  Make_Op_Eq (Loc,
4203
                    Left_Opnd  => X_Size,
4204
                    Right_Opnd => Y_Size)));
4205
         end if;
4206
 
4207
         Analyze_And_Resolve (N, Standard_Boolean);
4208
      end Same_Storage;
4209
 
4210
      -------------
4211
      -- Scaling --
4212
      -------------
4213
 
4214
      --  Transforms 'Scaling into a call to the floating-point attribute
4215
      --  function Scaling in Fat_xxx (where xxx is the root type)
4216
 
4217
      when Attribute_Scaling =>
4218
         Expand_Fpt_Attribute_RI (N);
4219
 
4220
      -------------------------
4221
      -- Simple_Storage_Pool --
4222
      -------------------------
4223
 
4224
      when Attribute_Simple_Storage_Pool =>
4225
         Rewrite (N,
4226
           Make_Type_Conversion (Loc,
4227
             Subtype_Mark => New_Reference_To (Etype (N), Loc),
4228
             Expression   => New_Reference_To (Entity (N), Loc)));
4229
         Analyze_And_Resolve (N, Typ);
4230
 
4231
      ----------
4232
      -- Size --
4233
      ----------
4234
 
4235
      when Attribute_Size        |
4236
           Attribute_Object_Size |
4237
           Attribute_Value_Size  |
4238
           Attribute_VADS_Size   => Size :
4239
 
4240
      declare
4241
         Siz      : Uint;
4242
         New_Node : Node_Id;
4243
 
4244
      begin
4245
         --  Processing for VADS_Size case. Note that this processing removes
4246
         --  all traces of VADS_Size from the tree, and completes all required
4247
         --  processing for VADS_Size by translating the attribute reference
4248
         --  to an appropriate Size or Object_Size reference.
4249
 
4250
         if Id = Attribute_VADS_Size
4251
           or else (Use_VADS_Size and then Id = Attribute_Size)
4252
         then
4253
            --  If the size is specified, then we simply use the specified
4254
            --  size. This applies to both types and objects. The size of an
4255
            --  object can be specified in the following ways:
4256
 
4257
            --    An explicit size object is given for an object
4258
            --    A component size is specified for an indexed component
4259
            --    A component clause is specified for a selected component
4260
            --    The object is a component of a packed composite object
4261
 
4262
            --  If the size is specified, then VADS_Size of an object
4263
 
4264
            if (Is_Entity_Name (Pref)
4265
                 and then Present (Size_Clause (Entity (Pref))))
4266
              or else
4267
                (Nkind (Pref) = N_Component_Clause
4268
                  and then (Present (Component_Clause
4269
                                     (Entity (Selector_Name (Pref))))
4270
                             or else Is_Packed (Etype (Prefix (Pref)))))
4271
              or else
4272
                (Nkind (Pref) = N_Indexed_Component
4273
                  and then (Component_Size (Etype (Prefix (Pref))) /= 0
4274
                             or else Is_Packed (Etype (Prefix (Pref)))))
4275
            then
4276
               Set_Attribute_Name (N, Name_Size);
4277
 
4278
            --  Otherwise if we have an object rather than a type, then the
4279
            --  VADS_Size attribute applies to the type of the object, rather
4280
            --  than the object itself. This is one of the respects in which
4281
            --  VADS_Size differs from Size.
4282
 
4283
            else
4284
               if (not Is_Entity_Name (Pref)
4285
                    or else not Is_Type (Entity (Pref)))
4286
                 and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp))
4287
               then
4288
                  Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
4289
               end if;
4290
 
4291
               --  For a scalar type for which no size was explicitly given,
4292
               --  VADS_Size means Object_Size. This is the other respect in
4293
               --  which VADS_Size differs from Size.
4294
 
4295
               if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then
4296
                  Set_Attribute_Name (N, Name_Object_Size);
4297
 
4298
               --  In all other cases, Size and VADS_Size are the sane
4299
 
4300
               else
4301
                  Set_Attribute_Name (N, Name_Size);
4302
               end if;
4303
            end if;
4304
         end if;
4305
 
4306
         --  For class-wide types, X'Class'Size is transformed into a direct
4307
         --  reference to the Size of the class type, so that the back end does
4308
         --  not have to deal with the X'Class'Size reference.
4309
 
4310
         if Is_Entity_Name (Pref)
4311
           and then Is_Class_Wide_Type (Entity (Pref))
4312
         then
4313
            Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
4314
            return;
4315
 
4316
         --  For X'Size applied to an object of a class-wide type, transform
4317
         --  X'Size into a call to the primitive operation _Size applied to X.
4318
 
4319
         elsif Is_Class_Wide_Type (Ptyp)
4320
           or else (Id = Attribute_Size
4321
                      and then Is_Tagged_Type (Ptyp)
4322
                      and then Has_Unknown_Discriminants (Ptyp))
4323
         then
4324
            --  No need to do anything else compiling under restriction
4325
            --  No_Dispatching_Calls. During the semantic analysis we
4326
            --  already notified such violation.
4327
 
4328
            if Restriction_Active (No_Dispatching_Calls) then
4329
               return;
4330
            end if;
4331
 
4332
            New_Node :=
4333
              Make_Function_Call (Loc,
4334
                Name => New_Reference_To
4335
                  (Find_Prim_Op (Ptyp, Name_uSize), Loc),
4336
                Parameter_Associations => New_List (Pref));
4337
 
4338
            if Typ /= Standard_Long_Long_Integer then
4339
 
4340
               --  The context is a specific integer type with which the
4341
               --  original attribute was compatible. The function has a
4342
               --  specific type as well, so to preserve the compatibility
4343
               --  we must convert explicitly.
4344
 
4345
               New_Node := Convert_To (Typ, New_Node);
4346
            end if;
4347
 
4348
            Rewrite (N, New_Node);
4349
            Analyze_And_Resolve (N, Typ);
4350
            return;
4351
 
4352
         --  Case of known RM_Size of a type
4353
 
4354
         elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
4355
           and then Is_Entity_Name (Pref)
4356
           and then Is_Type (Entity (Pref))
4357
           and then Known_Static_RM_Size (Entity (Pref))
4358
         then
4359
            Siz := RM_Size (Entity (Pref));
4360
 
4361
         --  Case of known Esize of a type
4362
 
4363
         elsif Id = Attribute_Object_Size
4364
           and then Is_Entity_Name (Pref)
4365
           and then Is_Type (Entity (Pref))
4366
           and then Known_Static_Esize (Entity (Pref))
4367
         then
4368
            Siz := Esize (Entity (Pref));
4369
 
4370
         --  Case of known size of object
4371
 
4372
         elsif Id = Attribute_Size
4373
           and then Is_Entity_Name (Pref)
4374
           and then Is_Object (Entity (Pref))
4375
           and then Known_Esize (Entity (Pref))
4376
           and then Known_Static_Esize (Entity (Pref))
4377
         then
4378
            Siz := Esize (Entity (Pref));
4379
 
4380
         --  For an array component, we can do Size in the front end
4381
         --  if the component_size of the array is set.
4382
 
4383
         elsif Nkind (Pref) = N_Indexed_Component then
4384
            Siz := Component_Size (Etype (Prefix (Pref)));
4385
 
4386
         --  For a record component, we can do Size in the front end if there
4387
         --  is a component clause, or if the record is packed and the
4388
         --  component's size is known at compile time.
4389
 
4390
         elsif Nkind (Pref) = N_Selected_Component then
4391
            declare
4392
               Rec  : constant Entity_Id := Etype (Prefix (Pref));
4393
               Comp : constant Entity_Id := Entity (Selector_Name (Pref));
4394
 
4395
            begin
4396
               if Present (Component_Clause (Comp)) then
4397
                  Siz := Esize (Comp);
4398
 
4399
               elsif Is_Packed (Rec) then
4400
                  Siz := RM_Size (Ptyp);
4401
 
4402
               else
4403
                  Apply_Universal_Integer_Attribute_Checks (N);
4404
                  return;
4405
               end if;
4406
            end;
4407
 
4408
         --  All other cases are handled by the back end
4409
 
4410
         else
4411
            Apply_Universal_Integer_Attribute_Checks (N);
4412
 
4413
            --  If Size is applied to a formal parameter that is of a packed
4414
            --  array subtype, then apply Size to the actual subtype.
4415
 
4416
            if Is_Entity_Name (Pref)
4417
              and then Is_Formal (Entity (Pref))
4418
              and then Is_Array_Type (Ptyp)
4419
              and then Is_Packed (Ptyp)
4420
            then
4421
               Rewrite (N,
4422
                 Make_Attribute_Reference (Loc,
4423
                   Prefix =>
4424
                     New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
4425
                   Attribute_Name => Name_Size));
4426
               Analyze_And_Resolve (N, Typ);
4427
            end if;
4428
 
4429
            --  If Size applies to a dereference of an access to unconstrained
4430
            --  packed array, the back end needs to see its unconstrained
4431
            --  nominal type, but also a hint to the actual constrained type.
4432
 
4433
            if Nkind (Pref) = N_Explicit_Dereference
4434
              and then Is_Array_Type (Ptyp)
4435
              and then not Is_Constrained (Ptyp)
4436
              and then Is_Packed (Ptyp)
4437
            then
4438
               Set_Actual_Designated_Subtype (Pref,
4439
                 Get_Actual_Subtype (Pref));
4440
            end if;
4441
 
4442
            return;
4443
         end if;
4444
 
4445
         --  Common processing for record and array component case
4446
 
4447
         if Siz /= No_Uint and then Siz /= 0 then
4448
            declare
4449
               CS : constant Boolean := Comes_From_Source (N);
4450
 
4451
            begin
4452
               Rewrite (N, Make_Integer_Literal (Loc, Siz));
4453
 
4454
               --  This integer literal is not a static expression. We do not
4455
               --  call Analyze_And_Resolve here, because this would activate
4456
               --  the circuit for deciding that a static value was out of
4457
               --  range, and we don't want that.
4458
 
4459
               --  So just manually set the type, mark the expression as non-
4460
               --  static, and then ensure that the result is checked properly
4461
               --  if the attribute comes from source (if it was internally
4462
               --  generated, we never need a constraint check).
4463
 
4464
               Set_Etype (N, Typ);
4465
               Set_Is_Static_Expression (N, False);
4466
 
4467
               if CS then
4468
                  Apply_Constraint_Check (N, Typ);
4469
               end if;
4470
            end;
4471
         end if;
4472
      end Size;
4473
 
4474
      ------------------
4475
      -- Storage_Pool --
4476
      ------------------
4477
 
4478
      when Attribute_Storage_Pool =>
4479
         Rewrite (N,
4480
           Make_Type_Conversion (Loc,
4481
             Subtype_Mark => New_Reference_To (Etype (N), Loc),
4482
             Expression   => New_Reference_To (Entity (N), Loc)));
4483
         Analyze_And_Resolve (N, Typ);
4484
 
4485
      ------------------
4486
      -- Storage_Size --
4487
      ------------------
4488
 
4489
      when Attribute_Storage_Size => Storage_Size : declare
4490
         Alloc_Op  : Entity_Id := Empty;
4491
 
4492
      begin
4493
 
4494
         --  Access type case, always go to the root type
4495
 
4496
         --  The case of access types results in a value of zero for the case
4497
         --  where no storage size attribute clause has been given. If a
4498
         --  storage size has been given, then the attribute is converted
4499
         --  to a reference to the variable used to hold this value.
4500
 
4501
         if Is_Access_Type (Ptyp) then
4502
            if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
4503
               Rewrite (N,
4504
                 Make_Attribute_Reference (Loc,
4505
                   Prefix => New_Reference_To (Typ, Loc),
4506
                   Attribute_Name => Name_Max,
4507
                   Expressions => New_List (
4508
                     Make_Integer_Literal (Loc, 0),
4509
                     Convert_To (Typ,
4510
                       New_Reference_To
4511
                         (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
4512
 
4513
            elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
4514
 
4515
               --  If the access type is associated with a simple storage pool
4516
               --  object, then attempt to locate the optional Storage_Size
4517
               --  function of the simple storage pool type. If not found,
4518
               --  then the result will default to zero.
4519
 
4520
               if Present (Get_Rep_Pragma (Root_Type (Ptyp),
4521
                                           Name_Simple_Storage_Pool_Type))
4522
               then
4523
                  declare
4524
                     Pool_Type : constant Entity_Id :=
4525
                                   Base_Type (Etype (Entity (N)));
4526
 
4527
                  begin
4528
                     Alloc_Op := Get_Name_Entity_Id (Name_Storage_Size);
4529
                     while Present (Alloc_Op) loop
4530
                        if Scope (Alloc_Op) = Scope (Pool_Type)
4531
                          and then Present (First_Formal (Alloc_Op))
4532
                          and then Etype (First_Formal (Alloc_Op)) = Pool_Type
4533
                        then
4534
                           exit;
4535
                        end if;
4536
 
4537
                        Alloc_Op := Homonym (Alloc_Op);
4538
                     end loop;
4539
                  end;
4540
 
4541
               --  In the normal Storage_Pool case, retrieve the primitive
4542
               --  function associated with the pool type.
4543
 
4544
               else
4545
                  Alloc_Op :=
4546
                    Find_Prim_Op
4547
                      (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
4548
                       Attribute_Name (N));
4549
               end if;
4550
 
4551
               --  If Storage_Size wasn't found (can only occur in the simple
4552
               --  storage pool case), then simply use zero for the result.
4553
 
4554
               if not Present (Alloc_Op) then
4555
                  Rewrite (N, Make_Integer_Literal (Loc, 0));
4556
 
4557
               --  Otherwise, rewrite the allocator as a call to pool type's
4558
               --  Storage_Size function.
4559
 
4560
               else
4561
                  Rewrite (N,
4562
                    OK_Convert_To (Typ,
4563
                      Make_Function_Call (Loc,
4564
                        Name =>
4565
                          New_Reference_To (Alloc_Op, Loc),
4566
 
4567
                        Parameter_Associations => New_List (
4568
                          New_Reference_To
4569
                            (Associated_Storage_Pool
4570
                               (Root_Type (Ptyp)), Loc)))));
4571
               end if;
4572
 
4573
            else
4574
               Rewrite (N, Make_Integer_Literal (Loc, 0));
4575
            end if;
4576
 
4577
            Analyze_And_Resolve (N, Typ);
4578
 
4579
         --  For tasks, we retrieve the size directly from the TCB. The
4580
         --  size may depend on a discriminant of the type, and therefore
4581
         --  can be a per-object expression, so type-level information is
4582
         --  not sufficient in general. There are four cases to consider:
4583
 
4584
         --  a) If the attribute appears within a task body, the designated
4585
         --    TCB is obtained by a call to Self.
4586
 
4587
         --  b) If the prefix of the attribute is the name of a task object,
4588
         --  the designated TCB is the one stored in the corresponding record.
4589
 
4590
         --  c) If the prefix is a task type, the size is obtained from the
4591
         --  size variable created for each task type
4592
 
4593
         --  d) If no storage_size was specified for the type , there is no
4594
         --  size variable, and the value is a system-specific default.
4595
 
4596
         else
4597
            if In_Open_Scopes (Ptyp) then
4598
 
4599
               --  Storage_Size (Self)
4600
 
4601
               Rewrite (N,
4602
                 Convert_To (Typ,
4603
                   Make_Function_Call (Loc,
4604
                     Name =>
4605
                       New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
4606
                     Parameter_Associations =>
4607
                       New_List (
4608
                         Make_Function_Call (Loc,
4609
                           Name =>
4610
                             New_Reference_To (RTE (RE_Self), Loc))))));
4611
 
4612
            elsif not Is_Entity_Name (Pref)
4613
              or else not Is_Type (Entity (Pref))
4614
            then
4615
               --  Storage_Size (Rec (Obj).Size)
4616
 
4617
               Rewrite (N,
4618
                 Convert_To (Typ,
4619
                   Make_Function_Call (Loc,
4620
                     Name =>
4621
                       New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
4622
                       Parameter_Associations =>
4623
                          New_List (
4624
                            Make_Selected_Component (Loc,
4625
                              Prefix =>
4626
                                Unchecked_Convert_To (
4627
                                  Corresponding_Record_Type (Ptyp),
4628
                                    New_Copy_Tree (Pref)),
4629
                              Selector_Name =>
4630
                                 Make_Identifier (Loc, Name_uTask_Id))))));
4631
 
4632
            elsif Present (Storage_Size_Variable (Ptyp)) then
4633
 
4634
               --  Static storage size pragma given for type: retrieve value
4635
               --  from its allocated storage variable.
4636
 
4637
               Rewrite (N,
4638
                 Convert_To (Typ,
4639
                   Make_Function_Call (Loc,
4640
                     Name => New_Occurrence_Of (
4641
                       RTE (RE_Adjust_Storage_Size), Loc),
4642
                     Parameter_Associations =>
4643
                       New_List (
4644
                         New_Reference_To (
4645
                           Storage_Size_Variable (Ptyp), Loc)))));
4646
            else
4647
               --  Get system default
4648
 
4649
               Rewrite (N,
4650
                 Convert_To (Typ,
4651
                   Make_Function_Call (Loc,
4652
                     Name =>
4653
                       New_Occurrence_Of (
4654
                        RTE (RE_Default_Stack_Size), Loc))));
4655
            end if;
4656
 
4657
            Analyze_And_Resolve (N, Typ);
4658
         end if;
4659
      end Storage_Size;
4660
 
4661
      -----------------
4662
      -- Stream_Size --
4663
      -----------------
4664
 
4665
      when Attribute_Stream_Size =>
4666
         Rewrite (N,
4667
           Make_Integer_Literal (Loc, Intval => Get_Stream_Size (Ptyp)));
4668
         Analyze_And_Resolve (N, Typ);
4669
 
4670
      ----------
4671
      -- Succ --
4672
      ----------
4673
 
4674
      --  1. Deal with enumeration types with holes
4675
      --  2. For floating-point, generate call to attribute function
4676
      --  3. For other cases, deal with constraint checking
4677
 
4678
      when Attribute_Succ => Succ : declare
4679
         Etyp : constant Entity_Id := Base_Type (Ptyp);
4680
 
4681
      begin
4682
 
4683
         --  For enumeration types with non-standard representations, we
4684
         --  expand typ'Succ (x) into
4685
 
4686
         --    Pos_To_Rep (Rep_To_Pos (x) + 1)
4687
 
4688
         --    If the representation is contiguous, we compute instead
4689
         --    Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
4690
 
4691
         if Is_Enumeration_Type (Ptyp)
4692
           and then Present (Enum_Pos_To_Rep (Etyp))
4693
         then
4694
            if Has_Contiguous_Rep (Etyp) then
4695
               Rewrite (N,
4696
                  Unchecked_Convert_To (Ptyp,
4697
                     Make_Op_Add (Loc,
4698
                        Left_Opnd  =>
4699
                         Make_Integer_Literal (Loc,
4700
                           Enumeration_Rep (First_Literal (Ptyp))),
4701
                        Right_Opnd =>
4702
                          Make_Function_Call (Loc,
4703
                            Name =>
4704
                              New_Reference_To
4705
                               (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4706
 
4707
                            Parameter_Associations =>
4708
                              New_List (
4709
                                Unchecked_Convert_To (Ptyp,
4710
                                  Make_Op_Add (Loc,
4711
                                  Left_Opnd =>
4712
                                    Unchecked_Convert_To (Standard_Integer,
4713
                                      Relocate_Node (First (Exprs))),
4714
                                  Right_Opnd =>
4715
                                    Make_Integer_Literal (Loc, 1))),
4716
                                Rep_To_Pos_Flag (Ptyp, Loc))))));
4717
            else
4718
               --  Add Boolean parameter True, to request program errror if
4719
               --  we have a bad representation on our hands. Add False if
4720
               --  checks are suppressed.
4721
 
4722
               Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
4723
               Rewrite (N,
4724
                 Make_Indexed_Component (Loc,
4725
                   Prefix =>
4726
                     New_Reference_To
4727
                       (Enum_Pos_To_Rep (Etyp), Loc),
4728
                   Expressions => New_List (
4729
                     Make_Op_Add (Loc,
4730
                       Left_Opnd =>
4731
                         Make_Function_Call (Loc,
4732
                           Name =>
4733
                             New_Reference_To
4734
                               (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4735
                           Parameter_Associations => Exprs),
4736
                       Right_Opnd => Make_Integer_Literal (Loc, 1)))));
4737
            end if;
4738
 
4739
            Analyze_And_Resolve (N, Typ);
4740
 
4741
         --  For floating-point, we transform 'Succ into a call to the Succ
4742
         --  floating-point attribute function in Fat_xxx (xxx is root type)
4743
 
4744
         elsif Is_Floating_Point_Type (Ptyp) then
4745
            Expand_Fpt_Attribute_R (N);
4746
            Analyze_And_Resolve (N, Typ);
4747
 
4748
         --  For modular types, nothing to do (no overflow, since wraps)
4749
 
4750
         elsif Is_Modular_Integer_Type (Ptyp) then
4751
            null;
4752
 
4753
         --  For other types, if argument is marked as needing a range check or
4754
         --  overflow checking is enabled, we must generate a check.
4755
 
4756
         elsif not Overflow_Checks_Suppressed (Ptyp)
4757
           or else Do_Range_Check (First (Exprs))
4758
         then
4759
            Set_Do_Range_Check (First (Exprs), False);
4760
            Expand_Pred_Succ (N);
4761
         end if;
4762
      end Succ;
4763
 
4764
      ---------
4765
      -- Tag --
4766
      ---------
4767
 
4768
      --  Transforms X'Tag into a direct reference to the tag of X
4769
 
4770
      when Attribute_Tag => Tag : declare
4771
         Ttyp           : Entity_Id;
4772
         Prefix_Is_Type : Boolean;
4773
 
4774
      begin
4775
         if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
4776
            Ttyp := Entity (Pref);
4777
            Prefix_Is_Type := True;
4778
         else
4779
            Ttyp := Ptyp;
4780
            Prefix_Is_Type := False;
4781
         end if;
4782
 
4783
         if Is_Class_Wide_Type (Ttyp) then
4784
            Ttyp := Root_Type (Ttyp);
4785
         end if;
4786
 
4787
         Ttyp := Underlying_Type (Ttyp);
4788
 
4789
         --  Ada 2005: The type may be a synchronized tagged type, in which
4790
         --  case the tag information is stored in the corresponding record.
4791
 
4792
         if Is_Concurrent_Type (Ttyp) then
4793
            Ttyp := Corresponding_Record_Type (Ttyp);
4794
         end if;
4795
 
4796
         if Prefix_Is_Type then
4797
 
4798
            --  For VMs we leave the type attribute unexpanded because
4799
            --  there's not a dispatching table to reference.
4800
 
4801
            if Tagged_Type_Expansion then
4802
               Rewrite (N,
4803
                 Unchecked_Convert_To (RTE (RE_Tag),
4804
                   New_Reference_To
4805
                     (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
4806
               Analyze_And_Resolve (N, RTE (RE_Tag));
4807
            end if;
4808
 
4809
         --  Ada 2005 (AI-251): The use of 'Tag in the sources always
4810
         --  references the primary tag of the actual object. If 'Tag is
4811
         --  applied to class-wide interface objects we generate code that
4812
         --  displaces "this" to reference the base of the object.
4813
 
4814
         elsif Comes_From_Source (N)
4815
            and then Is_Class_Wide_Type (Etype (Prefix (N)))
4816
            and then Is_Interface (Etype (Prefix (N)))
4817
         then
4818
            --  Generate:
4819
            --    (To_Tag_Ptr (Prefix'Address)).all
4820
 
4821
            --  Note that Prefix'Address is recursively expanded into a call
4822
            --  to Base_Address (Obj.Tag)
4823
 
4824
            --  Not needed for VM targets, since all handled by the VM
4825
 
4826
            if Tagged_Type_Expansion then
4827
               Rewrite (N,
4828
                 Make_Explicit_Dereference (Loc,
4829
                   Unchecked_Convert_To (RTE (RE_Tag_Ptr),
4830
                     Make_Attribute_Reference (Loc,
4831
                       Prefix => Relocate_Node (Pref),
4832
                       Attribute_Name => Name_Address))));
4833
               Analyze_And_Resolve (N, RTE (RE_Tag));
4834
            end if;
4835
 
4836
         else
4837
            Rewrite (N,
4838
              Make_Selected_Component (Loc,
4839
                Prefix => Relocate_Node (Pref),
4840
                Selector_Name =>
4841
                  New_Reference_To (First_Tag_Component (Ttyp), Loc)));
4842
            Analyze_And_Resolve (N, RTE (RE_Tag));
4843
         end if;
4844
      end Tag;
4845
 
4846
      ----------------
4847
      -- Terminated --
4848
      ----------------
4849
 
4850
      --  Transforms 'Terminated attribute into a call to Terminated function
4851
 
4852
      when Attribute_Terminated => Terminated :
4853
      begin
4854
         --  The prefix of Terminated is of a task interface class-wide type.
4855
         --  Generate:
4856
         --    terminated (Task_Id (Pref._disp_get_task_id));
4857
 
4858
         if Ada_Version >= Ada_2005
4859
           and then Ekind (Ptyp) = E_Class_Wide_Type
4860
           and then Is_Interface (Ptyp)
4861
           and then Is_Task_Interface (Ptyp)
4862
         then
4863
            Rewrite (N,
4864
              Make_Function_Call (Loc,
4865
                Name =>
4866
                  New_Reference_To (RTE (RE_Terminated), Loc),
4867
                Parameter_Associations => New_List (
4868
                  Make_Unchecked_Type_Conversion (Loc,
4869
                    Subtype_Mark =>
4870
                      New_Reference_To (RTE (RO_ST_Task_Id), Loc),
4871
                    Expression =>
4872
                      Make_Selected_Component (Loc,
4873
                        Prefix =>
4874
                          New_Copy_Tree (Pref),
4875
                        Selector_Name =>
4876
                          Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
4877
 
4878
         elsif Restricted_Profile then
4879
            Rewrite (N,
4880
              Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
4881
 
4882
         else
4883
            Rewrite (N,
4884
              Build_Call_With_Task (Pref, RTE (RE_Terminated)));
4885
         end if;
4886
 
4887
         Analyze_And_Resolve (N, Standard_Boolean);
4888
      end Terminated;
4889
 
4890
      ----------------
4891
      -- To_Address --
4892
      ----------------
4893
 
4894
      --  Transforms System'To_Address (X) and System.Address'Ref (X) into
4895
      --  unchecked conversion from (integral) type of X to type address.
4896
 
4897
      when Attribute_To_Address | Attribute_Ref =>
4898
         Rewrite (N,
4899
           Unchecked_Convert_To (RTE (RE_Address),
4900
             Relocate_Node (First (Exprs))));
4901
         Analyze_And_Resolve (N, RTE (RE_Address));
4902
 
4903
      ------------
4904
      -- To_Any --
4905
      ------------
4906
 
4907
      when Attribute_To_Any => To_Any : declare
4908
         P_Type : constant Entity_Id := Etype (Pref);
4909
         Decls  : constant List_Id   := New_List;
4910
      begin
4911
         Rewrite (N,
4912
           Build_To_Any_Call
4913
             (Convert_To (P_Type,
4914
              Relocate_Node (First (Exprs))), Decls));
4915
         Insert_Actions (N, Decls);
4916
         Analyze_And_Resolve (N, RTE (RE_Any));
4917
      end To_Any;
4918
 
4919
      ----------------
4920
      -- Truncation --
4921
      ----------------
4922
 
4923
      --  Transforms 'Truncation into a call to the floating-point attribute
4924
      --  function Truncation in Fat_xxx (where xxx is the root type).
4925
      --  Expansion is avoided for cases the back end can handle directly.
4926
 
4927
      when Attribute_Truncation =>
4928
         if not Is_Inline_Floating_Point_Attribute (N) then
4929
            Expand_Fpt_Attribute_R (N);
4930
         end if;
4931
 
4932
      --------------
4933
      -- TypeCode --
4934
      --------------
4935
 
4936
      when Attribute_TypeCode => TypeCode : declare
4937
         P_Type : constant Entity_Id := Etype (Pref);
4938
         Decls  : constant List_Id   := New_List;
4939
      begin
4940
         Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
4941
         Insert_Actions (N, Decls);
4942
         Analyze_And_Resolve (N, RTE (RE_TypeCode));
4943
      end TypeCode;
4944
 
4945
      -----------------------
4946
      -- Unbiased_Rounding --
4947
      -----------------------
4948
 
4949
      --  Transforms 'Unbiased_Rounding into a call to the floating-point
4950
      --  attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
4951
      --  root type). Expansion is avoided for cases the back end can handle
4952
      --  directly.
4953
 
4954
      when Attribute_Unbiased_Rounding =>
4955
         if not Is_Inline_Floating_Point_Attribute (N) then
4956
            Expand_Fpt_Attribute_R (N);
4957
         end if;
4958
 
4959
      -----------------
4960
      -- UET_Address --
4961
      -----------------
4962
 
4963
      when Attribute_UET_Address => UET_Address : declare
4964
         Ent : constant Entity_Id := Make_Temporary (Loc, 'T');
4965
 
4966
      begin
4967
         Insert_Action (N,
4968
           Make_Object_Declaration (Loc,
4969
             Defining_Identifier => Ent,
4970
             Aliased_Present     => True,
4971
             Object_Definition   =>
4972
               New_Occurrence_Of (RTE (RE_Address), Loc)));
4973
 
4974
         --  Construct name __gnat_xxx__SDP, where xxx is the unit name
4975
         --  in normal external form.
4976
 
4977
         Get_External_Unit_Name_String (Get_Unit_Name (Pref));
4978
         Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
4979
         Name_Len := Name_Len + 7;
4980
         Name_Buffer (1 .. 7) := "__gnat_";
4981
         Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP";
4982
         Name_Len := Name_Len + 5;
4983
 
4984
         Set_Is_Imported (Ent);
4985
         Set_Interface_Name (Ent,
4986
           Make_String_Literal (Loc,
4987
             Strval => String_From_Name_Buffer));
4988
 
4989
         --  Set entity as internal to ensure proper Sprint output of its
4990
         --  implicit importation.
4991
 
4992
         Set_Is_Internal (Ent);
4993
 
4994
         Rewrite (N,
4995
           Make_Attribute_Reference (Loc,
4996
             Prefix => New_Occurrence_Of (Ent, Loc),
4997
             Attribute_Name => Name_Address));
4998
 
4999
         Analyze_And_Resolve (N, Typ);
5000
      end UET_Address;
5001
 
5002
      ---------------
5003
      -- VADS_Size --
5004
      ---------------
5005
 
5006
      --  The processing for VADS_Size is shared with Size
5007
 
5008
      ---------
5009
      -- Val --
5010
      ---------
5011
 
5012
      --  For enumeration types with a standard representation, and for all
5013
      --  other types, Val is handled by the back end. For enumeration types
5014
      --  with a non-standard representation we use the _Pos_To_Rep array that
5015
      --  was created when the type was frozen.
5016
 
5017
      when Attribute_Val => Val : declare
5018
         Etyp : constant Entity_Id := Base_Type (Entity (Pref));
5019
 
5020
      begin
5021
         if Is_Enumeration_Type (Etyp)
5022
           and then Present (Enum_Pos_To_Rep (Etyp))
5023
         then
5024
            if Has_Contiguous_Rep (Etyp) then
5025
               declare
5026
                  Rep_Node : constant Node_Id :=
5027
                    Unchecked_Convert_To (Etyp,
5028
                       Make_Op_Add (Loc,
5029
                         Left_Opnd =>
5030
                            Make_Integer_Literal (Loc,
5031
                              Enumeration_Rep (First_Literal (Etyp))),
5032
                         Right_Opnd =>
5033
                          (Convert_To (Standard_Integer,
5034
                             Relocate_Node (First (Exprs))))));
5035
 
5036
               begin
5037
                  Rewrite (N,
5038
                     Unchecked_Convert_To (Etyp,
5039
                         Make_Op_Add (Loc,
5040
                           Left_Opnd =>
5041
                             Make_Integer_Literal (Loc,
5042
                               Enumeration_Rep (First_Literal (Etyp))),
5043
                           Right_Opnd =>
5044
                             Make_Function_Call (Loc,
5045
                               Name =>
5046
                                 New_Reference_To
5047
                                   (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5048
                               Parameter_Associations => New_List (
5049
                                 Rep_Node,
5050
                                 Rep_To_Pos_Flag (Etyp, Loc))))));
5051
               end;
5052
 
5053
            else
5054
               Rewrite (N,
5055
                 Make_Indexed_Component (Loc,
5056
                   Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc),
5057
                   Expressions => New_List (
5058
                     Convert_To (Standard_Integer,
5059
                       Relocate_Node (First (Exprs))))));
5060
            end if;
5061
 
5062
            Analyze_And_Resolve (N, Typ);
5063
 
5064
         --  If the argument is marked as requiring a range check then generate
5065
         --  it here.
5066
 
5067
         elsif Do_Range_Check (First (Exprs)) then
5068
            Set_Do_Range_Check (First (Exprs), False);
5069
            Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
5070
         end if;
5071
      end Val;
5072
 
5073
      -----------
5074
      -- Valid --
5075
      -----------
5076
 
5077
      --  The code for valid is dependent on the particular types involved.
5078
      --  See separate sections below for the generated code in each case.
5079
 
5080
      when Attribute_Valid => Valid : declare
5081
         Btyp : Entity_Id := Base_Type (Ptyp);
5082
         Tst  : Node_Id;
5083
 
5084
         Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
5085
         --  Save the validity checking mode. We always turn off validity
5086
         --  checking during process of 'Valid since this is one place
5087
         --  where we do not want the implicit validity checks to intefere
5088
         --  with the explicit validity check that the programmer is doing.
5089
 
5090
         function Make_Range_Test return Node_Id;
5091
         --  Build the code for a range test of the form
5092
         --    Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
5093
 
5094
         ---------------------
5095
         -- Make_Range_Test --
5096
         ---------------------
5097
 
5098
         function Make_Range_Test return Node_Id is
5099
            Temp : constant Node_Id := Duplicate_Subexpr (Pref);
5100
 
5101
         begin
5102
            --  The value whose validity is being checked has been captured in
5103
            --  an object declaration. We certainly don't want this object to
5104
            --  appear valid because the declaration initializes it!
5105
 
5106
            if Is_Entity_Name (Temp) then
5107
               Set_Is_Known_Valid (Entity (Temp), False);
5108
            end if;
5109
 
5110
            return
5111
              Make_In (Loc,
5112
                Left_Opnd  =>
5113
                  Unchecked_Convert_To (Btyp, Temp),
5114
                Right_Opnd =>
5115
                  Make_Range (Loc,
5116
                    Low_Bound =>
5117
                      Unchecked_Convert_To (Btyp,
5118
                        Make_Attribute_Reference (Loc,
5119
                          Prefix => New_Occurrence_Of (Ptyp, Loc),
5120
                          Attribute_Name => Name_First)),
5121
                    High_Bound =>
5122
                      Unchecked_Convert_To (Btyp,
5123
                        Make_Attribute_Reference (Loc,
5124
                          Prefix => New_Occurrence_Of (Ptyp, Loc),
5125
                          Attribute_Name => Name_Last))));
5126
         end Make_Range_Test;
5127
 
5128
      --  Start of processing for Attribute_Valid
5129
 
5130
      begin
5131
         --  Do not expand sourced code 'Valid reference in CodePeer mode,
5132
         --  will be handled by the back-end directly.
5133
 
5134
         if CodePeer_Mode and then Comes_From_Source (N) then
5135
            return;
5136
         end if;
5137
 
5138
         --  Turn off validity checks. We do not want any implicit validity
5139
         --  checks to intefere with the explicit check from the attribute
5140
 
5141
         Validity_Checks_On := False;
5142
 
5143
         --  Floating-point case. This case is handled by the Valid attribute
5144
         --  code in the floating-point attribute run-time library.
5145
 
5146
         if Is_Floating_Point_Type (Ptyp) then
5147
            declare
5148
               Pkg : RE_Id;
5149
               Ftp : Entity_Id;
5150
 
5151
            begin
5152
 
5153
               case Float_Rep (Btyp) is
5154
 
5155
                  --  For vax fpt types, call appropriate routine in special
5156
                  --  vax floating point unit. No need to worry about loads in
5157
                  --  this case, since these types have no signalling NaN's.
5158
 
5159
                  when VAX_Native => Expand_Vax_Valid (N);
5160
 
5161
                  --  The AAMP back end handles Valid for floating-point types
5162
 
5163
                  when AAMP =>
5164
                     Analyze_And_Resolve (Pref, Ptyp);
5165
                     Set_Etype (N, Standard_Boolean);
5166
                     Set_Analyzed (N);
5167
 
5168
                  when IEEE_Binary =>
5169
                     Find_Fat_Info (Ptyp, Ftp, Pkg);
5170
 
5171
                     --  If the floating-point object might be unaligned, we
5172
                     --  need to call the special routine Unaligned_Valid,
5173
                     --  which makes the needed copy, being careful not to
5174
                     --  load the value into any floating-point register.
5175
                     --  The argument in this case is obj'Address (see
5176
                     --  Unaligned_Valid routine in Fat_Gen).
5177
 
5178
                     if Is_Possibly_Unaligned_Object (Pref) then
5179
                        Expand_Fpt_Attribute
5180
                          (N, Pkg, Name_Unaligned_Valid,
5181
                           New_List (
5182
                             Make_Attribute_Reference (Loc,
5183
                               Prefix => Relocate_Node (Pref),
5184
                               Attribute_Name => Name_Address)));
5185
 
5186
                     --  In the normal case where we are sure the object is
5187
                     --  aligned, we generate a call to Valid, and the argument
5188
                     --  in this case is obj'Unrestricted_Access (after
5189
                     --  converting obj to the right floating-point type).
5190
 
5191
                     else
5192
                        Expand_Fpt_Attribute
5193
                          (N, Pkg, Name_Valid,
5194
                           New_List (
5195
                             Make_Attribute_Reference (Loc,
5196
                               Prefix => Unchecked_Convert_To (Ftp, Pref),
5197
                               Attribute_Name => Name_Unrestricted_Access)));
5198
                     end if;
5199
               end case;
5200
 
5201
               --  One more task, we still need a range check. Required
5202
               --  only if we have a constraint, since the Valid routine
5203
               --  catches infinities properly (infinities are never valid).
5204
 
5205
               --  The way we do the range check is simply to create the
5206
               --  expression: Valid (N) and then Base_Type(Pref) in Typ.
5207
 
5208
               if not Subtypes_Statically_Match (Ptyp, Btyp) then
5209
                  Rewrite (N,
5210
                    Make_And_Then (Loc,
5211
                      Left_Opnd  => Relocate_Node (N),
5212
                      Right_Opnd =>
5213
                        Make_In (Loc,
5214
                          Left_Opnd => Convert_To (Btyp, Pref),
5215
                          Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
5216
               end if;
5217
            end;
5218
 
5219
         --  Enumeration type with holes
5220
 
5221
         --  For enumeration types with holes, the Pos value constructed by
5222
         --  the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
5223
         --  second argument of False returns minus one for an invalid value,
5224
         --  and the non-negative pos value for a valid value, so the
5225
         --  expansion of X'Valid is simply:
5226
 
5227
         --     type(X)'Pos (X) >= 0
5228
 
5229
         --  We can't quite generate it that way because of the requirement
5230
         --  for the non-standard second argument of False in the resulting
5231
         --  rep_to_pos call, so we have to explicitly create:
5232
 
5233
         --     _rep_to_pos (X, False) >= 0
5234
 
5235
         --  If we have an enumeration subtype, we also check that the
5236
         --  value is in range:
5237
 
5238
         --    _rep_to_pos (X, False) >= 0
5239
         --      and then
5240
         --       (X >= type(X)'First and then type(X)'Last <= X)
5241
 
5242
         elsif Is_Enumeration_Type (Ptyp)
5243
           and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp)))
5244
         then
5245
            Tst :=
5246
              Make_Op_Ge (Loc,
5247
                Left_Opnd =>
5248
                  Make_Function_Call (Loc,
5249
                    Name =>
5250
                      New_Reference_To
5251
                        (TSS (Base_Type (Ptyp), TSS_Rep_To_Pos), Loc),
5252
                    Parameter_Associations => New_List (
5253
                      Pref,
5254
                      New_Occurrence_Of (Standard_False, Loc))),
5255
                Right_Opnd => Make_Integer_Literal (Loc, 0));
5256
 
5257
            if Ptyp /= Btyp
5258
              and then
5259
                (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
5260
                  or else
5261
                 Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
5262
            then
5263
               --  The call to Make_Range_Test will create declarations
5264
               --  that need a proper insertion point, but Pref is now
5265
               --  attached to a node with no ancestor. Attach to tree
5266
               --  even if it is to be rewritten below.
5267
 
5268
               Set_Parent (Tst, Parent (N));
5269
 
5270
               Tst :=
5271
                 Make_And_Then (Loc,
5272
                   Left_Opnd  => Make_Range_Test,
5273
                   Right_Opnd => Tst);
5274
            end if;
5275
 
5276
            Rewrite (N, Tst);
5277
 
5278
         --  Fortran convention booleans
5279
 
5280
         --  For the very special case of Fortran convention booleans, the
5281
         --  value is always valid, since it is an integer with the semantics
5282
         --  that non-zero is true, and any value is permissible.
5283
 
5284
         elsif Is_Boolean_Type (Ptyp)
5285
           and then Convention (Ptyp) = Convention_Fortran
5286
         then
5287
            Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
5288
 
5289
         --  For biased representations, we will be doing an unchecked
5290
         --  conversion without unbiasing the result. That means that the range
5291
         --  test has to take this into account, and the proper form of the
5292
         --  test is:
5293
 
5294
         --    Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
5295
 
5296
         elsif Has_Biased_Representation (Ptyp) then
5297
            Btyp := RTE (RE_Unsigned_32);
5298
            Rewrite (N,
5299
              Make_Op_Lt (Loc,
5300
                Left_Opnd =>
5301
                  Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
5302
                Right_Opnd =>
5303
                  Unchecked_Convert_To (Btyp,
5304
                    Make_Attribute_Reference (Loc,
5305
                      Prefix => New_Occurrence_Of (Ptyp, Loc),
5306
                      Attribute_Name => Name_Range_Length))));
5307
 
5308
         --  For all other scalar types, what we want logically is a
5309
         --  range test:
5310
 
5311
         --     X in type(X)'First .. type(X)'Last
5312
 
5313
         --  But that's precisely what won't work because of possible
5314
         --  unwanted optimization (and indeed the basic motivation for
5315
         --  the Valid attribute is exactly that this test does not work!)
5316
         --  What will work is:
5317
 
5318
         --     Btyp!(X) >= Btyp!(type(X)'First)
5319
         --       and then
5320
         --     Btyp!(X) <= Btyp!(type(X)'Last)
5321
 
5322
         --  where Btyp is an integer type large enough to cover the full
5323
         --  range of possible stored values (i.e. it is chosen on the basis
5324
         --  of the size of the type, not the range of the values). We write
5325
         --  this as two tests, rather than a range check, so that static
5326
         --  evaluation will easily remove either or both of the checks if
5327
         --  they can be -statically determined to be true (this happens
5328
         --  when the type of X is static and the range extends to the full
5329
         --  range of stored values).
5330
 
5331
         --  Unsigned types. Note: it is safe to consider only whether the
5332
         --  subtype is unsigned, since we will in that case be doing all
5333
         --  unsigned comparisons based on the subtype range. Since we use the
5334
         --  actual subtype object size, this is appropriate.
5335
 
5336
         --  For example, if we have
5337
 
5338
         --    subtype x is integer range 1 .. 200;
5339
         --    for x'Object_Size use 8;
5340
 
5341
         --  Now the base type is signed, but objects of this type are bits
5342
         --  unsigned, and doing an unsigned test of the range 1 to 200 is
5343
         --  correct, even though a value greater than 127 looks signed to a
5344
         --  signed comparison.
5345
 
5346
         elsif Is_Unsigned_Type (Ptyp) then
5347
            if Esize (Ptyp) <= 32 then
5348
               Btyp := RTE (RE_Unsigned_32);
5349
            else
5350
               Btyp := RTE (RE_Unsigned_64);
5351
            end if;
5352
 
5353
            Rewrite (N, Make_Range_Test);
5354
 
5355
         --  Signed types
5356
 
5357
         else
5358
            if Esize (Ptyp) <= Esize (Standard_Integer) then
5359
               Btyp := Standard_Integer;
5360
            else
5361
               Btyp := Universal_Integer;
5362
            end if;
5363
 
5364
            Rewrite (N, Make_Range_Test);
5365
         end if;
5366
 
5367
         Analyze_And_Resolve (N, Standard_Boolean);
5368
         Validity_Checks_On := Save_Validity_Checks_On;
5369
      end Valid;
5370
 
5371
      -----------
5372
      -- Value --
5373
      -----------
5374
 
5375
      --  Value attribute is handled in separate unit Exp_Imgv
5376
 
5377
      when Attribute_Value =>
5378
         Exp_Imgv.Expand_Value_Attribute (N);
5379
 
5380
      -----------------
5381
      -- Value_Size --
5382
      -----------------
5383
 
5384
      --  The processing for Value_Size shares the processing for Size
5385
 
5386
      -------------
5387
      -- Version --
5388
      -------------
5389
 
5390
      --  The processing for Version shares the processing for Body_Version
5391
 
5392
      ----------------
5393
      -- Wide_Image --
5394
      ----------------
5395
 
5396
      --  Wide_Image attribute is handled in separate unit Exp_Imgv
5397
 
5398
      when Attribute_Wide_Image =>
5399
         Exp_Imgv.Expand_Wide_Image_Attribute (N);
5400
 
5401
      ---------------------
5402
      -- Wide_Wide_Image --
5403
      ---------------------
5404
 
5405
      --  Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
5406
 
5407
      when Attribute_Wide_Wide_Image =>
5408
         Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N);
5409
 
5410
      ----------------
5411
      -- Wide_Value --
5412
      ----------------
5413
 
5414
      --  We expand typ'Wide_Value (X) into
5415
 
5416
      --    typ'Value
5417
      --      (Wide_String_To_String (X, Wide_Character_Encoding_Method))
5418
 
5419
      --  Wide_String_To_String is a runtime function that converts its wide
5420
      --  string argument to String, converting any non-translatable characters
5421
      --  into appropriate escape sequences. This preserves the required
5422
      --  semantics of Wide_Value in all cases, and results in a very simple
5423
      --  implementation approach.
5424
 
5425
      --  Note: for this approach to be fully standard compliant for the cases
5426
      --  where typ is Wide_Character and Wide_Wide_Character, the encoding
5427
      --  method must cover the entire character range (e.g. UTF-8). But that
5428
      --  is a reasonable requirement when dealing with encoded character
5429
      --  sequences. Presumably if one of the restrictive encoding mechanisms
5430
      --  is in use such as Shift-JIS, then characters that cannot be
5431
      --  represented using this encoding will not appear in any case.
5432
 
5433
      when Attribute_Wide_Value => Wide_Value :
5434
      begin
5435
         Rewrite (N,
5436
           Make_Attribute_Reference (Loc,
5437
             Prefix         => Pref,
5438
             Attribute_Name => Name_Value,
5439
 
5440
             Expressions    => New_List (
5441
               Make_Function_Call (Loc,
5442
                 Name =>
5443
                   New_Reference_To (RTE (RE_Wide_String_To_String), Loc),
5444
 
5445
                 Parameter_Associations => New_List (
5446
                   Relocate_Node (First (Exprs)),
5447
                   Make_Integer_Literal (Loc,
5448
                     Intval => Int (Wide_Character_Encoding_Method)))))));
5449
 
5450
         Analyze_And_Resolve (N, Typ);
5451
      end Wide_Value;
5452
 
5453
      ---------------------
5454
      -- Wide_Wide_Value --
5455
      ---------------------
5456
 
5457
      --  We expand typ'Wide_Value_Value (X) into
5458
 
5459
      --    typ'Value
5460
      --      (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
5461
 
5462
      --  Wide_Wide_String_To_String is a runtime function that converts its
5463
      --  wide string argument to String, converting any non-translatable
5464
      --  characters into appropriate escape sequences. This preserves the
5465
      --  required semantics of Wide_Wide_Value in all cases, and results in a
5466
      --  very simple implementation approach.
5467
 
5468
      --  It's not quite right where typ = Wide_Wide_Character, because the
5469
      --  encoding method may not cover the whole character type ???
5470
 
5471
      when Attribute_Wide_Wide_Value => Wide_Wide_Value :
5472
      begin
5473
         Rewrite (N,
5474
           Make_Attribute_Reference (Loc,
5475
             Prefix         => Pref,
5476
             Attribute_Name => Name_Value,
5477
 
5478
             Expressions    => New_List (
5479
               Make_Function_Call (Loc,
5480
                 Name =>
5481
                   New_Reference_To (RTE (RE_Wide_Wide_String_To_String), Loc),
5482
 
5483
                 Parameter_Associations => New_List (
5484
                   Relocate_Node (First (Exprs)),
5485
                   Make_Integer_Literal (Loc,
5486
                     Intval => Int (Wide_Character_Encoding_Method)))))));
5487
 
5488
         Analyze_And_Resolve (N, Typ);
5489
      end Wide_Wide_Value;
5490
 
5491
      ---------------------
5492
      -- Wide_Wide_Width --
5493
      ---------------------
5494
 
5495
      --  Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
5496
 
5497
      when Attribute_Wide_Wide_Width =>
5498
         Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
5499
 
5500
      ----------------
5501
      -- Wide_Width --
5502
      ----------------
5503
 
5504
      --  Wide_Width attribute is handled in separate unit Exp_Imgv
5505
 
5506
      when Attribute_Wide_Width =>
5507
         Exp_Imgv.Expand_Width_Attribute (N, Wide);
5508
 
5509
      -----------
5510
      -- Width --
5511
      -----------
5512
 
5513
      --  Width attribute is handled in separate unit Exp_Imgv
5514
 
5515
      when Attribute_Width =>
5516
         Exp_Imgv.Expand_Width_Attribute (N, Normal);
5517
 
5518
      -----------
5519
      -- Write --
5520
      -----------
5521
 
5522
      when Attribute_Write => Write : declare
5523
         P_Type : constant Entity_Id := Entity (Pref);
5524
         U_Type : constant Entity_Id := Underlying_Type (P_Type);
5525
         Pname  : Entity_Id;
5526
         Decl   : Node_Id;
5527
         Prag   : Node_Id;
5528
         Arg3   : Node_Id;
5529
         Wfunc  : Node_Id;
5530
 
5531
      begin
5532
         --  If no underlying type, we have an error that will be diagnosed
5533
         --  elsewhere, so here we just completely ignore the expansion.
5534
 
5535
         if No (U_Type) then
5536
            return;
5537
         end if;
5538
 
5539
         --  The simple case, if there is a TSS for Write, just call it
5540
 
5541
         Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
5542
 
5543
         if Present (Pname) then
5544
            null;
5545
 
5546
         else
5547
            --  If there is a Stream_Convert pragma, use it, we rewrite
5548
 
5549
            --     sourcetyp'Output (stream, Item)
5550
 
5551
            --  as
5552
 
5553
            --     strmtyp'Output (Stream, strmwrite (acttyp (Item)));
5554
 
5555
            --  where strmwrite is the given Write function that converts an
5556
            --  argument of type sourcetyp or a type acctyp, from which it is
5557
            --  derived to type strmtyp. The conversion to acttyp is required
5558
            --  for the derived case.
5559
 
5560
            Prag := Get_Stream_Convert_Pragma (P_Type);
5561
 
5562
            if Present (Prag) then
5563
               Arg3 :=
5564
                 Next (Next (First (Pragma_Argument_Associations (Prag))));
5565
               Wfunc := Entity (Expression (Arg3));
5566
 
5567
               Rewrite (N,
5568
                 Make_Attribute_Reference (Loc,
5569
                   Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
5570
                   Attribute_Name => Name_Output,
5571
                   Expressions => New_List (
5572
                     Relocate_Node (First (Exprs)),
5573
                     Make_Function_Call (Loc,
5574
                       Name => New_Occurrence_Of (Wfunc, Loc),
5575
                       Parameter_Associations => New_List (
5576
                         OK_Convert_To (Etype (First_Formal (Wfunc)),
5577
                           Relocate_Node (Next (First (Exprs)))))))));
5578
 
5579
               Analyze (N);
5580
               return;
5581
 
5582
            --  For elementary types, we call the W_xxx routine directly
5583
 
5584
            elsif Is_Elementary_Type (U_Type) then
5585
               Rewrite (N, Build_Elementary_Write_Call (N));
5586
               Analyze (N);
5587
               return;
5588
 
5589
            --  Array type case
5590
 
5591
            elsif Is_Array_Type (U_Type) then
5592
               Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
5593
               Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5594
 
5595
            --  Tagged type case, use the primitive Write function. Note that
5596
            --  this will dispatch in the class-wide case which is what we want
5597
 
5598
            elsif Is_Tagged_Type (U_Type) then
5599
               Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
5600
 
5601
            --  All other record type cases, including protected records.
5602
            --  The latter only arise for expander generated code for
5603
            --  handling shared passive partition access.
5604
 
5605
            else
5606
               pragma Assert
5607
                 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5608
 
5609
               --  Ada 2005 (AI-216): Program_Error is raised when executing
5610
               --  the default implementation of the Write attribute of an
5611
               --  Unchecked_Union type. However, if the 'Write reference is
5612
               --  within the generated Output stream procedure, Write outputs
5613
               --  the components, and the default values of the discriminant
5614
               --  are streamed by the Output procedure itself.
5615
 
5616
               if Is_Unchecked_Union (Base_Type (U_Type))
5617
                 and not Is_TSS (Current_Scope, TSS_Stream_Output)
5618
               then
5619
                  Insert_Action (N,
5620
                    Make_Raise_Program_Error (Loc,
5621
                      Reason => PE_Unchecked_Union_Restriction));
5622
               end if;
5623
 
5624
               if Has_Discriminants (U_Type)
5625
                 and then Present
5626
                   (Discriminant_Default_Value (First_Discriminant (U_Type)))
5627
               then
5628
                  Build_Mutable_Record_Write_Procedure
5629
                    (Loc, Full_Base (U_Type), Decl, Pname);
5630
               else
5631
                  Build_Record_Write_Procedure
5632
                    (Loc, Full_Base (U_Type), Decl, Pname);
5633
               end if;
5634
 
5635
               Insert_Action (N, Decl);
5636
            end if;
5637
         end if;
5638
 
5639
         --  If we fall through, Pname is the procedure to be called
5640
 
5641
         Rewrite_Stream_Proc_Call (Pname);
5642
      end Write;
5643
 
5644
      --  Component_Size is handled by the back end, unless the component size
5645
      --  is known at compile time, which is always true in the packed array
5646
      --  case. It is important that the packed array case is handled in the
5647
      --  front end (see Eval_Attribute) since the back end would otherwise get
5648
      --  confused by the equivalent packed array type.
5649
 
5650
      when Attribute_Component_Size =>
5651
         null;
5652
 
5653
      --  The following attributes are handled by the back end (except that
5654
      --  static cases have already been evaluated during semantic processing,
5655
      --  but in any case the back end should not count on this). The one bit
5656
      --  of special processing required is that these attributes typically
5657
      --  generate conditionals in the code, so we need to check the relevant
5658
      --  restriction.
5659
 
5660
      when Attribute_Max                          |
5661
           Attribute_Min                          =>
5662
         Check_Restriction (No_Implicit_Conditionals, N);
5663
 
5664
      --  The following attributes are handled by the back end (except that
5665
      --  static cases have already been evaluated during semantic processing,
5666
      --  but in any case the back end should not count on this).
5667
 
5668
      --  The back end also handles the non-class-wide cases of Size
5669
 
5670
      when Attribute_Bit_Order                    |
5671
           Attribute_Code_Address                 |
5672
           Attribute_Definite                     |
5673
           Attribute_Null_Parameter               |
5674
           Attribute_Passed_By_Reference          |
5675
           Attribute_Pool_Address                 =>
5676
         null;
5677
 
5678
      --  The following attributes are also handled by the back end, but return
5679
      --  a universal integer result, so may need a conversion for checking
5680
      --  that the result is in range.
5681
 
5682
      when Attribute_Aft                          |
5683
           Attribute_Max_Alignment_For_Allocation =>
5684
         Apply_Universal_Integer_Attribute_Checks (N);
5685
 
5686
      --  The following attributes should not appear at this stage, since they
5687
      --  have already been handled by the analyzer (and properly rewritten
5688
      --  with corresponding values or entities to represent the right values)
5689
 
5690
      when Attribute_Abort_Signal                 |
5691
           Attribute_Address_Size                 |
5692
           Attribute_Base                         |
5693
           Attribute_Class                        |
5694
           Attribute_Compiler_Version             |
5695
           Attribute_Default_Bit_Order            |
5696
           Attribute_Delta                        |
5697
           Attribute_Denorm                       |
5698
           Attribute_Digits                       |
5699
           Attribute_Emax                         |
5700
           Attribute_Enabled                      |
5701
           Attribute_Epsilon                      |
5702
           Attribute_Fast_Math                    |
5703
           Attribute_Has_Access_Values            |
5704
           Attribute_Has_Discriminants            |
5705
           Attribute_Has_Tagged_Values            |
5706
           Attribute_Large                        |
5707
           Attribute_Machine_Emax                 |
5708
           Attribute_Machine_Emin                 |
5709
           Attribute_Machine_Mantissa             |
5710
           Attribute_Machine_Overflows            |
5711
           Attribute_Machine_Radix                |
5712
           Attribute_Machine_Rounds               |
5713
           Attribute_Maximum_Alignment            |
5714
           Attribute_Model_Emin                   |
5715
           Attribute_Model_Epsilon                |
5716
           Attribute_Model_Mantissa               |
5717
           Attribute_Model_Small                  |
5718
           Attribute_Modulus                      |
5719
           Attribute_Partition_ID                 |
5720
           Attribute_Range                        |
5721
           Attribute_Safe_Emax                    |
5722
           Attribute_Safe_First                   |
5723
           Attribute_Safe_Large                   |
5724
           Attribute_Safe_Last                    |
5725
           Attribute_Safe_Small                   |
5726
           Attribute_Scale                        |
5727
           Attribute_Signed_Zeros                 |
5728
           Attribute_Small                        |
5729
           Attribute_Storage_Unit                 |
5730
           Attribute_Stub_Type                    |
5731
           Attribute_System_Allocator_Alignment   |
5732
           Attribute_Target_Name                  |
5733
           Attribute_Type_Class                   |
5734
           Attribute_Type_Key                     |
5735
           Attribute_Unconstrained_Array          |
5736
           Attribute_Universal_Literal_String     |
5737
           Attribute_Wchar_T_Size                 |
5738
           Attribute_Word_Size                    =>
5739
         raise Program_Error;
5740
 
5741
      --  The Asm_Input and Asm_Output attributes are not expanded at this
5742
      --  stage, but will be eliminated in the expansion of the Asm call, see
5743
      --  Exp_Intr for details. So the back end will never see these either.
5744
 
5745
      when Attribute_Asm_Input                    |
5746
           Attribute_Asm_Output                   =>
5747
         null;
5748
      end case;
5749
 
5750
   exception
5751
      when RE_Not_Available =>
5752
         return;
5753
   end Expand_N_Attribute_Reference;
5754
 
5755
   ----------------------
5756
   -- Expand_Pred_Succ --
5757
   ----------------------
5758
 
5759
   --  For typ'Pred (exp), we generate the check
5760
 
5761
   --    [constraint_error when exp = typ'Base'First]
5762
 
5763
   --  Similarly, for typ'Succ (exp), we generate the check
5764
 
5765
   --    [constraint_error when exp = typ'Base'Last]
5766
 
5767
   --  These checks are not generated for modular types, since the proper
5768
   --  semantics for Succ and Pred on modular types is to wrap, not raise CE.
5769
   --  We also suppress these checks if we are the right side of an assignment
5770
   --  statement or the expression of an object declaration, where the flag
5771
   --  Suppress_Assignment_Checks is set for the assignment/declaration.
5772
 
5773
   procedure Expand_Pred_Succ (N : Node_Id) is
5774
      Loc  : constant Source_Ptr := Sloc (N);
5775
      P    : constant Node_Id    := Parent (N);
5776
      Cnam : Name_Id;
5777
 
5778
   begin
5779
      if Attribute_Name (N) = Name_Pred then
5780
         Cnam := Name_First;
5781
      else
5782
         Cnam := Name_Last;
5783
      end if;
5784
 
5785
      if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration)
5786
        or else not Suppress_Assignment_Checks (P)
5787
      then
5788
         Insert_Action (N,
5789
           Make_Raise_Constraint_Error (Loc,
5790
             Condition =>
5791
               Make_Op_Eq (Loc,
5792
                 Left_Opnd =>
5793
                   Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
5794
                 Right_Opnd =>
5795
                   Make_Attribute_Reference (Loc,
5796
                     Prefix =>
5797
                       New_Reference_To (Base_Type (Etype (Prefix (N))), Loc),
5798
                     Attribute_Name => Cnam)),
5799
             Reason => CE_Overflow_Check_Failed));
5800
      end if;
5801
   end Expand_Pred_Succ;
5802
 
5803
   -------------------
5804
   -- Find_Fat_Info --
5805
   -------------------
5806
 
5807
   procedure Find_Fat_Info
5808
     (T        : Entity_Id;
5809
      Fat_Type : out Entity_Id;
5810
      Fat_Pkg  : out RE_Id)
5811
   is
5812
      Btyp : constant Entity_Id := Base_Type (T);
5813
      Rtyp : constant Entity_Id := Root_Type (T);
5814
      Digs : constant Nat       := UI_To_Int (Digits_Value (Btyp));
5815
 
5816
   begin
5817
      --  If the base type is VAX float, then get appropriate VAX float type
5818
 
5819
      if Vax_Float (Btyp) then
5820
         case Digs is
5821
            when 6 =>
5822
               Fat_Type := RTE (RE_Fat_VAX_F);
5823
               Fat_Pkg  := RE_Attr_VAX_F_Float;
5824
 
5825
            when 9 =>
5826
               Fat_Type := RTE (RE_Fat_VAX_D);
5827
               Fat_Pkg  := RE_Attr_VAX_D_Float;
5828
 
5829
            when 15 =>
5830
               Fat_Type := RTE (RE_Fat_VAX_G);
5831
               Fat_Pkg  := RE_Attr_VAX_G_Float;
5832
 
5833
            when others =>
5834
               raise Program_Error;
5835
         end case;
5836
 
5837
      --  If root type is VAX float, this is the case where the library has
5838
      --  been recompiled in VAX float mode, and we have an IEEE float type.
5839
      --  This is when we use the special IEEE Fat packages.
5840
 
5841
      elsif Vax_Float (Rtyp) then
5842
         case Digs is
5843
            when 6 =>
5844
               Fat_Type := RTE (RE_Fat_IEEE_Short);
5845
               Fat_Pkg  := RE_Attr_IEEE_Short;
5846
 
5847
            when 15 =>
5848
               Fat_Type := RTE (RE_Fat_IEEE_Long);
5849
               Fat_Pkg  := RE_Attr_IEEE_Long;
5850
 
5851
            when others =>
5852
               raise Program_Error;
5853
         end case;
5854
 
5855
      --  If neither the base type nor the root type is VAX_Native then VAX
5856
      --  float is out of the picture, and we can just use the root type.
5857
 
5858
      else
5859
         Fat_Type := Rtyp;
5860
 
5861
         if Fat_Type = Standard_Short_Float then
5862
            Fat_Pkg := RE_Attr_Short_Float;
5863
 
5864
         elsif Fat_Type = Standard_Float then
5865
            Fat_Pkg := RE_Attr_Float;
5866
 
5867
         elsif Fat_Type = Standard_Long_Float then
5868
            Fat_Pkg := RE_Attr_Long_Float;
5869
 
5870
         elsif Fat_Type = Standard_Long_Long_Float then
5871
            Fat_Pkg := RE_Attr_Long_Long_Float;
5872
 
5873
         --  Universal real (which is its own root type) is treated as being
5874
         --  equivalent to Standard.Long_Long_Float, since it is defined to
5875
         --  have the same precision as the longest Float type.
5876
 
5877
         elsif Fat_Type = Universal_Real then
5878
            Fat_Type := Standard_Long_Long_Float;
5879
            Fat_Pkg := RE_Attr_Long_Long_Float;
5880
 
5881
         else
5882
            raise Program_Error;
5883
         end if;
5884
      end if;
5885
   end Find_Fat_Info;
5886
 
5887
   ----------------------------
5888
   -- Find_Stream_Subprogram --
5889
   ----------------------------
5890
 
5891
   function Find_Stream_Subprogram
5892
     (Typ : Entity_Id;
5893
      Nam : TSS_Name_Type) return Entity_Id
5894
   is
5895
      Base_Typ : constant Entity_Id := Base_Type (Typ);
5896
      Ent      : constant Entity_Id := TSS (Typ, Nam);
5897
 
5898
      function Is_Available (Entity : RE_Id) return Boolean;
5899
      pragma Inline (Is_Available);
5900
      --  Function to check whether the specified run-time call is available
5901
      --  in the run time used. In the case of a configurable run time, it
5902
      --  is normal that some subprograms are not there.
5903
 
5904
      --  I don't understand this routine at all, why is this not just a
5905
      --  call to RTE_Available? And if for some reason we need a different
5906
      --  routine with different semantics, why is not in Rtsfind ???
5907
 
5908
      ------------------
5909
      -- Is_Available --
5910
      ------------------
5911
 
5912
      function Is_Available (Entity : RE_Id) return Boolean is
5913
      begin
5914
         --  Assume that the unit will always be available when using a
5915
         --  "normal" (not configurable) run time.
5916
 
5917
         return not Configurable_Run_Time_Mode
5918
           or else RTE_Available (Entity);
5919
      end Is_Available;
5920
 
5921
   --  Start of processing for Find_Stream_Subprogram
5922
 
5923
   begin
5924
      if Present (Ent) then
5925
         return Ent;
5926
      end if;
5927
 
5928
      --  Stream attributes for strings are expanded into library calls. The
5929
      --  following checks are disabled when the run-time is not available or
5930
      --  when compiling predefined types due to bootstrap issues. As a result,
5931
      --  the compiler will generate in-place stream routines for string types
5932
      --  that appear in GNAT's library, but will generate calls via rtsfind
5933
      --  to library routines for user code.
5934
 
5935
      --  ??? For now, disable this code for JVM, since this generates a
5936
      --  VerifyError exception at run time on e.g. c330001.
5937
 
5938
      --  This is disabled for AAMP, to avoid creating dependences on files not
5939
      --  supported in the AAMP library (such as s-fileio.adb).
5940
 
5941
      --  Note: In the case of using a configurable run time, it is very likely
5942
      --  that stream routines for string types are not present (they require
5943
      --  file system support). In this case, the specific stream routines for
5944
      --  strings are not used, relying on the regular stream mechanism
5945
      --  instead. That is why we include the test Is_Available when dealing
5946
      --  with these cases.
5947
 
5948
      if VM_Target /= JVM_Target
5949
        and then not AAMP_On_Target
5950
        and then
5951
          not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
5952
      then
5953
         --  String as defined in package Ada
5954
 
5955
         if Base_Typ = Standard_String then
5956
            if Restriction_Active (No_Stream_Optimizations) then
5957
               if Nam = TSS_Stream_Input
5958
                 and then Is_Available (RE_String_Input)
5959
               then
5960
                  return RTE (RE_String_Input);
5961
 
5962
               elsif Nam = TSS_Stream_Output
5963
                 and then Is_Available (RE_String_Output)
5964
               then
5965
                  return RTE (RE_String_Output);
5966
 
5967
               elsif Nam = TSS_Stream_Read
5968
                 and then Is_Available (RE_String_Read)
5969
               then
5970
                  return RTE (RE_String_Read);
5971
 
5972
               elsif Nam = TSS_Stream_Write
5973
                 and then Is_Available (RE_String_Write)
5974
               then
5975
                  return RTE (RE_String_Write);
5976
 
5977
               elsif Nam /= TSS_Stream_Input and then
5978
                     Nam /= TSS_Stream_Output and then
5979
                     Nam /= TSS_Stream_Read and then
5980
                     Nam /= TSS_Stream_Write
5981
               then
5982
                  raise Program_Error;
5983
               end if;
5984
 
5985
            else
5986
               if Nam = TSS_Stream_Input
5987
                 and then Is_Available (RE_String_Input_Blk_IO)
5988
               then
5989
                  return RTE (RE_String_Input_Blk_IO);
5990
 
5991
               elsif Nam = TSS_Stream_Output
5992
                 and then Is_Available (RE_String_Output_Blk_IO)
5993
               then
5994
                  return RTE (RE_String_Output_Blk_IO);
5995
 
5996
               elsif Nam = TSS_Stream_Read
5997
                 and then Is_Available (RE_String_Read_Blk_IO)
5998
               then
5999
                  return RTE (RE_String_Read_Blk_IO);
6000
 
6001
               elsif Nam = TSS_Stream_Write
6002
                 and then Is_Available (RE_String_Write_Blk_IO)
6003
               then
6004
                  return RTE (RE_String_Write_Blk_IO);
6005
 
6006
               elsif Nam /= TSS_Stream_Input and then
6007
                     Nam /= TSS_Stream_Output and then
6008
                     Nam /= TSS_Stream_Read and then
6009
                     Nam /= TSS_Stream_Write
6010
               then
6011
                  raise Program_Error;
6012
               end if;
6013
            end if;
6014
 
6015
         --  Wide_String as defined in package Ada
6016
 
6017
         elsif Base_Typ = Standard_Wide_String then
6018
            if Restriction_Active (No_Stream_Optimizations) then
6019
               if Nam = TSS_Stream_Input
6020
                 and then Is_Available (RE_Wide_String_Input)
6021
               then
6022
                  return RTE (RE_Wide_String_Input);
6023
 
6024
               elsif Nam = TSS_Stream_Output
6025
                 and then Is_Available (RE_Wide_String_Output)
6026
               then
6027
                  return RTE (RE_Wide_String_Output);
6028
 
6029
               elsif Nam = TSS_Stream_Read
6030
                 and then Is_Available (RE_Wide_String_Read)
6031
               then
6032
                  return RTE (RE_Wide_String_Read);
6033
 
6034
               elsif Nam = TSS_Stream_Write
6035
                 and then Is_Available (RE_Wide_String_Write)
6036
               then
6037
                  return RTE (RE_Wide_String_Write);
6038
 
6039
               elsif Nam /= TSS_Stream_Input and then
6040
                     Nam /= TSS_Stream_Output and then
6041
                     Nam /= TSS_Stream_Read and then
6042
                     Nam /= TSS_Stream_Write
6043
               then
6044
                  raise Program_Error;
6045
               end if;
6046
 
6047
            else
6048
               if Nam = TSS_Stream_Input
6049
                 and then Is_Available (RE_Wide_String_Input_Blk_IO)
6050
               then
6051
                  return RTE (RE_Wide_String_Input_Blk_IO);
6052
 
6053
               elsif Nam = TSS_Stream_Output
6054
                 and then Is_Available (RE_Wide_String_Output_Blk_IO)
6055
               then
6056
                  return RTE (RE_Wide_String_Output_Blk_IO);
6057
 
6058
               elsif Nam = TSS_Stream_Read
6059
                 and then Is_Available (RE_Wide_String_Read_Blk_IO)
6060
               then
6061
                  return RTE (RE_Wide_String_Read_Blk_IO);
6062
 
6063
               elsif Nam = TSS_Stream_Write
6064
                 and then Is_Available (RE_Wide_String_Write_Blk_IO)
6065
               then
6066
                  return RTE (RE_Wide_String_Write_Blk_IO);
6067
 
6068
               elsif Nam /= TSS_Stream_Input and then
6069
                     Nam /= TSS_Stream_Output and then
6070
                     Nam /= TSS_Stream_Read and then
6071
                     Nam /= TSS_Stream_Write
6072
               then
6073
                  raise Program_Error;
6074
               end if;
6075
            end if;
6076
 
6077
         --  Wide_Wide_String as defined in package Ada
6078
 
6079
         elsif Base_Typ = Standard_Wide_Wide_String then
6080
            if Restriction_Active (No_Stream_Optimizations) then
6081
               if Nam = TSS_Stream_Input
6082
                 and then Is_Available (RE_Wide_Wide_String_Input)
6083
               then
6084
                  return RTE (RE_Wide_Wide_String_Input);
6085
 
6086
               elsif Nam = TSS_Stream_Output
6087
                 and then Is_Available (RE_Wide_Wide_String_Output)
6088
               then
6089
                  return RTE (RE_Wide_Wide_String_Output);
6090
 
6091
               elsif Nam = TSS_Stream_Read
6092
                 and then Is_Available (RE_Wide_Wide_String_Read)
6093
               then
6094
                  return RTE (RE_Wide_Wide_String_Read);
6095
 
6096
               elsif Nam = TSS_Stream_Write
6097
                 and then Is_Available (RE_Wide_Wide_String_Write)
6098
               then
6099
                  return RTE (RE_Wide_Wide_String_Write);
6100
 
6101
               elsif Nam /= TSS_Stream_Input and then
6102
                     Nam /= TSS_Stream_Output and then
6103
                     Nam /= TSS_Stream_Read and then
6104
                     Nam /= TSS_Stream_Write
6105
               then
6106
                  raise Program_Error;
6107
               end if;
6108
 
6109
            else
6110
               if Nam = TSS_Stream_Input
6111
                 and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO)
6112
               then
6113
                  return RTE (RE_Wide_Wide_String_Input_Blk_IO);
6114
 
6115
               elsif Nam = TSS_Stream_Output
6116
                 and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO)
6117
               then
6118
                  return RTE (RE_Wide_Wide_String_Output_Blk_IO);
6119
 
6120
               elsif Nam = TSS_Stream_Read
6121
                 and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO)
6122
               then
6123
                  return RTE (RE_Wide_Wide_String_Read_Blk_IO);
6124
 
6125
               elsif Nam = TSS_Stream_Write
6126
                 and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO)
6127
               then
6128
                  return RTE (RE_Wide_Wide_String_Write_Blk_IO);
6129
 
6130
               elsif Nam /= TSS_Stream_Input and then
6131
                     Nam /= TSS_Stream_Output and then
6132
                     Nam /= TSS_Stream_Read and then
6133
                     Nam /= TSS_Stream_Write
6134
               then
6135
                  raise Program_Error;
6136
               end if;
6137
            end if;
6138
         end if;
6139
      end if;
6140
 
6141
      if Is_Tagged_Type (Typ)
6142
        and then Is_Derived_Type (Typ)
6143
      then
6144
         return Find_Prim_Op (Typ, Nam);
6145
      else
6146
         return Find_Inherited_TSS (Typ, Nam);
6147
      end if;
6148
   end Find_Stream_Subprogram;
6149
 
6150
   ---------------
6151
   -- Full_Base --
6152
   ---------------
6153
 
6154
   function Full_Base (T : Entity_Id) return Entity_Id is
6155
      BT : Entity_Id;
6156
 
6157
   begin
6158
      BT := Base_Type (T);
6159
 
6160
      if Is_Private_Type (BT)
6161
        and then Present (Full_View (BT))
6162
      then
6163
         BT := Full_View (BT);
6164
      end if;
6165
 
6166
      return BT;
6167
   end Full_Base;
6168
 
6169
   -----------------------
6170
   -- Get_Index_Subtype --
6171
   -----------------------
6172
 
6173
   function Get_Index_Subtype (N : Node_Id) return Node_Id is
6174
      P_Type : Entity_Id := Etype (Prefix (N));
6175
      Indx   : Node_Id;
6176
      J      : Int;
6177
 
6178
   begin
6179
      if Is_Access_Type (P_Type) then
6180
         P_Type := Designated_Type (P_Type);
6181
      end if;
6182
 
6183
      if No (Expressions (N)) then
6184
         J := 1;
6185
      else
6186
         J := UI_To_Int (Expr_Value (First (Expressions (N))));
6187
      end if;
6188
 
6189
      Indx := First_Index (P_Type);
6190
      while J > 1 loop
6191
         Next_Index (Indx);
6192
         J := J - 1;
6193
      end loop;
6194
 
6195
      return Etype (Indx);
6196
   end Get_Index_Subtype;
6197
 
6198
   -------------------------------
6199
   -- Get_Stream_Convert_Pragma --
6200
   -------------------------------
6201
 
6202
   function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
6203
      Typ : Entity_Id;
6204
      N   : Node_Id;
6205
 
6206
   begin
6207
      --  Note: we cannot use Get_Rep_Pragma here because of the peculiarity
6208
      --  that a stream convert pragma for a tagged type is not inherited from
6209
      --  its parent. Probably what is wrong here is that it is basically
6210
      --  incorrect to consider a stream convert pragma to be a representation
6211
      --  pragma at all ???
6212
 
6213
      N := First_Rep_Item (Implementation_Base_Type (T));
6214
      while Present (N) loop
6215
         if Nkind (N) = N_Pragma
6216
           and then Pragma_Name (N) = Name_Stream_Convert
6217
         then
6218
            --  For tagged types this pragma is not inherited, so we
6219
            --  must verify that it is defined for the given type and
6220
            --  not an ancestor.
6221
 
6222
            Typ :=
6223
              Entity (Expression (First (Pragma_Argument_Associations (N))));
6224
 
6225
            if not Is_Tagged_Type (T)
6226
              or else T = Typ
6227
              or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
6228
            then
6229
               return N;
6230
            end if;
6231
         end if;
6232
 
6233
         Next_Rep_Item (N);
6234
      end loop;
6235
 
6236
      return Empty;
6237
   end Get_Stream_Convert_Pragma;
6238
 
6239
   ---------------------------------
6240
   -- Is_Constrained_Packed_Array --
6241
   ---------------------------------
6242
 
6243
   function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
6244
      Arr : Entity_Id := Typ;
6245
 
6246
   begin
6247
      if Is_Access_Type (Arr) then
6248
         Arr := Designated_Type (Arr);
6249
      end if;
6250
 
6251
      return Is_Array_Type (Arr)
6252
        and then Is_Constrained (Arr)
6253
        and then Present (Packed_Array_Type (Arr));
6254
   end Is_Constrained_Packed_Array;
6255
 
6256
   ----------------------------------------
6257
   -- Is_Inline_Floating_Point_Attribute --
6258
   ----------------------------------------
6259
 
6260
   function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is
6261
      Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
6262
 
6263
   begin
6264
      if Nkind (Parent (N)) /= N_Type_Conversion
6265
        or else not Is_Integer_Type (Etype (Parent (N)))
6266
      then
6267
         return False;
6268
      end if;
6269
 
6270
      --  Should also support 'Machine_Rounding and 'Unbiased_Rounding, but
6271
      --  required back end support has not been implemented yet ???
6272
 
6273
      return Id = Attribute_Truncation;
6274
   end Is_Inline_Floating_Point_Attribute;
6275
 
6276
end Exp_Attr;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.