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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [sem_attr.adb] - Blame information for rev 826

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                             S E M _ A T T R                              --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, 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 Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
27
 
28
with Atree;    use Atree;
29
with Casing;   use Casing;
30
with Checks;   use Checks;
31
with Einfo;    use Einfo;
32
with Errout;   use Errout;
33
with Eval_Fat;
34
with Exp_Dist; use Exp_Dist;
35
with Exp_Util; use Exp_Util;
36
with Expander; use Expander;
37
with Freeze;   use Freeze;
38
with Gnatvsn;  use Gnatvsn;
39
with Itypes;   use Itypes;
40
with Lib;      use Lib;
41
with Lib.Xref; use Lib.Xref;
42
with Nlists;   use Nlists;
43
with Nmake;    use Nmake;
44
with Opt;      use Opt;
45
with Restrict; use Restrict;
46
with Rident;   use Rident;
47
with Rtsfind;  use Rtsfind;
48
with Sdefault; use Sdefault;
49
with Sem;      use Sem;
50
with Sem_Aux;  use Sem_Aux;
51
with Sem_Cat;  use Sem_Cat;
52
with Sem_Ch6;  use Sem_Ch6;
53
with Sem_Ch8;  use Sem_Ch8;
54
with Sem_Ch10; use Sem_Ch10;
55
with Sem_Dist; use Sem_Dist;
56
with Sem_Elim; use Sem_Elim;
57
with Sem_Eval; use Sem_Eval;
58
with Sem_Res;  use Sem_Res;
59
with Sem_Type; use Sem_Type;
60
with Sem_Util; use Sem_Util;
61
with Stand;    use Stand;
62
with Sinfo;    use Sinfo;
63
with Sinput;   use Sinput;
64
with Stringt;  use Stringt;
65
with Style;
66
with Stylesw;  use Stylesw;
67
with Targparm; use Targparm;
68
with Ttypes;   use Ttypes;
69
with Ttypef;   use Ttypef;
70
with Tbuild;   use Tbuild;
71
with Uintp;    use Uintp;
72
with Urealp;   use Urealp;
73
 
74
package body Sem_Attr is
75
 
76
   True_Value  : constant Uint := Uint_1;
77
   False_Value : constant Uint := Uint_0;
78
   --  Synonyms to be used when these constants are used as Boolean values
79
 
80
   Bad_Attribute : exception;
81
   --  Exception raised if an error is detected during attribute processing,
82
   --  used so that we can abandon the processing so we don't run into
83
   --  trouble with cascaded errors.
84
 
85
   --  The following array is the list of attributes defined in the Ada 83 RM
86
   --  that are not included in Ada 95, but still get recognized in GNAT.
87
 
88
   Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
89
      Attribute_Address           |
90
      Attribute_Aft               |
91
      Attribute_Alignment         |
92
      Attribute_Base              |
93
      Attribute_Callable          |
94
      Attribute_Constrained       |
95
      Attribute_Count             |
96
      Attribute_Delta             |
97
      Attribute_Digits            |
98
      Attribute_Emax              |
99
      Attribute_Epsilon           |
100
      Attribute_First             |
101
      Attribute_First_Bit         |
102
      Attribute_Fore              |
103
      Attribute_Image             |
104
      Attribute_Large             |
105
      Attribute_Last              |
106
      Attribute_Last_Bit          |
107
      Attribute_Leading_Part      |
108
      Attribute_Length            |
109
      Attribute_Machine_Emax      |
110
      Attribute_Machine_Emin      |
111
      Attribute_Machine_Mantissa  |
112
      Attribute_Machine_Overflows |
113
      Attribute_Machine_Radix     |
114
      Attribute_Machine_Rounds    |
115
      Attribute_Mantissa          |
116
      Attribute_Pos               |
117
      Attribute_Position          |
118
      Attribute_Pred              |
119
      Attribute_Range             |
120
      Attribute_Safe_Emax         |
121
      Attribute_Safe_Large        |
122
      Attribute_Safe_Small        |
123
      Attribute_Size              |
124
      Attribute_Small             |
125
      Attribute_Storage_Size      |
126
      Attribute_Succ              |
127
      Attribute_Terminated        |
128
      Attribute_Val               |
129
      Attribute_Value             |
130
      Attribute_Width             => True,
131
      others                      => False);
132
 
133
   --  The following array is the list of attributes defined in the Ada 2005
134
   --  RM which are not defined in Ada 95. These are recognized in Ada 95 mode,
135
   --  but in Ada 95 they are considered to be implementation defined.
136
 
137
   Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'(
138
      Attribute_Machine_Rounding  |
139
      Attribute_Priority          |
140
      Attribute_Stream_Size       |
141
      Attribute_Wide_Wide_Width   => True,
142
      others                      => False);
143
 
144
   --  The following array contains all attributes that imply a modification
145
   --  of their prefixes or result in an access value. Such prefixes can be
146
   --  considered as lvalues.
147
 
148
   Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array :=
149
      Attribute_Class_Array'(
150
      Attribute_Access              |
151
      Attribute_Address             |
152
      Attribute_Input               |
153
      Attribute_Read                |
154
      Attribute_Unchecked_Access    |
155
      Attribute_Unrestricted_Access => True,
156
      others                        => False);
157
 
158
   -----------------------
159
   -- Local_Subprograms --
160
   -----------------------
161
 
162
   procedure Eval_Attribute (N : Node_Id);
163
   --  Performs compile time evaluation of attributes where possible, leaving
164
   --  the Is_Static_Expression/Raises_Constraint_Error flags appropriately
165
   --  set, and replacing the node with a literal node if the value can be
166
   --  computed at compile time. All static attribute references are folded,
167
   --  as well as a number of cases of non-static attributes that can always
168
   --  be computed at compile time (e.g. floating-point model attributes that
169
   --  are applied to non-static subtypes). Of course in such cases, the
170
   --  Is_Static_Expression flag will not be set on the resulting literal.
171
   --  Note that the only required action of this procedure is to catch the
172
   --  static expression cases as described in the RM. Folding of other cases
173
   --  is done where convenient, but some additional non-static folding is in
174
   --  N_Expand_Attribute_Reference in cases where this is more convenient.
175
 
176
   function Is_Anonymous_Tagged_Base
177
     (Anon : Entity_Id;
178
      Typ  : Entity_Id)
179
      return Boolean;
180
   --  For derived tagged types that constrain parent discriminants we build
181
   --  an anonymous unconstrained base type. We need to recognize the relation
182
   --  between the two when analyzing an access attribute for a constrained
183
   --  component, before the full declaration for Typ has been analyzed, and
184
   --  where therefore the prefix of the attribute does not match the enclosing
185
   --  scope.
186
 
187
   -----------------------
188
   -- Analyze_Attribute --
189
   -----------------------
190
 
191
   procedure Analyze_Attribute (N : Node_Id) is
192
      Loc     : constant Source_Ptr   := Sloc (N);
193
      Aname   : constant Name_Id      := Attribute_Name (N);
194
      P       : constant Node_Id      := Prefix (N);
195
      Exprs   : constant List_Id      := Expressions (N);
196
      Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
197
      E1      : Node_Id;
198
      E2      : Node_Id;
199
 
200
      P_Type : Entity_Id;
201
      --  Type of prefix after analysis
202
 
203
      P_Base_Type : Entity_Id;
204
      --  Base type of prefix after analysis
205
 
206
      -----------------------
207
      -- Local Subprograms --
208
      -----------------------
209
 
210
      procedure Analyze_Access_Attribute;
211
      --  Used for Access, Unchecked_Access, Unrestricted_Access attributes.
212
      --  Internally, Id distinguishes which of the three cases is involved.
213
 
214
      procedure Check_Array_Or_Scalar_Type;
215
      --  Common procedure used by First, Last, Range attribute to check
216
      --  that the prefix is a constrained array or scalar type, or a name
217
      --  of an array object, and that an argument appears only if appropriate
218
      --  (i.e. only in the array case).
219
 
220
      procedure Check_Array_Type;
221
      --  Common semantic checks for all array attributes. Checks that the
222
      --  prefix is a constrained array type or the name of an array object.
223
      --  The error message for non-arrays is specialized appropriately.
224
 
225
      procedure Check_Asm_Attribute;
226
      --  Common semantic checks for Asm_Input and Asm_Output attributes
227
 
228
      procedure Check_Component;
229
      --  Common processing for Bit_Position, First_Bit, Last_Bit, and
230
      --  Position. Checks prefix is an appropriate selected component.
231
 
232
      procedure Check_Decimal_Fixed_Point_Type;
233
      --  Check that prefix of attribute N is a decimal fixed-point type
234
 
235
      procedure Check_Dereference;
236
      --  If the prefix of attribute is an object of an access type, then
237
      --  introduce an explicit dereference, and adjust P_Type accordingly.
238
 
239
      procedure Check_Discrete_Type;
240
      --  Verify that prefix of attribute N is a discrete type
241
 
242
      procedure Check_E0;
243
      --  Check that no attribute arguments are present
244
 
245
      procedure Check_Either_E0_Or_E1;
246
      --  Check that there are zero or one attribute arguments present
247
 
248
      procedure Check_E1;
249
      --  Check that exactly one attribute argument is present
250
 
251
      procedure Check_E2;
252
      --  Check that two attribute arguments are present
253
 
254
      procedure Check_Enum_Image;
255
      --  If the prefix type is an enumeration type, set all its literals
256
      --  as referenced, since the image function could possibly end up
257
      --  referencing any of the literals indirectly. Same for Enum_Val.
258
 
259
      procedure Check_Fixed_Point_Type;
260
      --  Verify that prefix of attribute N is a fixed type
261
 
262
      procedure Check_Fixed_Point_Type_0;
263
      --  Verify that prefix of attribute N is a fixed type and that
264
      --  no attribute expressions are present
265
 
266
      procedure Check_Floating_Point_Type;
267
      --  Verify that prefix of attribute N is a float type
268
 
269
      procedure Check_Floating_Point_Type_0;
270
      --  Verify that prefix of attribute N is a float type and that
271
      --  no attribute expressions are present
272
 
273
      procedure Check_Floating_Point_Type_1;
274
      --  Verify that prefix of attribute N is a float type and that
275
      --  exactly one attribute expression is present
276
 
277
      procedure Check_Floating_Point_Type_2;
278
      --  Verify that prefix of attribute N is a float type and that
279
      --  two attribute expressions are present
280
 
281
      procedure Legal_Formal_Attribute;
282
      --  Common processing for attributes Definite and Has_Discriminants.
283
      --  Checks that prefix is generic indefinite formal type.
284
 
285
      procedure Check_Integer_Type;
286
      --  Verify that prefix of attribute N is an integer type
287
 
288
      procedure Check_Library_Unit;
289
      --  Verify that prefix of attribute N is a library unit
290
 
291
      procedure Check_Modular_Integer_Type;
292
      --  Verify that prefix of attribute N is a modular integer type
293
 
294
      procedure Check_Not_CPP_Type;
295
      --  Check that P (the prefix of the attribute) is not an CPP type
296
      --  for which no Ada predefined primitive is available.
297
 
298
      procedure Check_Not_Incomplete_Type;
299
      --  Check that P (the prefix of the attribute) is not an incomplete
300
      --  type or a private type for which no full view has been given.
301
 
302
      procedure Check_Object_Reference (P : Node_Id);
303
      --  Check that P (the prefix of the attribute) is an object reference
304
 
305
      procedure Check_Program_Unit;
306
      --  Verify that prefix of attribute N is a program unit
307
 
308
      procedure Check_Real_Type;
309
      --  Verify that prefix of attribute N is fixed or float type
310
 
311
      procedure Check_Scalar_Type;
312
      --  Verify that prefix of attribute N is a scalar type
313
 
314
      procedure Check_Standard_Prefix;
315
      --  Verify that prefix of attribute N is package Standard
316
 
317
      procedure Check_Stream_Attribute (Nam : TSS_Name_Type);
318
      --  Validity checking for stream attribute. Nam is the TSS name of the
319
      --  corresponding possible defined attribute function (e.g. for the
320
      --  Read attribute, Nam will be TSS_Stream_Read).
321
 
322
      procedure Check_PolyORB_Attribute;
323
      --  Validity checking for PolyORB/DSA attribute
324
 
325
      procedure Check_Task_Prefix;
326
      --  Verify that prefix of attribute N is a task or task type
327
 
328
      procedure Check_Type;
329
      --  Verify that the prefix of attribute N is a type
330
 
331
      procedure Check_Unit_Name (Nod : Node_Id);
332
      --  Check that Nod is of the form of a library unit name, i.e that
333
      --  it is an identifier, or a selected component whose prefix is
334
      --  itself of the form of a library unit name. Note that this is
335
      --  quite different from Check_Program_Unit, since it only checks
336
      --  the syntactic form of the name, not the semantic identity. This
337
      --  is because it is used with attributes (Elab_Body, Elab_Spec, and
338
      --  UET_Address) which can refer to non-visible unit.
339
 
340
      procedure Error_Attr (Msg : String; Error_Node : Node_Id);
341
      pragma No_Return (Error_Attr);
342
      procedure Error_Attr;
343
      pragma No_Return (Error_Attr);
344
      --  Posts error using Error_Msg_N at given node, sets type of attribute
345
      --  node to Any_Type, and then raises Bad_Attribute to avoid any further
346
      --  semantic processing. The message typically contains a % insertion
347
      --  character which is replaced by the attribute name. The call with
348
      --  no arguments is used when the caller has already generated the
349
      --  required error messages.
350
 
351
      procedure Error_Attr_P (Msg : String);
352
      pragma No_Return (Error_Attr);
353
      --  Like Error_Attr, but error is posted at the start of the prefix
354
 
355
      procedure Standard_Attribute (Val : Int);
356
      --  Used to process attributes whose prefix is package Standard which
357
      --  yield values of type Universal_Integer. The attribute reference
358
      --  node is rewritten with an integer literal of the given value.
359
 
360
      procedure Unexpected_Argument (En : Node_Id);
361
      --  Signal unexpected attribute argument (En is the argument)
362
 
363
      procedure Validate_Non_Static_Attribute_Function_Call;
364
      --  Called when processing an attribute that is a function call to a
365
      --  non-static function, i.e. an attribute function that either takes
366
      --  non-scalar arguments or returns a non-scalar result. Verifies that
367
      --  such a call does not appear in a preelaborable context.
368
 
369
      ------------------------------
370
      -- Analyze_Access_Attribute --
371
      ------------------------------
372
 
373
      procedure Analyze_Access_Attribute is
374
         Acc_Type : Entity_Id;
375
 
376
         Scop : Entity_Id;
377
         Typ  : Entity_Id;
378
 
379
         function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id;
380
         --  Build an access-to-object type whose designated type is DT,
381
         --  and whose Ekind is appropriate to the attribute type. The
382
         --  type that is constructed is returned as the result.
383
 
384
         procedure Build_Access_Subprogram_Type (P : Node_Id);
385
         --  Build an access to subprogram whose designated type is the type of
386
         --  the prefix. If prefix is overloaded, so is the node itself. The
387
         --  result is stored in Acc_Type.
388
 
389
         function OK_Self_Reference return Boolean;
390
         --  An access reference whose prefix is a type can legally appear
391
         --  within an aggregate, where it is obtained by expansion of
392
         --  a defaulted aggregate. The enclosing aggregate that contains
393
         --  the self-referenced is flagged so that the self-reference can
394
         --  be expanded into a reference to the target object (see exp_aggr).
395
 
396
         ------------------------------
397
         -- Build_Access_Object_Type --
398
         ------------------------------
399
 
400
         function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is
401
            Typ : constant Entity_Id :=
402
                    New_Internal_Entity
403
                      (E_Access_Attribute_Type, Current_Scope, Loc, 'A');
404
         begin
405
            Set_Etype                     (Typ, Typ);
406
            Set_Is_Itype                  (Typ);
407
            Set_Associated_Node_For_Itype (Typ, N);
408
            Set_Directly_Designated_Type  (Typ, DT);
409
            return Typ;
410
         end Build_Access_Object_Type;
411
 
412
         ----------------------------------
413
         -- Build_Access_Subprogram_Type --
414
         ----------------------------------
415
 
416
         procedure Build_Access_Subprogram_Type (P : Node_Id) is
417
            Index : Interp_Index;
418
            It    : Interp;
419
 
420
            procedure Check_Local_Access (E : Entity_Id);
421
            --  Deal with possible access to local subprogram. If we have such
422
            --  an access, we set a flag to kill all tracked values on any call
423
            --  because this access value may be passed around, and any called
424
            --  code might use it to access a local procedure which clobbers a
425
            --  tracked value. If the scope is a loop or block, indicate that
426
            --  value tracking is disabled for the enclosing subprogram.
427
 
428
            function Get_Kind (E : Entity_Id) return Entity_Kind;
429
            --  Distinguish between access to regular/protected subprograms
430
 
431
            ------------------------
432
            -- Check_Local_Access --
433
            ------------------------
434
 
435
            procedure Check_Local_Access (E : Entity_Id) is
436
            begin
437
               if not Is_Library_Level_Entity (E) then
438
                  Set_Suppress_Value_Tracking_On_Call (Current_Scope);
439
                  Set_Suppress_Value_Tracking_On_Call
440
                    (Nearest_Dynamic_Scope (Current_Scope));
441
               end if;
442
            end Check_Local_Access;
443
 
444
            --------------
445
            -- Get_Kind --
446
            --------------
447
 
448
            function Get_Kind (E : Entity_Id) return Entity_Kind is
449
            begin
450
               if Convention (E) = Convention_Protected then
451
                  return E_Access_Protected_Subprogram_Type;
452
               else
453
                  return E_Access_Subprogram_Type;
454
               end if;
455
            end Get_Kind;
456
 
457
         --  Start of processing for Build_Access_Subprogram_Type
458
 
459
         begin
460
            --  In the case of an access to subprogram, use the name of the
461
            --  subprogram itself as the designated type. Type-checking in
462
            --  this case compares the signatures of the designated types.
463
 
464
            --  Note: This fragment of the tree is temporarily malformed
465
            --  because the correct tree requires an E_Subprogram_Type entity
466
            --  as the designated type. In most cases this designated type is
467
            --  later overridden by the semantics with the type imposed by the
468
            --  context during the resolution phase. In the specific case of
469
            --  the expression Address!(Prim'Unrestricted_Access), used to
470
            --  initialize slots of dispatch tables, this work will be done by
471
            --  the expander (see Exp_Aggr).
472
 
473
            --  The reason to temporarily add this kind of node to the tree
474
            --  instead of a proper E_Subprogram_Type itype, is the following:
475
            --  in case of errors found in the source file we report better
476
            --  error messages. For example, instead of generating the
477
            --  following error:
478
 
479
            --      "expected access to subprogram with profile
480
            --       defined at line X"
481
 
482
            --  we currently generate:
483
 
484
            --      "expected access to function Z defined at line X"
485
 
486
            Set_Etype (N, Any_Type);
487
 
488
            if not Is_Overloaded (P) then
489
               Check_Local_Access (Entity (P));
490
 
491
               if not Is_Intrinsic_Subprogram (Entity (P)) then
492
                  Acc_Type := Create_Itype (Get_Kind (Entity (P)), N);
493
                  Set_Is_Public (Acc_Type, False);
494
                  Set_Etype (Acc_Type, Acc_Type);
495
                  Set_Convention (Acc_Type, Convention (Entity (P)));
496
                  Set_Directly_Designated_Type (Acc_Type, Entity (P));
497
                  Set_Etype (N, Acc_Type);
498
                  Freeze_Before (N, Acc_Type);
499
               end if;
500
 
501
            else
502
               Get_First_Interp (P, Index, It);
503
               while Present (It.Nam) loop
504
                  Check_Local_Access (It.Nam);
505
 
506
                  if not Is_Intrinsic_Subprogram (It.Nam) then
507
                     Acc_Type := Create_Itype (Get_Kind (It.Nam), N);
508
                     Set_Is_Public (Acc_Type, False);
509
                     Set_Etype (Acc_Type, Acc_Type);
510
                     Set_Convention (Acc_Type, Convention (It.Nam));
511
                     Set_Directly_Designated_Type (Acc_Type, It.Nam);
512
                     Add_One_Interp (N, Acc_Type, Acc_Type);
513
                     Freeze_Before (N, Acc_Type);
514
                  end if;
515
 
516
                  Get_Next_Interp (Index, It);
517
               end loop;
518
            end if;
519
 
520
            --  Cannot be applied to intrinsic. Looking at the tests above,
521
            --  the only way Etype (N) can still be set to Any_Type is if
522
            --  Is_Intrinsic_Subprogram was True for some referenced entity.
523
 
524
            if Etype (N) = Any_Type then
525
               Error_Attr_P ("prefix of % attribute cannot be intrinsic");
526
            end if;
527
         end Build_Access_Subprogram_Type;
528
 
529
         ----------------------
530
         -- OK_Self_Reference --
531
         ----------------------
532
 
533
         function OK_Self_Reference return Boolean is
534
            Par : Node_Id;
535
 
536
         begin
537
            Par := Parent (N);
538
            while Present (Par)
539
              and then
540
               (Nkind (Par) = N_Component_Association
541
                 or else Nkind (Par) in N_Subexpr)
542
            loop
543
               if Nkind_In (Par, N_Aggregate, N_Extension_Aggregate) then
544
                  if Etype (Par) = Typ then
545
                     Set_Has_Self_Reference (Par);
546
                     return True;
547
                  end if;
548
               end if;
549
 
550
               Par := Parent (Par);
551
            end loop;
552
 
553
            --  No enclosing aggregate, or not a self-reference
554
 
555
            return False;
556
         end OK_Self_Reference;
557
 
558
      --  Start of processing for Analyze_Access_Attribute
559
 
560
      begin
561
         Check_E0;
562
 
563
         if Nkind (P) = N_Character_Literal then
564
            Error_Attr_P
565
              ("prefix of % attribute cannot be enumeration literal");
566
         end if;
567
 
568
         --  Case of access to subprogram
569
 
570
         if Is_Entity_Name (P)
571
           and then Is_Overloadable (Entity (P))
572
         then
573
            if Has_Pragma_Inline_Always (Entity (P)) then
574
               Error_Attr_P
575
                 ("prefix of % attribute cannot be Inline_Always subprogram");
576
            end if;
577
 
578
            if Aname = Name_Unchecked_Access then
579
               Error_Attr ("attribute% cannot be applied to a subprogram", P);
580
            end if;
581
 
582
            --  Issue an error if the prefix denotes an eliminated subprogram
583
 
584
            Check_For_Eliminated_Subprogram (P, Entity (P));
585
 
586
            --  Build the appropriate subprogram type
587
 
588
            Build_Access_Subprogram_Type (P);
589
 
590
            --  For unrestricted access, kill current values, since this
591
            --  attribute allows a reference to a local subprogram that
592
            --  could modify local variables to be passed out of scope
593
 
594
            if Aname = Name_Unrestricted_Access then
595
 
596
               --  Do not kill values on nodes initializing dispatch tables
597
               --  slots. The construct Prim_Ptr!(Prim'Unrestricted_Access)
598
               --  is currently generated by the expander only for this
599
               --  purpose. Done to keep the quality of warnings currently
600
               --  generated by the compiler (otherwise any declaration of
601
               --  a tagged type cleans constant indications from its scope).
602
 
603
               if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
604
                 and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr)
605
                             or else
606
                           Etype (Parent (N)) = RTE (RE_Size_Ptr))
607
                 and then Is_Dispatching_Operation
608
                            (Directly_Designated_Type (Etype (N)))
609
               then
610
                  null;
611
               else
612
                  Kill_Current_Values;
613
               end if;
614
            end if;
615
 
616
            return;
617
 
618
         --  Component is an operation of a protected type
619
 
620
         elsif Nkind (P) = N_Selected_Component
621
           and then Is_Overloadable (Entity (Selector_Name (P)))
622
         then
623
            if Ekind (Entity (Selector_Name (P))) = E_Entry then
624
               Error_Attr_P ("prefix of % attribute must be subprogram");
625
            end if;
626
 
627
            Build_Access_Subprogram_Type (Selector_Name (P));
628
            return;
629
         end if;
630
 
631
         --  Deal with incorrect reference to a type, but note that some
632
         --  accesses are allowed: references to the current type instance,
633
         --  or in Ada 2005 self-referential pointer in a default-initialized
634
         --  aggregate.
635
 
636
         if Is_Entity_Name (P) then
637
            Typ := Entity (P);
638
 
639
            --  The reference may appear in an aggregate that has been expanded
640
            --  into a loop. Locate scope of type definition, if any.
641
 
642
            Scop := Current_Scope;
643
            while Ekind (Scop) = E_Loop loop
644
               Scop := Scope (Scop);
645
            end loop;
646
 
647
            if Is_Type (Typ) then
648
 
649
               --  OK if we are within the scope of a limited type
650
               --  let's mark the component as having per object constraint
651
 
652
               if Is_Anonymous_Tagged_Base (Scop, Typ) then
653
                  Typ := Scop;
654
                  Set_Entity (P, Typ);
655
                  Set_Etype  (P, Typ);
656
               end if;
657
 
658
               if Typ = Scop then
659
                  declare
660
                     Q : Node_Id := Parent (N);
661
 
662
                  begin
663
                     while Present (Q)
664
                       and then Nkind (Q) /= N_Component_Declaration
665
                     loop
666
                        Q := Parent (Q);
667
                     end loop;
668
 
669
                     if Present (Q) then
670
                        Set_Has_Per_Object_Constraint
671
                          (Defining_Identifier (Q), True);
672
                     end if;
673
                  end;
674
 
675
                  if Nkind (P) = N_Expanded_Name then
676
                     Error_Msg_F
677
                       ("current instance prefix must be a direct name", P);
678
                  end if;
679
 
680
                  --  If a current instance attribute appears in a component
681
                  --  constraint it must appear alone; other contexts (spec-
682
                  --  expressions, within a task body) are not subject to this
683
                  --  restriction.
684
 
685
                  if not In_Spec_Expression
686
                    and then not Has_Completion (Scop)
687
                    and then not
688
                      Nkind_In (Parent (N), N_Discriminant_Association,
689
                                            N_Index_Or_Discriminant_Constraint)
690
                  then
691
                     Error_Msg_N
692
                       ("current instance attribute must appear alone", N);
693
                  end if;
694
 
695
               --  OK if we are in initialization procedure for the type
696
               --  in question, in which case the reference to the type
697
               --  is rewritten as a reference to the current object.
698
 
699
               elsif Ekind (Scop) = E_Procedure
700
                 and then Is_Init_Proc (Scop)
701
                 and then Etype (First_Formal (Scop)) = Typ
702
               then
703
                  Rewrite (N,
704
                    Make_Attribute_Reference (Loc,
705
                      Prefix         => Make_Identifier (Loc, Name_uInit),
706
                      Attribute_Name => Name_Unrestricted_Access));
707
                  Analyze (N);
708
                  return;
709
 
710
               --  OK if a task type, this test needs sharpening up ???
711
 
712
               elsif Is_Task_Type (Typ) then
713
                  null;
714
 
715
               --  OK if self-reference in an aggregate in Ada 2005, and
716
               --  the reference comes from a copied default expression.
717
 
718
               --  Note that we check legality of self-reference even if the
719
               --  expression comes from source, e.g. when a single component
720
               --  association in an aggregate has a box association.
721
 
722
               elsif Ada_Version >= Ada_05
723
                 and then OK_Self_Reference
724
               then
725
                  null;
726
 
727
               --  OK if reference to current instance of a protected object
728
 
729
               elsif Is_Protected_Self_Reference (P) then
730
                  null;
731
 
732
               --  Otherwise we have an error case
733
 
734
               else
735
                  Error_Attr ("% attribute cannot be applied to type", P);
736
                  return;
737
               end if;
738
            end if;
739
         end if;
740
 
741
         --  If we fall through, we have a normal access to object case.
742
         --  Unrestricted_Access is legal wherever an allocator would be
743
         --  legal, so its Etype is set to E_Allocator. The expected type
744
         --  of the other attributes is a general access type, and therefore
745
         --  we label them with E_Access_Attribute_Type.
746
 
747
         if not Is_Overloaded (P) then
748
            Acc_Type := Build_Access_Object_Type (P_Type);
749
            Set_Etype (N, Acc_Type);
750
         else
751
            declare
752
               Index : Interp_Index;
753
               It    : Interp;
754
            begin
755
               Set_Etype (N, Any_Type);
756
               Get_First_Interp (P, Index, It);
757
               while Present (It.Typ) loop
758
                  Acc_Type := Build_Access_Object_Type (It.Typ);
759
                  Add_One_Interp (N, Acc_Type, Acc_Type);
760
                  Get_Next_Interp (Index, It);
761
               end loop;
762
            end;
763
         end if;
764
 
765
         --  Special cases when we can find a prefix that is an entity name
766
 
767
         declare
768
            PP  : Node_Id;
769
            Ent : Entity_Id;
770
 
771
         begin
772
            PP := P;
773
            loop
774
               if Is_Entity_Name (PP) then
775
                  Ent := Entity (PP);
776
 
777
                  --  If we have an access to an object, and the attribute
778
                  --  comes from source, then set the object as potentially
779
                  --  source modified. We do this because the resulting access
780
                  --  pointer can be used to modify the variable, and we might
781
                  --  not detect this, leading to some junk warnings.
782
 
783
                  Set_Never_Set_In_Source (Ent, False);
784
 
785
                  --  Mark entity as address taken, and kill current values
786
 
787
                  Set_Address_Taken (Ent);
788
                  Kill_Current_Values (Ent);
789
                  exit;
790
 
791
               elsif Nkind_In (PP, N_Selected_Component,
792
                                   N_Indexed_Component)
793
               then
794
                  PP := Prefix (PP);
795
 
796
               else
797
                  exit;
798
               end if;
799
            end loop;
800
         end;
801
 
802
         --  Check for aliased view unless unrestricted case. We allow a
803
         --  nonaliased prefix when within an instance because the prefix may
804
         --  have been a tagged formal object, which is defined to be aliased
805
         --  even when the actual might not be (other instance cases will have
806
         --  been caught in the generic). Similarly, within an inlined body we
807
         --  know that the attribute is legal in the original subprogram, and
808
         --  therefore legal in the expansion.
809
 
810
         if Aname /= Name_Unrestricted_Access
811
           and then not Is_Aliased_View (P)
812
           and then not In_Instance
813
           and then not In_Inlined_Body
814
         then
815
            Error_Attr_P ("prefix of % attribute must be aliased");
816
         end if;
817
      end Analyze_Access_Attribute;
818
 
819
      --------------------------------
820
      -- Check_Array_Or_Scalar_Type --
821
      --------------------------------
822
 
823
      procedure Check_Array_Or_Scalar_Type is
824
         Index : Entity_Id;
825
 
826
         D : Int;
827
         --  Dimension number for array attributes
828
 
829
      begin
830
         --  Case of string literal or string literal subtype. These cases
831
         --  cannot arise from legal Ada code, but the expander is allowed
832
         --  to generate them. They require special handling because string
833
         --  literal subtypes do not have standard bounds (the whole idea
834
         --  of these subtypes is to avoid having to generate the bounds)
835
 
836
         if Ekind (P_Type) = E_String_Literal_Subtype then
837
            Set_Etype (N, Etype (First_Index (P_Base_Type)));
838
            return;
839
 
840
         --  Scalar types
841
 
842
         elsif Is_Scalar_Type (P_Type) then
843
            Check_Type;
844
 
845
            if Present (E1) then
846
               Error_Attr ("invalid argument in % attribute", E1);
847
            else
848
               Set_Etype (N, P_Base_Type);
849
               return;
850
            end if;
851
 
852
         --  The following is a special test to allow 'First to apply to
853
         --  private scalar types if the attribute comes from generated
854
         --  code. This occurs in the case of Normalize_Scalars code.
855
 
856
         elsif Is_Private_Type (P_Type)
857
           and then Present (Full_View (P_Type))
858
           and then Is_Scalar_Type (Full_View (P_Type))
859
           and then not Comes_From_Source (N)
860
         then
861
            Set_Etype (N, Implementation_Base_Type (P_Type));
862
 
863
         --  Array types other than string literal subtypes handled above
864
 
865
         else
866
            Check_Array_Type;
867
 
868
            --  We know prefix is an array type, or the name of an array
869
            --  object, and that the expression, if present, is static
870
            --  and within the range of the dimensions of the type.
871
 
872
            pragma Assert (Is_Array_Type (P_Type));
873
            Index := First_Index (P_Base_Type);
874
 
875
            if No (E1) then
876
 
877
               --  First dimension assumed
878
 
879
               Set_Etype (N, Base_Type (Etype (Index)));
880
 
881
            else
882
               D := UI_To_Int (Intval (E1));
883
 
884
               for J in 1 .. D - 1 loop
885
                  Next_Index (Index);
886
               end loop;
887
 
888
               Set_Etype (N, Base_Type (Etype (Index)));
889
               Set_Etype (E1, Standard_Integer);
890
            end if;
891
         end if;
892
      end Check_Array_Or_Scalar_Type;
893
 
894
      ----------------------
895
      -- Check_Array_Type --
896
      ----------------------
897
 
898
      procedure Check_Array_Type is
899
         D : Int;
900
         --  Dimension number for array attributes
901
 
902
      begin
903
         --  If the type is a string literal type, then this must be generated
904
         --  internally, and no further check is required on its legality.
905
 
906
         if Ekind (P_Type) = E_String_Literal_Subtype then
907
            return;
908
 
909
         --  If the type is a composite, it is an illegal aggregate, no point
910
         --  in going on.
911
 
912
         elsif P_Type = Any_Composite then
913
            raise Bad_Attribute;
914
         end if;
915
 
916
         --  Normal case of array type or subtype
917
 
918
         Check_Either_E0_Or_E1;
919
         Check_Dereference;
920
 
921
         if Is_Array_Type (P_Type) then
922
            if not Is_Constrained (P_Type)
923
              and then Is_Entity_Name (P)
924
              and then Is_Type (Entity (P))
925
            then
926
               --  Note: we do not call Error_Attr here, since we prefer to
927
               --  continue, using the relevant index type of the array,
928
               --  even though it is unconstrained. This gives better error
929
               --  recovery behavior.
930
 
931
               Error_Msg_Name_1 := Aname;
932
               Error_Msg_F
933
                 ("prefix for % attribute must be constrained array", P);
934
            end if;
935
 
936
            D := Number_Dimensions (P_Type);
937
 
938
         else
939
            if Is_Private_Type (P_Type) then
940
               Error_Attr_P ("prefix for % attribute may not be private type");
941
 
942
            elsif Is_Access_Type (P_Type)
943
              and then Is_Array_Type (Designated_Type (P_Type))
944
              and then Is_Entity_Name (P)
945
              and then Is_Type (Entity (P))
946
            then
947
               Error_Attr_P ("prefix of % attribute cannot be access type");
948
 
949
            elsif Attr_Id = Attribute_First
950
                    or else
951
                  Attr_Id = Attribute_Last
952
            then
953
               Error_Attr ("invalid prefix for % attribute", P);
954
 
955
            else
956
               Error_Attr_P ("prefix for % attribute must be array");
957
            end if;
958
         end if;
959
 
960
         if Present (E1) then
961
            Resolve (E1, Any_Integer);
962
            Set_Etype (E1, Standard_Integer);
963
 
964
            if not Is_Static_Expression (E1)
965
              or else Raises_Constraint_Error (E1)
966
            then
967
               Flag_Non_Static_Expr
968
                 ("expression for dimension must be static!", E1);
969
               Error_Attr;
970
 
971
            elsif  UI_To_Int (Expr_Value (E1)) > D
972
              or else UI_To_Int (Expr_Value (E1)) < 1
973
            then
974
               Error_Attr ("invalid dimension number for array type", E1);
975
            end if;
976
         end if;
977
 
978
         if (Style_Check and Style_Check_Array_Attribute_Index)
979
           and then Comes_From_Source (N)
980
         then
981
            Style.Check_Array_Attribute_Index (N, E1, D);
982
         end if;
983
      end Check_Array_Type;
984
 
985
      -------------------------
986
      -- Check_Asm_Attribute --
987
      -------------------------
988
 
989
      procedure Check_Asm_Attribute is
990
      begin
991
         Check_Type;
992
         Check_E2;
993
 
994
         --  Check first argument is static string expression
995
 
996
         Analyze_And_Resolve (E1, Standard_String);
997
 
998
         if Etype (E1) = Any_Type then
999
            return;
1000
 
1001
         elsif not Is_OK_Static_Expression (E1) then
1002
            Flag_Non_Static_Expr
1003
              ("constraint argument must be static string expression!", E1);
1004
            Error_Attr;
1005
         end if;
1006
 
1007
         --  Check second argument is right type
1008
 
1009
         Analyze_And_Resolve (E2, Entity (P));
1010
 
1011
         --  Note: that is all we need to do, we don't need to check
1012
         --  that it appears in a correct context. The Ada type system
1013
         --  will do that for us.
1014
 
1015
      end Check_Asm_Attribute;
1016
 
1017
      ---------------------
1018
      -- Check_Component --
1019
      ---------------------
1020
 
1021
      procedure Check_Component is
1022
      begin
1023
         Check_E0;
1024
 
1025
         if Nkind (P) /= N_Selected_Component
1026
           or else
1027
             (Ekind (Entity (Selector_Name (P))) /= E_Component
1028
               and then
1029
              Ekind (Entity (Selector_Name (P))) /= E_Discriminant)
1030
         then
1031
            Error_Attr_P ("prefix for % attribute must be selected component");
1032
         end if;
1033
      end Check_Component;
1034
 
1035
      ------------------------------------
1036
      -- Check_Decimal_Fixed_Point_Type --
1037
      ------------------------------------
1038
 
1039
      procedure Check_Decimal_Fixed_Point_Type is
1040
      begin
1041
         Check_Type;
1042
 
1043
         if not Is_Decimal_Fixed_Point_Type (P_Type) then
1044
            Error_Attr_P ("prefix of % attribute must be decimal type");
1045
         end if;
1046
      end Check_Decimal_Fixed_Point_Type;
1047
 
1048
      -----------------------
1049
      -- Check_Dereference --
1050
      -----------------------
1051
 
1052
      procedure Check_Dereference is
1053
      begin
1054
 
1055
         --  Case of a subtype mark
1056
 
1057
         if Is_Entity_Name (P)
1058
           and then Is_Type (Entity (P))
1059
         then
1060
            return;
1061
         end if;
1062
 
1063
         --  Case of an expression
1064
 
1065
         Resolve (P);
1066
 
1067
         if Is_Access_Type (P_Type) then
1068
 
1069
            --  If there is an implicit dereference, then we must freeze
1070
            --  the designated type of the access type, since the type of
1071
            --  the referenced array is this type (see AI95-00106).
1072
 
1073
            --  As done elsewhere, freezing must not happen when pre-analyzing
1074
            --  a pre- or postcondition or a default value for an object or
1075
            --  for a formal parameter.
1076
 
1077
            if not In_Spec_Expression then
1078
               Freeze_Before (N, Designated_Type (P_Type));
1079
            end if;
1080
 
1081
            Rewrite (P,
1082
              Make_Explicit_Dereference (Sloc (P),
1083
                Prefix => Relocate_Node (P)));
1084
 
1085
            Analyze_And_Resolve (P);
1086
            P_Type := Etype (P);
1087
 
1088
            if P_Type = Any_Type then
1089
               raise Bad_Attribute;
1090
            end if;
1091
 
1092
            P_Base_Type := Base_Type (P_Type);
1093
         end if;
1094
      end Check_Dereference;
1095
 
1096
      -------------------------
1097
      -- Check_Discrete_Type --
1098
      -------------------------
1099
 
1100
      procedure Check_Discrete_Type is
1101
      begin
1102
         Check_Type;
1103
 
1104
         if not Is_Discrete_Type (P_Type) then
1105
            Error_Attr_P ("prefix of % attribute must be discrete type");
1106
         end if;
1107
      end Check_Discrete_Type;
1108
 
1109
      --------------
1110
      -- Check_E0 --
1111
      --------------
1112
 
1113
      procedure Check_E0 is
1114
      begin
1115
         if Present (E1) then
1116
            Unexpected_Argument (E1);
1117
         end if;
1118
      end Check_E0;
1119
 
1120
      --------------
1121
      -- Check_E1 --
1122
      --------------
1123
 
1124
      procedure Check_E1 is
1125
      begin
1126
         Check_Either_E0_Or_E1;
1127
 
1128
         if No (E1) then
1129
 
1130
            --  Special-case attributes that are functions and that appear as
1131
            --  the prefix of another attribute. Error is posted on parent.
1132
 
1133
            if Nkind (Parent (N)) = N_Attribute_Reference
1134
              and then (Attribute_Name (Parent (N)) = Name_Address
1135
                          or else
1136
                        Attribute_Name (Parent (N)) = Name_Code_Address
1137
                          or else
1138
                        Attribute_Name (Parent (N)) = Name_Access)
1139
            then
1140
               Error_Msg_Name_1 := Attribute_Name (Parent (N));
1141
               Error_Msg_N ("illegal prefix for % attribute", Parent (N));
1142
               Set_Etype (Parent (N), Any_Type);
1143
               Set_Entity (Parent (N), Any_Type);
1144
               raise Bad_Attribute;
1145
 
1146
            else
1147
               Error_Attr ("missing argument for % attribute", N);
1148
            end if;
1149
         end if;
1150
      end Check_E1;
1151
 
1152
      --------------
1153
      -- Check_E2 --
1154
      --------------
1155
 
1156
      procedure Check_E2 is
1157
      begin
1158
         if No (E1) then
1159
            Error_Attr ("missing arguments for % attribute (2 required)", N);
1160
         elsif No (E2) then
1161
            Error_Attr ("missing argument for % attribute (2 required)", N);
1162
         end if;
1163
      end Check_E2;
1164
 
1165
      ---------------------------
1166
      -- Check_Either_E0_Or_E1 --
1167
      ---------------------------
1168
 
1169
      procedure Check_Either_E0_Or_E1 is
1170
      begin
1171
         if Present (E2) then
1172
            Unexpected_Argument (E2);
1173
         end if;
1174
      end Check_Either_E0_Or_E1;
1175
 
1176
      ----------------------
1177
      -- Check_Enum_Image --
1178
      ----------------------
1179
 
1180
      procedure Check_Enum_Image is
1181
         Lit : Entity_Id;
1182
      begin
1183
         if Is_Enumeration_Type (P_Base_Type) then
1184
            Lit := First_Literal (P_Base_Type);
1185
            while Present (Lit) loop
1186
               Set_Referenced (Lit);
1187
               Next_Literal (Lit);
1188
            end loop;
1189
         end if;
1190
      end Check_Enum_Image;
1191
 
1192
      ----------------------------
1193
      -- Check_Fixed_Point_Type --
1194
      ----------------------------
1195
 
1196
      procedure Check_Fixed_Point_Type is
1197
      begin
1198
         Check_Type;
1199
 
1200
         if not Is_Fixed_Point_Type (P_Type) then
1201
            Error_Attr_P ("prefix of % attribute must be fixed point type");
1202
         end if;
1203
      end Check_Fixed_Point_Type;
1204
 
1205
      ------------------------------
1206
      -- Check_Fixed_Point_Type_0 --
1207
      ------------------------------
1208
 
1209
      procedure Check_Fixed_Point_Type_0 is
1210
      begin
1211
         Check_Fixed_Point_Type;
1212
         Check_E0;
1213
      end Check_Fixed_Point_Type_0;
1214
 
1215
      -------------------------------
1216
      -- Check_Floating_Point_Type --
1217
      -------------------------------
1218
 
1219
      procedure Check_Floating_Point_Type is
1220
      begin
1221
         Check_Type;
1222
 
1223
         if not Is_Floating_Point_Type (P_Type) then
1224
            Error_Attr_P ("prefix of % attribute must be float type");
1225
         end if;
1226
      end Check_Floating_Point_Type;
1227
 
1228
      ---------------------------------
1229
      -- Check_Floating_Point_Type_0 --
1230
      ---------------------------------
1231
 
1232
      procedure Check_Floating_Point_Type_0 is
1233
      begin
1234
         Check_Floating_Point_Type;
1235
         Check_E0;
1236
      end Check_Floating_Point_Type_0;
1237
 
1238
      ---------------------------------
1239
      -- Check_Floating_Point_Type_1 --
1240
      ---------------------------------
1241
 
1242
      procedure Check_Floating_Point_Type_1 is
1243
      begin
1244
         Check_Floating_Point_Type;
1245
         Check_E1;
1246
      end Check_Floating_Point_Type_1;
1247
 
1248
      ---------------------------------
1249
      -- Check_Floating_Point_Type_2 --
1250
      ---------------------------------
1251
 
1252
      procedure Check_Floating_Point_Type_2 is
1253
      begin
1254
         Check_Floating_Point_Type;
1255
         Check_E2;
1256
      end Check_Floating_Point_Type_2;
1257
 
1258
      ------------------------
1259
      -- Check_Integer_Type --
1260
      ------------------------
1261
 
1262
      procedure Check_Integer_Type is
1263
      begin
1264
         Check_Type;
1265
 
1266
         if not Is_Integer_Type (P_Type) then
1267
            Error_Attr_P ("prefix of % attribute must be integer type");
1268
         end if;
1269
      end Check_Integer_Type;
1270
 
1271
      ------------------------
1272
      -- Check_Library_Unit --
1273
      ------------------------
1274
 
1275
      procedure Check_Library_Unit is
1276
      begin
1277
         if not Is_Compilation_Unit (Entity (P)) then
1278
            Error_Attr_P ("prefix of % attribute must be library unit");
1279
         end if;
1280
      end Check_Library_Unit;
1281
 
1282
      --------------------------------
1283
      -- Check_Modular_Integer_Type --
1284
      --------------------------------
1285
 
1286
      procedure Check_Modular_Integer_Type is
1287
      begin
1288
         Check_Type;
1289
 
1290
         if not Is_Modular_Integer_Type (P_Type) then
1291
            Error_Attr_P
1292
              ("prefix of % attribute must be modular integer type");
1293
         end if;
1294
      end Check_Modular_Integer_Type;
1295
 
1296
      ------------------------
1297
      -- Check_Not_CPP_Type --
1298
      ------------------------
1299
 
1300
      procedure Check_Not_CPP_Type is
1301
      begin
1302
         if Is_Tagged_Type (Etype (P))
1303
           and then Convention (Etype (P)) = Convention_CPP
1304
           and then Is_CPP_Class (Root_Type (Etype (P)))
1305
         then
1306
            Error_Attr_P
1307
              ("invalid use of % attribute with 'C'P'P tagged type");
1308
         end if;
1309
      end Check_Not_CPP_Type;
1310
 
1311
      -------------------------------
1312
      -- Check_Not_Incomplete_Type --
1313
      -------------------------------
1314
 
1315
      procedure Check_Not_Incomplete_Type is
1316
         E   : Entity_Id;
1317
         Typ : Entity_Id;
1318
 
1319
      begin
1320
         --  Ada 2005 (AI-50217, AI-326): If the prefix is an explicit
1321
         --  dereference we have to check wrong uses of incomplete types
1322
         --  (other wrong uses are checked at their freezing point).
1323
 
1324
         --  Example 1: Limited-with
1325
 
1326
         --    limited with Pkg;
1327
         --    package P is
1328
         --       type Acc is access Pkg.T;
1329
         --       X : Acc;
1330
         --       S : Integer := X.all'Size;                    -- ERROR
1331
         --    end P;
1332
 
1333
         --  Example 2: Tagged incomplete
1334
 
1335
         --     type T is tagged;
1336
         --     type Acc is access all T;
1337
         --     X : Acc;
1338
         --     S : constant Integer := X.all'Size;             -- ERROR
1339
         --     procedure Q (Obj : Integer := X.all'Alignment); -- ERROR
1340
 
1341
         if Ada_Version >= Ada_05
1342
           and then Nkind (P) = N_Explicit_Dereference
1343
         then
1344
            E := P;
1345
            while Nkind (E) = N_Explicit_Dereference loop
1346
               E := Prefix (E);
1347
            end loop;
1348
 
1349
            Typ := Etype (E);
1350
 
1351
            if From_With_Type (Typ) then
1352
               Error_Attr_P
1353
                 ("prefix of % attribute cannot be an incomplete type");
1354
 
1355
            else
1356
               if Is_Access_Type (Typ) then
1357
                  Typ := Directly_Designated_Type (Typ);
1358
               end if;
1359
 
1360
               if Is_Class_Wide_Type (Typ) then
1361
                  Typ := Root_Type (Typ);
1362
               end if;
1363
 
1364
               --  A legal use of a shadow entity occurs only when the unit
1365
               --  where the non-limited view resides is imported via a regular
1366
               --  with clause in the current body. Such references to shadow
1367
               --  entities may occur in subprogram formals.
1368
 
1369
               if Is_Incomplete_Type (Typ)
1370
                 and then From_With_Type (Typ)
1371
                 and then Present (Non_Limited_View (Typ))
1372
                 and then Is_Legal_Shadow_Entity_In_Body (Typ)
1373
               then
1374
                  Typ := Non_Limited_View (Typ);
1375
               end if;
1376
 
1377
               if Ekind (Typ) = E_Incomplete_Type
1378
                 and then No (Full_View (Typ))
1379
               then
1380
                  Error_Attr_P
1381
                    ("prefix of % attribute cannot be an incomplete type");
1382
               end if;
1383
            end if;
1384
         end if;
1385
 
1386
         if not Is_Entity_Name (P)
1387
           or else not Is_Type (Entity (P))
1388
           or else In_Spec_Expression
1389
         then
1390
            return;
1391
         else
1392
            Check_Fully_Declared (P_Type, P);
1393
         end if;
1394
      end Check_Not_Incomplete_Type;
1395
 
1396
      ----------------------------
1397
      -- Check_Object_Reference --
1398
      ----------------------------
1399
 
1400
      procedure Check_Object_Reference (P : Node_Id) is
1401
         Rtyp : Entity_Id;
1402
 
1403
      begin
1404
         --  If we need an object, and we have a prefix that is the name of
1405
         --  a function entity, convert it into a function call.
1406
 
1407
         if Is_Entity_Name (P)
1408
           and then Ekind (Entity (P)) = E_Function
1409
         then
1410
            Rtyp := Etype (Entity (P));
1411
 
1412
            Rewrite (P,
1413
              Make_Function_Call (Sloc (P),
1414
                Name => Relocate_Node (P)));
1415
 
1416
            Analyze_And_Resolve (P, Rtyp);
1417
 
1418
         --  Otherwise we must have an object reference
1419
 
1420
         elsif not Is_Object_Reference (P) then
1421
            Error_Attr_P ("prefix of % attribute must be object");
1422
         end if;
1423
      end Check_Object_Reference;
1424
 
1425
      ----------------------------
1426
      -- Check_PolyORB_Attribute --
1427
      ----------------------------
1428
 
1429
      procedure Check_PolyORB_Attribute is
1430
      begin
1431
         Validate_Non_Static_Attribute_Function_Call;
1432
 
1433
         Check_Type;
1434
         Check_Not_CPP_Type;
1435
 
1436
         if Get_PCS_Name /= Name_PolyORB_DSA then
1437
            Error_Attr
1438
              ("attribute% requires the 'Poly'O'R'B 'P'C'S", N);
1439
         end if;
1440
      end Check_PolyORB_Attribute;
1441
 
1442
      ------------------------
1443
      -- Check_Program_Unit --
1444
      ------------------------
1445
 
1446
      procedure Check_Program_Unit is
1447
      begin
1448
         if Is_Entity_Name (P) then
1449
            declare
1450
               K : constant Entity_Kind := Ekind (Entity (P));
1451
               T : constant Entity_Id   := Etype (Entity (P));
1452
 
1453
            begin
1454
               if K in Subprogram_Kind
1455
                 or else K in Task_Kind
1456
                 or else K in Protected_Kind
1457
                 or else K = E_Package
1458
                 or else K in Generic_Unit_Kind
1459
                 or else (K = E_Variable
1460
                            and then
1461
                              (Is_Task_Type (T)
1462
                                 or else
1463
                               Is_Protected_Type (T)))
1464
               then
1465
                  return;
1466
               end if;
1467
            end;
1468
         end if;
1469
 
1470
         Error_Attr_P ("prefix of % attribute must be program unit");
1471
      end Check_Program_Unit;
1472
 
1473
      ---------------------
1474
      -- Check_Real_Type --
1475
      ---------------------
1476
 
1477
      procedure Check_Real_Type is
1478
      begin
1479
         Check_Type;
1480
 
1481
         if not Is_Real_Type (P_Type) then
1482
            Error_Attr_P ("prefix of % attribute must be real type");
1483
         end if;
1484
      end Check_Real_Type;
1485
 
1486
      -----------------------
1487
      -- Check_Scalar_Type --
1488
      -----------------------
1489
 
1490
      procedure Check_Scalar_Type is
1491
      begin
1492
         Check_Type;
1493
 
1494
         if not Is_Scalar_Type (P_Type) then
1495
            Error_Attr_P ("prefix of % attribute must be scalar type");
1496
         end if;
1497
      end Check_Scalar_Type;
1498
 
1499
      ---------------------------
1500
      -- Check_Standard_Prefix --
1501
      ---------------------------
1502
 
1503
      procedure Check_Standard_Prefix is
1504
      begin
1505
         Check_E0;
1506
 
1507
         if Nkind (P) /= N_Identifier
1508
           or else Chars (P) /= Name_Standard
1509
         then
1510
            Error_Attr ("only allowed prefix for % attribute is Standard", P);
1511
         end if;
1512
      end Check_Standard_Prefix;
1513
 
1514
      ----------------------------
1515
      -- Check_Stream_Attribute --
1516
      ----------------------------
1517
 
1518
      procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is
1519
         Etyp : Entity_Id;
1520
         Btyp : Entity_Id;
1521
 
1522
         In_Shared_Var_Procs : Boolean;
1523
         --  True when compiling the body of System.Shared_Storage.
1524
         --  Shared_Var_Procs. For this runtime package (always compiled in
1525
         --  GNAT mode), we allow stream attributes references for limited
1526
         --  types for the case where shared passive objects are implemented
1527
         --  using stream attributes, which is the default in GNAT's persistent
1528
         --  storage implementation.
1529
 
1530
      begin
1531
         Validate_Non_Static_Attribute_Function_Call;
1532
 
1533
         --  With the exception of 'Input, Stream attributes are procedures,
1534
         --  and can only appear at the position of procedure calls. We check
1535
         --  for this here, before they are rewritten, to give a more precise
1536
         --  diagnostic.
1537
 
1538
         if Nam = TSS_Stream_Input then
1539
            null;
1540
 
1541
         elsif Is_List_Member (N)
1542
           and then not Nkind_In (Parent (N), N_Procedure_Call_Statement,
1543
                                              N_Aggregate)
1544
         then
1545
            null;
1546
 
1547
         else
1548
            Error_Attr
1549
              ("invalid context for attribute%, which is a procedure", N);
1550
         end if;
1551
 
1552
         Check_Type;
1553
         Btyp := Implementation_Base_Type (P_Type);
1554
 
1555
         --  Stream attributes not allowed on limited types unless the
1556
         --  attribute reference was generated by the expander (in which
1557
         --  case the underlying type will be used, as described in Sinfo),
1558
         --  or the attribute was specified explicitly for the type itself
1559
         --  or one of its ancestors (taking visibility rules into account if
1560
         --  in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp
1561
         --  (with no visibility restriction).
1562
 
1563
         declare
1564
            Gen_Body : constant Node_Id := Enclosing_Generic_Body (N);
1565
         begin
1566
            if Present (Gen_Body) then
1567
               In_Shared_Var_Procs :=
1568
                 Is_RTE (Corresponding_Spec (Gen_Body), RE_Shared_Var_Procs);
1569
            else
1570
               In_Shared_Var_Procs := False;
1571
            end if;
1572
         end;
1573
 
1574
         if (Comes_From_Source (N)
1575
              and then not (In_Shared_Var_Procs or In_Instance))
1576
           and then not Stream_Attribute_Available (P_Type, Nam)
1577
           and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert)
1578
         then
1579
            Error_Msg_Name_1 := Aname;
1580
 
1581
            if Is_Limited_Type (P_Type) then
1582
               Error_Msg_NE
1583
                 ("limited type& has no% attribute", P, P_Type);
1584
               Explain_Limited_Type (P_Type, P);
1585
            else
1586
               Error_Msg_NE
1587
                 ("attribute% for type& is not available", P, P_Type);
1588
            end if;
1589
         end if;
1590
 
1591
         --  Check restriction violations
1592
 
1593
         --  First check the No_Streams restriction, which prohibits the use
1594
         --  of explicit stream attributes in the source program. We do not
1595
         --  prevent the occurrence of stream attributes in generated code,
1596
         --  for instance those generated implicitly for dispatching purposes.
1597
 
1598
         if Comes_From_Source (N) then
1599
            Check_Restriction (No_Streams, P);
1600
         end if;
1601
 
1602
         --  Check special case of Exception_Id and Exception_Occurrence which
1603
         --  are not allowed for restriction No_Exception_Regstriation.
1604
 
1605
         if Is_RTE (P_Type, RE_Exception_Id)
1606
              or else
1607
            Is_RTE (P_Type, RE_Exception_Occurrence)
1608
         then
1609
            Check_Restriction (No_Exception_Registration, P);
1610
         end if;
1611
 
1612
         --  Here we must check that the first argument is an access type
1613
         --  that is compatible with Ada.Streams.Root_Stream_Type'Class.
1614
 
1615
         Analyze_And_Resolve (E1);
1616
         Etyp := Etype (E1);
1617
 
1618
         --  Note: the double call to Root_Type here is needed because the
1619
         --  root type of a class-wide type is the corresponding type (e.g.
1620
         --  X for X'Class, and we really want to go to the root.)
1621
 
1622
         if not Is_Access_Type (Etyp)
1623
           or else Root_Type (Root_Type (Designated_Type (Etyp))) /=
1624
                     RTE (RE_Root_Stream_Type)
1625
         then
1626
            Error_Attr
1627
              ("expected access to Ada.Streams.Root_Stream_Type''Class", E1);
1628
         end if;
1629
 
1630
         --  Check that the second argument is of the right type if there is
1631
         --  one (the Input attribute has only one argument so this is skipped)
1632
 
1633
         if Present (E2) then
1634
            Analyze (E2);
1635
 
1636
            if Nam = TSS_Stream_Read
1637
              and then not Is_OK_Variable_For_Out_Formal (E2)
1638
            then
1639
               Error_Attr
1640
                 ("second argument of % attribute must be a variable", E2);
1641
            end if;
1642
 
1643
            Resolve (E2, P_Type);
1644
         end if;
1645
 
1646
         Check_Not_CPP_Type;
1647
      end Check_Stream_Attribute;
1648
 
1649
      -----------------------
1650
      -- Check_Task_Prefix --
1651
      -----------------------
1652
 
1653
      procedure Check_Task_Prefix is
1654
      begin
1655
         Analyze (P);
1656
 
1657
         --  Ada 2005 (AI-345): Attribute 'Terminated can be applied to
1658
         --  task interface class-wide types.
1659
 
1660
         if Is_Task_Type (Etype (P))
1661
           or else (Is_Access_Type (Etype (P))
1662
                      and then Is_Task_Type (Designated_Type (Etype (P))))
1663
           or else (Ada_Version >= Ada_05
1664
                      and then Ekind (Etype (P)) = E_Class_Wide_Type
1665
                      and then Is_Interface (Etype (P))
1666
                      and then Is_Task_Interface (Etype (P)))
1667
         then
1668
            Resolve (P);
1669
 
1670
         else
1671
            if Ada_Version >= Ada_05 then
1672
               Error_Attr_P
1673
                 ("prefix of % attribute must be a task or a task " &
1674
                  "interface class-wide object");
1675
 
1676
            else
1677
               Error_Attr_P ("prefix of % attribute must be a task");
1678
            end if;
1679
         end if;
1680
      end Check_Task_Prefix;
1681
 
1682
      ----------------
1683
      -- Check_Type --
1684
      ----------------
1685
 
1686
      --  The possibilities are an entity name denoting a type, or an
1687
      --  attribute reference that denotes a type (Base or Class). If
1688
      --  the type is incomplete, replace it with its full view.
1689
 
1690
      procedure Check_Type is
1691
      begin
1692
         if not Is_Entity_Name (P)
1693
           or else not Is_Type (Entity (P))
1694
         then
1695
            Error_Attr_P ("prefix of % attribute must be a type");
1696
 
1697
         elsif Is_Protected_Self_Reference (P) then
1698
            Error_Attr_P
1699
              ("prefix of % attribute denotes current instance "
1700
               & "(RM 9.4(21/2))");
1701
 
1702
         elsif Ekind (Entity (P)) = E_Incomplete_Type
1703
            and then Present (Full_View (Entity (P)))
1704
         then
1705
            P_Type := Full_View (Entity (P));
1706
            Set_Entity (P, P_Type);
1707
         end if;
1708
      end Check_Type;
1709
 
1710
      ---------------------
1711
      -- Check_Unit_Name --
1712
      ---------------------
1713
 
1714
      procedure Check_Unit_Name (Nod : Node_Id) is
1715
      begin
1716
         if Nkind (Nod) = N_Identifier then
1717
            return;
1718
 
1719
         elsif Nkind (Nod) = N_Selected_Component then
1720
            Check_Unit_Name (Prefix (Nod));
1721
 
1722
            if Nkind (Selector_Name (Nod)) = N_Identifier then
1723
               return;
1724
            end if;
1725
         end if;
1726
 
1727
         Error_Attr ("argument for % attribute must be unit name", P);
1728
      end Check_Unit_Name;
1729
 
1730
      ----------------
1731
      -- Error_Attr --
1732
      ----------------
1733
 
1734
      procedure Error_Attr is
1735
      begin
1736
         Set_Etype (N, Any_Type);
1737
         Set_Entity (N, Any_Type);
1738
         raise Bad_Attribute;
1739
      end Error_Attr;
1740
 
1741
      procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
1742
      begin
1743
         Error_Msg_Name_1 := Aname;
1744
         Error_Msg_N (Msg, Error_Node);
1745
         Error_Attr;
1746
      end Error_Attr;
1747
 
1748
      ------------------
1749
      -- Error_Attr_P --
1750
      ------------------
1751
 
1752
      procedure Error_Attr_P (Msg : String) is
1753
      begin
1754
         Error_Msg_Name_1 := Aname;
1755
         Error_Msg_F (Msg, P);
1756
         Error_Attr;
1757
      end Error_Attr_P;
1758
 
1759
      ----------------------------
1760
      -- Legal_Formal_Attribute --
1761
      ----------------------------
1762
 
1763
      procedure Legal_Formal_Attribute is
1764
      begin
1765
         Check_E0;
1766
 
1767
         if not Is_Entity_Name (P)
1768
           or else not Is_Type (Entity (P))
1769
         then
1770
            Error_Attr_P ("prefix of % attribute must be generic type");
1771
 
1772
         elsif Is_Generic_Actual_Type (Entity (P))
1773
           or else In_Instance
1774
           or else In_Inlined_Body
1775
         then
1776
            null;
1777
 
1778
         elsif Is_Generic_Type (Entity (P)) then
1779
            if not Is_Indefinite_Subtype (Entity (P)) then
1780
               Error_Attr_P
1781
                 ("prefix of % attribute must be indefinite generic type");
1782
            end if;
1783
 
1784
         else
1785
            Error_Attr_P
1786
              ("prefix of % attribute must be indefinite generic type");
1787
         end if;
1788
 
1789
         Set_Etype (N, Standard_Boolean);
1790
      end Legal_Formal_Attribute;
1791
 
1792
      ------------------------
1793
      -- Standard_Attribute --
1794
      ------------------------
1795
 
1796
      procedure Standard_Attribute (Val : Int) is
1797
      begin
1798
         Check_Standard_Prefix;
1799
         Rewrite (N, Make_Integer_Literal (Loc, Val));
1800
         Analyze (N);
1801
      end Standard_Attribute;
1802
 
1803
      -------------------------
1804
      -- Unexpected Argument --
1805
      -------------------------
1806
 
1807
      procedure Unexpected_Argument (En : Node_Id) is
1808
      begin
1809
         Error_Attr ("unexpected argument for % attribute", En);
1810
      end Unexpected_Argument;
1811
 
1812
      -------------------------------------------------
1813
      -- Validate_Non_Static_Attribute_Function_Call --
1814
      -------------------------------------------------
1815
 
1816
      --  This function should be moved to Sem_Dist ???
1817
 
1818
      procedure Validate_Non_Static_Attribute_Function_Call is
1819
      begin
1820
         if In_Preelaborated_Unit
1821
           and then not In_Subprogram_Or_Concurrent_Unit
1822
         then
1823
            Flag_Non_Static_Expr
1824
              ("non-static function call in preelaborated unit!", N);
1825
         end if;
1826
      end Validate_Non_Static_Attribute_Function_Call;
1827
 
1828
   -----------------------------------------------
1829
   -- Start of Processing for Analyze_Attribute --
1830
   -----------------------------------------------
1831
 
1832
   begin
1833
      --  Immediate return if unrecognized attribute (already diagnosed
1834
      --  by parser, so there is nothing more that we need to do)
1835
 
1836
      if not Is_Attribute_Name (Aname) then
1837
         raise Bad_Attribute;
1838
      end if;
1839
 
1840
      --  Deal with Ada 83 issues
1841
 
1842
      if Comes_From_Source (N) then
1843
         if not Attribute_83 (Attr_Id) then
1844
            if Ada_Version = Ada_83 and then Comes_From_Source (N) then
1845
               Error_Msg_Name_1 := Aname;
1846
               Error_Msg_N ("(Ada 83) attribute% is not standard?", N);
1847
            end if;
1848
 
1849
            if Attribute_Impl_Def (Attr_Id) then
1850
               Check_Restriction (No_Implementation_Attributes, N);
1851
            end if;
1852
         end if;
1853
      end if;
1854
 
1855
      --  Deal with Ada 2005 issues
1856
 
1857
      if Attribute_05 (Attr_Id) and then Ada_Version <= Ada_95 then
1858
         Check_Restriction (No_Implementation_Attributes, N);
1859
      end if;
1860
 
1861
      --   Remote access to subprogram type access attribute reference needs
1862
      --   unanalyzed copy for tree transformation. The analyzed copy is used
1863
      --   for its semantic information (whether prefix is a remote subprogram
1864
      --   name), the unanalyzed copy is used to construct new subtree rooted
1865
      --   with N_Aggregate which represents a fat pointer aggregate.
1866
 
1867
      if Aname = Name_Access then
1868
         Discard_Node (Copy_Separate_Tree (N));
1869
      end if;
1870
 
1871
      --  Analyze prefix and exit if error in analysis. If the prefix is an
1872
      --  incomplete type, use full view if available. Note that there are
1873
      --  some attributes for which we do not analyze the prefix, since the
1874
      --  prefix is not a normal name.
1875
 
1876
      if Aname /= Name_Elab_Body
1877
           and then
1878
         Aname /= Name_Elab_Spec
1879
           and then
1880
         Aname /= Name_UET_Address
1881
           and then
1882
         Aname /= Name_Enabled
1883
      then
1884
         Analyze (P);
1885
         P_Type := Etype (P);
1886
 
1887
         if Is_Entity_Name (P)
1888
           and then Present (Entity (P))
1889
           and then Is_Type (Entity (P))
1890
         then
1891
            if Ekind (Entity (P)) = E_Incomplete_Type then
1892
               P_Type := Get_Full_View (P_Type);
1893
               Set_Entity (P, P_Type);
1894
               Set_Etype  (P, P_Type);
1895
 
1896
            elsif Entity (P) = Current_Scope
1897
              and then Is_Record_Type (Entity (P))
1898
            then
1899
               --  Use of current instance within the type. Verify that if the
1900
               --  attribute appears within a constraint, it  yields an access
1901
               --  type, other uses are illegal.
1902
 
1903
               declare
1904
                  Par : Node_Id;
1905
 
1906
               begin
1907
                  Par := Parent (N);
1908
                  while Present (Par)
1909
                    and then Nkind (Parent (Par)) /= N_Component_Definition
1910
                  loop
1911
                     Par := Parent (Par);
1912
                  end loop;
1913
 
1914
                  if Present (Par)
1915
                    and then Nkind (Par) = N_Subtype_Indication
1916
                  then
1917
                     if Attr_Id /= Attribute_Access
1918
                       and then Attr_Id /= Attribute_Unchecked_Access
1919
                       and then Attr_Id /= Attribute_Unrestricted_Access
1920
                     then
1921
                        Error_Msg_N
1922
                          ("in a constraint the current instance can only"
1923
                             & " be used with an access attribute", N);
1924
                     end if;
1925
                  end if;
1926
               end;
1927
            end if;
1928
         end if;
1929
 
1930
         if P_Type = Any_Type then
1931
            raise Bad_Attribute;
1932
         end if;
1933
 
1934
         P_Base_Type := Base_Type (P_Type);
1935
      end if;
1936
 
1937
      --  Analyze expressions that may be present, exiting if an error occurs
1938
 
1939
      if No (Exprs) then
1940
         E1 := Empty;
1941
         E2 := Empty;
1942
 
1943
      else
1944
         E1 := First (Exprs);
1945
         Analyze (E1);
1946
 
1947
         --  Check for missing/bad expression (result of previous error)
1948
 
1949
         if No (E1) or else Etype (E1) = Any_Type then
1950
            raise Bad_Attribute;
1951
         end if;
1952
 
1953
         E2 := Next (E1);
1954
 
1955
         if Present (E2) then
1956
            Analyze (E2);
1957
 
1958
            if Etype (E2) = Any_Type then
1959
               raise Bad_Attribute;
1960
            end if;
1961
 
1962
            if Present (Next (E2)) then
1963
               Unexpected_Argument (Next (E2));
1964
            end if;
1965
         end if;
1966
      end if;
1967
 
1968
      --  Ada 2005 (AI-345): Ensure that the compiler gives exactly the current
1969
      --  output compiling in Ada 95 mode for the case of ambiguous prefixes.
1970
 
1971
      if Ada_Version < Ada_05
1972
        and then Is_Overloaded (P)
1973
        and then Aname /= Name_Access
1974
        and then Aname /= Name_Address
1975
        and then Aname /= Name_Code_Address
1976
        and then Aname /= Name_Count
1977
        and then Aname /= Name_Result
1978
        and then Aname /= Name_Unchecked_Access
1979
      then
1980
         Error_Attr ("ambiguous prefix for % attribute", P);
1981
 
1982
      elsif Ada_Version >= Ada_05
1983
        and then Is_Overloaded (P)
1984
        and then Aname /= Name_Access
1985
        and then Aname /= Name_Address
1986
        and then Aname /= Name_Code_Address
1987
        and then Aname /= Name_Result
1988
        and then Aname /= Name_Unchecked_Access
1989
      then
1990
         --  Ada 2005 (AI-345): Since protected and task types have primitive
1991
         --  entry wrappers, the attributes Count, Caller and AST_Entry require
1992
         --  a context check
1993
 
1994
         if Ada_Version >= Ada_05
1995
           and then (Aname = Name_Count
1996
                      or else Aname = Name_Caller
1997
                      or else Aname = Name_AST_Entry)
1998
         then
1999
            declare
2000
               Count : Natural := 0;
2001
               I     : Interp_Index;
2002
               It    : Interp;
2003
 
2004
            begin
2005
               Get_First_Interp (P, I, It);
2006
               while Present (It.Nam) loop
2007
                  if Comes_From_Source (It.Nam) then
2008
                     Count := Count + 1;
2009
                  else
2010
                     Remove_Interp (I);
2011
                  end if;
2012
 
2013
                  Get_Next_Interp (I, It);
2014
               end loop;
2015
 
2016
               if Count > 1 then
2017
                  Error_Attr ("ambiguous prefix for % attribute", P);
2018
               else
2019
                  Set_Is_Overloaded (P, False);
2020
               end if;
2021
            end;
2022
 
2023
         else
2024
            Error_Attr ("ambiguous prefix for % attribute", P);
2025
         end if;
2026
      end if;
2027
 
2028
      --  Remaining processing depends on attribute
2029
 
2030
      case Attr_Id is
2031
 
2032
      ------------------
2033
      -- Abort_Signal --
2034
      ------------------
2035
 
2036
      when Attribute_Abort_Signal =>
2037
         Check_Standard_Prefix;
2038
         Rewrite (N,
2039
           New_Reference_To (Stand.Abort_Signal, Loc));
2040
         Analyze (N);
2041
 
2042
      ------------
2043
      -- Access --
2044
      ------------
2045
 
2046
      when Attribute_Access =>
2047
         Analyze_Access_Attribute;
2048
 
2049
      -------------
2050
      -- Address --
2051
      -------------
2052
 
2053
      when Attribute_Address =>
2054
         Check_E0;
2055
 
2056
         --  Check for some junk cases, where we have to allow the address
2057
         --  attribute but it does not make much sense, so at least for now
2058
         --  just replace with Null_Address.
2059
 
2060
         --  We also do this if the prefix is a reference to the AST_Entry
2061
         --  attribute. If expansion is active, the attribute will be
2062
         --  replaced by a function call, and address will work fine and
2063
         --  get the proper value, but if expansion is not active, then
2064
         --  the check here allows proper semantic analysis of the reference.
2065
 
2066
         --  An Address attribute created by expansion is legal even when it
2067
         --  applies to other entity-denoting expressions.
2068
 
2069
         if Is_Protected_Self_Reference (P) then
2070
 
2071
            --  Address attribute on a protected object self reference is legal
2072
 
2073
            null;
2074
 
2075
         elsif Is_Entity_Name (P) then
2076
            declare
2077
               Ent : constant Entity_Id := Entity (P);
2078
 
2079
            begin
2080
               if Is_Subprogram (Ent) then
2081
                  Set_Address_Taken (Ent);
2082
                  Kill_Current_Values (Ent);
2083
 
2084
                  --  An Address attribute is accepted when generated by the
2085
                  --  compiler for dispatching operation, and an error is
2086
                  --  issued once the subprogram is frozen (to avoid confusing
2087
                  --  errors about implicit uses of Address in the dispatch
2088
                  --  table initialization).
2089
 
2090
                  if Has_Pragma_Inline_Always (Entity (P))
2091
                    and then Comes_From_Source (P)
2092
                  then
2093
                     Error_Attr_P
2094
                       ("prefix of % attribute cannot be Inline_Always" &
2095
                        " subprogram");
2096
 
2097
                  --  It is illegal to apply 'Address to an intrinsic
2098
                  --  subprogram. This is now formalized in AI05-0095.
2099
                  --  In an instance, an attempt to obtain 'Address of an
2100
                  --  intrinsic subprogram (e.g the renaming of a predefined
2101
                  --  operator that is an actual) raises Program_Error.
2102
 
2103
                  elsif Convention (Ent) = Convention_Intrinsic then
2104
                     if In_Instance then
2105
                        Rewrite (N,
2106
                          Make_Raise_Program_Error (Loc,
2107
                            Reason => PE_Address_Of_Intrinsic));
2108
 
2109
                     else
2110
                        Error_Msg_N
2111
                         ("cannot take Address of intrinsic subprogram", N);
2112
                     end if;
2113
 
2114
                  --  Issue an error if prefix denotes an eliminated subprogram
2115
 
2116
                  else
2117
                     Check_For_Eliminated_Subprogram (P, Ent);
2118
                  end if;
2119
 
2120
               elsif Is_Object (Ent)
2121
                 or else Ekind (Ent) = E_Label
2122
               then
2123
                  Set_Address_Taken (Ent);
2124
 
2125
               --  If we have an address of an object, and the attribute
2126
               --  comes from source, then set the object as potentially
2127
               --  source modified. We do this because the resulting address
2128
               --  can potentially be used to modify the variable and we
2129
               --  might not detect this, leading to some junk warnings.
2130
 
2131
                  Set_Never_Set_In_Source (Ent, False);
2132
 
2133
               elsif (Is_Concurrent_Type (Etype (Ent))
2134
                       and then Etype (Ent) = Base_Type (Ent))
2135
                 or else Ekind (Ent) = E_Package
2136
                 or else Is_Generic_Unit (Ent)
2137
               then
2138
                  Rewrite (N,
2139
                    New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
2140
 
2141
               else
2142
                  Error_Attr ("invalid prefix for % attribute", P);
2143
               end if;
2144
            end;
2145
 
2146
         elsif Nkind (P) = N_Attribute_Reference
2147
           and then Attribute_Name (P) = Name_AST_Entry
2148
         then
2149
            Rewrite (N,
2150
              New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
2151
 
2152
         elsif Is_Object_Reference (P) then
2153
            null;
2154
 
2155
         elsif Nkind (P) = N_Selected_Component
2156
           and then Is_Subprogram (Entity (Selector_Name (P)))
2157
         then
2158
            null;
2159
 
2160
         --  What exactly are we allowing here ??? and is this properly
2161
         --  documented in the sinfo documentation for this node ???
2162
 
2163
         elsif not Comes_From_Source (N) then
2164
            null;
2165
 
2166
         else
2167
            Error_Attr ("invalid prefix for % attribute", P);
2168
         end if;
2169
 
2170
         Set_Etype (N, RTE (RE_Address));
2171
 
2172
      ------------------
2173
      -- Address_Size --
2174
      ------------------
2175
 
2176
      when Attribute_Address_Size =>
2177
         Standard_Attribute (System_Address_Size);
2178
 
2179
      --------------
2180
      -- Adjacent --
2181
      --------------
2182
 
2183
      when Attribute_Adjacent =>
2184
         Check_Floating_Point_Type_2;
2185
         Set_Etype (N, P_Base_Type);
2186
         Resolve (E1, P_Base_Type);
2187
         Resolve (E2, P_Base_Type);
2188
 
2189
      ---------
2190
      -- Aft --
2191
      ---------
2192
 
2193
      when Attribute_Aft =>
2194
         Check_Fixed_Point_Type_0;
2195
         Set_Etype (N, Universal_Integer);
2196
 
2197
      ---------------
2198
      -- Alignment --
2199
      ---------------
2200
 
2201
      when Attribute_Alignment =>
2202
 
2203
         --  Don't we need more checking here, cf Size ???
2204
 
2205
         Check_E0;
2206
         Check_Not_Incomplete_Type;
2207
         Check_Not_CPP_Type;
2208
         Set_Etype (N, Universal_Integer);
2209
 
2210
      ---------------
2211
      -- Asm_Input --
2212
      ---------------
2213
 
2214
      when Attribute_Asm_Input =>
2215
         Check_Asm_Attribute;
2216
         Set_Etype (N, RTE (RE_Asm_Input_Operand));
2217
 
2218
      ----------------
2219
      -- Asm_Output --
2220
      ----------------
2221
 
2222
      when Attribute_Asm_Output =>
2223
         Check_Asm_Attribute;
2224
 
2225
         if Etype (E2) = Any_Type then
2226
            return;
2227
 
2228
         elsif Aname = Name_Asm_Output then
2229
            if not Is_Variable (E2) then
2230
               Error_Attr
2231
                 ("second argument for Asm_Output is not variable", E2);
2232
            end if;
2233
         end if;
2234
 
2235
         Note_Possible_Modification (E2, Sure => True);
2236
         Set_Etype (N, RTE (RE_Asm_Output_Operand));
2237
 
2238
      ---------------
2239
      -- AST_Entry --
2240
      ---------------
2241
 
2242
      when Attribute_AST_Entry => AST_Entry : declare
2243
         Ent  : Entity_Id;
2244
         Pref : Node_Id;
2245
         Ptyp : Entity_Id;
2246
 
2247
         Indexed : Boolean;
2248
         --  Indicates if entry family index is present. Note the coding
2249
         --  here handles the entry family case, but in fact it cannot be
2250
         --  executed currently, because pragma AST_Entry does not permit
2251
         --  the specification of an entry family.
2252
 
2253
         procedure Bad_AST_Entry;
2254
         --  Signal a bad AST_Entry pragma
2255
 
2256
         function OK_Entry (E : Entity_Id) return Boolean;
2257
         --  Checks that E is of an appropriate entity kind for an entry
2258
         --  (i.e. E_Entry if Index is False, or E_Entry_Family if Index
2259
         --  is set True for the entry family case). In the True case,
2260
         --  makes sure that Is_AST_Entry is set on the entry.
2261
 
2262
         -------------------
2263
         -- Bad_AST_Entry --
2264
         -------------------
2265
 
2266
         procedure Bad_AST_Entry is
2267
         begin
2268
            Error_Attr_P ("prefix for % attribute must be task entry");
2269
         end Bad_AST_Entry;
2270
 
2271
         --------------
2272
         -- OK_Entry --
2273
         --------------
2274
 
2275
         function OK_Entry (E : Entity_Id) return Boolean is
2276
            Result : Boolean;
2277
 
2278
         begin
2279
            if Indexed then
2280
               Result := (Ekind (E) = E_Entry_Family);
2281
            else
2282
               Result := (Ekind (E) = E_Entry);
2283
            end if;
2284
 
2285
            if Result then
2286
               if not Is_AST_Entry (E) then
2287
                  Error_Msg_Name_2 := Aname;
2288
                  Error_Attr ("% attribute requires previous % pragma", P);
2289
               end if;
2290
            end if;
2291
 
2292
            return Result;
2293
         end OK_Entry;
2294
 
2295
      --  Start of processing for AST_Entry
2296
 
2297
      begin
2298
         Check_VMS (N);
2299
         Check_E0;
2300
 
2301
         --  Deal with entry family case
2302
 
2303
         if Nkind (P) = N_Indexed_Component then
2304
            Pref := Prefix (P);
2305
            Indexed := True;
2306
         else
2307
            Pref := P;
2308
            Indexed := False;
2309
         end if;
2310
 
2311
         Ptyp := Etype (Pref);
2312
 
2313
         if Ptyp = Any_Type or else Error_Posted (Pref) then
2314
            return;
2315
         end if;
2316
 
2317
         --  If the prefix is a selected component whose prefix is of an
2318
         --  access type, then introduce an explicit dereference.
2319
         --  ??? Could we reuse Check_Dereference here?
2320
 
2321
         if Nkind (Pref) = N_Selected_Component
2322
           and then Is_Access_Type (Ptyp)
2323
         then
2324
            Rewrite (Pref,
2325
              Make_Explicit_Dereference (Sloc (Pref),
2326
                Relocate_Node (Pref)));
2327
            Analyze_And_Resolve (Pref, Designated_Type (Ptyp));
2328
         end if;
2329
 
2330
         --  Prefix can be of the form a.b, where a is a task object
2331
         --  and b is one of the entries of the corresponding task type.
2332
 
2333
         if Nkind (Pref) = N_Selected_Component
2334
           and then OK_Entry (Entity (Selector_Name (Pref)))
2335
           and then Is_Object_Reference (Prefix (Pref))
2336
           and then Is_Task_Type (Etype (Prefix (Pref)))
2337
         then
2338
            null;
2339
 
2340
         --  Otherwise the prefix must be an entry of a containing task,
2341
         --  or of a variable of the enclosing task type.
2342
 
2343
         else
2344
            if Nkind_In (Pref, N_Identifier, N_Expanded_Name) then
2345
               Ent := Entity (Pref);
2346
 
2347
               if not OK_Entry (Ent)
2348
                 or else not In_Open_Scopes (Scope (Ent))
2349
               then
2350
                  Bad_AST_Entry;
2351
               end if;
2352
 
2353
            else
2354
               Bad_AST_Entry;
2355
            end if;
2356
         end if;
2357
 
2358
         Set_Etype (N, RTE (RE_AST_Handler));
2359
      end AST_Entry;
2360
 
2361
      ----------
2362
      -- Base --
2363
      ----------
2364
 
2365
      --  Note: when the base attribute appears in the context of a subtype
2366
      --  mark, the analysis is done by Sem_Ch8.Find_Type, rather than by
2367
      --  the following circuit.
2368
 
2369
      when Attribute_Base => Base : declare
2370
         Typ : Entity_Id;
2371
 
2372
      begin
2373
         Check_E0;
2374
         Find_Type (P);
2375
         Typ := Entity (P);
2376
 
2377
         if Ada_Version >= Ada_95
2378
           and then not Is_Scalar_Type (Typ)
2379
           and then not Is_Generic_Type (Typ)
2380
         then
2381
            Error_Attr_P ("prefix of Base attribute must be scalar type");
2382
 
2383
         elsif Sloc (Typ) = Standard_Location
2384
           and then Base_Type (Typ) = Typ
2385
           and then Warn_On_Redundant_Constructs
2386
         then
2387
               Error_Msg_NE
2388
                 ("?redundant attribute, & is its own base type", N, Typ);
2389
         end if;
2390
 
2391
         Set_Etype (N, Base_Type (Entity (P)));
2392
         Set_Entity (N, Base_Type (Entity (P)));
2393
         Rewrite (N, New_Reference_To (Entity (N), Loc));
2394
         Analyze (N);
2395
      end Base;
2396
 
2397
      ---------
2398
      -- Bit --
2399
      ---------
2400
 
2401
      when Attribute_Bit => Bit :
2402
      begin
2403
         Check_E0;
2404
 
2405
         if not Is_Object_Reference (P) then
2406
            Error_Attr_P ("prefix for % attribute must be object");
2407
 
2408
         --  What about the access object cases ???
2409
 
2410
         else
2411
            null;
2412
         end if;
2413
 
2414
         Set_Etype (N, Universal_Integer);
2415
      end Bit;
2416
 
2417
      ---------------
2418
      -- Bit_Order --
2419
      ---------------
2420
 
2421
      when Attribute_Bit_Order => Bit_Order :
2422
      begin
2423
         Check_E0;
2424
         Check_Type;
2425
 
2426
         if not Is_Record_Type (P_Type) then
2427
            Error_Attr_P ("prefix of % attribute must be record type");
2428
         end if;
2429
 
2430
         if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then
2431
            Rewrite (N,
2432
              New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
2433
         else
2434
            Rewrite (N,
2435
              New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
2436
         end if;
2437
 
2438
         Set_Etype (N, RTE (RE_Bit_Order));
2439
         Resolve (N);
2440
 
2441
         --  Reset incorrect indication of staticness
2442
 
2443
         Set_Is_Static_Expression (N, False);
2444
      end Bit_Order;
2445
 
2446
      ------------------
2447
      -- Bit_Position --
2448
      ------------------
2449
 
2450
      --  Note: in generated code, we can have a Bit_Position attribute
2451
      --  applied to a (naked) record component (i.e. the prefix is an
2452
      --  identifier that references an E_Component or E_Discriminant
2453
      --  entity directly, and this is interpreted as expected by Gigi.
2454
      --  The following code will not tolerate such usage, but when the
2455
      --  expander creates this special case, it marks it as analyzed
2456
      --  immediately and sets an appropriate type.
2457
 
2458
      when Attribute_Bit_Position =>
2459
         if Comes_From_Source (N) then
2460
            Check_Component;
2461
         end if;
2462
 
2463
         Set_Etype (N, Universal_Integer);
2464
 
2465
      ------------------
2466
      -- Body_Version --
2467
      ------------------
2468
 
2469
      when Attribute_Body_Version =>
2470
         Check_E0;
2471
         Check_Program_Unit;
2472
         Set_Etype (N, RTE (RE_Version_String));
2473
 
2474
      --------------
2475
      -- Callable --
2476
      --------------
2477
 
2478
      when Attribute_Callable =>
2479
         Check_E0;
2480
         Set_Etype (N, Standard_Boolean);
2481
         Check_Task_Prefix;
2482
 
2483
      ------------
2484
      -- Caller --
2485
      ------------
2486
 
2487
      when Attribute_Caller => Caller : declare
2488
         Ent        : Entity_Id;
2489
         S          : Entity_Id;
2490
 
2491
      begin
2492
         Check_E0;
2493
 
2494
         if Nkind_In (P, N_Identifier, N_Expanded_Name) then
2495
            Ent := Entity (P);
2496
 
2497
            if not Is_Entry (Ent) then
2498
               Error_Attr ("invalid entry name", N);
2499
            end if;
2500
 
2501
         else
2502
            Error_Attr ("invalid entry name", N);
2503
            return;
2504
         end if;
2505
 
2506
         for J in reverse 0 .. Scope_Stack.Last loop
2507
            S := Scope_Stack.Table (J).Entity;
2508
 
2509
            if S = Scope (Ent) then
2510
               Error_Attr ("Caller must appear in matching accept or body", N);
2511
            elsif S = Ent then
2512
               exit;
2513
            end if;
2514
         end loop;
2515
 
2516
         Set_Etype (N, RTE (RO_AT_Task_Id));
2517
      end Caller;
2518
 
2519
      -------------
2520
      -- Ceiling --
2521
      -------------
2522
 
2523
      when Attribute_Ceiling =>
2524
         Check_Floating_Point_Type_1;
2525
         Set_Etype (N, P_Base_Type);
2526
         Resolve (E1, P_Base_Type);
2527
 
2528
      -----------
2529
      -- Class --
2530
      -----------
2531
 
2532
      when Attribute_Class =>
2533
         Check_Restriction (No_Dispatch, N);
2534
         Check_E0;
2535
         Find_Type (N);
2536
 
2537
      ------------------
2538
      -- Code_Address --
2539
      ------------------
2540
 
2541
      when Attribute_Code_Address =>
2542
         Check_E0;
2543
 
2544
         if Nkind (P) = N_Attribute_Reference
2545
           and then (Attribute_Name (P) = Name_Elab_Body
2546
                       or else
2547
                     Attribute_Name (P) = Name_Elab_Spec)
2548
         then
2549
            null;
2550
 
2551
         elsif not Is_Entity_Name (P)
2552
           or else (Ekind (Entity (P)) /= E_Function
2553
                      and then
2554
                    Ekind (Entity (P)) /= E_Procedure)
2555
         then
2556
            Error_Attr ("invalid prefix for % attribute", P);
2557
            Set_Address_Taken (Entity (P));
2558
 
2559
         --  Issue an error if the prefix denotes an eliminated subprogram
2560
 
2561
         else
2562
            Check_For_Eliminated_Subprogram (P, Entity (P));
2563
         end if;
2564
 
2565
         Set_Etype (N, RTE (RE_Address));
2566
 
2567
      ----------------------
2568
      -- Compiler_Version --
2569
      ----------------------
2570
 
2571
      when Attribute_Compiler_Version =>
2572
         Check_E0;
2573
         Check_Standard_Prefix;
2574
         Rewrite (N, Make_String_Literal (Loc, "GNAT " & Gnat_Version_String));
2575
         Analyze_And_Resolve (N, Standard_String);
2576
 
2577
      --------------------
2578
      -- Component_Size --
2579
      --------------------
2580
 
2581
      when Attribute_Component_Size =>
2582
         Check_E0;
2583
         Set_Etype (N, Universal_Integer);
2584
 
2585
         --  Note: unlike other array attributes, unconstrained arrays are OK
2586
 
2587
         if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then
2588
            null;
2589
         else
2590
            Check_Array_Type;
2591
         end if;
2592
 
2593
      -------------
2594
      -- Compose --
2595
      -------------
2596
 
2597
      when Attribute_Compose =>
2598
         Check_Floating_Point_Type_2;
2599
         Set_Etype (N, P_Base_Type);
2600
         Resolve (E1, P_Base_Type);
2601
         Resolve (E2, Any_Integer);
2602
 
2603
      -----------------
2604
      -- Constrained --
2605
      -----------------
2606
 
2607
      when Attribute_Constrained =>
2608
         Check_E0;
2609
         Set_Etype (N, Standard_Boolean);
2610
 
2611
         --  Case from RM J.4(2) of constrained applied to private type
2612
 
2613
         if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
2614
            Check_Restriction (No_Obsolescent_Features, N);
2615
 
2616
            if Warn_On_Obsolescent_Feature then
2617
               Error_Msg_N
2618
                 ("constrained for private type is an " &
2619
                  "obsolescent feature (RM J.4)?", N);
2620
            end if;
2621
 
2622
            --  If we are within an instance, the attribute must be legal
2623
            --  because it was valid in the generic unit. Ditto if this is
2624
            --  an inlining of a function declared in an instance.
2625
 
2626
            if In_Instance
2627
              or else In_Inlined_Body
2628
            then
2629
               return;
2630
 
2631
            --  For sure OK if we have a real private type itself, but must
2632
            --  be completed, cannot apply Constrained to incomplete type.
2633
 
2634
            elsif Is_Private_Type (Entity (P)) then
2635
 
2636
               --  Note: this is one of the Annex J features that does not
2637
               --  generate a warning from -gnatwj, since in fact it seems
2638
               --  very useful, and is used in the GNAT runtime.
2639
 
2640
               Check_Not_Incomplete_Type;
2641
               return;
2642
            end if;
2643
 
2644
         --  Normal (non-obsolescent case) of application to object of
2645
         --  a discriminated type.
2646
 
2647
         else
2648
            Check_Object_Reference (P);
2649
 
2650
            --  If N does not come from source, then we allow the
2651
            --  the attribute prefix to be of a private type whose
2652
            --  full type has discriminants. This occurs in cases
2653
            --  involving expanded calls to stream attributes.
2654
 
2655
            if not Comes_From_Source (N) then
2656
               P_Type := Underlying_Type (P_Type);
2657
            end if;
2658
 
2659
            --  Must have discriminants or be an access type designating
2660
            --  a type with discriminants. If it is a classwide type is ???
2661
            --  has unknown discriminants.
2662
 
2663
            if Has_Discriminants (P_Type)
2664
               or else Has_Unknown_Discriminants (P_Type)
2665
               or else
2666
                 (Is_Access_Type (P_Type)
2667
                   and then Has_Discriminants (Designated_Type (P_Type)))
2668
            then
2669
               return;
2670
 
2671
            --  Also allow an object of a generic type if extensions allowed
2672
            --  and allow this for any type at all.
2673
 
2674
            elsif (Is_Generic_Type (P_Type)
2675
                     or else Is_Generic_Actual_Type (P_Type))
2676
              and then Extensions_Allowed
2677
            then
2678
               return;
2679
            end if;
2680
         end if;
2681
 
2682
         --  Fall through if bad prefix
2683
 
2684
         Error_Attr_P
2685
           ("prefix of % attribute must be object of discriminated type");
2686
 
2687
      ---------------
2688
      -- Copy_Sign --
2689
      ---------------
2690
 
2691
      when Attribute_Copy_Sign =>
2692
         Check_Floating_Point_Type_2;
2693
         Set_Etype (N, P_Base_Type);
2694
         Resolve (E1, P_Base_Type);
2695
         Resolve (E2, P_Base_Type);
2696
 
2697
      -----------
2698
      -- Count --
2699
      -----------
2700
 
2701
      when Attribute_Count => Count :
2702
      declare
2703
         Ent : Entity_Id;
2704
         S   : Entity_Id;
2705
         Tsk : Entity_Id;
2706
 
2707
      begin
2708
         Check_E0;
2709
 
2710
         if Nkind_In (P, N_Identifier, N_Expanded_Name) then
2711
            Ent := Entity (P);
2712
 
2713
            if Ekind (Ent) /= E_Entry then
2714
               Error_Attr ("invalid entry name", N);
2715
            end if;
2716
 
2717
         elsif Nkind (P) = N_Indexed_Component then
2718
            if not Is_Entity_Name (Prefix (P))
2719
              or else  No (Entity (Prefix (P)))
2720
              or else Ekind (Entity (Prefix (P))) /= E_Entry_Family
2721
            then
2722
               if Nkind (Prefix (P)) = N_Selected_Component
2723
                 and then Present (Entity (Selector_Name (Prefix (P))))
2724
                 and then Ekind (Entity (Selector_Name (Prefix (P)))) =
2725
                                                             E_Entry_Family
2726
               then
2727
                  Error_Attr
2728
                    ("attribute % must apply to entry of current task", P);
2729
 
2730
               else
2731
                  Error_Attr ("invalid entry family name", P);
2732
               end if;
2733
               return;
2734
 
2735
            else
2736
               Ent := Entity (Prefix (P));
2737
            end if;
2738
 
2739
         elsif Nkind (P) = N_Selected_Component
2740
           and then Present (Entity (Selector_Name (P)))
2741
           and then Ekind (Entity (Selector_Name (P))) = E_Entry
2742
         then
2743
            Error_Attr
2744
              ("attribute % must apply to entry of current task", P);
2745
 
2746
         else
2747
            Error_Attr ("invalid entry name", N);
2748
            return;
2749
         end if;
2750
 
2751
         for J in reverse 0 .. Scope_Stack.Last loop
2752
            S := Scope_Stack.Table (J).Entity;
2753
 
2754
            if S = Scope (Ent) then
2755
               if Nkind (P) = N_Expanded_Name then
2756
                  Tsk := Entity (Prefix (P));
2757
 
2758
                  --  The prefix denotes either the task type, or else a
2759
                  --  single task whose task type is being analyzed.
2760
 
2761
                  if (Is_Type (Tsk)
2762
                      and then Tsk = S)
2763
 
2764
                    or else (not Is_Type (Tsk)
2765
                      and then Etype (Tsk) = S
2766
                      and then not (Comes_From_Source (S)))
2767
                  then
2768
                     null;
2769
                  else
2770
                     Error_Attr
2771
                       ("Attribute % must apply to entry of current task", N);
2772
                  end if;
2773
               end if;
2774
 
2775
               exit;
2776
 
2777
            elsif Ekind (Scope (Ent)) in Task_Kind
2778
              and then Ekind (S) /= E_Loop
2779
              and then Ekind (S) /= E_Block
2780
              and then Ekind (S) /= E_Entry
2781
              and then Ekind (S) /= E_Entry_Family
2782
            then
2783
               Error_Attr ("Attribute % cannot appear in inner unit", N);
2784
 
2785
            elsif Ekind (Scope (Ent)) = E_Protected_Type
2786
              and then not Has_Completion (Scope (Ent))
2787
            then
2788
               Error_Attr ("attribute % can only be used inside body", N);
2789
            end if;
2790
         end loop;
2791
 
2792
         if Is_Overloaded (P) then
2793
            declare
2794
               Index : Interp_Index;
2795
               It    : Interp;
2796
 
2797
            begin
2798
               Get_First_Interp (P, Index, It);
2799
 
2800
               while Present (It.Nam) loop
2801
                  if It.Nam = Ent then
2802
                     null;
2803
 
2804
                  --  Ada 2005 (AI-345): Do not consider primitive entry
2805
                  --  wrappers generated for task or protected types.
2806
 
2807
                  elsif Ada_Version >= Ada_05
2808
                    and then not Comes_From_Source (It.Nam)
2809
                  then
2810
                     null;
2811
 
2812
                  else
2813
                     Error_Attr ("ambiguous entry name", N);
2814
                  end if;
2815
 
2816
                  Get_Next_Interp (Index, It);
2817
               end loop;
2818
            end;
2819
         end if;
2820
 
2821
         Set_Etype (N, Universal_Integer);
2822
      end Count;
2823
 
2824
      -----------------------
2825
      -- Default_Bit_Order --
2826
      -----------------------
2827
 
2828
      when Attribute_Default_Bit_Order => Default_Bit_Order :
2829
      begin
2830
         Check_Standard_Prefix;
2831
 
2832
         if Bytes_Big_Endian then
2833
            Rewrite (N,
2834
              Make_Integer_Literal (Loc, False_Value));
2835
         else
2836
            Rewrite (N,
2837
              Make_Integer_Literal (Loc, True_Value));
2838
         end if;
2839
 
2840
         Set_Etype (N, Universal_Integer);
2841
         Set_Is_Static_Expression (N);
2842
      end Default_Bit_Order;
2843
 
2844
      --------------
2845
      -- Definite --
2846
      --------------
2847
 
2848
      when Attribute_Definite =>
2849
         Legal_Formal_Attribute;
2850
 
2851
      -----------
2852
      -- Delta --
2853
      -----------
2854
 
2855
      when Attribute_Delta =>
2856
         Check_Fixed_Point_Type_0;
2857
         Set_Etype (N, Universal_Real);
2858
 
2859
      ------------
2860
      -- Denorm --
2861
      ------------
2862
 
2863
      when Attribute_Denorm =>
2864
         Check_Floating_Point_Type_0;
2865
         Set_Etype (N, Standard_Boolean);
2866
 
2867
      ------------
2868
      -- Digits --
2869
      ------------
2870
 
2871
      when Attribute_Digits =>
2872
         Check_E0;
2873
         Check_Type;
2874
 
2875
         if not Is_Floating_Point_Type (P_Type)
2876
           and then not Is_Decimal_Fixed_Point_Type (P_Type)
2877
         then
2878
            Error_Attr_P
2879
              ("prefix of % attribute must be float or decimal type");
2880
         end if;
2881
 
2882
         Set_Etype (N, Universal_Integer);
2883
 
2884
      ---------------
2885
      -- Elab_Body --
2886
      ---------------
2887
 
2888
      --  Also handles processing for Elab_Spec
2889
 
2890
      when Attribute_Elab_Body | Attribute_Elab_Spec =>
2891
         Check_E0;
2892
         Check_Unit_Name (P);
2893
         Set_Etype (N, Standard_Void_Type);
2894
 
2895
         --  We have to manually call the expander in this case to get
2896
         --  the necessary expansion (normally attributes that return
2897
         --  entities are not expanded).
2898
 
2899
         Expand (N);
2900
 
2901
      ---------------
2902
      -- Elab_Spec --
2903
      ---------------
2904
 
2905
      --  Shares processing with Elab_Body
2906
 
2907
      ----------------
2908
      -- Elaborated --
2909
      ----------------
2910
 
2911
      when Attribute_Elaborated =>
2912
         Check_E0;
2913
         Check_Library_Unit;
2914
         Set_Etype (N, Standard_Boolean);
2915
 
2916
      ----------
2917
      -- Emax --
2918
      ----------
2919
 
2920
      when Attribute_Emax =>
2921
         Check_Floating_Point_Type_0;
2922
         Set_Etype (N, Universal_Integer);
2923
 
2924
      -------------
2925
      -- Enabled --
2926
      -------------
2927
 
2928
      when Attribute_Enabled =>
2929
         Check_Either_E0_Or_E1;
2930
 
2931
         if Present (E1) then
2932
            if not Is_Entity_Name (E1) or else No (Entity (E1)) then
2933
               Error_Msg_N ("entity name expected for Enabled attribute", E1);
2934
               E1 := Empty;
2935
            end if;
2936
         end if;
2937
 
2938
         if Nkind (P) /= N_Identifier then
2939
            Error_Msg_N ("identifier expected (check name)", P);
2940
         elsif Get_Check_Id (Chars (P)) = No_Check_Id then
2941
            Error_Msg_N ("& is not a recognized check name", P);
2942
         end if;
2943
 
2944
         Set_Etype (N, Standard_Boolean);
2945
 
2946
      --------------
2947
      -- Enum_Rep --
2948
      --------------
2949
 
2950
      when Attribute_Enum_Rep => Enum_Rep : declare
2951
      begin
2952
         if Present (E1) then
2953
            Check_E1;
2954
            Check_Discrete_Type;
2955
            Resolve (E1, P_Base_Type);
2956
 
2957
         else
2958
            if not Is_Entity_Name (P)
2959
              or else (not Is_Object (Entity (P))
2960
                         and then
2961
                       Ekind (Entity (P)) /= E_Enumeration_Literal)
2962
            then
2963
               Error_Attr_P
2964
                 ("prefix of %attribute must be " &
2965
                  "discrete type/object or enum literal");
2966
            end if;
2967
         end if;
2968
 
2969
         Set_Etype (N, Universal_Integer);
2970
      end Enum_Rep;
2971
 
2972
      --------------
2973
      -- Enum_Val --
2974
      --------------
2975
 
2976
      when Attribute_Enum_Val => Enum_Val : begin
2977
         Check_E1;
2978
         Check_Type;
2979
 
2980
         if not Is_Enumeration_Type (P_Type) then
2981
            Error_Attr_P ("prefix of % attribute must be enumeration type");
2982
         end if;
2983
 
2984
         --  If the enumeration type has a standard representation, the effect
2985
         --  is the same as 'Val, so rewrite the attribute as a 'Val.
2986
 
2987
         if not Has_Non_Standard_Rep (P_Base_Type) then
2988
            Rewrite (N,
2989
              Make_Attribute_Reference (Loc,
2990
                Prefix         => Relocate_Node (Prefix (N)),
2991
                Attribute_Name => Name_Val,
2992
                Expressions    => New_List (Relocate_Node (E1))));
2993
            Analyze_And_Resolve (N, P_Base_Type);
2994
 
2995
         --  Non-standard representation case (enumeration with holes)
2996
 
2997
         else
2998
            Check_Enum_Image;
2999
            Resolve (E1, Any_Integer);
3000
            Set_Etype (N, P_Base_Type);
3001
         end if;
3002
      end Enum_Val;
3003
 
3004
      -------------
3005
      -- Epsilon --
3006
      -------------
3007
 
3008
      when Attribute_Epsilon =>
3009
         Check_Floating_Point_Type_0;
3010
         Set_Etype (N, Universal_Real);
3011
 
3012
      --------------
3013
      -- Exponent --
3014
      --------------
3015
 
3016
      when Attribute_Exponent =>
3017
         Check_Floating_Point_Type_1;
3018
         Set_Etype (N, Universal_Integer);
3019
         Resolve (E1, P_Base_Type);
3020
 
3021
      ------------------
3022
      -- External_Tag --
3023
      ------------------
3024
 
3025
      when Attribute_External_Tag =>
3026
         Check_E0;
3027
         Check_Type;
3028
 
3029
         Set_Etype (N, Standard_String);
3030
 
3031
         if not Is_Tagged_Type (P_Type) then
3032
            Error_Attr_P ("prefix of % attribute must be tagged");
3033
         end if;
3034
 
3035
      ---------------
3036
      -- Fast_Math --
3037
      ---------------
3038
 
3039
      when Attribute_Fast_Math =>
3040
         Check_Standard_Prefix;
3041
 
3042
         if Opt.Fast_Math then
3043
            Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
3044
         else
3045
            Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
3046
         end if;
3047
 
3048
      -----------
3049
      -- First --
3050
      -----------
3051
 
3052
      when Attribute_First =>
3053
         Check_Array_Or_Scalar_Type;
3054
 
3055
      ---------------
3056
      -- First_Bit --
3057
      ---------------
3058
 
3059
      when Attribute_First_Bit =>
3060
         Check_Component;
3061
         Set_Etype (N, Universal_Integer);
3062
 
3063
      -----------------
3064
      -- Fixed_Value --
3065
      -----------------
3066
 
3067
      when Attribute_Fixed_Value =>
3068
         Check_E1;
3069
         Check_Fixed_Point_Type;
3070
         Resolve (E1, Any_Integer);
3071
         Set_Etype (N, P_Base_Type);
3072
 
3073
      -----------
3074
      -- Floor --
3075
      -----------
3076
 
3077
      when Attribute_Floor =>
3078
         Check_Floating_Point_Type_1;
3079
         Set_Etype (N, P_Base_Type);
3080
         Resolve (E1, P_Base_Type);
3081
 
3082
      ----------
3083
      -- Fore --
3084
      ----------
3085
 
3086
      when Attribute_Fore =>
3087
         Check_Fixed_Point_Type_0;
3088
         Set_Etype (N, Universal_Integer);
3089
 
3090
      --------------
3091
      -- Fraction --
3092
      --------------
3093
 
3094
      when Attribute_Fraction =>
3095
         Check_Floating_Point_Type_1;
3096
         Set_Etype (N, P_Base_Type);
3097
         Resolve (E1, P_Base_Type);
3098
 
3099
      --------------
3100
      -- From_Any --
3101
      --------------
3102
 
3103
      when Attribute_From_Any =>
3104
         Check_E1;
3105
         Check_PolyORB_Attribute;
3106
         Set_Etype (N, P_Base_Type);
3107
 
3108
      -----------------------
3109
      -- Has_Access_Values --
3110
      -----------------------
3111
 
3112
      when Attribute_Has_Access_Values =>
3113
         Check_Type;
3114
         Check_E0;
3115
         Set_Etype (N, Standard_Boolean);
3116
 
3117
      -----------------------
3118
      -- Has_Tagged_Values --
3119
      -----------------------
3120
 
3121
      when Attribute_Has_Tagged_Values =>
3122
         Check_Type;
3123
         Check_E0;
3124
         Set_Etype (N, Standard_Boolean);
3125
 
3126
      -----------------------
3127
      -- Has_Discriminants --
3128
      -----------------------
3129
 
3130
      when Attribute_Has_Discriminants =>
3131
         Legal_Formal_Attribute;
3132
 
3133
      --------------
3134
      -- Identity --
3135
      --------------
3136
 
3137
      when Attribute_Identity =>
3138
         Check_E0;
3139
         Analyze (P);
3140
 
3141
         if Etype (P) =  Standard_Exception_Type then
3142
            Set_Etype (N, RTE (RE_Exception_Id));
3143
 
3144
         --  Ada 2005 (AI-345): Attribute 'Identity may be applied to
3145
         --  task interface class-wide types.
3146
 
3147
         elsif Is_Task_Type (Etype (P))
3148
           or else (Is_Access_Type (Etype (P))
3149
                      and then Is_Task_Type (Designated_Type (Etype (P))))
3150
           or else (Ada_Version >= Ada_05
3151
                      and then Ekind (Etype (P)) = E_Class_Wide_Type
3152
                      and then Is_Interface (Etype (P))
3153
                      and then Is_Task_Interface (Etype (P)))
3154
         then
3155
            Resolve (P);
3156
            Set_Etype (N, RTE (RO_AT_Task_Id));
3157
 
3158
         else
3159
            if Ada_Version >= Ada_05 then
3160
               Error_Attr_P
3161
                 ("prefix of % attribute must be an exception, a " &
3162
                  "task or a task interface class-wide object");
3163
            else
3164
               Error_Attr_P
3165
                 ("prefix of % attribute must be a task or an exception");
3166
            end if;
3167
         end if;
3168
 
3169
      -----------
3170
      -- Image --
3171
      -----------
3172
 
3173
      when Attribute_Image => Image :
3174
      begin
3175
         Set_Etype (N, Standard_String);
3176
         Check_Scalar_Type;
3177
 
3178
         if Is_Real_Type (P_Type) then
3179
            if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3180
               Error_Msg_Name_1 := Aname;
3181
               Error_Msg_N
3182
                 ("(Ada 83) % attribute not allowed for real types", N);
3183
            end if;
3184
         end if;
3185
 
3186
         if Is_Enumeration_Type (P_Type) then
3187
            Check_Restriction (No_Enumeration_Maps, N);
3188
         end if;
3189
 
3190
         Check_E1;
3191
         Resolve (E1, P_Base_Type);
3192
         Check_Enum_Image;
3193
         Validate_Non_Static_Attribute_Function_Call;
3194
      end Image;
3195
 
3196
      ---------
3197
      -- Img --
3198
      ---------
3199
 
3200
      when Attribute_Img => Img :
3201
      begin
3202
         Check_E0;
3203
         Set_Etype (N, Standard_String);
3204
 
3205
         if not Is_Scalar_Type (P_Type)
3206
           or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
3207
         then
3208
            Error_Attr_P
3209
              ("prefix of % attribute must be scalar object name");
3210
         end if;
3211
 
3212
         Check_Enum_Image;
3213
      end Img;
3214
 
3215
      -----------
3216
      -- Input --
3217
      -----------
3218
 
3219
      when Attribute_Input =>
3220
         Check_E1;
3221
         Check_Stream_Attribute (TSS_Stream_Input);
3222
         Set_Etype (N, P_Base_Type);
3223
 
3224
      -------------------
3225
      -- Integer_Value --
3226
      -------------------
3227
 
3228
      when Attribute_Integer_Value =>
3229
         Check_E1;
3230
         Check_Integer_Type;
3231
         Resolve (E1, Any_Fixed);
3232
 
3233
         --  Signal an error if argument type is not a specific fixed-point
3234
         --  subtype. An error has been signalled already if the argument
3235
         --  was not of a fixed-point type.
3236
 
3237
         if Etype (E1) = Any_Fixed and then not Error_Posted (E1) then
3238
            Error_Attr ("argument of % must be of a fixed-point type", E1);
3239
         end if;
3240
 
3241
         Set_Etype (N, P_Base_Type);
3242
 
3243
      -------------------
3244
      -- Invalid_Value --
3245
      -------------------
3246
 
3247
      when Attribute_Invalid_Value =>
3248
         Check_E0;
3249
         Check_Scalar_Type;
3250
         Set_Etype (N, P_Base_Type);
3251
         Invalid_Value_Used := True;
3252
 
3253
      -----------
3254
      -- Large --
3255
      -----------
3256
 
3257
      when Attribute_Large =>
3258
         Check_E0;
3259
         Check_Real_Type;
3260
         Set_Etype (N, Universal_Real);
3261
 
3262
      ----------
3263
      -- Last --
3264
      ----------
3265
 
3266
      when Attribute_Last =>
3267
         Check_Array_Or_Scalar_Type;
3268
 
3269
      --------------
3270
      -- Last_Bit --
3271
      --------------
3272
 
3273
      when Attribute_Last_Bit =>
3274
         Check_Component;
3275
         Set_Etype (N, Universal_Integer);
3276
 
3277
      ------------------
3278
      -- Leading_Part --
3279
      ------------------
3280
 
3281
      when Attribute_Leading_Part =>
3282
         Check_Floating_Point_Type_2;
3283
         Set_Etype (N, P_Base_Type);
3284
         Resolve (E1, P_Base_Type);
3285
         Resolve (E2, Any_Integer);
3286
 
3287
      ------------
3288
      -- Length --
3289
      ------------
3290
 
3291
      when Attribute_Length =>
3292
         Check_Array_Type;
3293
         Set_Etype (N, Universal_Integer);
3294
 
3295
      -------------
3296
      -- Machine --
3297
      -------------
3298
 
3299
      when Attribute_Machine =>
3300
         Check_Floating_Point_Type_1;
3301
         Set_Etype (N, P_Base_Type);
3302
         Resolve (E1, P_Base_Type);
3303
 
3304
      ------------------
3305
      -- Machine_Emax --
3306
      ------------------
3307
 
3308
      when Attribute_Machine_Emax =>
3309
         Check_Floating_Point_Type_0;
3310
         Set_Etype (N, Universal_Integer);
3311
 
3312
      ------------------
3313
      -- Machine_Emin --
3314
      ------------------
3315
 
3316
      when Attribute_Machine_Emin =>
3317
         Check_Floating_Point_Type_0;
3318
         Set_Etype (N, Universal_Integer);
3319
 
3320
      ----------------------
3321
      -- Machine_Mantissa --
3322
      ----------------------
3323
 
3324
      when Attribute_Machine_Mantissa =>
3325
         Check_Floating_Point_Type_0;
3326
         Set_Etype (N, Universal_Integer);
3327
 
3328
      -----------------------
3329
      -- Machine_Overflows --
3330
      -----------------------
3331
 
3332
      when Attribute_Machine_Overflows =>
3333
         Check_Real_Type;
3334
         Check_E0;
3335
         Set_Etype (N, Standard_Boolean);
3336
 
3337
      -------------------
3338
      -- Machine_Radix --
3339
      -------------------
3340
 
3341
      when Attribute_Machine_Radix =>
3342
         Check_Real_Type;
3343
         Check_E0;
3344
         Set_Etype (N, Universal_Integer);
3345
 
3346
      ----------------------
3347
      -- Machine_Rounding --
3348
      ----------------------
3349
 
3350
      when Attribute_Machine_Rounding =>
3351
         Check_Floating_Point_Type_1;
3352
         Set_Etype (N, P_Base_Type);
3353
         Resolve (E1, P_Base_Type);
3354
 
3355
      --------------------
3356
      -- Machine_Rounds --
3357
      --------------------
3358
 
3359
      when Attribute_Machine_Rounds =>
3360
         Check_Real_Type;
3361
         Check_E0;
3362
         Set_Etype (N, Standard_Boolean);
3363
 
3364
      ------------------
3365
      -- Machine_Size --
3366
      ------------------
3367
 
3368
      when Attribute_Machine_Size =>
3369
         Check_E0;
3370
         Check_Type;
3371
         Check_Not_Incomplete_Type;
3372
         Set_Etype (N, Universal_Integer);
3373
 
3374
      --------------
3375
      -- Mantissa --
3376
      --------------
3377
 
3378
      when Attribute_Mantissa =>
3379
         Check_E0;
3380
         Check_Real_Type;
3381
         Set_Etype (N, Universal_Integer);
3382
 
3383
      ---------
3384
      -- Max --
3385
      ---------
3386
 
3387
      when Attribute_Max =>
3388
         Check_E2;
3389
         Check_Scalar_Type;
3390
         Resolve (E1, P_Base_Type);
3391
         Resolve (E2, P_Base_Type);
3392
         Set_Etype (N, P_Base_Type);
3393
 
3394
      ----------------------------------
3395
      -- Max_Size_In_Storage_Elements --
3396
      ----------------------------------
3397
 
3398
      when Attribute_Max_Size_In_Storage_Elements =>
3399
         Check_E0;
3400
         Check_Type;
3401
         Check_Not_Incomplete_Type;
3402
         Set_Etype (N, Universal_Integer);
3403
 
3404
      -----------------------
3405
      -- Maximum_Alignment --
3406
      -----------------------
3407
 
3408
      when Attribute_Maximum_Alignment =>
3409
         Standard_Attribute (Ttypes.Maximum_Alignment);
3410
 
3411
      --------------------
3412
      -- Mechanism_Code --
3413
      --------------------
3414
 
3415
      when Attribute_Mechanism_Code =>
3416
         if not Is_Entity_Name (P)
3417
           or else not Is_Subprogram (Entity (P))
3418
         then
3419
            Error_Attr_P ("prefix of % attribute must be subprogram");
3420
         end if;
3421
 
3422
         Check_Either_E0_Or_E1;
3423
 
3424
         if Present (E1) then
3425
            Resolve (E1, Any_Integer);
3426
            Set_Etype (E1, Standard_Integer);
3427
 
3428
            if not Is_Static_Expression (E1) then
3429
               Flag_Non_Static_Expr
3430
                 ("expression for parameter number must be static!", E1);
3431
               Error_Attr;
3432
 
3433
            elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
3434
              or else UI_To_Int (Intval (E1)) < 0
3435
            then
3436
               Error_Attr ("invalid parameter number for %attribute", E1);
3437
            end if;
3438
         end if;
3439
 
3440
         Set_Etype (N, Universal_Integer);
3441
 
3442
      ---------
3443
      -- Min --
3444
      ---------
3445
 
3446
      when Attribute_Min =>
3447
         Check_E2;
3448
         Check_Scalar_Type;
3449
         Resolve (E1, P_Base_Type);
3450
         Resolve (E2, P_Base_Type);
3451
         Set_Etype (N, P_Base_Type);
3452
 
3453
      ---------
3454
      -- Mod --
3455
      ---------
3456
 
3457
      when Attribute_Mod =>
3458
 
3459
         --  Note: this attribute is only allowed in Ada 2005 mode, but
3460
         --  we do not need to test that here, since Mod is only recognized
3461
         --  as an attribute name in Ada 2005 mode during the parse.
3462
 
3463
         Check_E1;
3464
         Check_Modular_Integer_Type;
3465
         Resolve (E1, Any_Integer);
3466
         Set_Etype (N, P_Base_Type);
3467
 
3468
      -----------
3469
      -- Model --
3470
      -----------
3471
 
3472
      when Attribute_Model =>
3473
         Check_Floating_Point_Type_1;
3474
         Set_Etype (N, P_Base_Type);
3475
         Resolve (E1, P_Base_Type);
3476
 
3477
      ----------------
3478
      -- Model_Emin --
3479
      ----------------
3480
 
3481
      when Attribute_Model_Emin =>
3482
         Check_Floating_Point_Type_0;
3483
         Set_Etype (N, Universal_Integer);
3484
 
3485
      -------------------
3486
      -- Model_Epsilon --
3487
      -------------------
3488
 
3489
      when Attribute_Model_Epsilon =>
3490
         Check_Floating_Point_Type_0;
3491
         Set_Etype (N, Universal_Real);
3492
 
3493
      --------------------
3494
      -- Model_Mantissa --
3495
      --------------------
3496
 
3497
      when Attribute_Model_Mantissa =>
3498
         Check_Floating_Point_Type_0;
3499
         Set_Etype (N, Universal_Integer);
3500
 
3501
      -----------------
3502
      -- Model_Small --
3503
      -----------------
3504
 
3505
      when Attribute_Model_Small =>
3506
         Check_Floating_Point_Type_0;
3507
         Set_Etype (N, Universal_Real);
3508
 
3509
      -------------
3510
      -- Modulus --
3511
      -------------
3512
 
3513
      when Attribute_Modulus =>
3514
         Check_E0;
3515
         Check_Modular_Integer_Type;
3516
         Set_Etype (N, Universal_Integer);
3517
 
3518
      --------------------
3519
      -- Null_Parameter --
3520
      --------------------
3521
 
3522
      when Attribute_Null_Parameter => Null_Parameter : declare
3523
         Parnt  : constant Node_Id := Parent (N);
3524
         GParnt : constant Node_Id := Parent (Parnt);
3525
 
3526
         procedure Bad_Null_Parameter (Msg : String);
3527
         --  Used if bad Null parameter attribute node is found. Issues
3528
         --  given error message, and also sets the type to Any_Type to
3529
         --  avoid blowups later on from dealing with a junk node.
3530
 
3531
         procedure Must_Be_Imported (Proc_Ent : Entity_Id);
3532
         --  Called to check that Proc_Ent is imported subprogram
3533
 
3534
         ------------------------
3535
         -- Bad_Null_Parameter --
3536
         ------------------------
3537
 
3538
         procedure Bad_Null_Parameter (Msg : String) is
3539
         begin
3540
            Error_Msg_N (Msg, N);
3541
            Set_Etype (N, Any_Type);
3542
         end Bad_Null_Parameter;
3543
 
3544
         ----------------------
3545
         -- Must_Be_Imported --
3546
         ----------------------
3547
 
3548
         procedure Must_Be_Imported (Proc_Ent : Entity_Id) is
3549
            Pent : Entity_Id := Proc_Ent;
3550
 
3551
         begin
3552
            while Present (Alias (Pent)) loop
3553
               Pent := Alias (Pent);
3554
            end loop;
3555
 
3556
            --  Ignore check if procedure not frozen yet (we will get
3557
            --  another chance when the default parameter is reanalyzed)
3558
 
3559
            if not Is_Frozen (Pent) then
3560
               return;
3561
 
3562
            elsif not Is_Imported (Pent) then
3563
               Bad_Null_Parameter
3564
                 ("Null_Parameter can only be used with imported subprogram");
3565
 
3566
            else
3567
               return;
3568
            end if;
3569
         end Must_Be_Imported;
3570
 
3571
      --  Start of processing for Null_Parameter
3572
 
3573
      begin
3574
         Check_Type;
3575
         Check_E0;
3576
         Set_Etype (N, P_Type);
3577
 
3578
         --  Case of attribute used as default expression
3579
 
3580
         if Nkind (Parnt) = N_Parameter_Specification then
3581
            Must_Be_Imported (Defining_Entity (GParnt));
3582
 
3583
         --  Case of attribute used as actual for subprogram (positional)
3584
 
3585
         elsif Nkind_In (Parnt, N_Procedure_Call_Statement,
3586
                                N_Function_Call)
3587
            and then Is_Entity_Name (Name (Parnt))
3588
         then
3589
            Must_Be_Imported (Entity (Name (Parnt)));
3590
 
3591
         --  Case of attribute used as actual for subprogram (named)
3592
 
3593
         elsif Nkind (Parnt) = N_Parameter_Association
3594
           and then Nkind_In (GParnt, N_Procedure_Call_Statement,
3595
                                      N_Function_Call)
3596
           and then Is_Entity_Name (Name (GParnt))
3597
         then
3598
            Must_Be_Imported (Entity (Name (GParnt)));
3599
 
3600
         --  Not an allowed case
3601
 
3602
         else
3603
            Bad_Null_Parameter
3604
              ("Null_Parameter must be actual or default parameter");
3605
         end if;
3606
      end Null_Parameter;
3607
 
3608
      -----------------
3609
      -- Object_Size --
3610
      -----------------
3611
 
3612
      when Attribute_Object_Size =>
3613
         Check_E0;
3614
         Check_Type;
3615
         Check_Not_Incomplete_Type;
3616
         Set_Etype (N, Universal_Integer);
3617
 
3618
      ---------
3619
      -- Old --
3620
      ---------
3621
 
3622
      when Attribute_Old =>
3623
         Check_E0;
3624
         Set_Etype (N, P_Type);
3625
 
3626
         if No (Current_Subprogram) then
3627
            Error_Attr ("attribute % can only appear within subprogram", N);
3628
         end if;
3629
 
3630
         if Is_Limited_Type (P_Type) then
3631
            Error_Attr ("attribute % cannot apply to limited objects", P);
3632
         end if;
3633
 
3634
         if Is_Entity_Name (P)
3635
           and then Is_Constant_Object (Entity (P))
3636
         then
3637
            Error_Msg_N
3638
              ("?attribute Old applied to constant has no effect", P);
3639
         end if;
3640
 
3641
         --  Check that the expression does not refer to local entities
3642
 
3643
         Check_Local : declare
3644
            Subp : Entity_Id := Current_Subprogram;
3645
 
3646
            function Process (N : Node_Id) return Traverse_Result;
3647
            --  Check that N does not contain references to local variables
3648
            --  or other local entities of Subp.
3649
 
3650
            -------------
3651
            -- Process --
3652
            -------------
3653
 
3654
            function Process (N : Node_Id) return Traverse_Result is
3655
            begin
3656
               if Is_Entity_Name (N)
3657
                 and then not Is_Formal (Entity (N))
3658
                 and then Enclosing_Subprogram (Entity (N)) = Subp
3659
               then
3660
                  Error_Msg_Node_1 := Entity (N);
3661
                  Error_Attr
3662
                    ("attribute % cannot refer to local variable&", N);
3663
               end if;
3664
 
3665
               return OK;
3666
            end Process;
3667
 
3668
            procedure Check_No_Local is new Traverse_Proc;
3669
 
3670
         --  Start of processing for Check_Local
3671
 
3672
         begin
3673
            Check_No_Local (P);
3674
 
3675
            if In_Parameter_Specification (P) then
3676
 
3677
               --  We have additional restrictions on using 'Old in parameter
3678
               --  specifications.
3679
 
3680
               if Present (Enclosing_Subprogram (Current_Subprogram)) then
3681
 
3682
                  --  Check that there is no reference to the enclosing
3683
                  --  subprogram local variables. Otherwise, we might end
3684
                  --  up being called from the enclosing subprogram and thus
3685
                  --  using 'Old on a local variable which is not defined
3686
                  --  at entry time.
3687
 
3688
                  Subp := Enclosing_Subprogram (Current_Subprogram);
3689
                  Check_No_Local (P);
3690
 
3691
               else
3692
                  --  We must prevent default expression of library-level
3693
                  --  subprogram from using 'Old, as the subprogram may be
3694
                  --  used in elaboration code for which there is no enclosing
3695
                  --  subprogram.
3696
 
3697
                  Error_Attr
3698
                    ("attribute % can only appear within subprogram", N);
3699
               end if;
3700
            end if;
3701
         end Check_Local;
3702
 
3703
      ------------
3704
      -- Output --
3705
      ------------
3706
 
3707
      when Attribute_Output =>
3708
         Check_E2;
3709
         Check_Stream_Attribute (TSS_Stream_Output);
3710
         Set_Etype (N, Standard_Void_Type);
3711
         Resolve (N, Standard_Void_Type);
3712
 
3713
      ------------------
3714
      -- Partition_ID --
3715
      ------------------
3716
 
3717
      when Attribute_Partition_ID => Partition_Id :
3718
      begin
3719
         Check_E0;
3720
 
3721
         if P_Type /= Any_Type then
3722
            if not Is_Library_Level_Entity (Entity (P)) then
3723
               Error_Attr_P
3724
                 ("prefix of % attribute must be library-level entity");
3725
 
3726
            --  The defining entity of prefix should not be declared inside a
3727
            --  Pure unit. RM E.1(8). Is_Pure was set during declaration.
3728
 
3729
            elsif Is_Entity_Name (P)
3730
              and then Is_Pure (Entity (P))
3731
            then
3732
               Error_Attr_P
3733
                 ("prefix of % attribute must not be declared pure");
3734
            end if;
3735
         end if;
3736
 
3737
         Set_Etype (N, Universal_Integer);
3738
      end Partition_Id;
3739
 
3740
      -------------------------
3741
      -- Passed_By_Reference --
3742
      -------------------------
3743
 
3744
      when Attribute_Passed_By_Reference =>
3745
         Check_E0;
3746
         Check_Type;
3747
         Set_Etype (N, Standard_Boolean);
3748
 
3749
      ------------------
3750
      -- Pool_Address --
3751
      ------------------
3752
 
3753
      when Attribute_Pool_Address =>
3754
         Check_E0;
3755
         Set_Etype (N, RTE (RE_Address));
3756
 
3757
      ---------
3758
      -- Pos --
3759
      ---------
3760
 
3761
      when Attribute_Pos =>
3762
         Check_Discrete_Type;
3763
         Check_E1;
3764
         Resolve (E1, P_Base_Type);
3765
         Set_Etype (N, Universal_Integer);
3766
 
3767
      --------------
3768
      -- Position --
3769
      --------------
3770
 
3771
      when Attribute_Position =>
3772
         Check_Component;
3773
         Set_Etype (N, Universal_Integer);
3774
 
3775
      ----------
3776
      -- Pred --
3777
      ----------
3778
 
3779
      when Attribute_Pred =>
3780
         Check_Scalar_Type;
3781
         Check_E1;
3782
         Resolve (E1, P_Base_Type);
3783
         Set_Etype (N, P_Base_Type);
3784
 
3785
         --  Nothing to do for real type case
3786
 
3787
         if Is_Real_Type (P_Type) then
3788
            null;
3789
 
3790
         --  If not modular type, test for overflow check required
3791
 
3792
         else
3793
            if not Is_Modular_Integer_Type (P_Type)
3794
              and then not Range_Checks_Suppressed (P_Base_Type)
3795
            then
3796
               Enable_Range_Check (E1);
3797
            end if;
3798
         end if;
3799
 
3800
      --------------
3801
      -- Priority --
3802
      --------------
3803
 
3804
      --  Ada 2005 (AI-327): Dynamic ceiling priorities
3805
 
3806
      when Attribute_Priority =>
3807
         if Ada_Version < Ada_05 then
3808
            Error_Attr ("% attribute is allowed only in Ada 2005 mode", P);
3809
         end if;
3810
 
3811
         Check_E0;
3812
 
3813
         --  The prefix must be a protected object (AARM D.5.2 (2/2))
3814
 
3815
         Analyze (P);
3816
 
3817
         if Is_Protected_Type (Etype (P))
3818
           or else (Is_Access_Type (Etype (P))
3819
                      and then Is_Protected_Type (Designated_Type (Etype (P))))
3820
         then
3821
            Resolve (P, Etype (P));
3822
         else
3823
            Error_Attr_P ("prefix of % attribute must be a protected object");
3824
         end if;
3825
 
3826
         Set_Etype (N, Standard_Integer);
3827
 
3828
         --  Must be called from within a protected procedure or entry of the
3829
         --  protected object.
3830
 
3831
         declare
3832
            S : Entity_Id;
3833
 
3834
         begin
3835
            S := Current_Scope;
3836
            while S /= Etype (P)
3837
               and then S /= Standard_Standard
3838
            loop
3839
               S := Scope (S);
3840
            end loop;
3841
 
3842
            if S = Standard_Standard then
3843
               Error_Attr ("the attribute % is only allowed inside protected "
3844
                           & "operations", P);
3845
            end if;
3846
         end;
3847
 
3848
         Validate_Non_Static_Attribute_Function_Call;
3849
 
3850
      -----------
3851
      -- Range --
3852
      -----------
3853
 
3854
      when Attribute_Range =>
3855
         Check_Array_Or_Scalar_Type;
3856
 
3857
         if Ada_Version = Ada_83
3858
           and then Is_Scalar_Type (P_Type)
3859
           and then Comes_From_Source (N)
3860
         then
3861
            Error_Attr
3862
              ("(Ada 83) % attribute not allowed for scalar type", P);
3863
         end if;
3864
 
3865
      ------------
3866
      -- Result --
3867
      ------------
3868
 
3869
      when Attribute_Result => Result : declare
3870
         CS : Entity_Id := Current_Scope;
3871
         PS : Entity_Id := Scope (CS);
3872
 
3873
      begin
3874
         --  If the enclosing subprogram is always inlined, the enclosing
3875
         --  postcondition will not be propagated to the expanded call.
3876
 
3877
         if Has_Pragma_Inline_Always (PS)
3878
           and then Warn_On_Redundant_Constructs
3879
         then
3880
            Error_Msg_N
3881
              ("postconditions on inlined functions not enforced?", N);
3882
         end if;
3883
 
3884
         --  If we are in the scope of a function and in Spec_Expression mode,
3885
         --  this is likely the prescan of the postcondition pragma, and we
3886
         --  just set the proper type. If there is an error it will be caught
3887
         --  when the real Analyze call is done.
3888
 
3889
         if Ekind (CS) = E_Function
3890
           and then In_Spec_Expression
3891
         then
3892
            --  Check OK prefix
3893
 
3894
            if Chars (CS) /= Chars (P) then
3895
               Error_Msg_NE
3896
                 ("incorrect prefix for % attribute, expected &", P, CS);
3897
               Error_Attr;
3898
            end if;
3899
 
3900
            Set_Etype (N, Etype (CS));
3901
 
3902
            --  If several functions with that name are visible,
3903
            --  the intended one is the current scope.
3904
 
3905
            if Is_Overloaded (P) then
3906
               Set_Entity (P, CS);
3907
               Set_Is_Overloaded (P, False);
3908
            end if;
3909
 
3910
         --  Body case, where we must be inside a generated _Postcondition
3911
         --  procedure, and the prefix must be on the scope stack, or else
3912
         --  the attribute use is definitely misplaced. The condition itself
3913
         --  may have generated transient scopes, and is not necessarily the
3914
         --  current one.
3915
 
3916
         else
3917
            while Present (CS)
3918
              and then CS /= Standard_Standard
3919
            loop
3920
               if Chars (CS) = Name_uPostconditions then
3921
                  exit;
3922
               else
3923
                  CS := Scope (CS);
3924
               end if;
3925
            end loop;
3926
 
3927
            PS := Scope (CS);
3928
 
3929
            if Chars (CS) = Name_uPostconditions
3930
              and then Ekind (PS) = E_Function
3931
            then
3932
               --  Check OK prefix
3933
 
3934
               if Nkind_In (P, N_Identifier, N_Operator_Symbol)
3935
                 and then Chars (P) = Chars (PS)
3936
               then
3937
                  null;
3938
 
3939
               --  Within an instance, the prefix designates the local renaming
3940
               --  of the original generic.
3941
 
3942
               elsif Is_Entity_Name (P)
3943
                 and then Ekind (Entity (P)) = E_Function
3944
                 and then Present (Alias (Entity (P)))
3945
                 and then Chars (Alias (Entity (P))) = Chars (PS)
3946
               then
3947
                  null;
3948
 
3949
               else
3950
                  Error_Msg_NE
3951
                    ("incorrect prefix for % attribute, expected &", P, PS);
3952
                  Error_Attr;
3953
               end if;
3954
 
3955
               Rewrite (N,
3956
                 Make_Identifier (Sloc (N),
3957
                   Chars => Name_uResult));
3958
               Analyze_And_Resolve (N, Etype (PS));
3959
 
3960
            else
3961
               Error_Attr
3962
                 ("% attribute can only appear" &
3963
                   "  in function Postcondition pragma", P);
3964
            end if;
3965
         end if;
3966
      end Result;
3967
 
3968
      ------------------
3969
      -- Range_Length --
3970
      ------------------
3971
 
3972
      when Attribute_Range_Length =>
3973
         Check_E0;
3974
         Check_Discrete_Type;
3975
         Set_Etype (N, Universal_Integer);
3976
 
3977
      ----------
3978
      -- Read --
3979
      ----------
3980
 
3981
      when Attribute_Read =>
3982
         Check_E2;
3983
         Check_Stream_Attribute (TSS_Stream_Read);
3984
         Set_Etype (N, Standard_Void_Type);
3985
         Resolve (N, Standard_Void_Type);
3986
         Note_Possible_Modification (E2, Sure => True);
3987
 
3988
      ---------------
3989
      -- Remainder --
3990
      ---------------
3991
 
3992
      when Attribute_Remainder =>
3993
         Check_Floating_Point_Type_2;
3994
         Set_Etype (N, P_Base_Type);
3995
         Resolve (E1, P_Base_Type);
3996
         Resolve (E2, P_Base_Type);
3997
 
3998
      -----------
3999
      -- Round --
4000
      -----------
4001
 
4002
      when Attribute_Round =>
4003
         Check_E1;
4004
         Check_Decimal_Fixed_Point_Type;
4005
         Set_Etype (N, P_Base_Type);
4006
 
4007
         --  Because the context is universal_real (3.5.10(12)) it is a legal
4008
         --  context for a universal fixed expression. This is the only
4009
         --  attribute whose functional description involves U_R.
4010
 
4011
         if Etype (E1) = Universal_Fixed then
4012
            declare
4013
               Conv : constant Node_Id := Make_Type_Conversion (Loc,
4014
                  Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc),
4015
                  Expression   => Relocate_Node (E1));
4016
 
4017
            begin
4018
               Rewrite (E1, Conv);
4019
               Analyze (E1);
4020
            end;
4021
         end if;
4022
 
4023
         Resolve (E1, Any_Real);
4024
 
4025
      --------------
4026
      -- Rounding --
4027
      --------------
4028
 
4029
      when Attribute_Rounding =>
4030
         Check_Floating_Point_Type_1;
4031
         Set_Etype (N, P_Base_Type);
4032
         Resolve (E1, P_Base_Type);
4033
 
4034
      ---------------
4035
      -- Safe_Emax --
4036
      ---------------
4037
 
4038
      when Attribute_Safe_Emax =>
4039
         Check_Floating_Point_Type_0;
4040
         Set_Etype (N, Universal_Integer);
4041
 
4042
      ----------------
4043
      -- Safe_First --
4044
      ----------------
4045
 
4046
      when Attribute_Safe_First =>
4047
         Check_Floating_Point_Type_0;
4048
         Set_Etype (N, Universal_Real);
4049
 
4050
      ----------------
4051
      -- Safe_Large --
4052
      ----------------
4053
 
4054
      when Attribute_Safe_Large =>
4055
         Check_E0;
4056
         Check_Real_Type;
4057
         Set_Etype (N, Universal_Real);
4058
 
4059
      ---------------
4060
      -- Safe_Last --
4061
      ---------------
4062
 
4063
      when Attribute_Safe_Last =>
4064
         Check_Floating_Point_Type_0;
4065
         Set_Etype (N, Universal_Real);
4066
 
4067
      ----------------
4068
      -- Safe_Small --
4069
      ----------------
4070
 
4071
      when Attribute_Safe_Small =>
4072
         Check_E0;
4073
         Check_Real_Type;
4074
         Set_Etype (N, Universal_Real);
4075
 
4076
      -----------
4077
      -- Scale --
4078
      -----------
4079
 
4080
      when Attribute_Scale =>
4081
         Check_E0;
4082
         Check_Decimal_Fixed_Point_Type;
4083
         Set_Etype (N, Universal_Integer);
4084
 
4085
      -------------
4086
      -- Scaling --
4087
      -------------
4088
 
4089
      when Attribute_Scaling =>
4090
         Check_Floating_Point_Type_2;
4091
         Set_Etype (N, P_Base_Type);
4092
         Resolve (E1, P_Base_Type);
4093
 
4094
      ------------------
4095
      -- Signed_Zeros --
4096
      ------------------
4097
 
4098
      when Attribute_Signed_Zeros =>
4099
         Check_Floating_Point_Type_0;
4100
         Set_Etype (N, Standard_Boolean);
4101
 
4102
      ----------
4103
      -- Size --
4104
      ----------
4105
 
4106
      when Attribute_Size | Attribute_VADS_Size => Size :
4107
      begin
4108
         Check_E0;
4109
 
4110
         --  If prefix is parameterless function call, rewrite and resolve
4111
         --  as such.
4112
 
4113
         if Is_Entity_Name (P)
4114
           and then Ekind (Entity (P)) = E_Function
4115
         then
4116
            Resolve (P);
4117
 
4118
         --  Similar processing for a protected function call
4119
 
4120
         elsif Nkind (P) = N_Selected_Component
4121
           and then Ekind (Entity (Selector_Name (P))) = E_Function
4122
         then
4123
            Resolve (P);
4124
         end if;
4125
 
4126
         if Is_Object_Reference (P) then
4127
            Check_Object_Reference (P);
4128
 
4129
         elsif Is_Entity_Name (P)
4130
           and then (Is_Type (Entity (P))
4131
                       or else Ekind (Entity (P)) = E_Enumeration_Literal)
4132
         then
4133
            null;
4134
 
4135
         elsif Nkind (P) = N_Type_Conversion
4136
           and then not Comes_From_Source (P)
4137
         then
4138
            null;
4139
 
4140
         else
4141
            Error_Attr_P ("invalid prefix for % attribute");
4142
         end if;
4143
 
4144
         Check_Not_Incomplete_Type;
4145
         Check_Not_CPP_Type;
4146
         Set_Etype (N, Universal_Integer);
4147
      end Size;
4148
 
4149
      -----------
4150
      -- Small --
4151
      -----------
4152
 
4153
      when Attribute_Small =>
4154
         Check_E0;
4155
         Check_Real_Type;
4156
         Set_Etype (N, Universal_Real);
4157
 
4158
      ------------------
4159
      -- Storage_Pool --
4160
      ------------------
4161
 
4162
      when Attribute_Storage_Pool => Storage_Pool :
4163
      begin
4164
         Check_E0;
4165
 
4166
         if Is_Access_Type (P_Type) then
4167
            if Ekind (P_Type) = E_Access_Subprogram_Type then
4168
               Error_Attr_P
4169
                 ("cannot use % attribute for access-to-subprogram type");
4170
            end if;
4171
 
4172
            --  Set appropriate entity
4173
 
4174
            if Present (Associated_Storage_Pool (Root_Type (P_Type))) then
4175
               Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type)));
4176
            else
4177
               Set_Entity (N, RTE (RE_Global_Pool_Object));
4178
            end if;
4179
 
4180
            Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
4181
 
4182
            --  Validate_Remote_Access_To_Class_Wide_Type for attribute
4183
            --  Storage_Pool since this attribute is not defined for such
4184
            --  types (RM E.2.3(22)).
4185
 
4186
            Validate_Remote_Access_To_Class_Wide_Type (N);
4187
 
4188
         else
4189
            Error_Attr_P ("prefix of % attribute must be access type");
4190
         end if;
4191
      end Storage_Pool;
4192
 
4193
      ------------------
4194
      -- Storage_Size --
4195
      ------------------
4196
 
4197
      when Attribute_Storage_Size => Storage_Size :
4198
      begin
4199
         Check_E0;
4200
 
4201
         if Is_Task_Type (P_Type) then
4202
            Set_Etype (N, Universal_Integer);
4203
 
4204
         elsif Is_Access_Type (P_Type) then
4205
            if Ekind (P_Type) = E_Access_Subprogram_Type then
4206
               Error_Attr_P
4207
                 ("cannot use % attribute for access-to-subprogram type");
4208
            end if;
4209
 
4210
            if Is_Entity_Name (P)
4211
              and then Is_Type (Entity (P))
4212
            then
4213
               Check_Type;
4214
               Set_Etype (N, Universal_Integer);
4215
 
4216
               --   Validate_Remote_Access_To_Class_Wide_Type for attribute
4217
               --   Storage_Size since this attribute is not defined for
4218
               --   such types (RM E.2.3(22)).
4219
 
4220
               Validate_Remote_Access_To_Class_Wide_Type (N);
4221
 
4222
            --  The prefix is allowed to be an implicit dereference
4223
            --  of an access value designating a task.
4224
 
4225
            else
4226
               Check_Task_Prefix;
4227
               Set_Etype (N, Universal_Integer);
4228
            end if;
4229
 
4230
         else
4231
            Error_Attr_P ("prefix of % attribute must be access or task type");
4232
         end if;
4233
      end Storage_Size;
4234
 
4235
      ------------------
4236
      -- Storage_Unit --
4237
      ------------------
4238
 
4239
      when Attribute_Storage_Unit =>
4240
         Standard_Attribute (Ttypes.System_Storage_Unit);
4241
 
4242
      -----------------
4243
      -- Stream_Size --
4244
      -----------------
4245
 
4246
      when Attribute_Stream_Size =>
4247
         Check_E0;
4248
         Check_Type;
4249
 
4250
         if Is_Entity_Name (P)
4251
           and then Is_Elementary_Type (Entity (P))
4252
         then
4253
            Set_Etype (N, Universal_Integer);
4254
         else
4255
            Error_Attr_P ("invalid prefix for % attribute");
4256
         end if;
4257
 
4258
      ---------------
4259
      -- Stub_Type --
4260
      ---------------
4261
 
4262
      when Attribute_Stub_Type =>
4263
         Check_Type;
4264
         Check_E0;
4265
 
4266
         if Is_Remote_Access_To_Class_Wide_Type (P_Type) then
4267
            Rewrite (N,
4268
              New_Occurrence_Of (Corresponding_Stub_Type (P_Type), Loc));
4269
         else
4270
            Error_Attr_P
4271
              ("prefix of% attribute must be remote access to classwide");
4272
         end if;
4273
 
4274
      ----------
4275
      -- Succ --
4276
      ----------
4277
 
4278
      when Attribute_Succ =>
4279
         Check_Scalar_Type;
4280
         Check_E1;
4281
         Resolve (E1, P_Base_Type);
4282
         Set_Etype (N, P_Base_Type);
4283
 
4284
         --  Nothing to do for real type case
4285
 
4286
         if Is_Real_Type (P_Type) then
4287
            null;
4288
 
4289
         --  If not modular type, test for overflow check required
4290
 
4291
         else
4292
            if not Is_Modular_Integer_Type (P_Type)
4293
              and then not Range_Checks_Suppressed (P_Base_Type)
4294
            then
4295
               Enable_Range_Check (E1);
4296
            end if;
4297
         end if;
4298
 
4299
      ---------
4300
      -- Tag --
4301
      ---------
4302
 
4303
      when Attribute_Tag => Tag :
4304
      begin
4305
         Check_E0;
4306
         Check_Dereference;
4307
 
4308
         if not Is_Tagged_Type (P_Type) then
4309
            Error_Attr_P ("prefix of % attribute must be tagged");
4310
 
4311
         --  Next test does not apply to generated code
4312
         --  why not, and what does the illegal reference mean???
4313
 
4314
         elsif Is_Object_Reference (P)
4315
           and then not Is_Class_Wide_Type (P_Type)
4316
           and then Comes_From_Source (N)
4317
         then
4318
            Error_Attr_P
4319
              ("% attribute can only be applied to objects " &
4320
               "of class - wide type");
4321
         end if;
4322
 
4323
         --  The prefix cannot be an incomplete type. However, references
4324
         --  to 'Tag can be generated when expanding interface conversions,
4325
         --  and this is legal.
4326
 
4327
         if Comes_From_Source (N) then
4328
            Check_Not_Incomplete_Type;
4329
         end if;
4330
 
4331
         --  Set appropriate type
4332
 
4333
         Set_Etype (N, RTE (RE_Tag));
4334
      end Tag;
4335
 
4336
      -----------------
4337
      -- Target_Name --
4338
      -----------------
4339
 
4340
      when Attribute_Target_Name => Target_Name : declare
4341
         TN : constant String := Sdefault.Target_Name.all;
4342
         TL : Natural;
4343
 
4344
      begin
4345
         Check_Standard_Prefix;
4346
 
4347
         TL := TN'Last;
4348
 
4349
         if TN (TL) = '/' or else TN (TL) = '\' then
4350
            TL := TL - 1;
4351
         end if;
4352
 
4353
         Rewrite (N,
4354
           Make_String_Literal (Loc,
4355
             Strval => TN (TN'First .. TL)));
4356
         Analyze_And_Resolve (N, Standard_String);
4357
      end Target_Name;
4358
 
4359
      ----------------
4360
      -- Terminated --
4361
      ----------------
4362
 
4363
      when Attribute_Terminated =>
4364
         Check_E0;
4365
         Set_Etype (N, Standard_Boolean);
4366
         Check_Task_Prefix;
4367
 
4368
      ----------------
4369
      -- To_Address --
4370
      ----------------
4371
 
4372
      when Attribute_To_Address =>
4373
         Check_E1;
4374
         Analyze (P);
4375
 
4376
         if Nkind (P) /= N_Identifier
4377
           or else Chars (P) /= Name_System
4378
         then
4379
            Error_Attr_P ("prefix of %attribute must be System");
4380
         end if;
4381
 
4382
         Generate_Reference (RTE (RE_Address), P);
4383
         Analyze_And_Resolve (E1, Any_Integer);
4384
         Set_Etype (N, RTE (RE_Address));
4385
 
4386
      ------------
4387
      -- To_Any --
4388
      ------------
4389
 
4390
      when Attribute_To_Any =>
4391
         Check_E1;
4392
         Check_PolyORB_Attribute;
4393
         Set_Etype (N, RTE (RE_Any));
4394
 
4395
      ----------------
4396
      -- Truncation --
4397
      ----------------
4398
 
4399
      when Attribute_Truncation =>
4400
         Check_Floating_Point_Type_1;
4401
         Resolve (E1, P_Base_Type);
4402
         Set_Etype (N, P_Base_Type);
4403
 
4404
      ----------------
4405
      -- Type_Class --
4406
      ----------------
4407
 
4408
      when Attribute_Type_Class =>
4409
         Check_E0;
4410
         Check_Type;
4411
         Check_Not_Incomplete_Type;
4412
         Set_Etype (N, RTE (RE_Type_Class));
4413
 
4414
      --------------
4415
      -- TypeCode --
4416
      --------------
4417
 
4418
      when Attribute_TypeCode =>
4419
         Check_E0;
4420
         Check_PolyORB_Attribute;
4421
         Set_Etype (N, RTE (RE_TypeCode));
4422
 
4423
      -----------------
4424
      -- UET_Address --
4425
      -----------------
4426
 
4427
      when Attribute_UET_Address =>
4428
         Check_E0;
4429
         Check_Unit_Name (P);
4430
         Set_Etype (N, RTE (RE_Address));
4431
 
4432
      -----------------------
4433
      -- Unbiased_Rounding --
4434
      -----------------------
4435
 
4436
      when Attribute_Unbiased_Rounding =>
4437
         Check_Floating_Point_Type_1;
4438
         Set_Etype (N, P_Base_Type);
4439
         Resolve (E1, P_Base_Type);
4440
 
4441
      ----------------------
4442
      -- Unchecked_Access --
4443
      ----------------------
4444
 
4445
      when Attribute_Unchecked_Access =>
4446
         if Comes_From_Source (N) then
4447
            Check_Restriction (No_Unchecked_Access, N);
4448
         end if;
4449
 
4450
         Analyze_Access_Attribute;
4451
 
4452
      -------------------------
4453
      -- Unconstrained_Array --
4454
      -------------------------
4455
 
4456
      when Attribute_Unconstrained_Array =>
4457
         Check_E0;
4458
         Check_Type;
4459
         Check_Not_Incomplete_Type;
4460
         Set_Etype (N, Standard_Boolean);
4461
 
4462
      ------------------------------
4463
      -- Universal_Literal_String --
4464
      ------------------------------
4465
 
4466
      --  This is a GNAT specific attribute whose prefix must be a named
4467
      --  number where the expression is either a single numeric literal,
4468
      --  or a numeric literal immediately preceded by a minus sign. The
4469
      --  result is equivalent to a string literal containing the text of
4470
      --  the literal as it appeared in the source program with a possible
4471
      --  leading minus sign.
4472
 
4473
      when Attribute_Universal_Literal_String => Universal_Literal_String :
4474
      begin
4475
         Check_E0;
4476
 
4477
         if not Is_Entity_Name (P)
4478
           or else Ekind (Entity (P)) not in Named_Kind
4479
         then
4480
            Error_Attr_P ("prefix for % attribute must be named number");
4481
 
4482
         else
4483
            declare
4484
               Expr     : Node_Id;
4485
               Negative : Boolean;
4486
               S        : Source_Ptr;
4487
               Src      : Source_Buffer_Ptr;
4488
 
4489
            begin
4490
               Expr := Original_Node (Expression (Parent (Entity (P))));
4491
 
4492
               if Nkind (Expr) = N_Op_Minus then
4493
                  Negative := True;
4494
                  Expr := Original_Node (Right_Opnd (Expr));
4495
               else
4496
                  Negative := False;
4497
               end if;
4498
 
4499
               if not Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then
4500
                  Error_Attr
4501
                    ("named number for % attribute must be simple literal", N);
4502
               end if;
4503
 
4504
               --  Build string literal corresponding to source literal text
4505
 
4506
               Start_String;
4507
 
4508
               if Negative then
4509
                  Store_String_Char (Get_Char_Code ('-'));
4510
               end if;
4511
 
4512
               S := Sloc (Expr);
4513
               Src := Source_Text (Get_Source_File_Index (S));
4514
 
4515
               while Src (S) /= ';' and then Src (S) /= ' ' loop
4516
                  Store_String_Char (Get_Char_Code (Src (S)));
4517
                  S := S + 1;
4518
               end loop;
4519
 
4520
               --  Now we rewrite the attribute with the string literal
4521
 
4522
               Rewrite (N,
4523
                 Make_String_Literal (Loc, End_String));
4524
               Analyze (N);
4525
            end;
4526
         end if;
4527
      end Universal_Literal_String;
4528
 
4529
      -------------------------
4530
      -- Unrestricted_Access --
4531
      -------------------------
4532
 
4533
      --  This is a GNAT specific attribute which is like Access except that
4534
      --  all scope checks and checks for aliased views are omitted.
4535
 
4536
      when Attribute_Unrestricted_Access =>
4537
         if Comes_From_Source (N) then
4538
            Check_Restriction (No_Unchecked_Access, N);
4539
         end if;
4540
 
4541
         if Is_Entity_Name (P) then
4542
            Set_Address_Taken (Entity (P));
4543
         end if;
4544
 
4545
         Analyze_Access_Attribute;
4546
 
4547
      ---------
4548
      -- Val --
4549
      ---------
4550
 
4551
      when Attribute_Val => Val : declare
4552
      begin
4553
         Check_E1;
4554
         Check_Discrete_Type;
4555
         Resolve (E1, Any_Integer);
4556
         Set_Etype (N, P_Base_Type);
4557
 
4558
         --  Note, we need a range check in general, but we wait for the
4559
         --  Resolve call to do this, since we want to let Eval_Attribute
4560
         --  have a chance to find an static illegality first!
4561
      end Val;
4562
 
4563
      -----------
4564
      -- Valid --
4565
      -----------
4566
 
4567
      when Attribute_Valid =>
4568
         Check_E0;
4569
 
4570
         --  Ignore check for object if we have a 'Valid reference generated
4571
         --  by the expanded code, since in some cases valid checks can occur
4572
         --  on items that are names, but are not objects (e.g. attributes).
4573
 
4574
         if Comes_From_Source (N) then
4575
            Check_Object_Reference (P);
4576
         end if;
4577
 
4578
         if not Is_Scalar_Type (P_Type) then
4579
            Error_Attr_P ("object for % attribute must be of scalar type");
4580
         end if;
4581
 
4582
         Set_Etype (N, Standard_Boolean);
4583
 
4584
      -----------
4585
      -- Value --
4586
      -----------
4587
 
4588
      when Attribute_Value => Value :
4589
      begin
4590
         Check_E1;
4591
         Check_Scalar_Type;
4592
 
4593
         --  Case of enumeration type
4594
 
4595
         if Is_Enumeration_Type (P_Type) then
4596
            Check_Restriction (No_Enumeration_Maps, N);
4597
 
4598
            --  Mark all enumeration literals as referenced, since the use of
4599
            --  the Value attribute can implicitly reference any of the
4600
            --  literals of the enumeration base type.
4601
 
4602
            declare
4603
               Ent : Entity_Id := First_Literal (P_Base_Type);
4604
            begin
4605
               while Present (Ent) loop
4606
                  Set_Referenced (Ent);
4607
                  Next_Literal (Ent);
4608
               end loop;
4609
            end;
4610
         end if;
4611
 
4612
         --  Set Etype before resolving expression because expansion of
4613
         --  expression may require enclosing type. Note that the type
4614
         --  returned by 'Value is the base type of the prefix type.
4615
 
4616
         Set_Etype (N, P_Base_Type);
4617
         Validate_Non_Static_Attribute_Function_Call;
4618
      end Value;
4619
 
4620
      ----------------
4621
      -- Value_Size --
4622
      ----------------
4623
 
4624
      when Attribute_Value_Size =>
4625
         Check_E0;
4626
         Check_Type;
4627
         Check_Not_Incomplete_Type;
4628
         Set_Etype (N, Universal_Integer);
4629
 
4630
      -------------
4631
      -- Version --
4632
      -------------
4633
 
4634
      when Attribute_Version =>
4635
         Check_E0;
4636
         Check_Program_Unit;
4637
         Set_Etype (N, RTE (RE_Version_String));
4638
 
4639
      ------------------
4640
      -- Wchar_T_Size --
4641
      ------------------
4642
 
4643
      when Attribute_Wchar_T_Size =>
4644
         Standard_Attribute (Interfaces_Wchar_T_Size);
4645
 
4646
      ----------------
4647
      -- Wide_Image --
4648
      ----------------
4649
 
4650
      when Attribute_Wide_Image => Wide_Image :
4651
      begin
4652
         Check_Scalar_Type;
4653
         Set_Etype (N, Standard_Wide_String);
4654
         Check_E1;
4655
         Resolve (E1, P_Base_Type);
4656
         Validate_Non_Static_Attribute_Function_Call;
4657
      end Wide_Image;
4658
 
4659
      ---------------------
4660
      -- Wide_Wide_Image --
4661
      ---------------------
4662
 
4663
      when Attribute_Wide_Wide_Image => Wide_Wide_Image :
4664
      begin
4665
         Check_Scalar_Type;
4666
         Set_Etype (N, Standard_Wide_Wide_String);
4667
         Check_E1;
4668
         Resolve (E1, P_Base_Type);
4669
         Validate_Non_Static_Attribute_Function_Call;
4670
      end Wide_Wide_Image;
4671
 
4672
      ----------------
4673
      -- Wide_Value --
4674
      ----------------
4675
 
4676
      when Attribute_Wide_Value => Wide_Value :
4677
      begin
4678
         Check_E1;
4679
         Check_Scalar_Type;
4680
 
4681
         --  Set Etype before resolving expression because expansion
4682
         --  of expression may require enclosing type.
4683
 
4684
         Set_Etype (N, P_Type);
4685
         Validate_Non_Static_Attribute_Function_Call;
4686
      end Wide_Value;
4687
 
4688
      ---------------------
4689
      -- Wide_Wide_Value --
4690
      ---------------------
4691
 
4692
      when Attribute_Wide_Wide_Value => Wide_Wide_Value :
4693
      begin
4694
         Check_E1;
4695
         Check_Scalar_Type;
4696
 
4697
         --  Set Etype before resolving expression because expansion
4698
         --  of expression may require enclosing type.
4699
 
4700
         Set_Etype (N, P_Type);
4701
         Validate_Non_Static_Attribute_Function_Call;
4702
      end Wide_Wide_Value;
4703
 
4704
      ---------------------
4705
      -- Wide_Wide_Width --
4706
      ---------------------
4707
 
4708
      when Attribute_Wide_Wide_Width =>
4709
         Check_E0;
4710
         Check_Scalar_Type;
4711
         Set_Etype (N, Universal_Integer);
4712
 
4713
      ----------------
4714
      -- Wide_Width --
4715
      ----------------
4716
 
4717
      when Attribute_Wide_Width =>
4718
         Check_E0;
4719
         Check_Scalar_Type;
4720
         Set_Etype (N, Universal_Integer);
4721
 
4722
      -----------
4723
      -- Width --
4724
      -----------
4725
 
4726
      when Attribute_Width =>
4727
         Check_E0;
4728
         Check_Scalar_Type;
4729
         Set_Etype (N, Universal_Integer);
4730
 
4731
      ---------------
4732
      -- Word_Size --
4733
      ---------------
4734
 
4735
      when Attribute_Word_Size =>
4736
         Standard_Attribute (System_Word_Size);
4737
 
4738
      -----------
4739
      -- Write --
4740
      -----------
4741
 
4742
      when Attribute_Write =>
4743
         Check_E2;
4744
         Check_Stream_Attribute (TSS_Stream_Write);
4745
         Set_Etype (N, Standard_Void_Type);
4746
         Resolve (N, Standard_Void_Type);
4747
 
4748
      end case;
4749
 
4750
   --  All errors raise Bad_Attribute, so that we get out before any further
4751
   --  damage occurs when an error is detected (for example, if we check for
4752
   --  one attribute expression, and the check succeeds, we want to be able
4753
   --  to proceed securely assuming that an expression is in fact present.
4754
 
4755
   --  Note: we set the attribute analyzed in this case to prevent any
4756
   --  attempt at reanalysis which could generate spurious error msgs.
4757
 
4758
   exception
4759
      when Bad_Attribute =>
4760
         Set_Analyzed (N);
4761
         Set_Etype (N, Any_Type);
4762
         return;
4763
   end Analyze_Attribute;
4764
 
4765
   --------------------
4766
   -- Eval_Attribute --
4767
   --------------------
4768
 
4769
   procedure Eval_Attribute (N : Node_Id) is
4770
      Loc   : constant Source_Ptr   := Sloc (N);
4771
      Aname : constant Name_Id      := Attribute_Name (N);
4772
      Id    : constant Attribute_Id := Get_Attribute_Id (Aname);
4773
      P     : constant Node_Id      := Prefix (N);
4774
 
4775
      C_Type : constant Entity_Id := Etype (N);
4776
      --  The type imposed by the context
4777
 
4778
      E1 : Node_Id;
4779
      --  First expression, or Empty if none
4780
 
4781
      E2 : Node_Id;
4782
      --  Second expression, or Empty if none
4783
 
4784
      P_Entity : Entity_Id;
4785
      --  Entity denoted by prefix
4786
 
4787
      P_Type : Entity_Id;
4788
      --  The type of the prefix
4789
 
4790
      P_Base_Type : Entity_Id;
4791
      --  The base type of the prefix type
4792
 
4793
      P_Root_Type : Entity_Id;
4794
      --  The root type of the prefix type
4795
 
4796
      Static : Boolean;
4797
      --  True if the result is Static. This is set by the general processing
4798
      --  to true if the prefix is static, and all expressions are static. It
4799
      --  can be reset as processing continues for particular attributes
4800
 
4801
      Lo_Bound, Hi_Bound : Node_Id;
4802
      --  Expressions for low and high bounds of type or array index referenced
4803
      --  by First, Last, or Length attribute for array, set by Set_Bounds.
4804
 
4805
      CE_Node : Node_Id;
4806
      --  Constraint error node used if we have an attribute reference has
4807
      --  an argument that raises a constraint error. In this case we replace
4808
      --  the attribute with a raise constraint_error node. This is important
4809
      --  processing, since otherwise gigi might see an attribute which it is
4810
      --  unprepared to deal with.
4811
 
4812
      function Aft_Value return Nat;
4813
      --  Computes Aft value for current attribute prefix (used by Aft itself
4814
      --  and also by Width for computing the Width of a fixed point type).
4815
 
4816
      procedure Check_Expressions;
4817
      --  In case where the attribute is not foldable, the expressions, if
4818
      --  any, of the attribute, are in a non-static context. This procedure
4819
      --  performs the required additional checks.
4820
 
4821
      function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean;
4822
      --  Determines if the given type has compile time known bounds. Note
4823
      --  that we enter the case statement even in cases where the prefix
4824
      --  type does NOT have known bounds, so it is important to guard any
4825
      --  attempt to evaluate both bounds with a call to this function.
4826
 
4827
      procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint);
4828
      --  This procedure is called when the attribute N has a non-static
4829
      --  but compile time known value given by Val. It includes the
4830
      --  necessary checks for out of range values.
4831
 
4832
      procedure Float_Attribute_Universal_Integer
4833
        (IEEES_Val : Int;
4834
         IEEEL_Val : Int;
4835
         IEEEX_Val : Int;
4836
         VAXFF_Val : Int;
4837
         VAXDF_Val : Int;
4838
         VAXGF_Val : Int;
4839
         AAMPS_Val : Int;
4840
         AAMPL_Val : Int);
4841
      --  This procedure evaluates a float attribute with no arguments that
4842
      --  returns a universal integer result. The parameters give the values
4843
      --  for the possible floating-point root types. See ttypef for details.
4844
      --  The prefix type is a float type (and is thus not a generic type).
4845
 
4846
      procedure Float_Attribute_Universal_Real
4847
        (IEEES_Val : String;
4848
         IEEEL_Val : String;
4849
         IEEEX_Val : String;
4850
         VAXFF_Val : String;
4851
         VAXDF_Val : String;
4852
         VAXGF_Val : String;
4853
         AAMPS_Val : String;
4854
         AAMPL_Val : String);
4855
      --  This procedure evaluates a float attribute with no arguments that
4856
      --  returns a universal real result. The parameters give the values
4857
      --  required for the possible floating-point root types in string
4858
      --  format as real literals with a possible leading minus sign.
4859
      --  The prefix type is a float type (and is thus not a generic type).
4860
 
4861
      function Fore_Value return Nat;
4862
      --  Computes the Fore value for the current attribute prefix, which is
4863
      --  known to be a static fixed-point type. Used by Fore and Width.
4864
 
4865
      function Mantissa return Uint;
4866
      --  Returns the Mantissa value for the prefix type
4867
 
4868
      procedure Set_Bounds;
4869
      --  Used for First, Last and Length attributes applied to an array or
4870
      --  array subtype. Sets the variables Lo_Bound and Hi_Bound to the low
4871
      --  and high bound expressions for the index referenced by the attribute
4872
      --  designator (i.e. the first index if no expression is present, and
4873
      --  the N'th index if the value N is present as an expression). Also
4874
      --  used for First and Last of scalar types. Static is reset to False
4875
      --  if the type or index type is not statically constrained.
4876
 
4877
      function Statically_Denotes_Entity (N : Node_Id) return Boolean;
4878
      --  Verify that the prefix of a potentially static array attribute
4879
      --  satisfies the conditions of 4.9 (14).
4880
 
4881
      ---------------
4882
      -- Aft_Value --
4883
      ---------------
4884
 
4885
      function Aft_Value return Nat is
4886
         Result    : Nat;
4887
         Delta_Val : Ureal;
4888
 
4889
      begin
4890
         Result := 1;
4891
         Delta_Val := Delta_Value (P_Type);
4892
         while Delta_Val < Ureal_Tenth loop
4893
            Delta_Val := Delta_Val * Ureal_10;
4894
            Result := Result + 1;
4895
         end loop;
4896
 
4897
         return Result;
4898
      end Aft_Value;
4899
 
4900
      -----------------------
4901
      -- Check_Expressions --
4902
      -----------------------
4903
 
4904
      procedure Check_Expressions is
4905
         E : Node_Id;
4906
      begin
4907
         E := E1;
4908
         while Present (E) loop
4909
            Check_Non_Static_Context (E);
4910
            Next (E);
4911
         end loop;
4912
      end Check_Expressions;
4913
 
4914
      ----------------------------------
4915
      -- Compile_Time_Known_Attribute --
4916
      ----------------------------------
4917
 
4918
      procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint) is
4919
         T : constant Entity_Id := Etype (N);
4920
 
4921
      begin
4922
         Fold_Uint (N, Val, False);
4923
 
4924
         --  Check that result is in bounds of the type if it is static
4925
 
4926
         if Is_In_Range (N, T, Assume_Valid => False) then
4927
            null;
4928
 
4929
         elsif Is_Out_Of_Range (N, T) then
4930
            Apply_Compile_Time_Constraint_Error
4931
              (N, "value not in range of}?", CE_Range_Check_Failed);
4932
 
4933
         elsif not Range_Checks_Suppressed (T) then
4934
            Enable_Range_Check (N);
4935
 
4936
         else
4937
            Set_Do_Range_Check (N, False);
4938
         end if;
4939
      end Compile_Time_Known_Attribute;
4940
 
4941
      -------------------------------
4942
      -- Compile_Time_Known_Bounds --
4943
      -------------------------------
4944
 
4945
      function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean is
4946
      begin
4947
         return
4948
           Compile_Time_Known_Value (Type_Low_Bound (Typ))
4949
             and then
4950
           Compile_Time_Known_Value (Type_High_Bound (Typ));
4951
      end Compile_Time_Known_Bounds;
4952
 
4953
      ---------------------------------------
4954
      -- Float_Attribute_Universal_Integer --
4955
      ---------------------------------------
4956
 
4957
      procedure Float_Attribute_Universal_Integer
4958
        (IEEES_Val : Int;
4959
         IEEEL_Val : Int;
4960
         IEEEX_Val : Int;
4961
         VAXFF_Val : Int;
4962
         VAXDF_Val : Int;
4963
         VAXGF_Val : Int;
4964
         AAMPS_Val : Int;
4965
         AAMPL_Val : Int)
4966
      is
4967
         Val  : Int;
4968
         Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
4969
 
4970
      begin
4971
         if Vax_Float (P_Base_Type) then
4972
            if Digs = VAXFF_Digits then
4973
               Val := VAXFF_Val;
4974
            elsif Digs = VAXDF_Digits then
4975
               Val := VAXDF_Val;
4976
            else pragma Assert (Digs = VAXGF_Digits);
4977
               Val := VAXGF_Val;
4978
            end if;
4979
 
4980
         elsif Is_AAMP_Float (P_Base_Type) then
4981
            if Digs = AAMPS_Digits then
4982
               Val := AAMPS_Val;
4983
            else pragma Assert (Digs = AAMPL_Digits);
4984
               Val := AAMPL_Val;
4985
            end if;
4986
 
4987
         else
4988
            if Digs = IEEES_Digits then
4989
               Val := IEEES_Val;
4990
            elsif Digs = IEEEL_Digits then
4991
               Val := IEEEL_Val;
4992
            else pragma Assert (Digs = IEEEX_Digits);
4993
               Val := IEEEX_Val;
4994
            end if;
4995
         end if;
4996
 
4997
         Fold_Uint (N, UI_From_Int (Val), True);
4998
      end Float_Attribute_Universal_Integer;
4999
 
5000
      ------------------------------------
5001
      -- Float_Attribute_Universal_Real --
5002
      ------------------------------------
5003
 
5004
      procedure Float_Attribute_Universal_Real
5005
        (IEEES_Val : String;
5006
         IEEEL_Val : String;
5007
         IEEEX_Val : String;
5008
         VAXFF_Val : String;
5009
         VAXDF_Val : String;
5010
         VAXGF_Val : String;
5011
         AAMPS_Val : String;
5012
         AAMPL_Val : String)
5013
      is
5014
         Val  : Node_Id;
5015
         Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
5016
 
5017
      begin
5018
         if Vax_Float (P_Base_Type) then
5019
            if Digs = VAXFF_Digits then
5020
               Val := Real_Convert (VAXFF_Val);
5021
            elsif Digs = VAXDF_Digits then
5022
               Val := Real_Convert (VAXDF_Val);
5023
            else pragma Assert (Digs = VAXGF_Digits);
5024
               Val := Real_Convert (VAXGF_Val);
5025
            end if;
5026
 
5027
         elsif Is_AAMP_Float (P_Base_Type) then
5028
            if Digs = AAMPS_Digits then
5029
               Val := Real_Convert (AAMPS_Val);
5030
            else pragma Assert (Digs = AAMPL_Digits);
5031
               Val := Real_Convert (AAMPL_Val);
5032
            end if;
5033
 
5034
         else
5035
            if Digs = IEEES_Digits then
5036
               Val := Real_Convert (IEEES_Val);
5037
            elsif Digs = IEEEL_Digits then
5038
               Val := Real_Convert (IEEEL_Val);
5039
            else pragma Assert (Digs = IEEEX_Digits);
5040
               Val := Real_Convert (IEEEX_Val);
5041
            end if;
5042
         end if;
5043
 
5044
         Set_Sloc (Val, Loc);
5045
         Rewrite (N, Val);
5046
         Set_Is_Static_Expression (N, Static);
5047
         Analyze_And_Resolve (N, C_Type);
5048
      end Float_Attribute_Universal_Real;
5049
 
5050
      ----------------
5051
      -- Fore_Value --
5052
      ----------------
5053
 
5054
      --  Note that the Fore calculation is based on the actual values
5055
      --  of the bounds, and does not take into account possible rounding.
5056
 
5057
      function Fore_Value return Nat is
5058
         Lo      : constant Uint  := Expr_Value (Type_Low_Bound (P_Type));
5059
         Hi      : constant Uint  := Expr_Value (Type_High_Bound (P_Type));
5060
         Small   : constant Ureal := Small_Value (P_Type);
5061
         Lo_Real : constant Ureal := Lo * Small;
5062
         Hi_Real : constant Ureal := Hi * Small;
5063
         T       : Ureal;
5064
         R       : Nat;
5065
 
5066
      begin
5067
         --  Bounds are given in terms of small units, so first compute
5068
         --  proper values as reals.
5069
 
5070
         T := UR_Max (abs Lo_Real, abs Hi_Real);
5071
         R := 2;
5072
 
5073
         --  Loop to compute proper value if more than one digit required
5074
 
5075
         while T >= Ureal_10 loop
5076
            R := R + 1;
5077
            T := T / Ureal_10;
5078
         end loop;
5079
 
5080
         return R;
5081
      end Fore_Value;
5082
 
5083
      --------------
5084
      -- Mantissa --
5085
      --------------
5086
 
5087
      --  Table of mantissa values accessed by function  Computed using
5088
      --  the relation:
5089
 
5090
      --    T'Mantissa = integer next above (D * log(10)/log(2)) + 1)
5091
 
5092
      --  where D is T'Digits (RM83 3.5.7)
5093
 
5094
      Mantissa_Value : constant array (Nat range 1 .. 40) of Nat := (
5095
          1 =>   5,
5096
          2 =>   8,
5097
          3 =>  11,
5098
          4 =>  15,
5099
          5 =>  18,
5100
          6 =>  21,
5101
          7 =>  25,
5102
          8 =>  28,
5103
          9 =>  31,
5104
         10 =>  35,
5105
         11 =>  38,
5106
         12 =>  41,
5107
         13 =>  45,
5108
         14 =>  48,
5109
         15 =>  51,
5110
         16 =>  55,
5111
         17 =>  58,
5112
         18 =>  61,
5113
         19 =>  65,
5114
         20 =>  68,
5115
         21 =>  71,
5116
         22 =>  75,
5117
         23 =>  78,
5118
         24 =>  81,
5119
         25 =>  85,
5120
         26 =>  88,
5121
         27 =>  91,
5122
         28 =>  95,
5123
         29 =>  98,
5124
         30 => 101,
5125
         31 => 104,
5126
         32 => 108,
5127
         33 => 111,
5128
         34 => 114,
5129
         35 => 118,
5130
         36 => 121,
5131
         37 => 124,
5132
         38 => 128,
5133
         39 => 131,
5134
         40 => 134);
5135
 
5136
      function Mantissa return Uint is
5137
      begin
5138
         return
5139
           UI_From_Int (Mantissa_Value (UI_To_Int (Digits_Value (P_Type))));
5140
      end Mantissa;
5141
 
5142
      ----------------
5143
      -- Set_Bounds --
5144
      ----------------
5145
 
5146
      procedure Set_Bounds is
5147
         Ndim : Nat;
5148
         Indx : Node_Id;
5149
         Ityp : Entity_Id;
5150
 
5151
      begin
5152
         --  For a string literal subtype, we have to construct the bounds.
5153
         --  Valid Ada code never applies attributes to string literals, but
5154
         --  it is convenient to allow the expander to generate attribute
5155
         --  references of this type (e.g. First and Last applied to a string
5156
         --  literal).
5157
 
5158
         --  Note that the whole point of the E_String_Literal_Subtype is to
5159
         --  avoid this construction of bounds, but the cases in which we
5160
         --  have to materialize them are rare enough that we don't worry!
5161
 
5162
         --  The low bound is simply the low bound of the base type. The
5163
         --  high bound is computed from the length of the string and this
5164
         --  low bound.
5165
 
5166
         if Ekind (P_Type) = E_String_Literal_Subtype then
5167
            Ityp := Etype (First_Index (Base_Type (P_Type)));
5168
            Lo_Bound := Type_Low_Bound (Ityp);
5169
 
5170
            Hi_Bound :=
5171
              Make_Integer_Literal (Sloc (P),
5172
                Intval =>
5173
                  Expr_Value (Lo_Bound) + String_Literal_Length (P_Type) - 1);
5174
 
5175
            Set_Parent (Hi_Bound, P);
5176
            Analyze_And_Resolve (Hi_Bound, Etype (Lo_Bound));
5177
            return;
5178
 
5179
         --  For non-array case, just get bounds of scalar type
5180
 
5181
         elsif Is_Scalar_Type (P_Type) then
5182
            Ityp := P_Type;
5183
 
5184
            --  For a fixed-point type, we must freeze to get the attributes
5185
            --  of the fixed-point type set now so we can reference them.
5186
 
5187
            if Is_Fixed_Point_Type (P_Type)
5188
              and then not Is_Frozen (Base_Type (P_Type))
5189
              and then Compile_Time_Known_Value (Type_Low_Bound (P_Type))
5190
              and then Compile_Time_Known_Value (Type_High_Bound (P_Type))
5191
            then
5192
               Freeze_Fixed_Point_Type (Base_Type (P_Type));
5193
            end if;
5194
 
5195
         --  For array case, get type of proper index
5196
 
5197
         else
5198
            if No (E1) then
5199
               Ndim := 1;
5200
            else
5201
               Ndim := UI_To_Int (Expr_Value (E1));
5202
            end if;
5203
 
5204
            Indx := First_Index (P_Type);
5205
            for J in 1 .. Ndim - 1 loop
5206
               Next_Index (Indx);
5207
            end loop;
5208
 
5209
            --  If no index type, get out (some other error occurred, and
5210
            --  we don't have enough information to complete the job!)
5211
 
5212
            if No (Indx) then
5213
               Lo_Bound := Error;
5214
               Hi_Bound := Error;
5215
               return;
5216
            end if;
5217
 
5218
            Ityp := Etype (Indx);
5219
         end if;
5220
 
5221
         --  A discrete range in an index constraint is allowed to be a
5222
         --  subtype indication. This is syntactically a pain, but should
5223
         --  not propagate to the entity for the corresponding index subtype.
5224
         --  After checking that the subtype indication is legal, the range
5225
         --  of the subtype indication should be transfered to the entity.
5226
         --  The attributes for the bounds should remain the simple retrievals
5227
         --  that they are now.
5228
 
5229
         Lo_Bound := Type_Low_Bound (Ityp);
5230
         Hi_Bound := Type_High_Bound (Ityp);
5231
 
5232
         if not Is_Static_Subtype (Ityp) then
5233
            Static := False;
5234
         end if;
5235
      end Set_Bounds;
5236
 
5237
      -------------------------------
5238
      -- Statically_Denotes_Entity --
5239
      -------------------------------
5240
 
5241
      function Statically_Denotes_Entity (N : Node_Id) return Boolean is
5242
         E : Entity_Id;
5243
 
5244
      begin
5245
         if not Is_Entity_Name (N) then
5246
            return False;
5247
         else
5248
            E := Entity (N);
5249
         end if;
5250
 
5251
         return
5252
           Nkind (Parent (E)) /= N_Object_Renaming_Declaration
5253
             or else Statically_Denotes_Entity (Renamed_Object (E));
5254
      end Statically_Denotes_Entity;
5255
 
5256
   --  Start of processing for Eval_Attribute
5257
 
5258
   begin
5259
      --  Acquire first two expressions (at the moment, no attributes
5260
      --  take more than two expressions in any case).
5261
 
5262
      if Present (Expressions (N)) then
5263
         E1 := First (Expressions (N));
5264
         E2 := Next (E1);
5265
      else
5266
         E1 := Empty;
5267
         E2 := Empty;
5268
      end if;
5269
 
5270
      --  Special processing for Enabled attribute. This attribute has a very
5271
      --  special prefix, and the easiest way to avoid lots of special checks
5272
      --  to protect this special prefix from causing trouble is to deal with
5273
      --  this attribute immediately and be done with it.
5274
 
5275
      if Id = Attribute_Enabled then
5276
 
5277
         --  Evaluate the Enabled attribute
5278
 
5279
         --  We skip evaluation if the expander is not active. This is not just
5280
         --  an optimization. It is of key importance that we not rewrite the
5281
         --  attribute in a generic template, since we want to pick up the
5282
         --  setting of the check in the instance, and testing expander active
5283
         --  is as easy way of doing this as any.
5284
 
5285
         if Expander_Active then
5286
            declare
5287
               C : constant Check_Id := Get_Check_Id (Chars (P));
5288
               R : Boolean;
5289
 
5290
            begin
5291
               if No (E1) then
5292
                  if C in Predefined_Check_Id then
5293
                     R := Scope_Suppress (C);
5294
                  else
5295
                     R := Is_Check_Suppressed (Empty, C);
5296
                  end if;
5297
 
5298
               else
5299
                  R := Is_Check_Suppressed (Entity (E1), C);
5300
               end if;
5301
 
5302
               if R then
5303
                  Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
5304
               else
5305
                  Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
5306
               end if;
5307
            end;
5308
         end if;
5309
 
5310
         return;
5311
      end if;
5312
 
5313
      --  Special processing for cases where the prefix is an object. For
5314
      --  this purpose, a string literal counts as an object (attributes
5315
      --  of string literals can only appear in generated code).
5316
 
5317
      if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then
5318
 
5319
         --  For Component_Size, the prefix is an array object, and we apply
5320
         --  the attribute to the type of the object. This is allowed for
5321
         --  both unconstrained and constrained arrays, since the bounds
5322
         --  have no influence on the value of this attribute.
5323
 
5324
         if Id = Attribute_Component_Size then
5325
            P_Entity := Etype (P);
5326
 
5327
         --  For First and Last, the prefix is an array object, and we apply
5328
         --  the attribute to the type of the array, but we need a constrained
5329
         --  type for this, so we use the actual subtype if available.
5330
 
5331
         elsif Id = Attribute_First
5332
                 or else
5333
               Id = Attribute_Last
5334
                 or else
5335
               Id = Attribute_Length
5336
         then
5337
            declare
5338
               AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P);
5339
 
5340
            begin
5341
               if Present (AS) and then Is_Constrained (AS) then
5342
                  P_Entity := AS;
5343
 
5344
               --  If we have an unconstrained type we cannot fold
5345
 
5346
               else
5347
                  Check_Expressions;
5348
                  return;
5349
               end if;
5350
            end;
5351
 
5352
         --  For Size, give size of object if available, otherwise we
5353
         --  cannot fold Size.
5354
 
5355
         elsif Id = Attribute_Size then
5356
            if Is_Entity_Name (P)
5357
              and then Known_Esize (Entity (P))
5358
            then
5359
               Compile_Time_Known_Attribute (N, Esize (Entity (P)));
5360
               return;
5361
 
5362
            else
5363
               Check_Expressions;
5364
               return;
5365
            end if;
5366
 
5367
         --  For Alignment, give size of object if available, otherwise we
5368
         --  cannot fold Alignment.
5369
 
5370
         elsif Id = Attribute_Alignment then
5371
            if Is_Entity_Name (P)
5372
              and then Known_Alignment (Entity (P))
5373
            then
5374
               Fold_Uint (N, Alignment (Entity (P)), False);
5375
               return;
5376
 
5377
            else
5378
               Check_Expressions;
5379
               return;
5380
            end if;
5381
 
5382
         --  No other attributes for objects are folded
5383
 
5384
         else
5385
            Check_Expressions;
5386
            return;
5387
         end if;
5388
 
5389
      --  Cases where P is not an object. Cannot do anything if P is
5390
      --  not the name of an entity.
5391
 
5392
      elsif not Is_Entity_Name (P) then
5393
         Check_Expressions;
5394
         return;
5395
 
5396
      --  Otherwise get prefix entity
5397
 
5398
      else
5399
         P_Entity := Entity (P);
5400
      end if;
5401
 
5402
      --  At this stage P_Entity is the entity to which the attribute
5403
      --  is to be applied. This is usually simply the entity of the
5404
      --  prefix, except in some cases of attributes for objects, where
5405
      --  as described above, we apply the attribute to the object type.
5406
 
5407
      --  First foldable possibility is a scalar or array type (RM 4.9(7))
5408
      --  that is not generic (generic types are eliminated by RM 4.9(25)).
5409
      --  Note we allow non-static non-generic types at this stage as further
5410
      --  described below.
5411
 
5412
      if Is_Type (P_Entity)
5413
        and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity))
5414
        and then (not Is_Generic_Type (P_Entity))
5415
      then
5416
         P_Type := P_Entity;
5417
 
5418
      --  Second foldable possibility is an array object (RM 4.9(8))
5419
 
5420
      elsif (Ekind (P_Entity) = E_Variable
5421
               or else
5422
             Ekind (P_Entity) = E_Constant)
5423
        and then Is_Array_Type (Etype (P_Entity))
5424
        and then (not Is_Generic_Type (Etype (P_Entity)))
5425
      then
5426
         P_Type := Etype (P_Entity);
5427
 
5428
         --  If the entity is an array constant with an unconstrained nominal
5429
         --  subtype then get the type from the initial value. If the value has
5430
         --  been expanded into assignments, there is no expression and the
5431
         --  attribute reference remains dynamic.
5432
 
5433
         --  We could do better here and retrieve the type ???
5434
 
5435
         if Ekind (P_Entity) = E_Constant
5436
           and then not Is_Constrained (P_Type)
5437
         then
5438
            if No (Constant_Value (P_Entity)) then
5439
               return;
5440
            else
5441
               P_Type := Etype (Constant_Value (P_Entity));
5442
            end if;
5443
         end if;
5444
 
5445
      --  Definite must be folded if the prefix is not a generic type,
5446
      --  that is to say if we are within an instantiation. Same processing
5447
      --  applies to the GNAT attributes Has_Discriminants, Type_Class,
5448
      --  Has_Tagged_Value, and Unconstrained_Array.
5449
 
5450
      elsif (Id = Attribute_Definite
5451
               or else
5452
             Id = Attribute_Has_Access_Values
5453
               or else
5454
             Id = Attribute_Has_Discriminants
5455
               or else
5456
             Id = Attribute_Has_Tagged_Values
5457
               or else
5458
             Id = Attribute_Type_Class
5459
               or else
5460
             Id = Attribute_Unconstrained_Array)
5461
        and then not Is_Generic_Type (P_Entity)
5462
      then
5463
         P_Type := P_Entity;
5464
 
5465
      --  We can fold 'Size applied to a type if the size is known (as happens
5466
      --  for a size from an attribute definition clause). At this stage, this
5467
      --  can happen only for types (e.g. record types) for which the size is
5468
      --  always non-static. We exclude generic types from consideration (since
5469
      --  they have bogus sizes set within templates).
5470
 
5471
      elsif Id = Attribute_Size
5472
        and then Is_Type (P_Entity)
5473
        and then (not Is_Generic_Type (P_Entity))
5474
        and then Known_Static_RM_Size (P_Entity)
5475
      then
5476
         Compile_Time_Known_Attribute (N, RM_Size (P_Entity));
5477
         return;
5478
 
5479
      --  We can fold 'Alignment applied to a type if the alignment is known
5480
      --  (as happens for an alignment from an attribute definition clause).
5481
      --  At this stage, this can happen only for types (e.g. record
5482
      --  types) for which the size is always non-static. We exclude
5483
      --  generic types from consideration (since they have bogus
5484
      --  sizes set within templates).
5485
 
5486
      elsif Id = Attribute_Alignment
5487
        and then Is_Type (P_Entity)
5488
        and then (not Is_Generic_Type (P_Entity))
5489
        and then Known_Alignment (P_Entity)
5490
      then
5491
         Compile_Time_Known_Attribute (N, Alignment (P_Entity));
5492
         return;
5493
 
5494
      --  If this is an access attribute that is known to fail accessibility
5495
      --  check, rewrite accordingly.
5496
 
5497
      elsif Attribute_Name (N) = Name_Access
5498
        and then Raises_Constraint_Error (N)
5499
      then
5500
         Rewrite (N,
5501
           Make_Raise_Program_Error (Loc,
5502
             Reason => PE_Accessibility_Check_Failed));
5503
         Set_Etype (N, C_Type);
5504
         return;
5505
 
5506
      --  No other cases are foldable (they certainly aren't static, and at
5507
      --  the moment we don't try to fold any cases other than these three).
5508
 
5509
      else
5510
         Check_Expressions;
5511
         return;
5512
      end if;
5513
 
5514
      --  If either attribute or the prefix is Any_Type, then propagate
5515
      --  Any_Type to the result and don't do anything else at all.
5516
 
5517
      if P_Type = Any_Type
5518
        or else (Present (E1) and then Etype (E1) = Any_Type)
5519
        or else (Present (E2) and then Etype (E2) = Any_Type)
5520
      then
5521
         Set_Etype (N, Any_Type);
5522
         return;
5523
      end if;
5524
 
5525
      --  Scalar subtype case. We have not yet enforced the static requirement
5526
      --  of (RM 4.9(7)) and we don't intend to just yet, since there are cases
5527
      --  of non-static attribute references (e.g. S'Digits for a non-static
5528
      --  floating-point type, which we can compute at compile time).
5529
 
5530
      --  Note: this folding of non-static attributes is not simply a case of
5531
      --  optimization. For many of the attributes affected, Gigi cannot handle
5532
      --  the attribute and depends on the front end having folded them away.
5533
 
5534
      --  Note: although we don't require staticness at this stage, we do set
5535
      --  the Static variable to record the staticness, for easy reference by
5536
      --  those attributes where it matters (e.g. Succ and Pred), and also to
5537
      --  be used to ensure that non-static folded things are not marked as
5538
      --  being static (a check that is done right at the end).
5539
 
5540
      P_Root_Type := Root_Type (P_Type);
5541
      P_Base_Type := Base_Type (P_Type);
5542
 
5543
      --  If the root type or base type is generic, then we cannot fold. This
5544
      --  test is needed because subtypes of generic types are not always
5545
      --  marked as being generic themselves (which seems odd???)
5546
 
5547
      if Is_Generic_Type (P_Root_Type)
5548
        or else Is_Generic_Type (P_Base_Type)
5549
      then
5550
         return;
5551
      end if;
5552
 
5553
      if Is_Scalar_Type (P_Type) then
5554
         Static := Is_OK_Static_Subtype (P_Type);
5555
 
5556
      --  Array case. We enforce the constrained requirement of (RM 4.9(7-8))
5557
      --  since we can't do anything with unconstrained arrays. In addition,
5558
      --  only the First, Last and Length attributes are possibly static.
5559
 
5560
      --  Definite, Has_Access_Values, Has_Discriminants, Has_Tagged_Values,
5561
      --  Type_Class, and Unconstrained_Array are again exceptions, because
5562
      --  they apply as well to unconstrained types.
5563
 
5564
      --  In addition Component_Size is an exception since it is possibly
5565
      --  foldable, even though it is never static, and it does apply to
5566
      --  unconstrained arrays. Furthermore, it is essential to fold this
5567
      --  in the packed case, since otherwise the value will be incorrect.
5568
 
5569
      elsif Id = Attribute_Definite
5570
              or else
5571
            Id = Attribute_Has_Access_Values
5572
              or else
5573
            Id = Attribute_Has_Discriminants
5574
              or else
5575
            Id = Attribute_Has_Tagged_Values
5576
              or else
5577
            Id = Attribute_Type_Class
5578
              or else
5579
            Id = Attribute_Unconstrained_Array
5580
              or else
5581
            Id = Attribute_Component_Size
5582
      then
5583
         Static := False;
5584
 
5585
      else
5586
         if not Is_Constrained (P_Type)
5587
           or else (Id /= Attribute_First and then
5588
                    Id /= Attribute_Last  and then
5589
                    Id /= Attribute_Length)
5590
         then
5591
            Check_Expressions;
5592
            return;
5593
         end if;
5594
 
5595
         --  The rules in (RM 4.9(7,8)) require a static array, but as in the
5596
         --  scalar case, we hold off on enforcing staticness, since there are
5597
         --  cases which we can fold at compile time even though they are not
5598
         --  static (e.g. 'Length applied to a static index, even though other
5599
         --  non-static indexes make the array type non-static). This is only
5600
         --  an optimization, but it falls out essentially free, so why not.
5601
         --  Again we compute the variable Static for easy reference later
5602
         --  (note that no array attributes are static in Ada 83).
5603
 
5604
         --  We also need to set Static properly for subsequent legality checks
5605
         --  which might otherwise accept non-static constants in contexts
5606
         --  where they are not legal.
5607
 
5608
         Static := Ada_Version >= Ada_95
5609
                     and then Statically_Denotes_Entity (P);
5610
 
5611
         declare
5612
            N : Node_Id;
5613
 
5614
         begin
5615
            N := First_Index (P_Type);
5616
 
5617
            --  The expression is static if the array type is constrained
5618
            --  by given bounds, and not by an initial expression. Constant
5619
            --  strings are static in any case.
5620
 
5621
            if Root_Type (P_Type) /= Standard_String then
5622
               Static :=
5623
                 Static and then not Is_Constr_Subt_For_U_Nominal (P_Type);
5624
            end if;
5625
 
5626
            while Present (N) loop
5627
               Static := Static and then Is_Static_Subtype (Etype (N));
5628
 
5629
               --  If however the index type is generic, attributes cannot
5630
               --  be folded.
5631
 
5632
               if Is_Generic_Type (Etype (N))
5633
                 and then Id /= Attribute_Component_Size
5634
               then
5635
                  return;
5636
               end if;
5637
 
5638
               Next_Index (N);
5639
            end loop;
5640
         end;
5641
      end if;
5642
 
5643
      --  Check any expressions that are present. Note that these expressions,
5644
      --  depending on the particular attribute type, are either part of the
5645
      --  attribute designator, or they are arguments in a case where the
5646
      --  attribute reference returns a function. In the latter case, the
5647
      --  rule in (RM 4.9(22)) applies and in particular requires the type
5648
      --  of the expressions to be scalar in order for the attribute to be
5649
      --  considered to be static.
5650
 
5651
      declare
5652
         E : Node_Id;
5653
 
5654
      begin
5655
         E := E1;
5656
         while Present (E) loop
5657
 
5658
            --  If expression is not static, then the attribute reference
5659
            --  result certainly cannot be static.
5660
 
5661
            if not Is_Static_Expression (E) then
5662
               Static := False;
5663
            end if;
5664
 
5665
            --  If the result is not known at compile time, or is not of
5666
            --  a scalar type, then the result is definitely not static,
5667
            --  so we can quit now.
5668
 
5669
            if not Compile_Time_Known_Value (E)
5670
              or else not Is_Scalar_Type (Etype (E))
5671
            then
5672
               --  An odd special case, if this is a Pos attribute, this
5673
               --  is where we need to apply a range check since it does
5674
               --  not get done anywhere else.
5675
 
5676
               if Id = Attribute_Pos then
5677
                  if Is_Integer_Type (Etype (E)) then
5678
                     Apply_Range_Check (E, Etype (N));
5679
                  end if;
5680
               end if;
5681
 
5682
               Check_Expressions;
5683
               return;
5684
 
5685
            --  If the expression raises a constraint error, then so does
5686
            --  the attribute reference. We keep going in this case because
5687
            --  we are still interested in whether the attribute reference
5688
            --  is static even if it is not static.
5689
 
5690
            elsif Raises_Constraint_Error (E) then
5691
               Set_Raises_Constraint_Error (N);
5692
            end if;
5693
 
5694
            Next (E);
5695
         end loop;
5696
 
5697
         if Raises_Constraint_Error (Prefix (N)) then
5698
            return;
5699
         end if;
5700
      end;
5701
 
5702
      --  Deal with the case of a static attribute reference that raises
5703
      --  constraint error. The Raises_Constraint_Error flag will already
5704
      --  have been set, and the Static flag shows whether the attribute
5705
      --  reference is static. In any case we certainly can't fold such an
5706
      --  attribute reference.
5707
 
5708
      --  Note that the rewriting of the attribute node with the constraint
5709
      --  error node is essential in this case, because otherwise Gigi might
5710
      --  blow up on one of the attributes it never expects to see.
5711
 
5712
      --  The constraint_error node must have the type imposed by the context,
5713
      --  to avoid spurious errors in the enclosing expression.
5714
 
5715
      if Raises_Constraint_Error (N) then
5716
         CE_Node :=
5717
           Make_Raise_Constraint_Error (Sloc (N),
5718
             Reason => CE_Range_Check_Failed);
5719
         Set_Etype (CE_Node, Etype (N));
5720
         Set_Raises_Constraint_Error (CE_Node);
5721
         Check_Expressions;
5722
         Rewrite (N, Relocate_Node (CE_Node));
5723
         Set_Is_Static_Expression (N, Static);
5724
         return;
5725
      end if;
5726
 
5727
      --  At this point we have a potentially foldable attribute reference.
5728
      --  If Static is set, then the attribute reference definitely obeys
5729
      --  the requirements in (RM 4.9(7,8,22)), and it definitely can be
5730
      --  folded. If Static is not set, then the attribute may or may not
5731
      --  be foldable, and the individual attribute processing routines
5732
      --  test Static as required in cases where it makes a difference.
5733
 
5734
      --  In the case where Static is not set, we do know that all the
5735
      --  expressions present are at least known at compile time (we
5736
      --  assumed above that if this was not the case, then there was
5737
      --  no hope of static evaluation). However, we did not require
5738
      --  that the bounds of the prefix type be compile time known,
5739
      --  let alone static). That's because there are many attributes
5740
      --  that can be computed at compile time on non-static subtypes,
5741
      --  even though such references are not static expressions.
5742
 
5743
      case Id is
5744
 
5745
      --------------
5746
      -- Adjacent --
5747
      --------------
5748
 
5749
      when Attribute_Adjacent =>
5750
         Fold_Ureal (N,
5751
           Eval_Fat.Adjacent
5752
             (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
5753
 
5754
      ---------
5755
      -- Aft --
5756
      ---------
5757
 
5758
      when Attribute_Aft =>
5759
         Fold_Uint (N, UI_From_Int (Aft_Value), True);
5760
 
5761
      ---------------
5762
      -- Alignment --
5763
      ---------------
5764
 
5765
      when Attribute_Alignment => Alignment_Block : declare
5766
         P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
5767
 
5768
      begin
5769
         --  Fold if alignment is set and not otherwise
5770
 
5771
         if Known_Alignment (P_TypeA) then
5772
            Fold_Uint (N, Alignment (P_TypeA), Is_Discrete_Type (P_TypeA));
5773
         end if;
5774
      end Alignment_Block;
5775
 
5776
      ---------------
5777
      -- AST_Entry --
5778
      ---------------
5779
 
5780
      --  Can only be folded in No_Ast_Handler case
5781
 
5782
      when Attribute_AST_Entry =>
5783
         if not Is_AST_Entry (P_Entity) then
5784
            Rewrite (N,
5785
              New_Occurrence_Of (RTE (RE_No_AST_Handler), Loc));
5786
         else
5787
            null;
5788
         end if;
5789
 
5790
      ---------
5791
      -- Bit --
5792
      ---------
5793
 
5794
      --  Bit can never be folded
5795
 
5796
      when Attribute_Bit =>
5797
         null;
5798
 
5799
      ------------------
5800
      -- Body_Version --
5801
      ------------------
5802
 
5803
      --  Body_version can never be static
5804
 
5805
      when Attribute_Body_Version =>
5806
         null;
5807
 
5808
      -------------
5809
      -- Ceiling --
5810
      -------------
5811
 
5812
      when Attribute_Ceiling =>
5813
         Fold_Ureal (N,
5814
           Eval_Fat.Ceiling (P_Root_Type, Expr_Value_R (E1)), Static);
5815
 
5816
      --------------------
5817
      -- Component_Size --
5818
      --------------------
5819
 
5820
      when Attribute_Component_Size =>
5821
         if Known_Static_Component_Size (P_Type) then
5822
            Fold_Uint (N, Component_Size (P_Type), False);
5823
         end if;
5824
 
5825
      -------------
5826
      -- Compose --
5827
      -------------
5828
 
5829
      when Attribute_Compose =>
5830
         Fold_Ureal (N,
5831
           Eval_Fat.Compose
5832
             (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)),
5833
              Static);
5834
 
5835
      -----------------
5836
      -- Constrained --
5837
      -----------------
5838
 
5839
      --  Constrained is never folded for now, there may be cases that
5840
      --  could be handled at compile time. To be looked at later.
5841
 
5842
      when Attribute_Constrained =>
5843
         null;
5844
 
5845
      ---------------
5846
      -- Copy_Sign --
5847
      ---------------
5848
 
5849
      when Attribute_Copy_Sign =>
5850
         Fold_Ureal (N,
5851
           Eval_Fat.Copy_Sign
5852
             (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
5853
 
5854
      -----------
5855
      -- Delta --
5856
      -----------
5857
 
5858
      when Attribute_Delta =>
5859
         Fold_Ureal (N, Delta_Value (P_Type), True);
5860
 
5861
      --------------
5862
      -- Definite --
5863
      --------------
5864
 
5865
      when Attribute_Definite =>
5866
         Rewrite (N, New_Occurrence_Of (
5867
           Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc));
5868
         Analyze_And_Resolve (N, Standard_Boolean);
5869
 
5870
      ------------
5871
      -- Denorm --
5872
      ------------
5873
 
5874
      when Attribute_Denorm =>
5875
         Fold_Uint
5876
           (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)), True);
5877
 
5878
      ------------
5879
      -- Digits --
5880
      ------------
5881
 
5882
      when Attribute_Digits =>
5883
         Fold_Uint (N, Digits_Value (P_Type), True);
5884
 
5885
      ----------
5886
      -- Emax --
5887
      ----------
5888
 
5889
      when Attribute_Emax =>
5890
 
5891
         --  Ada 83 attribute is defined as (RM83 3.5.8)
5892
 
5893
         --    T'Emax = 4 * T'Mantissa
5894
 
5895
         Fold_Uint (N, 4 * Mantissa, True);
5896
 
5897
      --------------
5898
      -- Enum_Rep --
5899
      --------------
5900
 
5901
      when Attribute_Enum_Rep =>
5902
 
5903
         --  For an enumeration type with a non-standard representation use
5904
         --  the Enumeration_Rep field of the proper constant. Note that this
5905
         --  will not work for types Character/Wide_[Wide-]Character, since no
5906
         --  real entities are created for the enumeration literals, but that
5907
         --  does not matter since these two types do not have non-standard
5908
         --  representations anyway.
5909
 
5910
         if Is_Enumeration_Type (P_Type)
5911
           and then Has_Non_Standard_Rep (P_Type)
5912
         then
5913
            Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)), Static);
5914
 
5915
         --  For enumeration types with standard representations and all
5916
         --  other cases (i.e. all integer and modular types), Enum_Rep
5917
         --  is equivalent to Pos.
5918
 
5919
         else
5920
            Fold_Uint (N, Expr_Value (E1), Static);
5921
         end if;
5922
 
5923
      --------------
5924
      -- Enum_Val --
5925
      --------------
5926
 
5927
      when Attribute_Enum_Val => Enum_Val : declare
5928
         Lit : Node_Id;
5929
 
5930
      begin
5931
         --  We have something like Enum_Type'Enum_Val (23), so search for a
5932
         --  corresponding value in the list of Enum_Rep values for the type.
5933
 
5934
         Lit := First_Literal (P_Base_Type);
5935
         loop
5936
            if Enumeration_Rep (Lit) = Expr_Value (E1) then
5937
               Fold_Uint (N, Enumeration_Pos (Lit), Static);
5938
               exit;
5939
            end if;
5940
 
5941
            Next_Literal (Lit);
5942
 
5943
            if No (Lit) then
5944
               Apply_Compile_Time_Constraint_Error
5945
                 (N, "no representation value matches",
5946
                  CE_Range_Check_Failed,
5947
                  Warn => not Static);
5948
               exit;
5949
            end if;
5950
         end loop;
5951
      end Enum_Val;
5952
 
5953
      -------------
5954
      -- Epsilon --
5955
      -------------
5956
 
5957
      when Attribute_Epsilon =>
5958
 
5959
         --  Ada 83 attribute is defined as (RM83 3.5.8)
5960
 
5961
         --    T'Epsilon = 2.0**(1 - T'Mantissa)
5962
 
5963
         Fold_Ureal (N, Ureal_2 ** (1 - Mantissa), True);
5964
 
5965
      --------------
5966
      -- Exponent --
5967
      --------------
5968
 
5969
      when Attribute_Exponent =>
5970
         Fold_Uint (N,
5971
           Eval_Fat.Exponent (P_Root_Type, Expr_Value_R (E1)), Static);
5972
 
5973
      -----------
5974
      -- First --
5975
      -----------
5976
 
5977
      when Attribute_First => First_Attr :
5978
      begin
5979
         Set_Bounds;
5980
 
5981
         if Compile_Time_Known_Value (Lo_Bound) then
5982
            if Is_Real_Type (P_Type) then
5983
               Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static);
5984
            else
5985
               Fold_Uint  (N, Expr_Value (Lo_Bound), Static);
5986
            end if;
5987
         end if;
5988
      end First_Attr;
5989
 
5990
      -----------------
5991
      -- Fixed_Value --
5992
      -----------------
5993
 
5994
      when Attribute_Fixed_Value =>
5995
         null;
5996
 
5997
      -----------
5998
      -- Floor --
5999
      -----------
6000
 
6001
      when Attribute_Floor =>
6002
         Fold_Ureal (N,
6003
           Eval_Fat.Floor (P_Root_Type, Expr_Value_R (E1)), Static);
6004
 
6005
      ----------
6006
      -- Fore --
6007
      ----------
6008
 
6009
      when Attribute_Fore =>
6010
         if Compile_Time_Known_Bounds (P_Type) then
6011
            Fold_Uint (N, UI_From_Int (Fore_Value), Static);
6012
         end if;
6013
 
6014
      --------------
6015
      -- Fraction --
6016
      --------------
6017
 
6018
      when Attribute_Fraction =>
6019
         Fold_Ureal (N,
6020
           Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)), Static);
6021
 
6022
      -----------------------
6023
      -- Has_Access_Values --
6024
      -----------------------
6025
 
6026
      when Attribute_Has_Access_Values =>
6027
         Rewrite (N, New_Occurrence_Of
6028
           (Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc));
6029
         Analyze_And_Resolve (N, Standard_Boolean);
6030
 
6031
      -----------------------
6032
      -- Has_Discriminants --
6033
      -----------------------
6034
 
6035
      when Attribute_Has_Discriminants =>
6036
         Rewrite (N, New_Occurrence_Of (
6037
           Boolean_Literals (Has_Discriminants (P_Entity)), Loc));
6038
         Analyze_And_Resolve (N, Standard_Boolean);
6039
 
6040
      -----------------------
6041
      -- Has_Tagged_Values --
6042
      -----------------------
6043
 
6044
      when Attribute_Has_Tagged_Values =>
6045
         Rewrite (N, New_Occurrence_Of
6046
           (Boolean_Literals (Has_Tagged_Component (P_Root_Type)), Loc));
6047
         Analyze_And_Resolve (N, Standard_Boolean);
6048
 
6049
      --------------
6050
      -- Identity --
6051
      --------------
6052
 
6053
      when Attribute_Identity =>
6054
         null;
6055
 
6056
      -----------
6057
      -- Image --
6058
      -----------
6059
 
6060
      --  Image is a scalar attribute, but is never static, because it is
6061
      --  not a static function (having a non-scalar argument (RM 4.9(22))
6062
      --  However, we can constant-fold the image of an enumeration literal
6063
      --  if names are available.
6064
 
6065
      when Attribute_Image =>
6066
         if Is_Entity_Name (E1)
6067
           and then Ekind (Entity (E1)) = E_Enumeration_Literal
6068
           and then not Discard_Names (First_Subtype (Etype (E1)))
6069
           and then not Global_Discard_Names
6070
         then
6071
            declare
6072
               Lit : constant Entity_Id := Entity (E1);
6073
               Str : String_Id;
6074
            begin
6075
               Start_String;
6076
               Get_Unqualified_Decoded_Name_String (Chars (Lit));
6077
               Set_Casing (All_Upper_Case);
6078
               Store_String_Chars (Name_Buffer (1 .. Name_Len));
6079
               Str := End_String;
6080
               Rewrite (N, Make_String_Literal (Loc, Strval => Str));
6081
               Analyze_And_Resolve (N, Standard_String);
6082
               Set_Is_Static_Expression (N, False);
6083
            end;
6084
         end if;
6085
 
6086
      ---------
6087
      -- Img --
6088
      ---------
6089
 
6090
      --  Img is a scalar attribute, but is never static, because it is
6091
      --  not a static function (having a non-scalar argument (RM 4.9(22))
6092
 
6093
      when Attribute_Img =>
6094
         null;
6095
 
6096
      -------------------
6097
      -- Integer_Value --
6098
      -------------------
6099
 
6100
      --  We never try to fold Integer_Value (though perhaps we could???)
6101
 
6102
      when Attribute_Integer_Value =>
6103
         null;
6104
 
6105
      -------------------
6106
      -- Invalid_Value --
6107
      -------------------
6108
 
6109
      --  Invalid_Value is a scalar attribute that is never static, because
6110
      --  the value is by design out of range.
6111
 
6112
      when Attribute_Invalid_Value =>
6113
         null;
6114
 
6115
      -----------
6116
      -- Large --
6117
      -----------
6118
 
6119
      when Attribute_Large =>
6120
 
6121
         --  For fixed-point, we use the identity:
6122
 
6123
         --    T'Large = (2.0**T'Mantissa - 1.0) * T'Small
6124
 
6125
         if Is_Fixed_Point_Type (P_Type) then
6126
            Rewrite (N,
6127
              Make_Op_Multiply (Loc,
6128
                Left_Opnd =>
6129
                  Make_Op_Subtract (Loc,
6130
                    Left_Opnd =>
6131
                      Make_Op_Expon (Loc,
6132
                        Left_Opnd =>
6133
                          Make_Real_Literal (Loc, Ureal_2),
6134
                        Right_Opnd =>
6135
                          Make_Attribute_Reference (Loc,
6136
                            Prefix => P,
6137
                            Attribute_Name => Name_Mantissa)),
6138
                    Right_Opnd => Make_Real_Literal (Loc, Ureal_1)),
6139
 
6140
                Right_Opnd =>
6141
                  Make_Real_Literal (Loc, Small_Value (Entity (P)))));
6142
 
6143
            Analyze_And_Resolve (N, C_Type);
6144
 
6145
         --  Floating-point (Ada 83 compatibility)
6146
 
6147
         else
6148
            --  Ada 83 attribute is defined as (RM83 3.5.8)
6149
 
6150
            --    T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa))
6151
 
6152
            --  where
6153
 
6154
            --    T'Emax = 4 * T'Mantissa
6155
 
6156
            Fold_Ureal (N,
6157
              Ureal_2 ** (4 * Mantissa) * (Ureal_1 - Ureal_2 ** (-Mantissa)),
6158
              True);
6159
         end if;
6160
 
6161
      ----------
6162
      -- Last --
6163
      ----------
6164
 
6165
      when Attribute_Last => Last :
6166
      begin
6167
         Set_Bounds;
6168
 
6169
         if Compile_Time_Known_Value (Hi_Bound) then
6170
            if Is_Real_Type (P_Type) then
6171
               Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static);
6172
            else
6173
               Fold_Uint  (N, Expr_Value (Hi_Bound), Static);
6174
            end if;
6175
         end if;
6176
      end Last;
6177
 
6178
      ------------------
6179
      -- Leading_Part --
6180
      ------------------
6181
 
6182
      when Attribute_Leading_Part =>
6183
         Fold_Ureal (N,
6184
           Eval_Fat.Leading_Part
6185
             (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static);
6186
 
6187
      ------------
6188
      -- Length --
6189
      ------------
6190
 
6191
      when Attribute_Length => Length : declare
6192
         Ind : Node_Id;
6193
 
6194
      begin
6195
         --  In the case of a generic index type, the bounds may appear static
6196
         --  but the computation is not meaningful in this case, and may
6197
         --  generate a spurious warning.
6198
 
6199
         Ind := First_Index (P_Type);
6200
         while Present (Ind) loop
6201
            if Is_Generic_Type (Etype (Ind)) then
6202
               return;
6203
            end if;
6204
 
6205
            Next_Index (Ind);
6206
         end loop;
6207
 
6208
         Set_Bounds;
6209
 
6210
         --  For two compile time values, we can compute length
6211
 
6212
         if Compile_Time_Known_Value (Lo_Bound)
6213
           and then Compile_Time_Known_Value (Hi_Bound)
6214
         then
6215
            Fold_Uint (N,
6216
              UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))),
6217
              True);
6218
         end if;
6219
 
6220
         --  One more case is where Hi_Bound and Lo_Bound are compile-time
6221
         --  comparable, and we can figure out the difference between them.
6222
 
6223
         declare
6224
            Diff : aliased Uint;
6225
 
6226
         begin
6227
            case
6228
              Compile_Time_Compare
6229
                (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
6230
            is
6231
               when EQ =>
6232
                  Fold_Uint (N, Uint_1, False);
6233
 
6234
               when GT =>
6235
                  Fold_Uint (N, Uint_0, False);
6236
 
6237
               when LT =>
6238
                  if Diff /= No_Uint then
6239
                     Fold_Uint (N, Diff + 1, False);
6240
                  end if;
6241
 
6242
               when others =>
6243
                  null;
6244
            end case;
6245
         end;
6246
      end Length;
6247
 
6248
      -------------
6249
      -- Machine --
6250
      -------------
6251
 
6252
      when Attribute_Machine =>
6253
         Fold_Ureal (N,
6254
           Eval_Fat.Machine
6255
             (P_Root_Type, Expr_Value_R (E1), Eval_Fat.Round, N),
6256
           Static);
6257
 
6258
      ------------------
6259
      -- Machine_Emax --
6260
      ------------------
6261
 
6262
      when Attribute_Machine_Emax =>
6263
         Float_Attribute_Universal_Integer (
6264
           IEEES_Machine_Emax,
6265
           IEEEL_Machine_Emax,
6266
           IEEEX_Machine_Emax,
6267
           VAXFF_Machine_Emax,
6268
           VAXDF_Machine_Emax,
6269
           VAXGF_Machine_Emax,
6270
           AAMPS_Machine_Emax,
6271
           AAMPL_Machine_Emax);
6272
 
6273
      ------------------
6274
      -- Machine_Emin --
6275
      ------------------
6276
 
6277
      when Attribute_Machine_Emin =>
6278
         Float_Attribute_Universal_Integer (
6279
           IEEES_Machine_Emin,
6280
           IEEEL_Machine_Emin,
6281
           IEEEX_Machine_Emin,
6282
           VAXFF_Machine_Emin,
6283
           VAXDF_Machine_Emin,
6284
           VAXGF_Machine_Emin,
6285
           AAMPS_Machine_Emin,
6286
           AAMPL_Machine_Emin);
6287
 
6288
      ----------------------
6289
      -- Machine_Mantissa --
6290
      ----------------------
6291
 
6292
      when Attribute_Machine_Mantissa =>
6293
         Float_Attribute_Universal_Integer (
6294
           IEEES_Machine_Mantissa,
6295
           IEEEL_Machine_Mantissa,
6296
           IEEEX_Machine_Mantissa,
6297
           VAXFF_Machine_Mantissa,
6298
           VAXDF_Machine_Mantissa,
6299
           VAXGF_Machine_Mantissa,
6300
           AAMPS_Machine_Mantissa,
6301
           AAMPL_Machine_Mantissa);
6302
 
6303
      -----------------------
6304
      -- Machine_Overflows --
6305
      -----------------------
6306
 
6307
      when Attribute_Machine_Overflows =>
6308
 
6309
         --  Always true for fixed-point
6310
 
6311
         if Is_Fixed_Point_Type (P_Type) then
6312
            Fold_Uint (N, True_Value, True);
6313
 
6314
         --  Floating point case
6315
 
6316
         else
6317
            Fold_Uint (N,
6318
              UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)),
6319
              True);
6320
         end if;
6321
 
6322
      -------------------
6323
      -- Machine_Radix --
6324
      -------------------
6325
 
6326
      when Attribute_Machine_Radix =>
6327
         if Is_Fixed_Point_Type (P_Type) then
6328
            if Is_Decimal_Fixed_Point_Type (P_Type)
6329
              and then Machine_Radix_10 (P_Type)
6330
            then
6331
               Fold_Uint (N, Uint_10, True);
6332
            else
6333
               Fold_Uint (N, Uint_2, True);
6334
            end if;
6335
 
6336
         --  All floating-point type always have radix 2
6337
 
6338
         else
6339
            Fold_Uint (N, Uint_2, True);
6340
         end if;
6341
 
6342
      ----------------------
6343
      -- Machine_Rounding --
6344
      ----------------------
6345
 
6346
      --  Note: for the folding case, it is fine to treat Machine_Rounding
6347
      --  exactly the same way as Rounding, since this is one of the allowed
6348
      --  behaviors, and performance is not an issue here. It might be a bit
6349
      --  better to give the same result as it would give at run-time, even
6350
      --  though the non-determinism is certainly permitted.
6351
 
6352
      when Attribute_Machine_Rounding =>
6353
         Fold_Ureal (N,
6354
           Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static);
6355
 
6356
      --------------------
6357
      -- Machine_Rounds --
6358
      --------------------
6359
 
6360
      when Attribute_Machine_Rounds =>
6361
 
6362
         --  Always False for fixed-point
6363
 
6364
         if Is_Fixed_Point_Type (P_Type) then
6365
            Fold_Uint (N, False_Value, True);
6366
 
6367
         --  Else yield proper floating-point result
6368
 
6369
         else
6370
            Fold_Uint
6371
              (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)), True);
6372
         end if;
6373
 
6374
      ------------------
6375
      -- Machine_Size --
6376
      ------------------
6377
 
6378
      --  Note: Machine_Size is identical to Object_Size
6379
 
6380
      when Attribute_Machine_Size => Machine_Size : declare
6381
         P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
6382
 
6383
      begin
6384
         if Known_Esize (P_TypeA) then
6385
            Fold_Uint (N, Esize (P_TypeA), True);
6386
         end if;
6387
      end Machine_Size;
6388
 
6389
      --------------
6390
      -- Mantissa --
6391
      --------------
6392
 
6393
      when Attribute_Mantissa =>
6394
 
6395
         --  Fixed-point mantissa
6396
 
6397
         if Is_Fixed_Point_Type (P_Type) then
6398
 
6399
            --  Compile time foldable case
6400
 
6401
            if Compile_Time_Known_Value (Type_Low_Bound  (P_Type))
6402
                 and then
6403
               Compile_Time_Known_Value (Type_High_Bound (P_Type))
6404
            then
6405
               --  The calculation of the obsolete Ada 83 attribute Mantissa
6406
               --  is annoying, because of AI00143, quoted here:
6407
 
6408
               --  !question 84-01-10
6409
 
6410
               --  Consider the model numbers for F:
6411
 
6412
               --         type F is delta 1.0 range -7.0 .. 8.0;
6413
 
6414
               --  The wording requires that F'MANTISSA be the SMALLEST
6415
               --  integer number for which each  bound  of the specified
6416
               --  range is either a model number or lies at most small
6417
               --  distant from a model number. This means F'MANTISSA
6418
               --  is required to be 3 since the range  -7.0 .. 7.0 fits
6419
               --  in 3 signed bits, and 8 is "at most" 1.0 from a model
6420
               --  number, namely, 7. Is this analysis correct? Note that
6421
               --  this implies the upper bound of the range is not
6422
               --  represented as a model number.
6423
 
6424
               --  !response 84-03-17
6425
 
6426
               --  The analysis is correct. The upper and lower bounds for
6427
               --  a fixed  point type can lie outside the range of model
6428
               --  numbers.
6429
 
6430
               declare
6431
                  Siz     : Uint;
6432
                  LBound  : Ureal;
6433
                  UBound  : Ureal;
6434
                  Bound   : Ureal;
6435
                  Max_Man : Uint;
6436
 
6437
               begin
6438
                  LBound  := Expr_Value_R (Type_Low_Bound  (P_Type));
6439
                  UBound  := Expr_Value_R (Type_High_Bound (P_Type));
6440
                  Bound   := UR_Max (UR_Abs (LBound), UR_Abs (UBound));
6441
                  Max_Man := UR_Trunc (Bound / Small_Value (P_Type));
6442
 
6443
                  --  If the Bound is exactly a model number, i.e. a multiple
6444
                  --  of Small, then we back it off by one to get the integer
6445
                  --  value that must be representable.
6446
 
6447
                  if Small_Value (P_Type) * Max_Man = Bound then
6448
                     Max_Man := Max_Man - 1;
6449
                  end if;
6450
 
6451
                  --  Now find corresponding size = Mantissa value
6452
 
6453
                  Siz := Uint_0;
6454
                  while 2 ** Siz < Max_Man loop
6455
                     Siz := Siz + 1;
6456
                  end loop;
6457
 
6458
                  Fold_Uint (N, Siz, True);
6459
               end;
6460
 
6461
            else
6462
               --  The case of dynamic bounds cannot be evaluated at compile
6463
               --  time. Instead we use a runtime routine (see Exp_Attr).
6464
 
6465
               null;
6466
            end if;
6467
 
6468
         --  Floating-point Mantissa
6469
 
6470
         else
6471
            Fold_Uint (N, Mantissa, True);
6472
         end if;
6473
 
6474
      ---------
6475
      -- Max --
6476
      ---------
6477
 
6478
      when Attribute_Max => Max :
6479
      begin
6480
         if Is_Real_Type (P_Type) then
6481
            Fold_Ureal
6482
              (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
6483
         else
6484
            Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static);
6485
         end if;
6486
      end Max;
6487
 
6488
      ----------------------------------
6489
      -- Max_Size_In_Storage_Elements --
6490
      ----------------------------------
6491
 
6492
      --  Max_Size_In_Storage_Elements is simply the Size rounded up to a
6493
      --  Storage_Unit boundary. We can fold any cases for which the size
6494
      --  is known by the front end.
6495
 
6496
      when Attribute_Max_Size_In_Storage_Elements =>
6497
         if Known_Esize (P_Type) then
6498
            Fold_Uint (N,
6499
              (Esize (P_Type) + System_Storage_Unit - 1) /
6500
                                          System_Storage_Unit,
6501
               Static);
6502
         end if;
6503
 
6504
      --------------------
6505
      -- Mechanism_Code --
6506
      --------------------
6507
 
6508
      when Attribute_Mechanism_Code =>
6509
         declare
6510
            Val    : Int;
6511
            Formal : Entity_Id;
6512
            Mech   : Mechanism_Type;
6513
 
6514
         begin
6515
            if No (E1) then
6516
               Mech := Mechanism (P_Entity);
6517
 
6518
            else
6519
               Val := UI_To_Int (Expr_Value (E1));
6520
 
6521
               Formal := First_Formal (P_Entity);
6522
               for J in 1 .. Val - 1 loop
6523
                  Next_Formal (Formal);
6524
               end loop;
6525
               Mech := Mechanism (Formal);
6526
            end if;
6527
 
6528
            if Mech < 0 then
6529
               Fold_Uint (N, UI_From_Int (Int (-Mech)), True);
6530
            end if;
6531
         end;
6532
 
6533
      ---------
6534
      -- Min --
6535
      ---------
6536
 
6537
      when Attribute_Min => Min :
6538
      begin
6539
         if Is_Real_Type (P_Type) then
6540
            Fold_Ureal
6541
              (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
6542
         else
6543
            Fold_Uint
6544
              (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static);
6545
         end if;
6546
      end Min;
6547
 
6548
      ---------
6549
      -- Mod --
6550
      ---------
6551
 
6552
      when Attribute_Mod =>
6553
         Fold_Uint
6554
           (N, UI_Mod (Expr_Value (E1), Modulus (P_Base_Type)), Static);
6555
 
6556
      -----------
6557
      -- Model --
6558
      -----------
6559
 
6560
      when Attribute_Model =>
6561
         Fold_Ureal (N,
6562
           Eval_Fat.Model (P_Root_Type, Expr_Value_R (E1)), Static);
6563
 
6564
      ----------------
6565
      -- Model_Emin --
6566
      ----------------
6567
 
6568
      when Attribute_Model_Emin =>
6569
         Float_Attribute_Universal_Integer (
6570
           IEEES_Model_Emin,
6571
           IEEEL_Model_Emin,
6572
           IEEEX_Model_Emin,
6573
           VAXFF_Model_Emin,
6574
           VAXDF_Model_Emin,
6575
           VAXGF_Model_Emin,
6576
           AAMPS_Model_Emin,
6577
           AAMPL_Model_Emin);
6578
 
6579
      -------------------
6580
      -- Model_Epsilon --
6581
      -------------------
6582
 
6583
      when Attribute_Model_Epsilon =>
6584
         Float_Attribute_Universal_Real (
6585
           IEEES_Model_Epsilon'Universal_Literal_String,
6586
           IEEEL_Model_Epsilon'Universal_Literal_String,
6587
           IEEEX_Model_Epsilon'Universal_Literal_String,
6588
           VAXFF_Model_Epsilon'Universal_Literal_String,
6589
           VAXDF_Model_Epsilon'Universal_Literal_String,
6590
           VAXGF_Model_Epsilon'Universal_Literal_String,
6591
           AAMPS_Model_Epsilon'Universal_Literal_String,
6592
           AAMPL_Model_Epsilon'Universal_Literal_String);
6593
 
6594
      --------------------
6595
      -- Model_Mantissa --
6596
      --------------------
6597
 
6598
      when Attribute_Model_Mantissa =>
6599
         Float_Attribute_Universal_Integer (
6600
           IEEES_Model_Mantissa,
6601
           IEEEL_Model_Mantissa,
6602
           IEEEX_Model_Mantissa,
6603
           VAXFF_Model_Mantissa,
6604
           VAXDF_Model_Mantissa,
6605
           VAXGF_Model_Mantissa,
6606
           AAMPS_Model_Mantissa,
6607
           AAMPL_Model_Mantissa);
6608
 
6609
      -----------------
6610
      -- Model_Small --
6611
      -----------------
6612
 
6613
      when Attribute_Model_Small =>
6614
         Float_Attribute_Universal_Real (
6615
           IEEES_Model_Small'Universal_Literal_String,
6616
           IEEEL_Model_Small'Universal_Literal_String,
6617
           IEEEX_Model_Small'Universal_Literal_String,
6618
           VAXFF_Model_Small'Universal_Literal_String,
6619
           VAXDF_Model_Small'Universal_Literal_String,
6620
           VAXGF_Model_Small'Universal_Literal_String,
6621
           AAMPS_Model_Small'Universal_Literal_String,
6622
           AAMPL_Model_Small'Universal_Literal_String);
6623
 
6624
      -------------
6625
      -- Modulus --
6626
      -------------
6627
 
6628
      when Attribute_Modulus =>
6629
         Fold_Uint (N, Modulus (P_Type), True);
6630
 
6631
      --------------------
6632
      -- Null_Parameter --
6633
      --------------------
6634
 
6635
      --  Cannot fold, we know the value sort of, but the whole point is
6636
      --  that there is no way to talk about this imaginary value except
6637
      --  by using the attribute, so we leave it the way it is.
6638
 
6639
      when Attribute_Null_Parameter =>
6640
         null;
6641
 
6642
      -----------------
6643
      -- Object_Size --
6644
      -----------------
6645
 
6646
      --  The Object_Size attribute for a type returns the Esize of the
6647
      --  type and can be folded if this value is known.
6648
 
6649
      when Attribute_Object_Size => Object_Size : declare
6650
         P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
6651
 
6652
      begin
6653
         if Known_Esize (P_TypeA) then
6654
            Fold_Uint (N, Esize (P_TypeA), True);
6655
         end if;
6656
      end Object_Size;
6657
 
6658
      -------------------------
6659
      -- Passed_By_Reference --
6660
      -------------------------
6661
 
6662
      --  Scalar types are never passed by reference
6663
 
6664
      when Attribute_Passed_By_Reference =>
6665
         Fold_Uint (N, False_Value, True);
6666
 
6667
      ---------
6668
      -- Pos --
6669
      ---------
6670
 
6671
      when Attribute_Pos =>
6672
         Fold_Uint (N, Expr_Value (E1), True);
6673
 
6674
      ----------
6675
      -- Pred --
6676
      ----------
6677
 
6678
      when Attribute_Pred => Pred :
6679
      begin
6680
         --  Floating-point case
6681
 
6682
         if Is_Floating_Point_Type (P_Type) then
6683
            Fold_Ureal (N,
6684
              Eval_Fat.Pred (P_Root_Type, Expr_Value_R (E1)), Static);
6685
 
6686
         --  Fixed-point case
6687
 
6688
         elsif Is_Fixed_Point_Type (P_Type) then
6689
            Fold_Ureal (N,
6690
              Expr_Value_R (E1) - Small_Value (P_Type), True);
6691
 
6692
         --  Modular integer case (wraps)
6693
 
6694
         elsif Is_Modular_Integer_Type (P_Type) then
6695
            Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type), Static);
6696
 
6697
         --  Other scalar cases
6698
 
6699
         else
6700
            pragma Assert (Is_Scalar_Type (P_Type));
6701
 
6702
            if Is_Enumeration_Type (P_Type)
6703
              and then Expr_Value (E1) =
6704
                         Expr_Value (Type_Low_Bound (P_Base_Type))
6705
            then
6706
               Apply_Compile_Time_Constraint_Error
6707
                 (N, "Pred of `&''First`",
6708
                  CE_Overflow_Check_Failed,
6709
                  Ent  => P_Base_Type,
6710
                  Warn => not Static);
6711
 
6712
               Check_Expressions;
6713
               return;
6714
            end if;
6715
 
6716
            Fold_Uint (N, Expr_Value (E1) - 1, Static);
6717
         end if;
6718
      end Pred;
6719
 
6720
      -----------
6721
      -- Range --
6722
      -----------
6723
 
6724
      --  No processing required, because by this stage, Range has been
6725
      --  replaced by First .. Last, so this branch can never be taken.
6726
 
6727
      when Attribute_Range =>
6728
         raise Program_Error;
6729
 
6730
      ------------------
6731
      -- Range_Length --
6732
      ------------------
6733
 
6734
      when Attribute_Range_Length =>
6735
         Set_Bounds;
6736
 
6737
         --  Can fold if both bounds are compile time known
6738
 
6739
         if Compile_Time_Known_Value (Hi_Bound)
6740
           and then Compile_Time_Known_Value (Lo_Bound)
6741
         then
6742
            Fold_Uint (N,
6743
              UI_Max
6744
                (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1),
6745
                 Static);
6746
         end if;
6747
 
6748
         --  One more case is where Hi_Bound and Lo_Bound are compile-time
6749
         --  comparable, and we can figure out the difference between them.
6750
 
6751
         declare
6752
            Diff : aliased Uint;
6753
 
6754
         begin
6755
            case
6756
              Compile_Time_Compare
6757
                (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
6758
            is
6759
               when EQ =>
6760
                  Fold_Uint (N, Uint_1, False);
6761
 
6762
               when GT =>
6763
                  Fold_Uint (N, Uint_0, False);
6764
 
6765
               when LT =>
6766
                  if Diff /= No_Uint then
6767
                     Fold_Uint (N, Diff + 1, False);
6768
                  end if;
6769
 
6770
               when others =>
6771
                  null;
6772
            end case;
6773
         end;
6774
 
6775
      ---------------
6776
      -- Remainder --
6777
      ---------------
6778
 
6779
      when Attribute_Remainder => Remainder : declare
6780
         X : constant Ureal := Expr_Value_R (E1);
6781
         Y : constant Ureal := Expr_Value_R (E2);
6782
 
6783
      begin
6784
         if UR_Is_Zero (Y) then
6785
            Apply_Compile_Time_Constraint_Error
6786
              (N, "division by zero in Remainder",
6787
               CE_Overflow_Check_Failed,
6788
               Warn => not Static);
6789
 
6790
            Check_Expressions;
6791
            return;
6792
         end if;
6793
 
6794
         Fold_Ureal (N, Eval_Fat.Remainder (P_Root_Type, X, Y), Static);
6795
      end Remainder;
6796
 
6797
      -----------
6798
      -- Round --
6799
      -----------
6800
 
6801
      when Attribute_Round => Round :
6802
      declare
6803
         Sr : Ureal;
6804
         Si : Uint;
6805
 
6806
      begin
6807
         --  First we get the (exact result) in units of small
6808
 
6809
         Sr := Expr_Value_R (E1) / Small_Value (C_Type);
6810
 
6811
         --  Now round that exactly to an integer
6812
 
6813
         Si := UR_To_Uint (Sr);
6814
 
6815
         --  Finally the result is obtained by converting back to real
6816
 
6817
         Fold_Ureal (N, Si * Small_Value (C_Type), Static);
6818
      end Round;
6819
 
6820
      --------------
6821
      -- Rounding --
6822
      --------------
6823
 
6824
      when Attribute_Rounding =>
6825
         Fold_Ureal (N,
6826
           Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static);
6827
 
6828
      ---------------
6829
      -- Safe_Emax --
6830
      ---------------
6831
 
6832
      when Attribute_Safe_Emax =>
6833
         Float_Attribute_Universal_Integer (
6834
           IEEES_Safe_Emax,
6835
           IEEEL_Safe_Emax,
6836
           IEEEX_Safe_Emax,
6837
           VAXFF_Safe_Emax,
6838
           VAXDF_Safe_Emax,
6839
           VAXGF_Safe_Emax,
6840
           AAMPS_Safe_Emax,
6841
           AAMPL_Safe_Emax);
6842
 
6843
      ----------------
6844
      -- Safe_First --
6845
      ----------------
6846
 
6847
      when Attribute_Safe_First =>
6848
         Float_Attribute_Universal_Real (
6849
           IEEES_Safe_First'Universal_Literal_String,
6850
           IEEEL_Safe_First'Universal_Literal_String,
6851
           IEEEX_Safe_First'Universal_Literal_String,
6852
           VAXFF_Safe_First'Universal_Literal_String,
6853
           VAXDF_Safe_First'Universal_Literal_String,
6854
           VAXGF_Safe_First'Universal_Literal_String,
6855
           AAMPS_Safe_First'Universal_Literal_String,
6856
           AAMPL_Safe_First'Universal_Literal_String);
6857
 
6858
      ----------------
6859
      -- Safe_Large --
6860
      ----------------
6861
 
6862
      when Attribute_Safe_Large =>
6863
         if Is_Fixed_Point_Type (P_Type) then
6864
            Fold_Ureal
6865
              (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static);
6866
         else
6867
            Float_Attribute_Universal_Real (
6868
              IEEES_Safe_Large'Universal_Literal_String,
6869
              IEEEL_Safe_Large'Universal_Literal_String,
6870
              IEEEX_Safe_Large'Universal_Literal_String,
6871
              VAXFF_Safe_Large'Universal_Literal_String,
6872
              VAXDF_Safe_Large'Universal_Literal_String,
6873
              VAXGF_Safe_Large'Universal_Literal_String,
6874
              AAMPS_Safe_Large'Universal_Literal_String,
6875
              AAMPL_Safe_Large'Universal_Literal_String);
6876
         end if;
6877
 
6878
      ---------------
6879
      -- Safe_Last --
6880
      ---------------
6881
 
6882
      when Attribute_Safe_Last =>
6883
         Float_Attribute_Universal_Real (
6884
           IEEES_Safe_Last'Universal_Literal_String,
6885
           IEEEL_Safe_Last'Universal_Literal_String,
6886
           IEEEX_Safe_Last'Universal_Literal_String,
6887
           VAXFF_Safe_Last'Universal_Literal_String,
6888
           VAXDF_Safe_Last'Universal_Literal_String,
6889
           VAXGF_Safe_Last'Universal_Literal_String,
6890
           AAMPS_Safe_Last'Universal_Literal_String,
6891
           AAMPL_Safe_Last'Universal_Literal_String);
6892
 
6893
      ----------------
6894
      -- Safe_Small --
6895
      ----------------
6896
 
6897
      when Attribute_Safe_Small =>
6898
 
6899
         --  In Ada 95, the old Ada 83 attribute Safe_Small is redundant
6900
         --  for fixed-point, since is the same as Small, but we implement
6901
         --  it for backwards compatibility.
6902
 
6903
         if Is_Fixed_Point_Type (P_Type) then
6904
            Fold_Ureal (N, Small_Value (P_Type), Static);
6905
 
6906
         --  Ada 83 Safe_Small for floating-point cases
6907
 
6908
         else
6909
            Float_Attribute_Universal_Real (
6910
              IEEES_Safe_Small'Universal_Literal_String,
6911
              IEEEL_Safe_Small'Universal_Literal_String,
6912
              IEEEX_Safe_Small'Universal_Literal_String,
6913
              VAXFF_Safe_Small'Universal_Literal_String,
6914
              VAXDF_Safe_Small'Universal_Literal_String,
6915
              VAXGF_Safe_Small'Universal_Literal_String,
6916
              AAMPS_Safe_Small'Universal_Literal_String,
6917
              AAMPL_Safe_Small'Universal_Literal_String);
6918
         end if;
6919
 
6920
      -----------
6921
      -- Scale --
6922
      -----------
6923
 
6924
      when Attribute_Scale =>
6925
         Fold_Uint (N, Scale_Value (P_Type), True);
6926
 
6927
      -------------
6928
      -- Scaling --
6929
      -------------
6930
 
6931
      when Attribute_Scaling =>
6932
         Fold_Ureal (N,
6933
           Eval_Fat.Scaling
6934
             (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static);
6935
 
6936
      ------------------
6937
      -- Signed_Zeros --
6938
      ------------------
6939
 
6940
      when Attribute_Signed_Zeros =>
6941
         Fold_Uint
6942
           (N, UI_From_Int (Boolean'Pos (Signed_Zeros_On_Target)), Static);
6943
 
6944
      ----------
6945
      -- Size --
6946
      ----------
6947
 
6948
      --  Size attribute returns the RM size. All scalar types can be folded,
6949
      --  as well as any types for which the size is known by the front end,
6950
      --  including any type for which a size attribute is specified.
6951
 
6952
      when Attribute_Size | Attribute_VADS_Size => Size : declare
6953
         P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
6954
 
6955
      begin
6956
         if RM_Size (P_TypeA) /= Uint_0 then
6957
 
6958
            --  VADS_Size case
6959
 
6960
            if Id = Attribute_VADS_Size or else Use_VADS_Size then
6961
               declare
6962
                  S : constant Node_Id := Size_Clause (P_TypeA);
6963
 
6964
               begin
6965
                  --  If a size clause applies, then use the size from it.
6966
                  --  This is one of the rare cases where we can use the
6967
                  --  Size_Clause field for a subtype when Has_Size_Clause
6968
                  --  is False. Consider:
6969
 
6970
                  --    type x is range 1 .. 64;
6971
                  --    for x'size use 12;
6972
                  --    subtype y is x range 0 .. 3;
6973
 
6974
                  --  Here y has a size clause inherited from x, but normally
6975
                  --  it does not apply, and y'size is 2. However, y'VADS_Size
6976
                  --  is indeed 12 and not 2.
6977
 
6978
                  if Present (S)
6979
                    and then Is_OK_Static_Expression (Expression (S))
6980
                  then
6981
                     Fold_Uint (N, Expr_Value (Expression (S)), True);
6982
 
6983
                  --  If no size is specified, then we simply use the object
6984
                  --  size in the VADS_Size case (e.g. Natural'Size is equal
6985
                  --  to Integer'Size, not one less).
6986
 
6987
                  else
6988
                     Fold_Uint (N, Esize (P_TypeA), True);
6989
                  end if;
6990
               end;
6991
 
6992
            --  Normal case (Size) in which case we want the RM_Size
6993
 
6994
            else
6995
               Fold_Uint (N,
6996
                 RM_Size (P_TypeA),
6997
                 Static and then Is_Discrete_Type (P_TypeA));
6998
            end if;
6999
         end if;
7000
      end Size;
7001
 
7002
      -----------
7003
      -- Small --
7004
      -----------
7005
 
7006
      when Attribute_Small =>
7007
 
7008
         --  The floating-point case is present only for Ada 83 compatibility.
7009
         --  Note that strictly this is an illegal addition, since we are
7010
         --  extending an Ada 95 defined attribute, but we anticipate an
7011
         --  ARG ruling that will permit this.
7012
 
7013
         if Is_Floating_Point_Type (P_Type) then
7014
 
7015
            --  Ada 83 attribute is defined as (RM83 3.5.8)
7016
 
7017
            --    T'Small = 2.0**(-T'Emax - 1)
7018
 
7019
            --  where
7020
 
7021
            --    T'Emax = 4 * T'Mantissa
7022
 
7023
            Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1), Static);
7024
 
7025
         --  Normal Ada 95 fixed-point case
7026
 
7027
         else
7028
            Fold_Ureal (N, Small_Value (P_Type), True);
7029
         end if;
7030
 
7031
      -----------------
7032
      -- Stream_Size --
7033
      -----------------
7034
 
7035
      when Attribute_Stream_Size =>
7036
         null;
7037
 
7038
      ----------
7039
      -- Succ --
7040
      ----------
7041
 
7042
      when Attribute_Succ => Succ :
7043
      begin
7044
         --  Floating-point case
7045
 
7046
         if Is_Floating_Point_Type (P_Type) then
7047
            Fold_Ureal (N,
7048
              Eval_Fat.Succ (P_Root_Type, Expr_Value_R (E1)), Static);
7049
 
7050
         --  Fixed-point case
7051
 
7052
         elsif Is_Fixed_Point_Type (P_Type) then
7053
            Fold_Ureal (N,
7054
              Expr_Value_R (E1) + Small_Value (P_Type), Static);
7055
 
7056
         --  Modular integer case (wraps)
7057
 
7058
         elsif Is_Modular_Integer_Type (P_Type) then
7059
            Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type), Static);
7060
 
7061
         --  Other scalar cases
7062
 
7063
         else
7064
            pragma Assert (Is_Scalar_Type (P_Type));
7065
 
7066
            if Is_Enumeration_Type (P_Type)
7067
              and then Expr_Value (E1) =
7068
                         Expr_Value (Type_High_Bound (P_Base_Type))
7069
            then
7070
               Apply_Compile_Time_Constraint_Error
7071
                 (N, "Succ of `&''Last`",
7072
                  CE_Overflow_Check_Failed,
7073
                  Ent  => P_Base_Type,
7074
                  Warn => not Static);
7075
 
7076
               Check_Expressions;
7077
               return;
7078
            else
7079
               Fold_Uint (N, Expr_Value (E1) + 1, Static);
7080
            end if;
7081
         end if;
7082
      end Succ;
7083
 
7084
      ----------------
7085
      -- Truncation --
7086
      ----------------
7087
 
7088
      when Attribute_Truncation =>
7089
         Fold_Ureal (N,
7090
           Eval_Fat.Truncation (P_Root_Type, Expr_Value_R (E1)), Static);
7091
 
7092
      ----------------
7093
      -- Type_Class --
7094
      ----------------
7095
 
7096
      when Attribute_Type_Class => Type_Class : declare
7097
         Typ : constant Entity_Id := Underlying_Type (P_Base_Type);
7098
         Id  : RE_Id;
7099
 
7100
      begin
7101
         if Is_Descendent_Of_Address (Typ) then
7102
            Id := RE_Type_Class_Address;
7103
 
7104
         elsif Is_Enumeration_Type (Typ) then
7105
            Id := RE_Type_Class_Enumeration;
7106
 
7107
         elsif Is_Integer_Type (Typ) then
7108
            Id := RE_Type_Class_Integer;
7109
 
7110
         elsif Is_Fixed_Point_Type (Typ) then
7111
            Id := RE_Type_Class_Fixed_Point;
7112
 
7113
         elsif Is_Floating_Point_Type (Typ) then
7114
            Id := RE_Type_Class_Floating_Point;
7115
 
7116
         elsif Is_Array_Type (Typ) then
7117
            Id := RE_Type_Class_Array;
7118
 
7119
         elsif Is_Record_Type (Typ) then
7120
            Id := RE_Type_Class_Record;
7121
 
7122
         elsif Is_Access_Type (Typ) then
7123
            Id := RE_Type_Class_Access;
7124
 
7125
         elsif Is_Enumeration_Type (Typ) then
7126
            Id := RE_Type_Class_Enumeration;
7127
 
7128
         elsif Is_Task_Type (Typ) then
7129
            Id := RE_Type_Class_Task;
7130
 
7131
         --  We treat protected types like task types. It would make more
7132
         --  sense to have another enumeration value, but after all the
7133
         --  whole point of this feature is to be exactly DEC compatible,
7134
         --  and changing the type Type_Class would not meet this requirement.
7135
 
7136
         elsif Is_Protected_Type (Typ) then
7137
            Id := RE_Type_Class_Task;
7138
 
7139
         --  Not clear if there are any other possibilities, but if there
7140
         --  are, then we will treat them as the address case.
7141
 
7142
         else
7143
            Id := RE_Type_Class_Address;
7144
         end if;
7145
 
7146
         Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
7147
      end Type_Class;
7148
 
7149
      -----------------------
7150
      -- Unbiased_Rounding --
7151
      -----------------------
7152
 
7153
      when Attribute_Unbiased_Rounding =>
7154
         Fold_Ureal (N,
7155
           Eval_Fat.Unbiased_Rounding (P_Root_Type, Expr_Value_R (E1)),
7156
           Static);
7157
 
7158
      -------------------------
7159
      -- Unconstrained_Array --
7160
      -------------------------
7161
 
7162
      when Attribute_Unconstrained_Array => Unconstrained_Array : declare
7163
         Typ : constant Entity_Id := Underlying_Type (P_Type);
7164
 
7165
      begin
7166
         Rewrite (N, New_Occurrence_Of (
7167
           Boolean_Literals (
7168
             Is_Array_Type (P_Type)
7169
              and then not Is_Constrained (Typ)), Loc));
7170
 
7171
         --  Analyze and resolve as boolean, note that this attribute is
7172
         --  a static attribute in GNAT.
7173
 
7174
         Analyze_And_Resolve (N, Standard_Boolean);
7175
         Static := True;
7176
      end Unconstrained_Array;
7177
 
7178
      ---------------
7179
      -- VADS_Size --
7180
      ---------------
7181
 
7182
      --  Processing is shared with Size
7183
 
7184
      ---------
7185
      -- Val --
7186
      ---------
7187
 
7188
      when Attribute_Val => Val :
7189
      begin
7190
         if  Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
7191
           or else
7192
             Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
7193
         then
7194
            Apply_Compile_Time_Constraint_Error
7195
              (N, "Val expression out of range",
7196
               CE_Range_Check_Failed,
7197
               Warn => not Static);
7198
 
7199
            Check_Expressions;
7200
            return;
7201
 
7202
         else
7203
            Fold_Uint (N, Expr_Value (E1), Static);
7204
         end if;
7205
      end Val;
7206
 
7207
      ----------------
7208
      -- Value_Size --
7209
      ----------------
7210
 
7211
      --  The Value_Size attribute for a type returns the RM size of the
7212
      --  type. This an always be folded for scalar types, and can also
7213
      --  be folded for non-scalar types if the size is set.
7214
 
7215
      when Attribute_Value_Size => Value_Size : declare
7216
         P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
7217
      begin
7218
         if RM_Size (P_TypeA) /= Uint_0 then
7219
            Fold_Uint (N, RM_Size (P_TypeA), True);
7220
         end if;
7221
      end Value_Size;
7222
 
7223
      -------------
7224
      -- Version --
7225
      -------------
7226
 
7227
      --  Version can never be static
7228
 
7229
      when Attribute_Version =>
7230
         null;
7231
 
7232
      ----------------
7233
      -- Wide_Image --
7234
      ----------------
7235
 
7236
      --  Wide_Image is a scalar attribute, but is never static, because it
7237
      --  is not a static function (having a non-scalar argument (RM 4.9(22))
7238
 
7239
      when Attribute_Wide_Image =>
7240
         null;
7241
 
7242
      ---------------------
7243
      -- Wide_Wide_Image --
7244
      ---------------------
7245
 
7246
      --  Wide_Wide_Image is a scalar attribute but is never static, because it
7247
      --  is not a static function (having a non-scalar argument (RM 4.9(22)).
7248
 
7249
      when Attribute_Wide_Wide_Image =>
7250
         null;
7251
 
7252
      ---------------------
7253
      -- Wide_Wide_Width --
7254
      ---------------------
7255
 
7256
      --  Processing for Wide_Wide_Width is combined with Width
7257
 
7258
      ----------------
7259
      -- Wide_Width --
7260
      ----------------
7261
 
7262
      --  Processing for Wide_Width is combined with Width
7263
 
7264
      -----------
7265
      -- Width --
7266
      -----------
7267
 
7268
      --  This processing also handles the case of Wide_[Wide_]Width
7269
 
7270
      when Attribute_Width |
7271
           Attribute_Wide_Width |
7272
           Attribute_Wide_Wide_Width => Width :
7273
      begin
7274
         if Compile_Time_Known_Bounds (P_Type) then
7275
 
7276
            --  Floating-point types
7277
 
7278
            if Is_Floating_Point_Type (P_Type) then
7279
 
7280
               --  Width is zero for a null range (RM 3.5 (38))
7281
 
7282
               if Expr_Value_R (Type_High_Bound (P_Type)) <
7283
                  Expr_Value_R (Type_Low_Bound (P_Type))
7284
               then
7285
                  Fold_Uint (N, Uint_0, True);
7286
 
7287
               else
7288
                  --  For floating-point, we have +N.dddE+nnn where length
7289
                  --  of ddd is determined by type'Digits - 1, but is one
7290
                  --  if Digits is one (RM 3.5 (33)).
7291
 
7292
                  --  nnn is set to 2 for Short_Float and Float (32 bit
7293
                  --  floats), and 3 for Long_Float and Long_Long_Float.
7294
                  --  For machines where Long_Long_Float is the IEEE
7295
                  --  extended precision type, the exponent takes 4 digits.
7296
 
7297
                  declare
7298
                     Len : Int :=
7299
                             Int'Max (2, UI_To_Int (Digits_Value (P_Type)));
7300
 
7301
                  begin
7302
                     if Esize (P_Type) <= 32 then
7303
                        Len := Len + 6;
7304
                     elsif Esize (P_Type) = 64 then
7305
                        Len := Len + 7;
7306
                     else
7307
                        Len := Len + 8;
7308
                     end if;
7309
 
7310
                     Fold_Uint (N, UI_From_Int (Len), True);
7311
                  end;
7312
               end if;
7313
 
7314
            --  Fixed-point types
7315
 
7316
            elsif Is_Fixed_Point_Type (P_Type) then
7317
 
7318
               --  Width is zero for a null range (RM 3.5 (38))
7319
 
7320
               if Expr_Value (Type_High_Bound (P_Type)) <
7321
                  Expr_Value (Type_Low_Bound  (P_Type))
7322
               then
7323
                  Fold_Uint (N, Uint_0, True);
7324
 
7325
               --  The non-null case depends on the specific real type
7326
 
7327
               else
7328
                  --  For fixed-point type width is Fore + 1 + Aft (RM 3.5(34))
7329
 
7330
                  Fold_Uint
7331
                    (N, UI_From_Int (Fore_Value + 1 + Aft_Value), True);
7332
               end if;
7333
 
7334
            --  Discrete types
7335
 
7336
            else
7337
               declare
7338
                  R  : constant Entity_Id := Root_Type (P_Type);
7339
                  Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type));
7340
                  Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type));
7341
                  W  : Nat;
7342
                  Wt : Nat;
7343
                  T  : Uint;
7344
                  L  : Node_Id;
7345
                  C  : Character;
7346
 
7347
               begin
7348
                  --  Empty ranges
7349
 
7350
                  if Lo > Hi then
7351
                     W := 0;
7352
 
7353
                  --  Width for types derived from Standard.Character
7354
                  --  and Standard.Wide_[Wide_]Character.
7355
 
7356
                  elsif Is_Standard_Character_Type (P_Type) then
7357
                     W := 0;
7358
 
7359
                     --  Set W larger if needed
7360
 
7361
                     for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop
7362
 
7363
                        --  All wide characters look like Hex_hhhhhhhh
7364
 
7365
                        if J > 255 then
7366
                           W := 12;
7367
 
7368
                        else
7369
                           C := Character'Val (J);
7370
 
7371
                           --  Test for all cases where Character'Image
7372
                           --  yields an image that is longer than three
7373
                           --  characters. First the cases of Reserved_xxx
7374
                           --  names (length = 12).
7375
 
7376
                           case C is
7377
                              when Reserved_128 | Reserved_129 |
7378
                                   Reserved_132 | Reserved_153
7379
 
7380
                                => Wt := 12;
7381
 
7382
                              when BS | HT | LF | VT | FF | CR |
7383
                                   SO | SI | EM | FS | GS | RS |
7384
                                   US | RI | MW | ST | PM
7385
 
7386
                                => Wt := 2;
7387
 
7388
                              when NUL | SOH | STX | ETX | EOT |
7389
                                   ENQ | ACK | BEL | DLE | DC1 |
7390
                                   DC2 | DC3 | DC4 | NAK | SYN |
7391
                                   ETB | CAN | SUB | ESC | DEL |
7392
                                   BPH | NBH | NEL | SSA | ESA |
7393
                                   HTS | HTJ | VTS | PLD | PLU |
7394
                                   SS2 | SS3 | DCS | PU1 | PU2 |
7395
                                   STS | CCH | SPA | EPA | SOS |
7396
                                   SCI | CSI | OSC | APC
7397
 
7398
                                => Wt := 3;
7399
 
7400
                              when Space .. Tilde |
7401
                                   No_Break_Space .. LC_Y_Diaeresis
7402
 
7403
                                => Wt := 3;
7404
                           end case;
7405
 
7406
                           W := Int'Max (W, Wt);
7407
                        end if;
7408
                     end loop;
7409
 
7410
                  --  Width for types derived from Standard.Boolean
7411
 
7412
                  elsif R = Standard_Boolean then
7413
                     if Lo = 0 then
7414
                        W := 5; -- FALSE
7415
                     else
7416
                        W := 4; -- TRUE
7417
                     end if;
7418
 
7419
                  --  Width for integer types
7420
 
7421
                  elsif Is_Integer_Type (P_Type) then
7422
                     T := UI_Max (abs Lo, abs Hi);
7423
 
7424
                     W := 2;
7425
                     while T >= 10 loop
7426
                        W := W + 1;
7427
                        T := T / 10;
7428
                     end loop;
7429
 
7430
                  --  Only remaining possibility is user declared enum type
7431
 
7432
                  else
7433
                     pragma Assert (Is_Enumeration_Type (P_Type));
7434
 
7435
                     W := 0;
7436
                     L := First_Literal (P_Type);
7437
 
7438
                     while Present (L) loop
7439
 
7440
                        --  Only pay attention to in range characters
7441
 
7442
                        if Lo <= Enumeration_Pos (L)
7443
                          and then Enumeration_Pos (L) <= Hi
7444
                        then
7445
                           --  For Width case, use decoded name
7446
 
7447
                           if Id = Attribute_Width then
7448
                              Get_Decoded_Name_String (Chars (L));
7449
                              Wt := Nat (Name_Len);
7450
 
7451
                           --  For Wide_[Wide_]Width, use encoded name, and
7452
                           --  then adjust for the encoding.
7453
 
7454
                           else
7455
                              Get_Name_String (Chars (L));
7456
 
7457
                              --  Character literals are always of length 3
7458
 
7459
                              if Name_Buffer (1) = 'Q' then
7460
                                 Wt := 3;
7461
 
7462
                              --  Otherwise loop to adjust for upper/wide chars
7463
 
7464
                              else
7465
                                 Wt := Nat (Name_Len);
7466
 
7467
                                 for J in 1 .. Name_Len loop
7468
                                    if Name_Buffer (J) = 'U' then
7469
                                       Wt := Wt - 2;
7470
                                    elsif Name_Buffer (J) = 'W' then
7471
                                       Wt := Wt - 4;
7472
                                    end if;
7473
                                 end loop;
7474
                              end if;
7475
                           end if;
7476
 
7477
                           W := Int'Max (W, Wt);
7478
                        end if;
7479
 
7480
                        Next_Literal (L);
7481
                     end loop;
7482
                  end if;
7483
 
7484
                  Fold_Uint (N, UI_From_Int (W), True);
7485
               end;
7486
            end if;
7487
         end if;
7488
      end Width;
7489
 
7490
      --  The following attributes denote function that cannot be folded
7491
 
7492
      when Attribute_From_Any |
7493
           Attribute_To_Any   |
7494
           Attribute_TypeCode =>
7495
         null;
7496
 
7497
      --  The following attributes can never be folded, and furthermore we
7498
      --  should not even have entered the case statement for any of these.
7499
      --  Note that in some cases, the values have already been folded as
7500
      --  a result of the processing in Analyze_Attribute.
7501
 
7502
      when Attribute_Abort_Signal             |
7503
           Attribute_Access                   |
7504
           Attribute_Address                  |
7505
           Attribute_Address_Size             |
7506
           Attribute_Asm_Input                |
7507
           Attribute_Asm_Output               |
7508
           Attribute_Base                     |
7509
           Attribute_Bit_Order                |
7510
           Attribute_Bit_Position             |
7511
           Attribute_Callable                 |
7512
           Attribute_Caller                   |
7513
           Attribute_Class                    |
7514
           Attribute_Code_Address             |
7515
           Attribute_Compiler_Version         |
7516
           Attribute_Count                    |
7517
           Attribute_Default_Bit_Order        |
7518
           Attribute_Elaborated               |
7519
           Attribute_Elab_Body                |
7520
           Attribute_Elab_Spec                |
7521
           Attribute_Enabled                  |
7522
           Attribute_External_Tag             |
7523
           Attribute_Fast_Math                |
7524
           Attribute_First_Bit                |
7525
           Attribute_Input                    |
7526
           Attribute_Last_Bit                 |
7527
           Attribute_Maximum_Alignment        |
7528
           Attribute_Old                      |
7529
           Attribute_Output                   |
7530
           Attribute_Partition_ID             |
7531
           Attribute_Pool_Address             |
7532
           Attribute_Position                 |
7533
           Attribute_Priority                 |
7534
           Attribute_Read                     |
7535
           Attribute_Result                   |
7536
           Attribute_Storage_Pool             |
7537
           Attribute_Storage_Size             |
7538
           Attribute_Storage_Unit             |
7539
           Attribute_Stub_Type                |
7540
           Attribute_Tag                      |
7541
           Attribute_Target_Name              |
7542
           Attribute_Terminated               |
7543
           Attribute_To_Address               |
7544
           Attribute_UET_Address              |
7545
           Attribute_Unchecked_Access         |
7546
           Attribute_Universal_Literal_String |
7547
           Attribute_Unrestricted_Access      |
7548
           Attribute_Valid                    |
7549
           Attribute_Value                    |
7550
           Attribute_Wchar_T_Size             |
7551
           Attribute_Wide_Value               |
7552
           Attribute_Wide_Wide_Value          |
7553
           Attribute_Word_Size                |
7554
           Attribute_Write                    =>
7555
 
7556
         raise Program_Error;
7557
      end case;
7558
 
7559
      --  At the end of the case, one more check. If we did a static evaluation
7560
      --  so that the result is now a literal, then set Is_Static_Expression
7561
      --  in the constant only if the prefix type is a static subtype. For
7562
      --  non-static subtypes, the folding is still OK, but not static.
7563
 
7564
      --  An exception is the GNAT attribute Constrained_Array which is
7565
      --  defined to be a static attribute in all cases.
7566
 
7567
      if Nkind_In (N, N_Integer_Literal,
7568
                      N_Real_Literal,
7569
                      N_Character_Literal,
7570
                      N_String_Literal)
7571
        or else (Is_Entity_Name (N)
7572
                  and then Ekind (Entity (N)) = E_Enumeration_Literal)
7573
      then
7574
         Set_Is_Static_Expression (N, Static);
7575
 
7576
      --  If this is still an attribute reference, then it has not been folded
7577
      --  and that means that its expressions are in a non-static context.
7578
 
7579
      elsif Nkind (N) = N_Attribute_Reference then
7580
         Check_Expressions;
7581
 
7582
      --  Note: the else case not covered here are odd cases where the
7583
      --  processing has transformed the attribute into something other
7584
      --  than a constant. Nothing more to do in such cases.
7585
 
7586
      else
7587
         null;
7588
      end if;
7589
   end Eval_Attribute;
7590
 
7591
   ------------------------------
7592
   -- Is_Anonymous_Tagged_Base --
7593
   ------------------------------
7594
 
7595
   function Is_Anonymous_Tagged_Base
7596
     (Anon : Entity_Id;
7597
      Typ  : Entity_Id)
7598
      return Boolean
7599
   is
7600
   begin
7601
      return
7602
        Anon = Current_Scope
7603
          and then Is_Itype (Anon)
7604
          and then Associated_Node_For_Itype (Anon) = Parent (Typ);
7605
   end Is_Anonymous_Tagged_Base;
7606
 
7607
   --------------------------------
7608
   -- Name_Implies_Lvalue_Prefix --
7609
   --------------------------------
7610
 
7611
   function Name_Implies_Lvalue_Prefix (Nam : Name_Id) return Boolean is
7612
      pragma Assert (Is_Attribute_Name (Nam));
7613
   begin
7614
      return Attribute_Name_Implies_Lvalue_Prefix (Get_Attribute_Id (Nam));
7615
   end Name_Implies_Lvalue_Prefix;
7616
 
7617
   -----------------------
7618
   -- Resolve_Attribute --
7619
   -----------------------
7620
 
7621
   procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is
7622
      Loc      : constant Source_Ptr   := Sloc (N);
7623
      P        : constant Node_Id      := Prefix (N);
7624
      Aname    : constant Name_Id      := Attribute_Name (N);
7625
      Attr_Id  : constant Attribute_Id := Get_Attribute_Id (Aname);
7626
      Btyp     : constant Entity_Id    := Base_Type (Typ);
7627
      Des_Btyp : Entity_Id;
7628
      Index    : Interp_Index;
7629
      It       : Interp;
7630
      Nom_Subt : Entity_Id;
7631
 
7632
      procedure Accessibility_Message;
7633
      --  Error, or warning within an instance, if the static accessibility
7634
      --  rules of 3.10.2 are violated.
7635
 
7636
      ---------------------------
7637
      -- Accessibility_Message --
7638
      ---------------------------
7639
 
7640
      procedure Accessibility_Message is
7641
         Indic : Node_Id := Parent (Parent (N));
7642
 
7643
      begin
7644
         --  In an instance, this is a runtime check, but one we
7645
         --  know will fail, so generate an appropriate warning.
7646
 
7647
         if In_Instance_Body then
7648
            Error_Msg_F
7649
              ("?non-local pointer cannot point to local object", P);
7650
            Error_Msg_F
7651
              ("\?Program_Error will be raised at run time", P);
7652
            Rewrite (N,
7653
              Make_Raise_Program_Error (Loc,
7654
                Reason => PE_Accessibility_Check_Failed));
7655
            Set_Etype (N, Typ);
7656
            return;
7657
 
7658
         else
7659
            Error_Msg_F
7660
              ("non-local pointer cannot point to local object", P);
7661
 
7662
            --  Check for case where we have a missing access definition
7663
 
7664
            if Is_Record_Type (Current_Scope)
7665
              and then
7666
                Nkind_In (Parent (N), N_Discriminant_Association,
7667
                                      N_Index_Or_Discriminant_Constraint)
7668
            then
7669
               Indic := Parent (Parent (N));
7670
               while Present (Indic)
7671
                 and then Nkind (Indic) /= N_Subtype_Indication
7672
               loop
7673
                  Indic := Parent (Indic);
7674
               end loop;
7675
 
7676
               if Present (Indic) then
7677
                  Error_Msg_NE
7678
                    ("\use an access definition for" &
7679
                     " the access discriminant of&",
7680
                     N, Entity (Subtype_Mark (Indic)));
7681
               end if;
7682
            end if;
7683
         end if;
7684
      end Accessibility_Message;
7685
 
7686
   --  Start of processing for Resolve_Attribute
7687
 
7688
   begin
7689
      --  If error during analysis, no point in continuing, except for
7690
      --  array types, where we get  better recovery by using unconstrained
7691
      --  indices than nothing at all (see Check_Array_Type).
7692
 
7693
      if Error_Posted (N)
7694
        and then Attr_Id /= Attribute_First
7695
        and then Attr_Id /= Attribute_Last
7696
        and then Attr_Id /= Attribute_Length
7697
        and then Attr_Id /= Attribute_Range
7698
      then
7699
         return;
7700
      end if;
7701
 
7702
      --  If attribute was universal type, reset to actual type
7703
 
7704
      if Etype (N) = Universal_Integer
7705
        or else Etype (N) = Universal_Real
7706
      then
7707
         Set_Etype (N, Typ);
7708
      end if;
7709
 
7710
      --  Remaining processing depends on attribute
7711
 
7712
      case Attr_Id is
7713
 
7714
         ------------
7715
         -- Access --
7716
         ------------
7717
 
7718
         --  For access attributes, if the prefix denotes an entity, it is
7719
         --  interpreted as a name, never as a call. It may be overloaded,
7720
         --  in which case resolution uses the profile of the context type.
7721
         --  Otherwise prefix must be resolved.
7722
 
7723
         when Attribute_Access
7724
            | Attribute_Unchecked_Access
7725
            | Attribute_Unrestricted_Access =>
7726
 
7727
         Access_Attribute :
7728
         begin
7729
            if Is_Variable (P) then
7730
               Note_Possible_Modification (P, Sure => False);
7731
            end if;
7732
 
7733
            --  The following comes from a query by Adam Beneschan, concerning
7734
            --  improper use of universal_access in equality tests involving
7735
            --  anonymous access types. Another good reason for 'Ref, but
7736
            --  for now disable the test, which breaks several filed tests.
7737
 
7738
            if Ekind (Typ) = E_Anonymous_Access_Type
7739
              and then Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne)
7740
              and then False
7741
            then
7742
               Error_Msg_N ("need unique type to resolve 'Access", N);
7743
               Error_Msg_N ("\qualify attribute with some access type", N);
7744
            end if;
7745
 
7746
            if Is_Entity_Name (P) then
7747
               if Is_Overloaded (P) then
7748
                  Get_First_Interp (P, Index, It);
7749
                  while Present (It.Nam) loop
7750
                     if Type_Conformant (Designated_Type (Typ), It.Nam) then
7751
                        Set_Entity (P, It.Nam);
7752
 
7753
                        --  The prefix is definitely NOT overloaded anymore at
7754
                        --  this point, so we reset the Is_Overloaded flag to
7755
                        --  avoid any confusion when reanalyzing the node.
7756
 
7757
                        Set_Is_Overloaded (P, False);
7758
                        Set_Is_Overloaded (N, False);
7759
                        Generate_Reference (Entity (P), P);
7760
                        exit;
7761
                     end if;
7762
 
7763
                     Get_Next_Interp (Index, It);
7764
                  end loop;
7765
 
7766
               --  If Prefix is a subprogram name, it is frozen by this
7767
               --  reference:
7768
 
7769
               --    If it is a type, there is nothing to resolve.
7770
               --    If it is an object, complete its resolution.
7771
 
7772
               elsif Is_Overloadable (Entity (P)) then
7773
 
7774
                  --  Avoid insertion of freeze actions in spec expression mode
7775
 
7776
                  if not In_Spec_Expression then
7777
                     Insert_Actions (N, Freeze_Entity (Entity (P), Loc));
7778
                  end if;
7779
 
7780
               elsif Is_Type (Entity (P)) then
7781
                  null;
7782
               else
7783
                  Resolve (P);
7784
               end if;
7785
 
7786
               Error_Msg_Name_1 := Aname;
7787
 
7788
               if not Is_Entity_Name (P) then
7789
                  null;
7790
 
7791
               elsif Is_Overloadable (Entity (P))
7792
                 and then Is_Abstract_Subprogram (Entity (P))
7793
               then
7794
                  Error_Msg_F ("prefix of % attribute cannot be abstract", P);
7795
                  Set_Etype (N, Any_Type);
7796
 
7797
               elsif Convention (Entity (P)) = Convention_Intrinsic then
7798
                  if Ekind (Entity (P)) = E_Enumeration_Literal then
7799
                     Error_Msg_F
7800
                       ("prefix of % attribute cannot be enumeration literal",
7801
                        P);
7802
                  else
7803
                     Error_Msg_F
7804
                       ("prefix of % attribute cannot be intrinsic", P);
7805
                  end if;
7806
 
7807
                  Set_Etype (N, Any_Type);
7808
               end if;
7809
 
7810
               --  Assignments, return statements, components of aggregates,
7811
               --  generic instantiations will require convention checks if
7812
               --  the type is an access to subprogram. Given that there will
7813
               --  also be accessibility checks on those, this is where the
7814
               --  checks can eventually be centralized ???
7815
 
7816
               if Ekind (Btyp) = E_Access_Subprogram_Type
7817
                    or else
7818
                  Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
7819
                    or else
7820
                  Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type
7821
               then
7822
                  --  Deal with convention mismatch
7823
 
7824
                  if Convention (Btyp) /= Convention (Entity (P)) then
7825
                     Error_Msg_FE
7826
                       ("subprogram & has wrong convention", P, Entity (P));
7827
 
7828
                     Error_Msg_FE
7829
                       ("\does not match convention of access type &",
7830
                        P, Btyp);
7831
 
7832
                     if not Has_Convention_Pragma (Btyp) then
7833
                        Error_Msg_FE
7834
                          ("\probable missing pragma Convention for &",
7835
                           P, Btyp);
7836
                     end if;
7837
 
7838
                  else
7839
                     Check_Subtype_Conformant
7840
                       (New_Id  => Entity (P),
7841
                        Old_Id  => Designated_Type (Btyp),
7842
                        Err_Loc => P);
7843
                  end if;
7844
 
7845
                  if Attr_Id = Attribute_Unchecked_Access then
7846
                     Error_Msg_Name_1 := Aname;
7847
                     Error_Msg_F
7848
                       ("attribute% cannot be applied to a subprogram", P);
7849
 
7850
                  elsif Aname = Name_Unrestricted_Access then
7851
                     null;  --  Nothing to check
7852
 
7853
                  --  Check the static accessibility rule of 3.10.2(32).
7854
                  --  This rule also applies within the private part of an
7855
                  --  instantiation. This rule does not apply to anonymous
7856
                  --  access-to-subprogram types in access parameters.
7857
 
7858
                  elsif Attr_Id = Attribute_Access
7859
                    and then not In_Instance_Body
7860
                    and then
7861
                      (Ekind (Btyp) = E_Access_Subprogram_Type
7862
                        or else Is_Local_Anonymous_Access (Btyp))
7863
 
7864
                    and then Subprogram_Access_Level (Entity (P)) >
7865
                               Type_Access_Level (Btyp)
7866
                  then
7867
                     Error_Msg_F
7868
                       ("subprogram must not be deeper than access type", P);
7869
 
7870
                  --  Check the restriction of 3.10.2(32) that disallows the
7871
                  --  access attribute within a generic body when the ultimate
7872
                  --  ancestor of the type of the attribute is declared outside
7873
                  --  of the generic unit and the subprogram is declared within
7874
                  --  that generic unit. This includes any such attribute that
7875
                  --  occurs within the body of a generic unit that is a child
7876
                  --  of the generic unit where the subprogram is declared.
7877
                  --  The rule also prohibits applying the attribute when the
7878
                  --  access type is a generic formal access type (since the
7879
                  --  level of the actual type is not known). This restriction
7880
                  --  does not apply when the attribute type is an anonymous
7881
                  --  access-to-subprogram type. Note that this check was
7882
                  --  revised by AI-229, because the originally Ada 95 rule
7883
                  --  was too lax. The original rule only applied when the
7884
                  --  subprogram was declared within the body of the generic,
7885
                  --  which allowed the possibility of dangling references).
7886
                  --  The rule was also too strict in some case, in that it
7887
                  --  didn't permit the access to be declared in the generic
7888
                  --  spec, whereas the revised rule does (as long as it's not
7889
                  --  a formal type).
7890
 
7891
                  --  There are a couple of subtleties of the test for applying
7892
                  --  the check that are worth noting. First, we only apply it
7893
                  --  when the levels of the subprogram and access type are the
7894
                  --  same (the case where the subprogram is statically deeper
7895
                  --  was applied above, and the case where the type is deeper
7896
                  --  is always safe). Second, we want the check to apply
7897
                  --  within nested generic bodies and generic child unit
7898
                  --  bodies, but not to apply to an attribute that appears in
7899
                  --  the generic unit's specification. This is done by testing
7900
                  --  that the attribute's innermost enclosing generic body is
7901
                  --  not the same as the innermost generic body enclosing the
7902
                  --  generic unit where the subprogram is declared (we don't
7903
                  --  want the check to apply when the access attribute is in
7904
                  --  the spec and there's some other generic body enclosing
7905
                  --  generic). Finally, there's no point applying the check
7906
                  --  when within an instance, because any violations will have
7907
                  --  been caught by the compilation of the generic unit.
7908
 
7909
                  elsif Attr_Id = Attribute_Access
7910
                    and then not In_Instance
7911
                    and then Present (Enclosing_Generic_Unit (Entity (P)))
7912
                    and then Present (Enclosing_Generic_Body (N))
7913
                    and then Enclosing_Generic_Body (N) /=
7914
                               Enclosing_Generic_Body
7915
                                 (Enclosing_Generic_Unit (Entity (P)))
7916
                    and then Subprogram_Access_Level (Entity (P)) =
7917
                               Type_Access_Level (Btyp)
7918
                    and then Ekind (Btyp) /=
7919
                               E_Anonymous_Access_Subprogram_Type
7920
                    and then Ekind (Btyp) /=
7921
                               E_Anonymous_Access_Protected_Subprogram_Type
7922
                  then
7923
                     --  The attribute type's ultimate ancestor must be
7924
                     --  declared within the same generic unit as the
7925
                     --  subprogram is declared. The error message is
7926
                     --  specialized to say "ancestor" for the case where
7927
                     --  the access type is not its own ancestor, since
7928
                     --  saying simply "access type" would be very confusing.
7929
 
7930
                     if Enclosing_Generic_Unit (Entity (P)) /=
7931
                          Enclosing_Generic_Unit (Root_Type (Btyp))
7932
                     then
7933
                        Error_Msg_N
7934
                          ("''Access attribute not allowed in generic body",
7935
                           N);
7936
 
7937
                        if Root_Type (Btyp) = Btyp then
7938
                           Error_Msg_NE
7939
                             ("\because " &
7940
                              "access type & is declared outside " &
7941
                              "generic unit (RM 3.10.2(32))", N, Btyp);
7942
                        else
7943
                           Error_Msg_NE
7944
                             ("\because ancestor of " &
7945
                              "access type & is declared outside " &
7946
                              "generic unit (RM 3.10.2(32))", N, Btyp);
7947
                        end if;
7948
 
7949
                        Error_Msg_NE
7950
                          ("\move ''Access to private part, or " &
7951
                           "(Ada 2005) use anonymous access type instead of &",
7952
                           N, Btyp);
7953
 
7954
                     --  If the ultimate ancestor of the attribute's type is
7955
                     --  a formal type, then the attribute is illegal because
7956
                     --  the actual type might be declared at a higher level.
7957
                     --  The error message is specialized to say "ancestor"
7958
                     --  for the case where the access type is not its own
7959
                     --  ancestor, since saying simply "access type" would be
7960
                     --  very confusing.
7961
 
7962
                     elsif Is_Generic_Type (Root_Type (Btyp)) then
7963
                        if Root_Type (Btyp) = Btyp then
7964
                           Error_Msg_N
7965
                             ("access type must not be a generic formal type",
7966
                              N);
7967
                        else
7968
                           Error_Msg_N
7969
                             ("ancestor access type must not be a generic " &
7970
                              "formal type", N);
7971
                        end if;
7972
                     end if;
7973
                  end if;
7974
               end if;
7975
 
7976
               --  If this is a renaming, an inherited operation, or a
7977
               --  subprogram instance, use the original entity. This may make
7978
               --  the node type-inconsistent, so this transformation can only
7979
               --  be done if the node will not be reanalyzed. In particular,
7980
               --  if it is within a default expression, the transformation
7981
               --  must be delayed until the default subprogram is created for
7982
               --  it, when the enclosing subprogram is frozen.
7983
 
7984
               if Is_Entity_Name (P)
7985
                 and then Is_Overloadable (Entity (P))
7986
                 and then Present (Alias (Entity (P)))
7987
                 and then Expander_Active
7988
               then
7989
                  Rewrite (P,
7990
                    New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
7991
               end if;
7992
 
7993
            elsif Nkind (P) = N_Selected_Component
7994
              and then Is_Overloadable (Entity (Selector_Name (P)))
7995
            then
7996
               --  Protected operation. If operation is overloaded, must
7997
               --  disambiguate. Prefix that denotes protected object itself
7998
               --  is resolved with its own type.
7999
 
8000
               if Attr_Id = Attribute_Unchecked_Access then
8001
                  Error_Msg_Name_1 := Aname;
8002
                  Error_Msg_F
8003
                    ("attribute% cannot be applied to protected operation", P);
8004
               end if;
8005
 
8006
               Resolve (Prefix (P));
8007
               Generate_Reference (Entity (Selector_Name (P)), P);
8008
 
8009
            elsif Is_Overloaded (P) then
8010
 
8011
               --  Use the designated type of the context to disambiguate
8012
               --  Note that this was not strictly conformant to Ada 95,
8013
               --  but was the implementation adopted by most Ada 95 compilers.
8014
               --  The use of the context type to resolve an Access attribute
8015
               --  reference is now mandated in AI-235 for Ada 2005.
8016
 
8017
               declare
8018
                  Index : Interp_Index;
8019
                  It    : Interp;
8020
 
8021
               begin
8022
                  Get_First_Interp (P, Index, It);
8023
                  while Present (It.Typ) loop
8024
                     if Covers (Designated_Type (Typ), It.Typ) then
8025
                        Resolve (P, It.Typ);
8026
                        exit;
8027
                     end if;
8028
 
8029
                     Get_Next_Interp (Index, It);
8030
                  end loop;
8031
               end;
8032
            else
8033
               Resolve (P);
8034
            end if;
8035
 
8036
            --  X'Access is illegal if X denotes a constant and the access type
8037
            --  is access-to-variable. Same for 'Unchecked_Access. The rule
8038
            --  does not apply to 'Unrestricted_Access. If the reference is a
8039
            --  default-initialized aggregate component for a self-referential
8040
            --  type the reference is legal.
8041
 
8042
            if not (Ekind (Btyp) = E_Access_Subprogram_Type
8043
                     or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
8044
                     or else (Is_Record_Type (Btyp)
8045
                               and then
8046
                                 Present (Corresponding_Remote_Type (Btyp)))
8047
                     or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type
8048
                     or else Ekind (Btyp)
8049
                               = E_Anonymous_Access_Protected_Subprogram_Type
8050
                     or else Is_Access_Constant (Btyp)
8051
                     or else Is_Variable (P)
8052
                     or else Attr_Id = Attribute_Unrestricted_Access)
8053
            then
8054
               if Is_Entity_Name (P)
8055
                 and then Is_Type (Entity (P))
8056
               then
8057
                  --  Legality of a self-reference through an access
8058
                  --  attribute has been verified in Analyze_Access_Attribute.
8059
 
8060
                  null;
8061
 
8062
               elsif Comes_From_Source (N) then
8063
                  Error_Msg_F ("access-to-variable designates constant", P);
8064
               end if;
8065
            end if;
8066
 
8067
            Des_Btyp := Designated_Type (Btyp);
8068
 
8069
            if Ada_Version >= Ada_05
8070
              and then Is_Incomplete_Type (Des_Btyp)
8071
            then
8072
               --  Ada 2005 (AI-412): If the (sub)type is a limited view of an
8073
               --  imported entity, and the non-limited view is visible, make
8074
               --  use of it. If it is an incomplete subtype, use the base type
8075
               --  in any case.
8076
 
8077
               if From_With_Type (Des_Btyp)
8078
                 and then Present (Non_Limited_View (Des_Btyp))
8079
               then
8080
                  Des_Btyp := Non_Limited_View (Des_Btyp);
8081
 
8082
               elsif Ekind (Des_Btyp) = E_Incomplete_Subtype then
8083
                  Des_Btyp := Etype (Des_Btyp);
8084
               end if;
8085
            end if;
8086
 
8087
            if (Attr_Id = Attribute_Access
8088
                  or else
8089
                Attr_Id = Attribute_Unchecked_Access)
8090
              and then (Ekind (Btyp) = E_General_Access_Type
8091
                          or else Ekind (Btyp) = E_Anonymous_Access_Type)
8092
            then
8093
               --  Ada 2005 (AI-230): Check the accessibility of anonymous
8094
               --  access types for stand-alone objects, record and array
8095
               --  components, and return objects. For a component definition
8096
               --  the level is the same of the enclosing composite type.
8097
 
8098
               if Ada_Version >= Ada_05
8099
                 and then Is_Local_Anonymous_Access (Btyp)
8100
                 and then Object_Access_Level (P) > Type_Access_Level (Btyp)
8101
                 and then Attr_Id = Attribute_Access
8102
               then
8103
                  --  In an instance, this is a runtime check, but one we
8104
                  --  know will fail, so generate an appropriate warning.
8105
 
8106
                  if In_Instance_Body then
8107
                     Error_Msg_F
8108
                       ("?non-local pointer cannot point to local object", P);
8109
                     Error_Msg_F
8110
                       ("\?Program_Error will be raised at run time", P);
8111
                     Rewrite (N,
8112
                       Make_Raise_Program_Error (Loc,
8113
                         Reason => PE_Accessibility_Check_Failed));
8114
                     Set_Etype (N, Typ);
8115
 
8116
                  else
8117
                     Error_Msg_F
8118
                       ("non-local pointer cannot point to local object", P);
8119
                  end if;
8120
               end if;
8121
 
8122
               if Is_Dependent_Component_Of_Mutable_Object (P) then
8123
                  Error_Msg_F
8124
                    ("illegal attribute for discriminant-dependent component",
8125
                     P);
8126
               end if;
8127
 
8128
               --  Check static matching rule of 3.10.2(27). Nominal subtype
8129
               --  of the prefix must statically match the designated type.
8130
 
8131
               Nom_Subt := Etype (P);
8132
 
8133
               if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then
8134
                  Nom_Subt := Base_Type (Nom_Subt);
8135
               end if;
8136
 
8137
               if Is_Tagged_Type (Designated_Type (Typ)) then
8138
 
8139
                  --  If the attribute is in the context of an access
8140
                  --  parameter, then the prefix is allowed to be of the
8141
                  --  class-wide type (by AI-127).
8142
 
8143
                  if Ekind (Typ) = E_Anonymous_Access_Type then
8144
                     if not Covers (Designated_Type (Typ), Nom_Subt)
8145
                       and then not Covers (Nom_Subt, Designated_Type (Typ))
8146
                     then
8147
                        declare
8148
                           Desig : Entity_Id;
8149
 
8150
                        begin
8151
                           Desig := Designated_Type (Typ);
8152
 
8153
                           if Is_Class_Wide_Type (Desig) then
8154
                              Desig := Etype (Desig);
8155
                           end if;
8156
 
8157
                           if Is_Anonymous_Tagged_Base (Nom_Subt, Desig) then
8158
                              null;
8159
 
8160
                           else
8161
                              Error_Msg_FE
8162
                                ("type of prefix: & not compatible",
8163
                                  P, Nom_Subt);
8164
                              Error_Msg_FE
8165
                                ("\with &, the expected designated type",
8166
                                  P, Designated_Type (Typ));
8167
                           end if;
8168
                        end;
8169
                     end if;
8170
 
8171
                  elsif not Covers (Designated_Type (Typ), Nom_Subt)
8172
                    or else
8173
                      (not Is_Class_Wide_Type (Designated_Type (Typ))
8174
                        and then Is_Class_Wide_Type (Nom_Subt))
8175
                  then
8176
                     Error_Msg_FE
8177
                       ("type of prefix: & is not covered", P, Nom_Subt);
8178
                     Error_Msg_FE
8179
                       ("\by &, the expected designated type" &
8180
                           " (RM 3.10.2 (27))", P, Designated_Type (Typ));
8181
                  end if;
8182
 
8183
                  if Is_Class_Wide_Type (Designated_Type (Typ))
8184
                    and then Has_Discriminants (Etype (Designated_Type (Typ)))
8185
                    and then Is_Constrained (Etype (Designated_Type (Typ)))
8186
                    and then Designated_Type (Typ) /= Nom_Subt
8187
                  then
8188
                     Apply_Discriminant_Check
8189
                       (N, Etype (Designated_Type (Typ)));
8190
                  end if;
8191
 
8192
               --  Ada 2005 (AI-363): Require static matching when designated
8193
               --  type has discriminants and a constrained partial view, since
8194
               --  in general objects of such types are mutable, so we can't
8195
               --  allow the access value to designate a constrained object
8196
               --  (because access values must be assumed to designate mutable
8197
               --  objects when designated type does not impose a constraint).
8198
 
8199
               elsif Subtypes_Statically_Match (Des_Btyp, Nom_Subt) then
8200
                  null;
8201
 
8202
               elsif Has_Discriminants (Designated_Type (Typ))
8203
                 and then not Is_Constrained (Des_Btyp)
8204
                 and then
8205
                   (Ada_Version < Ada_05
8206
                     or else
8207
                       not Has_Constrained_Partial_View
8208
                             (Designated_Type (Base_Type (Typ))))
8209
               then
8210
                  null;
8211
 
8212
               else
8213
                  Error_Msg_F
8214
                    ("object subtype must statically match "
8215
                     & "designated subtype", P);
8216
 
8217
                  if Is_Entity_Name (P)
8218
                    and then Is_Array_Type (Designated_Type (Typ))
8219
                  then
8220
                     declare
8221
                        D : constant Node_Id := Declaration_Node (Entity (P));
8222
 
8223
                     begin
8224
                        Error_Msg_N ("aliased object has explicit bounds?",
8225
                          D);
8226
                        Error_Msg_N ("\declare without bounds"
8227
                          & " (and with explicit initialization)?", D);
8228
                        Error_Msg_N ("\for use with unconstrained access?", D);
8229
                     end;
8230
                  end if;
8231
               end if;
8232
 
8233
               --  Check the static accessibility rule of 3.10.2(28).
8234
               --  Note that this check is not performed for the
8235
               --  case of an anonymous access type, since the access
8236
               --  attribute is always legal in such a context.
8237
 
8238
               if Attr_Id /= Attribute_Unchecked_Access
8239
                 and then Object_Access_Level (P) > Type_Access_Level (Btyp)
8240
                 and then Ekind (Btyp) = E_General_Access_Type
8241
               then
8242
                  Accessibility_Message;
8243
                  return;
8244
               end if;
8245
            end if;
8246
 
8247
            if Ekind (Btyp) = E_Access_Protected_Subprogram_Type
8248
                 or else
8249
               Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type
8250
            then
8251
               if Is_Entity_Name (P)
8252
                 and then not Is_Protected_Type (Scope (Entity (P)))
8253
               then
8254
                  Error_Msg_F ("context requires a protected subprogram", P);
8255
 
8256
               --  Check accessibility of protected object against that of the
8257
               --  access type, but only on user code, because the expander
8258
               --  creates access references for handlers. If the context is an
8259
               --  anonymous_access_to_protected, there are no accessibility
8260
               --  checks either. Omit check entirely for Unrestricted_Access.
8261
 
8262
               elsif Object_Access_Level (P) > Type_Access_Level (Btyp)
8263
                 and then Comes_From_Source (N)
8264
                 and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type
8265
                 and then Attr_Id /= Attribute_Unrestricted_Access
8266
               then
8267
                  Accessibility_Message;
8268
                  return;
8269
               end if;
8270
 
8271
            elsif (Ekind (Btyp) = E_Access_Subprogram_Type
8272
                     or else
8273
                   Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type)
8274
              and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type
8275
            then
8276
               Error_Msg_F ("context requires a non-protected subprogram", P);
8277
            end if;
8278
 
8279
            --  The context cannot be a pool-specific type, but this is a
8280
            --  legality rule, not a resolution rule, so it must be checked
8281
            --  separately, after possibly disambiguation (see AI-245).
8282
 
8283
            if Ekind (Btyp) = E_Access_Type
8284
              and then Attr_Id /= Attribute_Unrestricted_Access
8285
            then
8286
               Wrong_Type (N, Typ);
8287
            end if;
8288
 
8289
            --  The context may be a constrained access type (however ill-
8290
            --  advised such subtypes might be) so in order to generate a
8291
            --  constraint check when needed set the type of the attribute
8292
            --  reference to the base type of the context.
8293
 
8294
            Set_Etype (N, Btyp);
8295
 
8296
            --  Check for incorrect atomic/volatile reference (RM C.6(12))
8297
 
8298
            if Attr_Id /= Attribute_Unrestricted_Access then
8299
               if Is_Atomic_Object (P)
8300
                 and then not Is_Atomic (Designated_Type (Typ))
8301
               then
8302
                  Error_Msg_F
8303
                    ("access to atomic object cannot yield access-to-" &
8304
                     "non-atomic type", P);
8305
 
8306
               elsif Is_Volatile_Object (P)
8307
                 and then not Is_Volatile (Designated_Type (Typ))
8308
               then
8309
                  Error_Msg_F
8310
                    ("access to volatile object cannot yield access-to-" &
8311
                     "non-volatile type", P);
8312
               end if;
8313
            end if;
8314
 
8315
            if Is_Entity_Name (P) then
8316
               Set_Address_Taken (Entity (P));
8317
            end if;
8318
         end Access_Attribute;
8319
 
8320
         -------------
8321
         -- Address --
8322
         -------------
8323
 
8324
         --  Deal with resolving the type for Address attribute, overloading
8325
         --  is not permitted here, since there is no context to resolve it.
8326
 
8327
         when Attribute_Address | Attribute_Code_Address =>
8328
         Address_Attribute : begin
8329
 
8330
            --  To be safe, assume that if the address of a variable is taken,
8331
            --  it may be modified via this address, so note modification.
8332
 
8333
            if Is_Variable (P) then
8334
               Note_Possible_Modification (P, Sure => False);
8335
            end if;
8336
 
8337
            if Nkind (P) in N_Subexpr
8338
              and then Is_Overloaded (P)
8339
            then
8340
               Get_First_Interp (P, Index, It);
8341
               Get_Next_Interp (Index, It);
8342
 
8343
               if Present (It.Nam) then
8344
                  Error_Msg_Name_1 := Aname;
8345
                  Error_Msg_F
8346
                    ("prefix of % attribute cannot be overloaded", P);
8347
               end if;
8348
            end if;
8349
 
8350
            if not Is_Entity_Name (P)
8351
              or else not Is_Overloadable (Entity (P))
8352
            then
8353
               if not Is_Task_Type (Etype (P))
8354
                 or else Nkind (P) = N_Explicit_Dereference
8355
               then
8356
                  Resolve (P);
8357
               end if;
8358
            end if;
8359
 
8360
            --  If this is the name of a derived subprogram, or that of a
8361
            --  generic actual, the address is that of the original entity.
8362
 
8363
            if Is_Entity_Name (P)
8364
              and then Is_Overloadable (Entity (P))
8365
              and then Present (Alias (Entity (P)))
8366
            then
8367
               Rewrite (P,
8368
                 New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
8369
            end if;
8370
 
8371
            if Is_Entity_Name (P) then
8372
               Set_Address_Taken (Entity (P));
8373
            end if;
8374
 
8375
            if Nkind (P) = N_Slice then
8376
 
8377
               --  Arr (X .. Y)'address is identical to Arr (X)'address,
8378
               --  even if the array is packed and the slice itself is not
8379
               --  addressable. Transform the prefix into an indexed component.
8380
 
8381
               --  Note that the transformation is safe only if we know that
8382
               --  the slice is non-null. That is because a null slice can have
8383
               --  an out of bounds index value.
8384
 
8385
               --  Right now, gigi blows up if given 'Address on a slice as a
8386
               --  result of some incorrect freeze nodes generated by the front
8387
               --  end, and this covers up that bug in one case, but the bug is
8388
               --  likely still there in the cases not handled by this code ???
8389
 
8390
               --  It's not clear what 'Address *should* return for a null
8391
               --  slice with out of bounds indexes, this might be worth an ARG
8392
               --  discussion ???
8393
 
8394
               --  One approach would be to do a length check unconditionally,
8395
               --  and then do the transformation below unconditionally, but
8396
               --  analyze with checks off, avoiding the problem of the out of
8397
               --  bounds index. This approach would interpret the address of
8398
               --  an out of bounds null slice as being the address where the
8399
               --  array element would be if there was one, which is probably
8400
               --  as reasonable an interpretation as any ???
8401
 
8402
               declare
8403
                  Loc : constant Source_Ptr := Sloc (P);
8404
                  D   : constant Node_Id := Discrete_Range (P);
8405
                  Lo  : Node_Id;
8406
 
8407
               begin
8408
                  if Is_Entity_Name (D)
8409
                    and then
8410
                      Not_Null_Range
8411
                        (Type_Low_Bound (Entity (D)),
8412
                         Type_High_Bound (Entity (D)))
8413
                  then
8414
                     Lo :=
8415
                       Make_Attribute_Reference (Loc,
8416
                          Prefix => (New_Occurrence_Of (Entity (D), Loc)),
8417
                          Attribute_Name => Name_First);
8418
 
8419
                  elsif Nkind (D) = N_Range
8420
                    and then Not_Null_Range (Low_Bound (D), High_Bound (D))
8421
                  then
8422
                     Lo := Low_Bound (D);
8423
 
8424
                  else
8425
                     Lo := Empty;
8426
                  end if;
8427
 
8428
                  if Present (Lo) then
8429
                     Rewrite (P,
8430
                        Make_Indexed_Component (Loc,
8431
                           Prefix =>  Relocate_Node (Prefix (P)),
8432
                           Expressions => New_List (Lo)));
8433
 
8434
                     Analyze_And_Resolve (P);
8435
                  end if;
8436
               end;
8437
            end if;
8438
         end Address_Attribute;
8439
 
8440
         ---------------
8441
         -- AST_Entry --
8442
         ---------------
8443
 
8444
         --  Prefix of the AST_Entry attribute is an entry name which must
8445
         --  not be resolved, since this is definitely not an entry call.
8446
 
8447
         when Attribute_AST_Entry =>
8448
            null;
8449
 
8450
         ------------------
8451
         -- Body_Version --
8452
         ------------------
8453
 
8454
         --  Prefix of Body_Version attribute can be a subprogram name which
8455
         --  must not be resolved, since this is not a call.
8456
 
8457
         when Attribute_Body_Version =>
8458
            null;
8459
 
8460
         ------------
8461
         -- Caller --
8462
         ------------
8463
 
8464
         --  Prefix of Caller attribute is an entry name which must not
8465
         --  be resolved, since this is definitely not an entry call.
8466
 
8467
         when Attribute_Caller =>
8468
            null;
8469
 
8470
         ------------------
8471
         -- Code_Address --
8472
         ------------------
8473
 
8474
         --  Shares processing with Address attribute
8475
 
8476
         -----------
8477
         -- Count --
8478
         -----------
8479
 
8480
         --  If the prefix of the Count attribute is an entry name it must not
8481
         --  be resolved, since this is definitely not an entry call. However,
8482
         --  if it is an element of an entry family, the index itself may
8483
         --  have to be resolved because it can be a general expression.
8484
 
8485
         when Attribute_Count =>
8486
            if Nkind (P) = N_Indexed_Component
8487
              and then Is_Entity_Name (Prefix (P))
8488
            then
8489
               declare
8490
                  Indx : constant Node_Id   := First (Expressions (P));
8491
                  Fam  : constant Entity_Id := Entity (Prefix (P));
8492
               begin
8493
                  Resolve (Indx, Entry_Index_Type (Fam));
8494
                  Apply_Range_Check (Indx, Entry_Index_Type (Fam));
8495
               end;
8496
            end if;
8497
 
8498
         ----------------
8499
         -- Elaborated --
8500
         ----------------
8501
 
8502
         --  Prefix of the Elaborated attribute is a subprogram name which
8503
         --  must not be resolved, since this is definitely not a call. Note
8504
         --  that it is a library unit, so it cannot be overloaded here.
8505
 
8506
         when Attribute_Elaborated =>
8507
            null;
8508
 
8509
         -------------
8510
         -- Enabled --
8511
         -------------
8512
 
8513
         --  Prefix of Enabled attribute is a check name, which must be treated
8514
         --  specially and not touched by Resolve.
8515
 
8516
         when Attribute_Enabled =>
8517
            null;
8518
 
8519
         --------------------
8520
         -- Mechanism_Code --
8521
         --------------------
8522
 
8523
         --  Prefix of the Mechanism_Code attribute is a function name
8524
         --  which must not be resolved. Should we check for overloaded ???
8525
 
8526
         when Attribute_Mechanism_Code =>
8527
            null;
8528
 
8529
         ------------------
8530
         -- Partition_ID --
8531
         ------------------
8532
 
8533
         --  Most processing is done in sem_dist, after determining the
8534
         --  context type. Node is rewritten as a conversion to a runtime call.
8535
 
8536
         when Attribute_Partition_ID =>
8537
            Process_Partition_Id (N);
8538
            return;
8539
 
8540
         ------------------
8541
         -- Pool_Address --
8542
         ------------------
8543
 
8544
         when Attribute_Pool_Address =>
8545
            Resolve (P);
8546
 
8547
         -----------
8548
         -- Range --
8549
         -----------
8550
 
8551
         --  We replace the Range attribute node with a range expression
8552
         --  whose bounds are the 'First and 'Last attributes applied to the
8553
         --  same prefix. The reason that we do this transformation here
8554
         --  instead of in the expander is that it simplifies other parts of
8555
         --  the semantic analysis which assume that the Range has been
8556
         --  replaced; thus it must be done even when in semantic-only mode
8557
         --  (note that the RM specifically mentions this equivalence, we
8558
         --  take care that the prefix is only evaluated once).
8559
 
8560
         when Attribute_Range => Range_Attribute :
8561
            declare
8562
               LB   : Node_Id;
8563
               HB   : Node_Id;
8564
 
8565
            begin
8566
               if not Is_Entity_Name (P)
8567
                 or else not Is_Type (Entity (P))
8568
               then
8569
                  Resolve (P);
8570
               end if;
8571
 
8572
               HB :=
8573
                 Make_Attribute_Reference (Loc,
8574
                   Prefix         =>
8575
                     Duplicate_Subexpr (P, Name_Req => True),
8576
                   Attribute_Name => Name_Last,
8577
                   Expressions    => Expressions (N));
8578
 
8579
               LB :=
8580
                 Make_Attribute_Reference (Loc,
8581
                   Prefix         => P,
8582
                   Attribute_Name => Name_First,
8583
                   Expressions    => Expressions (N));
8584
 
8585
               --  If the original was marked as Must_Not_Freeze (see code
8586
               --  in Sem_Ch3.Make_Index), then make sure the rewriting
8587
               --  does not freeze either.
8588
 
8589
               if Must_Not_Freeze (N) then
8590
                  Set_Must_Not_Freeze (HB);
8591
                  Set_Must_Not_Freeze (LB);
8592
                  Set_Must_Not_Freeze (Prefix (HB));
8593
                  Set_Must_Not_Freeze (Prefix (LB));
8594
               end if;
8595
 
8596
               if Raises_Constraint_Error (Prefix (N)) then
8597
 
8598
                  --  Preserve Sloc of prefix in the new bounds, so that
8599
                  --  the posted warning can be removed if we are within
8600
                  --  unreachable code.
8601
 
8602
                  Set_Sloc (LB, Sloc (Prefix (N)));
8603
                  Set_Sloc (HB, Sloc (Prefix (N)));
8604
               end if;
8605
 
8606
               Rewrite (N, Make_Range (Loc, LB, HB));
8607
               Analyze_And_Resolve (N, Typ);
8608
 
8609
               --  Normally after resolving attribute nodes, Eval_Attribute
8610
               --  is called to do any possible static evaluation of the node.
8611
               --  However, here since the Range attribute has just been
8612
               --  transformed into a range expression it is no longer an
8613
               --  attribute node and therefore the call needs to be avoided
8614
               --  and is accomplished by simply returning from the procedure.
8615
 
8616
               return;
8617
            end Range_Attribute;
8618
 
8619
         ------------
8620
         -- Result --
8621
         ------------
8622
 
8623
         --  We will only come here during the prescan of a spec expression
8624
         --  containing a Result attribute. In that case the proper Etype has
8625
         --  already been set, and nothing more needs to be done here.
8626
 
8627
         when Attribute_Result =>
8628
            null;
8629
 
8630
         -----------------
8631
         -- UET_Address --
8632
         -----------------
8633
 
8634
         --  Prefix must not be resolved in this case, since it is not a
8635
         --  real entity reference. No action of any kind is require!
8636
 
8637
         when Attribute_UET_Address =>
8638
            return;
8639
 
8640
         ----------------------
8641
         -- Unchecked_Access --
8642
         ----------------------
8643
 
8644
         --  Processing is shared with Access
8645
 
8646
         -------------------------
8647
         -- Unrestricted_Access --
8648
         -------------------------
8649
 
8650
         --  Processing is shared with Access
8651
 
8652
         ---------
8653
         -- Val --
8654
         ---------
8655
 
8656
         --  Apply range check. Note that we did not do this during the
8657
         --  analysis phase, since we wanted Eval_Attribute to have a
8658
         --  chance at finding an illegal out of range value.
8659
 
8660
         when Attribute_Val =>
8661
 
8662
            --  Note that we do our own Eval_Attribute call here rather than
8663
            --  use the common one, because we need to do processing after
8664
            --  the call, as per above comment.
8665
 
8666
            Eval_Attribute (N);
8667
 
8668
            --  Eval_Attribute may replace the node with a raise CE, or
8669
            --  fold it to a constant. Obviously we only apply a scalar
8670
            --  range check if this did not happen!
8671
 
8672
            if Nkind (N) = N_Attribute_Reference
8673
              and then Attribute_Name (N) = Name_Val
8674
            then
8675
               Apply_Scalar_Range_Check (First (Expressions (N)), Btyp);
8676
            end if;
8677
 
8678
            return;
8679
 
8680
         -------------
8681
         -- Version --
8682
         -------------
8683
 
8684
         --  Prefix of Version attribute can be a subprogram name which
8685
         --  must not be resolved, since this is not a call.
8686
 
8687
         when Attribute_Version =>
8688
            null;
8689
 
8690
         ----------------------
8691
         -- Other Attributes --
8692
         ----------------------
8693
 
8694
         --  For other attributes, resolve prefix unless it is a type. If
8695
         --  the attribute reference itself is a type name ('Base and 'Class)
8696
         --  then this is only legal within a task or protected record.
8697
 
8698
         when others =>
8699
            if not Is_Entity_Name (P)
8700
              or else not Is_Type (Entity (P))
8701
            then
8702
               Resolve (P);
8703
            end if;
8704
 
8705
            --  If the attribute reference itself is a type name ('Base,
8706
            --  'Class) then this is only legal within a task or protected
8707
            --  record. What is this all about ???
8708
 
8709
            if Is_Entity_Name (N)
8710
              and then Is_Type (Entity (N))
8711
            then
8712
               if Is_Concurrent_Type (Entity (N))
8713
                 and then In_Open_Scopes (Entity (P))
8714
               then
8715
                  null;
8716
               else
8717
                  Error_Msg_N
8718
                    ("invalid use of subtype name in expression or call", N);
8719
               end if;
8720
            end if;
8721
 
8722
            --  For attributes whose argument may be a string, complete
8723
            --  resolution of argument now. This avoids premature expansion
8724
            --  (and the creation of transient scopes) before the attribute
8725
            --  reference is resolved.
8726
 
8727
            case Attr_Id is
8728
               when Attribute_Value =>
8729
                  Resolve (First (Expressions (N)), Standard_String);
8730
 
8731
               when Attribute_Wide_Value =>
8732
                  Resolve (First (Expressions (N)), Standard_Wide_String);
8733
 
8734
               when Attribute_Wide_Wide_Value =>
8735
                  Resolve (First (Expressions (N)), Standard_Wide_Wide_String);
8736
 
8737
               when others => null;
8738
            end case;
8739
 
8740
            --  If the prefix of the attribute is a class-wide type then it
8741
            --  will be expanded into a dispatching call to a predefined
8742
            --  primitive. Therefore we must check for potential violation
8743
            --  of such restriction.
8744
 
8745
            if Is_Class_Wide_Type (Etype (P)) then
8746
               Check_Restriction (No_Dispatching_Calls, N);
8747
            end if;
8748
      end case;
8749
 
8750
      --  Normally the Freezing is done by Resolve but sometimes the Prefix
8751
      --  is not resolved, in which case the freezing must be done now.
8752
 
8753
      Freeze_Expression (P);
8754
 
8755
      --  Finally perform static evaluation on the attribute reference
8756
 
8757
      Eval_Attribute (N);
8758
   end Resolve_Attribute;
8759
 
8760
   --------------------------------
8761
   -- Stream_Attribute_Available --
8762
   --------------------------------
8763
 
8764
   function Stream_Attribute_Available
8765
     (Typ          : Entity_Id;
8766
      Nam          : TSS_Name_Type;
8767
      Partial_View : Node_Id := Empty) return Boolean
8768
   is
8769
      Etyp : Entity_Id := Typ;
8770
 
8771
   --  Start of processing for Stream_Attribute_Available
8772
 
8773
   begin
8774
      --  We need some comments in this body ???
8775
 
8776
      if Has_Stream_Attribute_Definition (Typ, Nam) then
8777
         return True;
8778
      end if;
8779
 
8780
      if Is_Class_Wide_Type (Typ) then
8781
         return not Is_Limited_Type (Typ)
8782
           or else Stream_Attribute_Available (Etype (Typ), Nam);
8783
      end if;
8784
 
8785
      if Nam = TSS_Stream_Input
8786
        and then Is_Abstract_Type (Typ)
8787
        and then not Is_Class_Wide_Type (Typ)
8788
      then
8789
         return False;
8790
      end if;
8791
 
8792
      if not (Is_Limited_Type (Typ)
8793
        or else (Present (Partial_View)
8794
                   and then Is_Limited_Type (Partial_View)))
8795
      then
8796
         return True;
8797
      end if;
8798
 
8799
      --  In Ada 2005, Input can invoke Read, and Output can invoke Write
8800
 
8801
      if Nam = TSS_Stream_Input
8802
        and then Ada_Version >= Ada_05
8803
        and then Stream_Attribute_Available (Etyp, TSS_Stream_Read)
8804
      then
8805
         return True;
8806
 
8807
      elsif Nam = TSS_Stream_Output
8808
        and then Ada_Version >= Ada_05
8809
        and then Stream_Attribute_Available (Etyp, TSS_Stream_Write)
8810
      then
8811
         return True;
8812
      end if;
8813
 
8814
      --  Case of Read and Write: check for attribute definition clause that
8815
      --  applies to an ancestor type.
8816
 
8817
      while Etype (Etyp) /= Etyp loop
8818
         Etyp := Etype (Etyp);
8819
 
8820
         if Has_Stream_Attribute_Definition (Etyp, Nam) then
8821
            return True;
8822
         end if;
8823
      end loop;
8824
 
8825
      if Ada_Version < Ada_05 then
8826
 
8827
         --  In Ada 95 mode, also consider a non-visible definition
8828
 
8829
         declare
8830
            Btyp : constant Entity_Id := Implementation_Base_Type (Typ);
8831
         begin
8832
            return Btyp /= Typ
8833
              and then Stream_Attribute_Available
8834
                         (Btyp, Nam, Partial_View => Typ);
8835
         end;
8836
      end if;
8837
 
8838
      return False;
8839
   end Stream_Attribute_Available;
8840
 
8841
end Sem_Attr;

powered by: WebSVN 2.1.0

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