OSDN Git Service

ce66987c87e197b7e1655f3ee935895992b287d0
[pf3gnuchains/gcc-fork.git] / gcc / ada / sem_attr.adb
1 ------------------------------------------------------------------------------
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-2007, 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 Lib;      use Lib;
39 with Lib.Xref; use Lib.Xref;
40 with Nlists;   use Nlists;
41 with Nmake;    use Nmake;
42 with Opt;      use Opt;
43 with Restrict; use Restrict;
44 with Rident;   use Rident;
45 with Rtsfind;  use Rtsfind;
46 with Sdefault; use Sdefault;
47 with Sem;      use Sem;
48 with Sem_Cat;  use Sem_Cat;
49 with Sem_Ch6;  use Sem_Ch6;
50 with Sem_Ch8;  use Sem_Ch8;
51 with Sem_Dist; use Sem_Dist;
52 with Sem_Eval; use Sem_Eval;
53 with Sem_Res;  use Sem_Res;
54 with Sem_Type; use Sem_Type;
55 with Sem_Util; use Sem_Util;
56 with Stand;    use Stand;
57 with Sinfo;    use Sinfo;
58 with Sinput;   use Sinput;
59 with Stringt;  use Stringt;
60 with Style;
61 with Stylesw;  use Stylesw;
62 with Targparm; use Targparm;
63 with Ttypes;   use Ttypes;
64 with Ttypef;   use Ttypef;
65 with Tbuild;   use Tbuild;
66 with Uintp;    use Uintp;
67 with Urealp;   use Urealp;
68
69 package body Sem_Attr is
70
71    True_Value  : constant Uint := Uint_1;
72    False_Value : constant Uint := Uint_0;
73    --  Synonyms to be used when these constants are used as Boolean values
74
75    Bad_Attribute : exception;
76    --  Exception raised if an error is detected during attribute processing,
77    --  used so that we can abandon the processing so we don't run into
78    --  trouble with cascaded errors.
79
80    --  The following array is the list of attributes defined in the Ada 83 RM
81    --  that are not included in Ada 95, but still get recognized in GNAT.
82
83    Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
84       Attribute_Address           |
85       Attribute_Aft               |
86       Attribute_Alignment         |
87       Attribute_Base              |
88       Attribute_Callable          |
89       Attribute_Constrained       |
90       Attribute_Count             |
91       Attribute_Delta             |
92       Attribute_Digits            |
93       Attribute_Emax              |
94       Attribute_Epsilon           |
95       Attribute_First             |
96       Attribute_First_Bit         |
97       Attribute_Fore              |
98       Attribute_Image             |
99       Attribute_Large             |
100       Attribute_Last              |
101       Attribute_Last_Bit          |
102       Attribute_Leading_Part      |
103       Attribute_Length            |
104       Attribute_Machine_Emax      |
105       Attribute_Machine_Emin      |
106       Attribute_Machine_Mantissa  |
107       Attribute_Machine_Overflows |
108       Attribute_Machine_Radix     |
109       Attribute_Machine_Rounds    |
110       Attribute_Mantissa          |
111       Attribute_Pos               |
112       Attribute_Position          |
113       Attribute_Pred              |
114       Attribute_Range             |
115       Attribute_Safe_Emax         |
116       Attribute_Safe_Large        |
117       Attribute_Safe_Small        |
118       Attribute_Size              |
119       Attribute_Small             |
120       Attribute_Storage_Size      |
121       Attribute_Succ              |
122       Attribute_Terminated        |
123       Attribute_Val               |
124       Attribute_Value             |
125       Attribute_Width             => True,
126       others                      => False);
127
128    --  The following array is the list of attributes defined in the Ada 2005
129    --  RM which are not defined in Ada 95. These are recognized in Ada 95 mode,
130    --  but in Ada 95 they are considered to be implementation defined.
131
132    Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'(
133       Attribute_Machine_Rounding  |
134       Attribute_Priority          |
135       Attribute_Stream_Size       |
136       Attribute_Wide_Wide_Width   => True,
137       others                      => False);
138
139    --  The following array contains all attributes that imply a modification
140    --  of their prefixes or result in an access value. Such prefixes can be
141    --  considered as lvalues.
142
143    Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array :=
144       Attribute_Class_Array'(
145       Attribute_Access              |
146       Attribute_Address             |
147       Attribute_Input               |
148       Attribute_Read                |
149       Attribute_Unchecked_Access    |
150       Attribute_Unrestricted_Access => True,
151       others                        => False);
152
153    -----------------------
154    -- Local_Subprograms --
155    -----------------------
156
157    procedure Eval_Attribute (N : Node_Id);
158    --  Performs compile time evaluation of attributes where possible, leaving
159    --  the Is_Static_Expression/Raises_Constraint_Error flags appropriately
160    --  set, and replacing the node with a literal node if the value can be
161    --  computed at compile time. All static attribute references are folded,
162    --  as well as a number of cases of non-static attributes that can always
163    --  be computed at compile time (e.g. floating-point model attributes that
164    --  are applied to non-static subtypes). Of course in such cases, the
165    --  Is_Static_Expression flag will not be set on the resulting literal.
166    --  Note that the only required action of this procedure is to catch the
167    --  static expression cases as described in the RM. Folding of other cases
168    --  is done where convenient, but some additional non-static folding is in
169    --  N_Expand_Attribute_Reference in cases where this is more convenient.
170
171    function Is_Anonymous_Tagged_Base
172      (Anon : Entity_Id;
173       Typ  : Entity_Id)
174       return Boolean;
175    --  For derived tagged types that constrain parent discriminants we build
176    --  an anonymous unconstrained base type. We need to recognize the relation
177    --  between the two when analyzing an access attribute for a constrained
178    --  component, before the full declaration for Typ has been analyzed, and
179    --  where therefore the prefix of the attribute does not match the enclosing
180    --  scope.
181
182    -----------------------
183    -- Analyze_Attribute --
184    -----------------------
185
186    procedure Analyze_Attribute (N : Node_Id) is
187       Loc     : constant Source_Ptr   := Sloc (N);
188       Aname   : constant Name_Id      := Attribute_Name (N);
189       P       : constant Node_Id      := Prefix (N);
190       Exprs   : constant List_Id      := Expressions (N);
191       Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
192       E1      : Node_Id;
193       E2      : Node_Id;
194
195       P_Type : Entity_Id;
196       --  Type of prefix after analysis
197
198       P_Base_Type : Entity_Id;
199       --  Base type of prefix after analysis
200
201       -----------------------
202       -- Local Subprograms --
203       -----------------------
204
205       procedure Analyze_Access_Attribute;
206       --  Used for Access, Unchecked_Access, Unrestricted_Access attributes.
207       --  Internally, Id distinguishes which of the three cases is involved.
208
209       procedure Check_Array_Or_Scalar_Type;
210       --  Common procedure used by First, Last, Range attribute to check
211       --  that the prefix is a constrained array or scalar type, or a name
212       --  of an array object, and that an argument appears only if appropriate
213       --  (i.e. only in the array case).
214
215       procedure Check_Array_Type;
216       --  Common semantic checks for all array attributes. Checks that the
217       --  prefix is a constrained array type or the name of an array object.
218       --  The error message for non-arrays is specialized appropriately.
219
220       procedure Check_Asm_Attribute;
221       --  Common semantic checks for Asm_Input and Asm_Output attributes
222
223       procedure Check_Component;
224       --  Common processing for Bit_Position, First_Bit, Last_Bit, and
225       --  Position. Checks prefix is an appropriate selected component.
226
227       procedure Check_Decimal_Fixed_Point_Type;
228       --  Check that prefix of attribute N is a decimal fixed-point type
229
230       procedure Check_Dereference;
231       --  If the prefix of attribute is an object of an access type, then
232       --  introduce an explicit deference, and adjust P_Type accordingly.
233
234       procedure Check_Discrete_Type;
235       --  Verify that prefix of attribute N is a discrete type
236
237       procedure Check_E0;
238       --  Check that no attribute arguments are present
239
240       procedure Check_Either_E0_Or_E1;
241       --  Check that there are zero or one attribute arguments present
242
243       procedure Check_E1;
244       --  Check that exactly one attribute argument is present
245
246       procedure Check_E2;
247       --  Check that two attribute arguments are present
248
249       procedure Check_Enum_Image;
250       --  If the prefix type is an enumeration type, set all its literals
251       --  as referenced, since the image function could possibly end up
252       --  referencing any of the literals indirectly.
253
254       procedure Check_Fixed_Point_Type;
255       --  Verify that prefix of attribute N is a fixed type
256
257       procedure Check_Fixed_Point_Type_0;
258       --  Verify that prefix of attribute N is a fixed type and that
259       --  no attribute expressions are present
260
261       procedure Check_Floating_Point_Type;
262       --  Verify that prefix of attribute N is a float type
263
264       procedure Check_Floating_Point_Type_0;
265       --  Verify that prefix of attribute N is a float type and that
266       --  no attribute expressions are present
267
268       procedure Check_Floating_Point_Type_1;
269       --  Verify that prefix of attribute N is a float type and that
270       --  exactly one attribute expression is present
271
272       procedure Check_Floating_Point_Type_2;
273       --  Verify that prefix of attribute N is a float type and that
274       --  two attribute expressions are present
275
276       procedure Legal_Formal_Attribute;
277       --  Common processing for attributes Definite, Has_Access_Values,
278       --  and Has_Discriminants
279
280       procedure Check_Integer_Type;
281       --  Verify that prefix of attribute N is an integer type
282
283       procedure Check_Library_Unit;
284       --  Verify that prefix of attribute N is a library unit
285
286       procedure Check_Modular_Integer_Type;
287       --  Verify that prefix of attribute N is a modular integer type
288
289       procedure Check_Not_Incomplete_Type;
290       --  Check that P (the prefix of the attribute) is not an incomplete
291       --  type or a private type for which no full view has been given.
292
293       procedure Check_Object_Reference (P : Node_Id);
294       --  Check that P (the prefix of the attribute) is an object reference
295
296       procedure Check_Program_Unit;
297       --  Verify that prefix of attribute N is a program unit
298
299       procedure Check_Real_Type;
300       --  Verify that prefix of attribute N is fixed or float type
301
302       procedure Check_Scalar_Type;
303       --  Verify that prefix of attribute N is a scalar type
304
305       procedure Check_Standard_Prefix;
306       --  Verify that prefix of attribute N is package Standard
307
308       procedure Check_Stream_Attribute (Nam : TSS_Name_Type);
309       --  Validity checking for stream attribute. Nam is the TSS name of the
310       --  corresponding possible defined attribute function (e.g. for the
311       --  Read attribute, Nam will be TSS_Stream_Read).
312
313       procedure Check_Task_Prefix;
314       --  Verify that prefix of attribute N is a task or task type
315
316       procedure Check_Type;
317       --  Verify that the prefix of attribute N is a type
318
319       procedure Check_Unit_Name (Nod : Node_Id);
320       --  Check that Nod is of the form of a library unit name, i.e that
321       --  it is an identifier, or a selected component whose prefix is
322       --  itself of the form of a library unit name. Note that this is
323       --  quite different from Check_Program_Unit, since it only checks
324       --  the syntactic form of the name, not the semantic identity. This
325       --  is because it is used with attributes (Elab_Body, Elab_Spec, and
326       --  UET_Address) which can refer to non-visible unit.
327
328       procedure Error_Attr (Msg : String; Error_Node : Node_Id);
329       pragma No_Return (Error_Attr);
330       procedure Error_Attr;
331       pragma No_Return (Error_Attr);
332       --  Posts error using Error_Msg_N at given node, sets type of attribute
333       --  node to Any_Type, and then raises Bad_Attribute to avoid any further
334       --  semantic processing. The message typically contains a % insertion
335       --  character which is replaced by the attribute name. The call with
336       --  no arguments is used when the caller has already generated the
337       --  required error messages.
338
339       procedure Error_Attr_P (Msg : String);
340       pragma No_Return (Error_Attr);
341       --  Like Error_Attr, but error is posted at the start of the prefix
342
343       procedure Standard_Attribute (Val : Int);
344       --  Used to process attributes whose prefix is package Standard which
345       --  yield values of type Universal_Integer. The attribute reference
346       --  node is rewritten with an integer literal of the given value.
347
348       procedure Unexpected_Argument (En : Node_Id);
349       --  Signal unexpected attribute argument (En is the argument)
350
351       procedure Validate_Non_Static_Attribute_Function_Call;
352       --  Called when processing an attribute that is a function call to a
353       --  non-static function, i.e. an attribute function that either takes
354       --  non-scalar arguments or returns a non-scalar result. Verifies that
355       --  such a call does not appear in a preelaborable context.
356
357       ------------------------------
358       -- Analyze_Access_Attribute --
359       ------------------------------
360
361       procedure Analyze_Access_Attribute is
362          Acc_Type : Entity_Id;
363
364          Scop : Entity_Id;
365          Typ  : Entity_Id;
366
367          function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id;
368          --  Build an access-to-object type whose designated type is DT,
369          --  and whose Ekind is appropriate to the attribute type. The
370          --  type that is constructed is returned as the result.
371
372          procedure Build_Access_Subprogram_Type (P : Node_Id);
373          --  Build an access to subprogram whose designated type is
374          --  the type of the prefix. If prefix is overloaded, so it the
375          --  node itself. The result is stored in Acc_Type.
376
377          function OK_Self_Reference return Boolean;
378          --  An access reference whose prefix is a type can legally appear
379          --  within an aggregate, where it is obtained by expansion of
380          --  a defaulted aggregate. The enclosing aggregate that contains
381          --  the self-referenced is flagged so that the self-reference can
382          --  be expanded into a reference to the target object (see exp_aggr).
383
384          ------------------------------
385          -- Build_Access_Object_Type --
386          ------------------------------
387
388          function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is
389             Typ : constant Entity_Id :=
390                     New_Internal_Entity
391                       (E_Access_Attribute_Type, Current_Scope, Loc, 'A');
392          begin
393             Set_Etype                     (Typ, Typ);
394             Init_Size_Align               (Typ);
395             Set_Is_Itype                  (Typ);
396             Set_Associated_Node_For_Itype (Typ, N);
397             Set_Directly_Designated_Type  (Typ, DT);
398             return Typ;
399          end Build_Access_Object_Type;
400
401          ----------------------------------
402          -- Build_Access_Subprogram_Type --
403          ----------------------------------
404
405          procedure Build_Access_Subprogram_Type (P : Node_Id) is
406             Index : Interp_Index;
407             It    : Interp;
408
409             procedure Check_Local_Access (E : Entity_Id);
410             --  Deal with possible access to local subprogram. If we have such
411             --  an access, we set a flag to kill all tracked values on any call
412             --  because this access value may be passed around, and any called
413             --  code might use it to access a local procedure which clobbers a
414             --  tracked value.
415
416             function Get_Kind (E : Entity_Id) return Entity_Kind;
417             --  Distinguish between access to regular/protected subprograms
418
419             ------------------------
420             -- Check_Local_Access --
421             ------------------------
422
423             procedure Check_Local_Access (E : Entity_Id) is
424             begin
425                if not Is_Library_Level_Entity (E) then
426                   Set_Suppress_Value_Tracking_On_Call (Current_Scope);
427                end if;
428             end Check_Local_Access;
429
430             --------------
431             -- Get_Kind --
432             --------------
433
434             function Get_Kind (E : Entity_Id) return Entity_Kind is
435             begin
436                if Convention (E) = Convention_Protected then
437                   return E_Access_Protected_Subprogram_Type;
438                else
439                   return E_Access_Subprogram_Type;
440                end if;
441             end Get_Kind;
442
443          --  Start of processing for Build_Access_Subprogram_Type
444
445          begin
446             --  In the case of an access to subprogram, use the name of the
447             --  subprogram itself as the designated type. Type-checking in
448             --  this case compares the signatures of the designated types.
449
450             Set_Etype (N, Any_Type);
451
452             if not Is_Overloaded (P) then
453                Check_Local_Access (Entity (P));
454
455                if not Is_Intrinsic_Subprogram (Entity (P)) then
456                   Acc_Type :=
457                     New_Internal_Entity
458                       (Get_Kind (Entity (P)), Current_Scope, Loc, 'A');
459                   Set_Etype (Acc_Type, Acc_Type);
460                   Set_Directly_Designated_Type (Acc_Type, Entity (P));
461                   Set_Etype (N, Acc_Type);
462                end if;
463
464             else
465                Get_First_Interp (P, Index, It);
466                while Present (It.Nam) loop
467                   Check_Local_Access (It.Nam);
468
469                   if not Is_Intrinsic_Subprogram (It.Nam) then
470                      Acc_Type :=
471                        New_Internal_Entity
472                          (Get_Kind (It.Nam), Current_Scope, Loc, 'A');
473                      Set_Etype (Acc_Type, Acc_Type);
474                      Set_Directly_Designated_Type (Acc_Type, It.Nam);
475                      Add_One_Interp (N, Acc_Type, Acc_Type);
476                   end if;
477
478                   Get_Next_Interp (Index, It);
479                end loop;
480             end if;
481
482             --  Cannot be applied to intrinsic. Looking at the tests above,
483             --  the only way Etype (N) can still be set to Any_Type is if
484             --  Is_Intrinsic_Subprogram was True for some referenced entity.
485
486             if Etype (N) = Any_Type then
487                Error_Attr_P ("prefix of % attribute cannot be intrinsic");
488             end if;
489          end Build_Access_Subprogram_Type;
490
491          ----------------------
492          -- OK_Self_Reference --
493          ----------------------
494
495          function OK_Self_Reference return Boolean is
496             Par : Node_Id;
497
498          begin
499             Par := Parent (N);
500             while Present (Par)
501               and then
502                (Nkind (Par) = N_Component_Association
503                  or else Nkind (Par) in N_Subexpr)
504             loop
505                if Nkind (Par) = N_Aggregate
506                  or else Nkind (Par) = N_Extension_Aggregate
507                then
508                   if Etype (Par) = Typ then
509                      Set_Has_Self_Reference (Par);
510                      return True;
511                   end if;
512                end if;
513
514                Par := Parent (Par);
515             end loop;
516
517             --  No enclosing aggregate, or not a self-reference
518
519             return False;
520          end OK_Self_Reference;
521
522       --  Start of processing for Analyze_Access_Attribute
523
524       begin
525          Check_E0;
526
527          if Nkind (P) = N_Character_Literal then
528             Error_Attr_P
529               ("prefix of % attribute cannot be enumeration literal");
530          end if;
531
532          --  Case of access to subprogram
533
534          if Is_Entity_Name (P)
535            and then Is_Overloadable (Entity (P))
536          then
537             --  Not allowed for nested subprograms if No_Implicit_Dynamic_Code
538             --  restriction set (since in general a trampoline is required).
539
540             if not Is_Library_Level_Entity (Entity (P)) then
541                Check_Restriction (No_Implicit_Dynamic_Code, P);
542             end if;
543
544             if Is_Always_Inlined (Entity (P)) then
545                Error_Attr_P
546                  ("prefix of % attribute cannot be Inline_Always subprogram");
547             end if;
548
549             if Aname = Name_Unchecked_Access then
550                Error_Attr ("attribute% cannot be applied to a subprogram", P);
551             end if;
552
553             --  Build the appropriate subprogram type
554
555             Build_Access_Subprogram_Type (P);
556
557             --  For unrestricted access, kill current values, since this
558             --  attribute allows a reference to a local subprogram that
559             --  could modify local variables to be passed out of scope
560
561             if Aname = Name_Unrestricted_Access then
562                Kill_Current_Values;
563             end if;
564
565             return;
566
567          --  Component is an operation of a protected type
568
569          elsif Nkind (P) = N_Selected_Component
570            and then Is_Overloadable (Entity (Selector_Name (P)))
571          then
572             if Ekind (Entity (Selector_Name (P))) = E_Entry then
573                Error_Attr_P ("prefix of % attribute must be subprogram");
574             end if;
575
576             Build_Access_Subprogram_Type (Selector_Name (P));
577             return;
578          end if;
579
580          --  Deal with incorrect reference to a type, but note that some
581          --  accesses are allowed: references to the current type instance,
582          --  or in Ada 2005 self-referential pointer in a default-initialized
583          --  aggregate.
584
585          if Is_Entity_Name (P) then
586             Typ := Entity (P);
587
588             --  The reference may appear in an aggregate that has been expanded
589             --  into a loop. Locate scope of type definition, if any.
590
591             Scop := Current_Scope;
592             while Ekind (Scop) = E_Loop loop
593                Scop := Scope (Scop);
594             end loop;
595
596             if Is_Type (Typ) then
597
598                --  OK if we are within the scope of a limited type
599                --  let's mark the component as having per object constraint
600
601                if Is_Anonymous_Tagged_Base (Scop, Typ) then
602                   Typ := Scop;
603                   Set_Entity (P, Typ);
604                   Set_Etype  (P, Typ);
605                end if;
606
607                if Typ = Scop then
608                   declare
609                      Q : Node_Id := Parent (N);
610
611                   begin
612                      while Present (Q)
613                        and then Nkind (Q) /= N_Component_Declaration
614                      loop
615                         Q := Parent (Q);
616                      end loop;
617
618                      if Present (Q) then
619                         Set_Has_Per_Object_Constraint (
620                           Defining_Identifier (Q), True);
621                      end if;
622                   end;
623
624                   if Nkind (P) = N_Expanded_Name then
625                      Error_Msg_F
626                        ("current instance prefix must be a direct name", P);
627                   end if;
628
629                   --  If a current instance attribute appears within a
630                   --  a component constraint it must appear alone; other
631                   --  contexts (default expressions, within a task body)
632                   --  are not subject to this restriction.
633
634                   if not In_Default_Expression
635                     and then not Has_Completion (Scop)
636                     and then
637                       Nkind (Parent (N)) /= N_Discriminant_Association
638                     and then
639                       Nkind (Parent (N)) /= N_Index_Or_Discriminant_Constraint
640                   then
641                      Error_Msg_N
642                        ("current instance attribute must appear alone", N);
643                   end if;
644
645                --  OK if we are in initialization procedure for the type
646                --  in question, in which case the reference to the type
647                --  is rewritten as a reference to the current object.
648
649                elsif Ekind (Scop) = E_Procedure
650                  and then Is_Init_Proc (Scop)
651                  and then Etype (First_Formal (Scop)) = Typ
652                then
653                   Rewrite (N,
654                     Make_Attribute_Reference (Loc,
655                       Prefix         => Make_Identifier (Loc, Name_uInit),
656                       Attribute_Name => Name_Unrestricted_Access));
657                   Analyze (N);
658                   return;
659
660                --  OK if a task type, this test needs sharpening up ???
661
662                elsif Is_Task_Type (Typ) then
663                   null;
664
665                --  OK if self-reference in an aggregate in Ada 2005, and
666                --  the reference comes from a copied default expression.
667
668                --  Note that we check legality of self-reference even if the
669                --  expression comes from source, e.g. when a single component
670                --  association in an aggregate has a box association.
671
672                elsif Ada_Version >= Ada_05
673                  and then OK_Self_Reference
674                then
675                   null;
676
677                --  Otherwise we have an error case
678
679                else
680                   Error_Attr ("% attribute cannot be applied to type", P);
681                   return;
682                end if;
683             end if;
684          end if;
685
686          --  If we fall through, we have a normal access to object case.
687          --  Unrestricted_Access is legal wherever an allocator would be
688          --  legal, so its Etype is set to E_Allocator. The expected type
689          --  of the other attributes is a general access type, and therefore
690          --  we label them with E_Access_Attribute_Type.
691
692          if not Is_Overloaded (P) then
693             Acc_Type := Build_Access_Object_Type (P_Type);
694             Set_Etype (N, Acc_Type);
695          else
696             declare
697                Index : Interp_Index;
698                It    : Interp;
699             begin
700                Set_Etype (N, Any_Type);
701                Get_First_Interp (P, Index, It);
702                while Present (It.Typ) loop
703                   Acc_Type := Build_Access_Object_Type (It.Typ);
704                   Add_One_Interp (N, Acc_Type, Acc_Type);
705                   Get_Next_Interp (Index, It);
706                end loop;
707             end;
708          end if;
709
710          --  Special cases when we can find a prefix that is an entity name
711
712          declare
713             PP  : Node_Id;
714             Ent : Entity_Id;
715
716          begin
717             PP := P;
718             loop
719                if Is_Entity_Name (PP) then
720                   Ent := Entity (PP);
721
722                   --  If we have an access to an object, and the attribute
723                   --  comes from source, then set the object as potentially
724                   --  source modified. We do this because the resulting access
725                   --  pointer can be used to modify the variable, and we might
726                   --  not detect this, leading to some junk warnings.
727
728                   Set_Never_Set_In_Source (Ent, False);
729
730                   --  Mark entity as address taken, and kill current values
731
732                   Set_Address_Taken (Ent);
733                   Kill_Current_Values (Ent);
734                   exit;
735
736                elsif Nkind (PP) = N_Selected_Component
737                  or else Nkind (PP) = N_Indexed_Component
738                then
739                   PP := Prefix (PP);
740
741                else
742                   exit;
743                end if;
744             end loop;
745          end;
746
747          --  Check for aliased view unless unrestricted case. We allow a
748          --  nonaliased prefix when within an instance because the prefix may
749          --  have been a tagged formal object, which is defined to be aliased
750          --  even when the actual might not be (other instance cases will have
751          --  been caught in the generic). Similarly, within an inlined body we
752          --  know that the attribute is legal in the original subprogram, and
753          --  therefore legal in the expansion.
754
755          if Aname /= Name_Unrestricted_Access
756            and then not Is_Aliased_View (P)
757            and then not In_Instance
758            and then not In_Inlined_Body
759          then
760             Error_Attr_P ("prefix of % attribute must be aliased");
761          end if;
762       end Analyze_Access_Attribute;
763
764       --------------------------------
765       -- Check_Array_Or_Scalar_Type --
766       --------------------------------
767
768       procedure Check_Array_Or_Scalar_Type is
769          Index : Entity_Id;
770
771          D : Int;
772          --  Dimension number for array attributes
773
774       begin
775          --  Case of string literal or string literal subtype. These cases
776          --  cannot arise from legal Ada code, but the expander is allowed
777          --  to generate them. They require special handling because string
778          --  literal subtypes do not have standard bounds (the whole idea
779          --  of these subtypes is to avoid having to generate the bounds)
780
781          if Ekind (P_Type) = E_String_Literal_Subtype then
782             Set_Etype (N, Etype (First_Index (P_Base_Type)));
783             return;
784
785          --  Scalar types
786
787          elsif Is_Scalar_Type (P_Type) then
788             Check_Type;
789
790             if Present (E1) then
791                Error_Attr ("invalid argument in % attribute", E1);
792             else
793                Set_Etype (N, P_Base_Type);
794                return;
795             end if;
796
797          --  The following is a special test to allow 'First to apply to
798          --  private scalar types if the attribute comes from generated
799          --  code. This occurs in the case of Normalize_Scalars code.
800
801          elsif Is_Private_Type (P_Type)
802            and then Present (Full_View (P_Type))
803            and then Is_Scalar_Type (Full_View (P_Type))
804            and then not Comes_From_Source (N)
805          then
806             Set_Etype (N, Implementation_Base_Type (P_Type));
807
808          --  Array types other than string literal subtypes handled above
809
810          else
811             Check_Array_Type;
812
813             --  We know prefix is an array type, or the name of an array
814             --  object, and that the expression, if present, is static
815             --  and within the range of the dimensions of the type.
816
817             pragma Assert (Is_Array_Type (P_Type));
818             Index := First_Index (P_Base_Type);
819
820             if No (E1) then
821
822                --  First dimension assumed
823
824                Set_Etype (N, Base_Type (Etype (Index)));
825
826             else
827                D := UI_To_Int (Intval (E1));
828
829                for J in 1 .. D - 1 loop
830                   Next_Index (Index);
831                end loop;
832
833                Set_Etype (N, Base_Type (Etype (Index)));
834                Set_Etype (E1, Standard_Integer);
835             end if;
836          end if;
837       end Check_Array_Or_Scalar_Type;
838
839       ----------------------
840       -- Check_Array_Type --
841       ----------------------
842
843       procedure Check_Array_Type is
844          D : Int;
845          --  Dimension number for array attributes
846
847       begin
848          --  If the type is a string literal type, then this must be generated
849          --  internally, and no further check is required on its legality.
850
851          if Ekind (P_Type) = E_String_Literal_Subtype then
852             return;
853
854          --  If the type is a composite, it is an illegal aggregate, no point
855          --  in going on.
856
857          elsif P_Type = Any_Composite then
858             raise Bad_Attribute;
859          end if;
860
861          --  Normal case of array type or subtype
862
863          Check_Either_E0_Or_E1;
864          Check_Dereference;
865
866          if Is_Array_Type (P_Type) then
867             if not Is_Constrained (P_Type)
868               and then Is_Entity_Name (P)
869               and then Is_Type (Entity (P))
870             then
871                --  Note: we do not call Error_Attr here, since we prefer to
872                --  continue, using the relevant index type of the array,
873                --  even though it is unconstrained. This gives better error
874                --  recovery behavior.
875
876                Error_Msg_Name_1 := Aname;
877                Error_Msg_F
878                  ("prefix for % attribute must be constrained array", P);
879             end if;
880
881             D := Number_Dimensions (P_Type);
882
883          else
884             if Is_Private_Type (P_Type) then
885                Error_Attr_P ("prefix for % attribute may not be private type");
886
887             elsif Is_Access_Type (P_Type)
888               and then Is_Array_Type (Designated_Type (P_Type))
889               and then Is_Entity_Name (P)
890               and then Is_Type (Entity (P))
891             then
892                Error_Attr_P ("prefix of % attribute cannot be access type");
893
894             elsif Attr_Id = Attribute_First
895                     or else
896                   Attr_Id = Attribute_Last
897             then
898                Error_Attr ("invalid prefix for % attribute", P);
899
900             else
901                Error_Attr_P ("prefix for % attribute must be array");
902             end if;
903          end if;
904
905          if Present (E1) then
906             Resolve (E1, Any_Integer);
907             Set_Etype (E1, Standard_Integer);
908
909             if not Is_Static_Expression (E1)
910               or else Raises_Constraint_Error (E1)
911             then
912                Flag_Non_Static_Expr
913                  ("expression for dimension must be static!", E1);
914                Error_Attr;
915
916             elsif  UI_To_Int (Expr_Value (E1)) > D
917               or else UI_To_Int (Expr_Value (E1)) < 1
918             then
919                Error_Attr ("invalid dimension number for array type", E1);
920             end if;
921          end if;
922
923          if (Style_Check and Style_Check_Array_Attribute_Index)
924            and then Comes_From_Source (N)
925          then
926             Style.Check_Array_Attribute_Index (N, E1, D);
927          end if;
928       end Check_Array_Type;
929
930       -------------------------
931       -- Check_Asm_Attribute --
932       -------------------------
933
934       procedure Check_Asm_Attribute is
935       begin
936          Check_Type;
937          Check_E2;
938
939          --  Check first argument is static string expression
940
941          Analyze_And_Resolve (E1, Standard_String);
942
943          if Etype (E1) = Any_Type then
944             return;
945
946          elsif not Is_OK_Static_Expression (E1) then
947             Flag_Non_Static_Expr
948               ("constraint argument must be static string expression!", E1);
949             Error_Attr;
950          end if;
951
952          --  Check second argument is right type
953
954          Analyze_And_Resolve (E2, Entity (P));
955
956          --  Note: that is all we need to do, we don't need to check
957          --  that it appears in a correct context. The Ada type system
958          --  will do that for us.
959
960       end Check_Asm_Attribute;
961
962       ---------------------
963       -- Check_Component --
964       ---------------------
965
966       procedure Check_Component is
967       begin
968          Check_E0;
969
970          if Nkind (P) /= N_Selected_Component
971            or else
972              (Ekind (Entity (Selector_Name (P))) /= E_Component
973                and then
974               Ekind (Entity (Selector_Name (P))) /= E_Discriminant)
975          then
976             Error_Attr_P ("prefix for % attribute must be selected component");
977          end if;
978       end Check_Component;
979
980       ------------------------------------
981       -- Check_Decimal_Fixed_Point_Type --
982       ------------------------------------
983
984       procedure Check_Decimal_Fixed_Point_Type is
985       begin
986          Check_Type;
987
988          if not Is_Decimal_Fixed_Point_Type (P_Type) then
989             Error_Attr_P ("prefix of % attribute must be decimal type");
990          end if;
991       end Check_Decimal_Fixed_Point_Type;
992
993       -----------------------
994       -- Check_Dereference --
995       -----------------------
996
997       procedure Check_Dereference is
998       begin
999
1000          --  Case of a subtype mark
1001
1002          if Is_Entity_Name (P)
1003            and then Is_Type (Entity (P))
1004          then
1005             return;
1006          end if;
1007
1008          --  Case of an expression
1009
1010          Resolve (P);
1011
1012          if Is_Access_Type (P_Type) then
1013
1014             --  If there is an implicit dereference, then we must freeze
1015             --  the designated type of the access type, since the type of
1016             --  the referenced array is this type (see AI95-00106).
1017
1018             Freeze_Before (N, Designated_Type (P_Type));
1019
1020             Rewrite (P,
1021               Make_Explicit_Dereference (Sloc (P),
1022                 Prefix => Relocate_Node (P)));
1023
1024             Analyze_And_Resolve (P);
1025             P_Type := Etype (P);
1026
1027             if P_Type = Any_Type then
1028                raise Bad_Attribute;
1029             end if;
1030
1031             P_Base_Type := Base_Type (P_Type);
1032          end if;
1033       end Check_Dereference;
1034
1035       -------------------------
1036       -- Check_Discrete_Type --
1037       -------------------------
1038
1039       procedure Check_Discrete_Type is
1040       begin
1041          Check_Type;
1042
1043          if not Is_Discrete_Type (P_Type) then
1044             Error_Attr_P ("prefix of % attribute must be discrete type");
1045          end if;
1046       end Check_Discrete_Type;
1047
1048       --------------
1049       -- Check_E0 --
1050       --------------
1051
1052       procedure Check_E0 is
1053       begin
1054          if Present (E1) then
1055             Unexpected_Argument (E1);
1056          end if;
1057       end Check_E0;
1058
1059       --------------
1060       -- Check_E1 --
1061       --------------
1062
1063       procedure Check_E1 is
1064       begin
1065          Check_Either_E0_Or_E1;
1066
1067          if No (E1) then
1068
1069             --  Special-case attributes that are functions and that appear as
1070             --  the prefix of another attribute. Error is posted on parent.
1071
1072             if Nkind (Parent (N)) = N_Attribute_Reference
1073               and then (Attribute_Name (Parent (N)) = Name_Address
1074                           or else
1075                         Attribute_Name (Parent (N)) = Name_Code_Address
1076                           or else
1077                         Attribute_Name (Parent (N)) = Name_Access)
1078             then
1079                Error_Msg_Name_1 := Attribute_Name (Parent (N));
1080                Error_Msg_N ("illegal prefix for % attribute", Parent (N));
1081                Set_Etype (Parent (N), Any_Type);
1082                Set_Entity (Parent (N), Any_Type);
1083                raise Bad_Attribute;
1084
1085             else
1086                Error_Attr ("missing argument for % attribute", N);
1087             end if;
1088          end if;
1089       end Check_E1;
1090
1091       --------------
1092       -- Check_E2 --
1093       --------------
1094
1095       procedure Check_E2 is
1096       begin
1097          if No (E1) then
1098             Error_Attr ("missing arguments for % attribute (2 required)", N);
1099          elsif No (E2) then
1100             Error_Attr ("missing argument for % attribute (2 required)", N);
1101          end if;
1102       end Check_E2;
1103
1104       ---------------------------
1105       -- Check_Either_E0_Or_E1 --
1106       ---------------------------
1107
1108       procedure Check_Either_E0_Or_E1 is
1109       begin
1110          if Present (E2) then
1111             Unexpected_Argument (E2);
1112          end if;
1113       end Check_Either_E0_Or_E1;
1114
1115       ----------------------
1116       -- Check_Enum_Image --
1117       ----------------------
1118
1119       procedure Check_Enum_Image is
1120          Lit : Entity_Id;
1121       begin
1122          if Is_Enumeration_Type (P_Base_Type) then
1123             Lit := First_Literal (P_Base_Type);
1124             while Present (Lit) loop
1125                Set_Referenced (Lit);
1126                Next_Literal (Lit);
1127             end loop;
1128          end if;
1129       end Check_Enum_Image;
1130
1131       ----------------------------
1132       -- Check_Fixed_Point_Type --
1133       ----------------------------
1134
1135       procedure Check_Fixed_Point_Type is
1136       begin
1137          Check_Type;
1138
1139          if not Is_Fixed_Point_Type (P_Type) then
1140             Error_Attr_P ("prefix of % attribute must be fixed point type");
1141          end if;
1142       end Check_Fixed_Point_Type;
1143
1144       ------------------------------
1145       -- Check_Fixed_Point_Type_0 --
1146       ------------------------------
1147
1148       procedure Check_Fixed_Point_Type_0 is
1149       begin
1150          Check_Fixed_Point_Type;
1151          Check_E0;
1152       end Check_Fixed_Point_Type_0;
1153
1154       -------------------------------
1155       -- Check_Floating_Point_Type --
1156       -------------------------------
1157
1158       procedure Check_Floating_Point_Type is
1159       begin
1160          Check_Type;
1161
1162          if not Is_Floating_Point_Type (P_Type) then
1163             Error_Attr_P ("prefix of % attribute must be float type");
1164          end if;
1165       end Check_Floating_Point_Type;
1166
1167       ---------------------------------
1168       -- Check_Floating_Point_Type_0 --
1169       ---------------------------------
1170
1171       procedure Check_Floating_Point_Type_0 is
1172       begin
1173          Check_Floating_Point_Type;
1174          Check_E0;
1175       end Check_Floating_Point_Type_0;
1176
1177       ---------------------------------
1178       -- Check_Floating_Point_Type_1 --
1179       ---------------------------------
1180
1181       procedure Check_Floating_Point_Type_1 is
1182       begin
1183          Check_Floating_Point_Type;
1184          Check_E1;
1185       end Check_Floating_Point_Type_1;
1186
1187       ---------------------------------
1188       -- Check_Floating_Point_Type_2 --
1189       ---------------------------------
1190
1191       procedure Check_Floating_Point_Type_2 is
1192       begin
1193          Check_Floating_Point_Type;
1194          Check_E2;
1195       end Check_Floating_Point_Type_2;
1196
1197       ------------------------
1198       -- Check_Integer_Type --
1199       ------------------------
1200
1201       procedure Check_Integer_Type is
1202       begin
1203          Check_Type;
1204
1205          if not Is_Integer_Type (P_Type) then
1206             Error_Attr_P ("prefix of % attribute must be integer type");
1207          end if;
1208       end Check_Integer_Type;
1209
1210       ------------------------
1211       -- Check_Library_Unit --
1212       ------------------------
1213
1214       procedure Check_Library_Unit is
1215       begin
1216          if not Is_Compilation_Unit (Entity (P)) then
1217             Error_Attr_P ("prefix of % attribute must be library unit");
1218          end if;
1219       end Check_Library_Unit;
1220
1221       --------------------------------
1222       -- Check_Modular_Integer_Type --
1223       --------------------------------
1224
1225       procedure Check_Modular_Integer_Type is
1226       begin
1227          Check_Type;
1228
1229          if not Is_Modular_Integer_Type (P_Type) then
1230             Error_Attr_P
1231               ("prefix of % attribute must be modular integer type");
1232          end if;
1233       end Check_Modular_Integer_Type;
1234
1235       -------------------------------
1236       -- Check_Not_Incomplete_Type --
1237       -------------------------------
1238
1239       procedure Check_Not_Incomplete_Type is
1240          E   : Entity_Id;
1241          Typ : Entity_Id;
1242
1243       begin
1244          --  Ada 2005 (AI-50217, AI-326): If the prefix is an explicit
1245          --  dereference we have to check wrong uses of incomplete types
1246          --  (other wrong uses are checked at their freezing point).
1247
1248          --  Example 1: Limited-with
1249
1250          --    limited with Pkg;
1251          --    package P is
1252          --       type Acc is access Pkg.T;
1253          --       X : Acc;
1254          --       S : Integer := X.all'Size;                    -- ERROR
1255          --    end P;
1256
1257          --  Example 2: Tagged incomplete
1258
1259          --     type T is tagged;
1260          --     type Acc is access all T;
1261          --     X : Acc;
1262          --     S : constant Integer := X.all'Size;             -- ERROR
1263          --     procedure Q (Obj : Integer := X.all'Alignment); -- ERROR
1264
1265          if Ada_Version >= Ada_05
1266            and then Nkind (P) = N_Explicit_Dereference
1267          then
1268             E := P;
1269             while Nkind (E) = N_Explicit_Dereference loop
1270                E := Prefix (E);
1271             end loop;
1272
1273             if From_With_Type (Etype (E)) then
1274                Error_Attr_P
1275                  ("prefix of % attribute cannot be an incomplete type");
1276
1277             else
1278                if Is_Access_Type (Etype (E)) then
1279                   Typ := Directly_Designated_Type (Etype (E));
1280                else
1281                   Typ := Etype (E);
1282                end if;
1283
1284                if Ekind (Typ) = E_Incomplete_Type
1285                  and then No (Full_View (Typ))
1286                then
1287                   Error_Attr_P
1288                     ("prefix of % attribute cannot be an incomplete type");
1289                end if;
1290             end if;
1291          end if;
1292
1293          if not Is_Entity_Name (P)
1294            or else not Is_Type (Entity (P))
1295            or else In_Default_Expression
1296          then
1297             return;
1298          else
1299             Check_Fully_Declared (P_Type, P);
1300          end if;
1301       end Check_Not_Incomplete_Type;
1302
1303       ----------------------------
1304       -- Check_Object_Reference --
1305       ----------------------------
1306
1307       procedure Check_Object_Reference (P : Node_Id) is
1308          Rtyp : Entity_Id;
1309
1310       begin
1311          --  If we need an object, and we have a prefix that is the name of
1312          --  a function entity, convert it into a function call.
1313
1314          if Is_Entity_Name (P)
1315            and then Ekind (Entity (P)) = E_Function
1316          then
1317             Rtyp := Etype (Entity (P));
1318
1319             Rewrite (P,
1320               Make_Function_Call (Sloc (P),
1321                 Name => Relocate_Node (P)));
1322
1323             Analyze_And_Resolve (P, Rtyp);
1324
1325          --  Otherwise we must have an object reference
1326
1327          elsif not Is_Object_Reference (P) then
1328             Error_Attr_P ("prefix of % attribute must be object");
1329          end if;
1330       end Check_Object_Reference;
1331
1332       ------------------------
1333       -- Check_Program_Unit --
1334       ------------------------
1335
1336       procedure Check_Program_Unit is
1337       begin
1338          if Is_Entity_Name (P) then
1339             declare
1340                K : constant Entity_Kind := Ekind (Entity (P));
1341                T : constant Entity_Id   := Etype (Entity (P));
1342
1343             begin
1344                if K in Subprogram_Kind
1345                  or else K in Task_Kind
1346                  or else K in Protected_Kind
1347                  or else K = E_Package
1348                  or else K in Generic_Unit_Kind
1349                  or else (K = E_Variable
1350                             and then
1351                               (Is_Task_Type (T)
1352                                  or else
1353                                Is_Protected_Type (T)))
1354                then
1355                   return;
1356                end if;
1357             end;
1358          end if;
1359
1360          Error_Attr_P ("prefix of % attribute must be program unit");
1361       end Check_Program_Unit;
1362
1363       ---------------------
1364       -- Check_Real_Type --
1365       ---------------------
1366
1367       procedure Check_Real_Type is
1368       begin
1369          Check_Type;
1370
1371          if not Is_Real_Type (P_Type) then
1372             Error_Attr_P ("prefix of % attribute must be real type");
1373          end if;
1374       end Check_Real_Type;
1375
1376       -----------------------
1377       -- Check_Scalar_Type --
1378       -----------------------
1379
1380       procedure Check_Scalar_Type is
1381       begin
1382          Check_Type;
1383
1384          if not Is_Scalar_Type (P_Type) then
1385             Error_Attr_P ("prefix of % attribute must be scalar type");
1386          end if;
1387       end Check_Scalar_Type;
1388
1389       ---------------------------
1390       -- Check_Standard_Prefix --
1391       ---------------------------
1392
1393       procedure Check_Standard_Prefix is
1394       begin
1395          Check_E0;
1396
1397          if Nkind (P) /= N_Identifier
1398            or else Chars (P) /= Name_Standard
1399          then
1400             Error_Attr ("only allowed prefix for % attribute is Standard", P);
1401          end if;
1402
1403       end Check_Standard_Prefix;
1404
1405       ----------------------------
1406       -- Check_Stream_Attribute --
1407       ----------------------------
1408
1409       procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is
1410          Etyp : Entity_Id;
1411          Btyp : Entity_Id;
1412
1413       begin
1414          Validate_Non_Static_Attribute_Function_Call;
1415
1416          --  With the exception of 'Input, Stream attributes are procedures,
1417          --  and can only appear at the position of procedure calls. We check
1418          --  for this here, before they are rewritten, to give a more precise
1419          --  diagnostic.
1420
1421          if Nam = TSS_Stream_Input then
1422             null;
1423
1424          elsif Is_List_Member (N)
1425            and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
1426            and then Nkind (Parent (N)) /= N_Aggregate
1427          then
1428             null;
1429
1430          else
1431             Error_Attr
1432               ("invalid context for attribute%, which is a procedure", N);
1433          end if;
1434
1435          Check_Type;
1436          Btyp := Implementation_Base_Type (P_Type);
1437
1438          --  Stream attributes not allowed on limited types unless the
1439          --  attribute reference was generated by the expander (in which
1440          --  case the underlying type will be used, as described in Sinfo),
1441          --  or the attribute was specified explicitly for the type itself
1442          --  or one of its ancestors (taking visibility rules into account if
1443          --  in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp
1444          --  (with no visibility restriction).
1445
1446          if Comes_From_Source (N)
1447            and then not Stream_Attribute_Available (P_Type, Nam)
1448            and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert)
1449          then
1450             Error_Msg_Name_1 := Aname;
1451
1452             if Is_Limited_Type (P_Type) then
1453                Error_Msg_NE
1454                  ("limited type& has no% attribute", P, P_Type);
1455                Explain_Limited_Type (P_Type, P);
1456             else
1457                Error_Msg_NE
1458                  ("attribute% for type& is not available", P, P_Type);
1459             end if;
1460          end if;
1461
1462          --  Check for violation of restriction No_Stream_Attributes
1463
1464          if Is_RTE (P_Type, RE_Exception_Id)
1465               or else
1466             Is_RTE (P_Type, RE_Exception_Occurrence)
1467          then
1468             Check_Restriction (No_Exception_Registration, P);
1469          end if;
1470
1471          --  Here we must check that the first argument is an access type
1472          --  that is compatible with Ada.Streams.Root_Stream_Type'Class.
1473
1474          Analyze_And_Resolve (E1);
1475          Etyp := Etype (E1);
1476
1477          --  Note: the double call to Root_Type here is needed because the
1478          --  root type of a class-wide type is the corresponding type (e.g.
1479          --  X for X'Class, and we really want to go to the root.)
1480
1481          if not Is_Access_Type (Etyp)
1482            or else Root_Type (Root_Type (Designated_Type (Etyp))) /=
1483                      RTE (RE_Root_Stream_Type)
1484          then
1485             Error_Attr
1486               ("expected access to Ada.Streams.Root_Stream_Type''Class", E1);
1487          end if;
1488
1489          --  Check that the second argument is of the right type if there is
1490          --  one (the Input attribute has only one argument so this is skipped)
1491
1492          if Present (E2) then
1493             Analyze (E2);
1494
1495             if Nam = TSS_Stream_Read
1496               and then not Is_OK_Variable_For_Out_Formal (E2)
1497             then
1498                Error_Attr
1499                  ("second argument of % attribute must be a variable", E2);
1500             end if;
1501
1502             Resolve (E2, P_Type);
1503          end if;
1504       end Check_Stream_Attribute;
1505
1506       -----------------------
1507       -- Check_Task_Prefix --
1508       -----------------------
1509
1510       procedure Check_Task_Prefix is
1511       begin
1512          Analyze (P);
1513
1514          --  Ada 2005 (AI-345): Attribute 'Terminated can be applied to
1515          --  task interface class-wide types.
1516
1517          if Is_Task_Type (Etype (P))
1518            or else (Is_Access_Type (Etype (P))
1519                       and then Is_Task_Type (Designated_Type (Etype (P))))
1520            or else (Ada_Version >= Ada_05
1521                       and then Ekind (Etype (P)) = E_Class_Wide_Type
1522                       and then Is_Interface (Etype (P))
1523                       and then Is_Task_Interface (Etype (P)))
1524          then
1525             Resolve (P);
1526
1527          else
1528             if Ada_Version >= Ada_05 then
1529                Error_Attr_P
1530                  ("prefix of % attribute must be a task or a task " &
1531                   "interface class-wide object");
1532
1533             else
1534                Error_Attr_P ("prefix of % attribute must be a task");
1535             end if;
1536          end if;
1537       end Check_Task_Prefix;
1538
1539       ----------------
1540       -- Check_Type --
1541       ----------------
1542
1543       --  The possibilities are an entity name denoting a type, or an
1544       --  attribute reference that denotes a type (Base or Class). If
1545       --  the type is incomplete, replace it with its full view.
1546
1547       procedure Check_Type is
1548       begin
1549          if not Is_Entity_Name (P)
1550            or else not Is_Type (Entity (P))
1551          then
1552             Error_Attr_P ("prefix of % attribute must be a type");
1553
1554          elsif Ekind (Entity (P)) = E_Incomplete_Type
1555             and then Present (Full_View (Entity (P)))
1556          then
1557             P_Type := Full_View (Entity (P));
1558             Set_Entity (P, P_Type);
1559          end if;
1560       end Check_Type;
1561
1562       ---------------------
1563       -- Check_Unit_Name --
1564       ---------------------
1565
1566       procedure Check_Unit_Name (Nod : Node_Id) is
1567       begin
1568          if Nkind (Nod) = N_Identifier then
1569             return;
1570
1571          elsif Nkind (Nod) = N_Selected_Component then
1572             Check_Unit_Name (Prefix (Nod));
1573
1574             if Nkind (Selector_Name (Nod)) = N_Identifier then
1575                return;
1576             end if;
1577          end if;
1578
1579          Error_Attr ("argument for % attribute must be unit name", P);
1580       end Check_Unit_Name;
1581
1582       ----------------
1583       -- Error_Attr --
1584       ----------------
1585
1586       procedure Error_Attr is
1587       begin
1588          Set_Etype (N, Any_Type);
1589          Set_Entity (N, Any_Type);
1590          raise Bad_Attribute;
1591       end Error_Attr;
1592
1593       procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
1594       begin
1595          Error_Msg_Name_1 := Aname;
1596          Error_Msg_N (Msg, Error_Node);
1597          Error_Attr;
1598       end Error_Attr;
1599
1600       ------------------
1601       -- Error_Attr_P --
1602       ------------------
1603
1604       procedure Error_Attr_P (Msg : String) is
1605       begin
1606          Error_Msg_Name_1 := Aname;
1607          Error_Msg_F (Msg, P);
1608          Error_Attr;
1609       end Error_Attr_P;
1610
1611       ----------------------------
1612       -- Legal_Formal_Attribute --
1613       ----------------------------
1614
1615       procedure Legal_Formal_Attribute is
1616       begin
1617          Check_E0;
1618
1619          if not Is_Entity_Name (P)
1620            or else not Is_Type (Entity (P))
1621          then
1622             Error_Attr_P ("prefix of % attribute must be generic type");
1623
1624          elsif Is_Generic_Actual_Type (Entity (P))
1625            or else In_Instance
1626            or else In_Inlined_Body
1627          then
1628             null;
1629
1630          elsif Is_Generic_Type (Entity (P)) then
1631             if not Is_Indefinite_Subtype (Entity (P)) then
1632                Error_Attr_P
1633                  ("prefix of % attribute must be indefinite generic type");
1634             end if;
1635
1636          else
1637             Error_Attr_P
1638               ("prefix of % attribute must be indefinite generic type");
1639          end if;
1640
1641          Set_Etype (N, Standard_Boolean);
1642       end Legal_Formal_Attribute;
1643
1644       ------------------------
1645       -- Standard_Attribute --
1646       ------------------------
1647
1648       procedure Standard_Attribute (Val : Int) is
1649       begin
1650          Check_Standard_Prefix;
1651          Rewrite (N, Make_Integer_Literal (Loc, Val));
1652          Analyze (N);
1653       end Standard_Attribute;
1654
1655       -------------------------
1656       -- Unexpected Argument --
1657       -------------------------
1658
1659       procedure Unexpected_Argument (En : Node_Id) is
1660       begin
1661          Error_Attr ("unexpected argument for % attribute", En);
1662       end Unexpected_Argument;
1663
1664       -------------------------------------------------
1665       -- Validate_Non_Static_Attribute_Function_Call --
1666       -------------------------------------------------
1667
1668       --  This function should be moved to Sem_Dist ???
1669
1670       procedure Validate_Non_Static_Attribute_Function_Call is
1671       begin
1672          if In_Preelaborated_Unit
1673            and then not In_Subprogram_Or_Concurrent_Unit
1674          then
1675             Flag_Non_Static_Expr
1676               ("non-static function call in preelaborated unit!", N);
1677          end if;
1678       end Validate_Non_Static_Attribute_Function_Call;
1679
1680    -----------------------------------------------
1681    -- Start of Processing for Analyze_Attribute --
1682    -----------------------------------------------
1683
1684    begin
1685       --  Immediate return if unrecognized attribute (already diagnosed
1686       --  by parser, so there is nothing more that we need to do)
1687
1688       if not Is_Attribute_Name (Aname) then
1689          raise Bad_Attribute;
1690       end if;
1691
1692       --  Deal with Ada 83 issues
1693
1694       if Comes_From_Source (N) then
1695          if not Attribute_83 (Attr_Id) then
1696             if Ada_Version = Ada_83 and then Comes_From_Source (N) then
1697                Error_Msg_Name_1 := Aname;
1698                Error_Msg_N ("(Ada 83) attribute% is not standard?", N);
1699             end if;
1700
1701             if Attribute_Impl_Def (Attr_Id) then
1702                Check_Restriction (No_Implementation_Attributes, N);
1703             end if;
1704          end if;
1705       end if;
1706
1707       --  Deal with Ada 2005 issues
1708
1709       if Attribute_05 (Attr_Id) and then Ada_Version <= Ada_95 then
1710          Check_Restriction (No_Implementation_Attributes, N);
1711       end if;
1712
1713       --   Remote access to subprogram type access attribute reference needs
1714       --   unanalyzed copy for tree transformation. The analyzed copy is used
1715       --   for its semantic information (whether prefix is a remote subprogram
1716       --   name), the unanalyzed copy is used to construct new subtree rooted
1717       --   with N_Aggregate which represents a fat pointer aggregate.
1718
1719       if Aname = Name_Access then
1720          Discard_Node (Copy_Separate_Tree (N));
1721       end if;
1722
1723       --  Analyze prefix and exit if error in analysis. If the prefix is an
1724       --  incomplete type, use full view if available. Note that there are
1725       --  some attributes for which we do not analyze the prefix, since the
1726       --  prefix is not a normal name.
1727
1728       if Aname /= Name_Elab_Body
1729            and then
1730          Aname /= Name_Elab_Spec
1731            and then
1732          Aname /= Name_UET_Address
1733            and then
1734          Aname /= Name_Enabled
1735       then
1736          Analyze (P);
1737          P_Type := Etype (P);
1738
1739          if Is_Entity_Name (P)
1740            and then Present (Entity (P))
1741            and then Is_Type (Entity (P))
1742          then
1743             if Ekind (Entity (P)) = E_Incomplete_Type then
1744                P_Type := Get_Full_View (P_Type);
1745                Set_Entity (P, P_Type);
1746                Set_Etype  (P, P_Type);
1747
1748             elsif Entity (P) = Current_Scope
1749               and then Is_Record_Type (Entity (P))
1750             then
1751                --  Use of current instance within the type. Verify that if the
1752                --  attribute appears within a constraint, it  yields an access
1753                --  type, other uses are illegal.
1754
1755                declare
1756                   Par : Node_Id;
1757
1758                begin
1759                   Par := Parent (N);
1760                   while Present (Par)
1761                     and then Nkind (Parent (Par)) /= N_Component_Definition
1762                   loop
1763                      Par := Parent (Par);
1764                   end loop;
1765
1766                   if Present (Par)
1767                     and then Nkind (Par) = N_Subtype_Indication
1768                   then
1769                      if Attr_Id /= Attribute_Access
1770                        and then Attr_Id /= Attribute_Unchecked_Access
1771                        and then Attr_Id /= Attribute_Unrestricted_Access
1772                      then
1773                         Error_Msg_N
1774                           ("in a constraint the current instance can only"
1775                              & " be used with an access attribute", N);
1776                      end if;
1777                   end if;
1778                end;
1779             end if;
1780          end if;
1781
1782          if P_Type = Any_Type then
1783             raise Bad_Attribute;
1784          end if;
1785
1786          P_Base_Type := Base_Type (P_Type);
1787       end if;
1788
1789       --  Analyze expressions that may be present, exiting if an error occurs
1790
1791       if No (Exprs) then
1792          E1 := Empty;
1793          E2 := Empty;
1794
1795       else
1796          E1 := First (Exprs);
1797          Analyze (E1);
1798
1799          --  Check for missing/bad expression (result of previous error)
1800
1801          if No (E1) or else Etype (E1) = Any_Type then
1802             raise Bad_Attribute;
1803          end if;
1804
1805          E2 := Next (E1);
1806
1807          if Present (E2) then
1808             Analyze (E2);
1809
1810             if Etype (E2) = Any_Type then
1811                raise Bad_Attribute;
1812             end if;
1813
1814             if Present (Next (E2)) then
1815                Unexpected_Argument (Next (E2));
1816             end if;
1817          end if;
1818       end if;
1819
1820       --  Ada 2005 (AI-345): Ensure that the compiler gives exactly the current
1821       --  output compiling in Ada 95 mode for the case of ambiguous prefixes.
1822
1823       if Ada_Version < Ada_05
1824         and then Is_Overloaded (P)
1825         and then Aname /= Name_Access
1826         and then Aname /= Name_Address
1827         and then Aname /= Name_Code_Address
1828         and then Aname /= Name_Count
1829         and then Aname /= Name_Unchecked_Access
1830       then
1831          Error_Attr ("ambiguous prefix for % attribute", P);
1832
1833       elsif Ada_Version >= Ada_05
1834         and then Is_Overloaded (P)
1835         and then Aname /= Name_Access
1836         and then Aname /= Name_Address
1837         and then Aname /= Name_Code_Address
1838         and then Aname /= Name_Unchecked_Access
1839       then
1840          --  Ada 2005 (AI-345): Since protected and task types have primitive
1841          --  entry wrappers, the attributes Count, Caller and AST_Entry require
1842          --  a context check
1843
1844          if Aname = Name_Count
1845            or else Aname = Name_Caller
1846            or else Aname = Name_AST_Entry
1847          then
1848             declare
1849                Count : Natural := 0;
1850                I     : Interp_Index;
1851                It    : Interp;
1852
1853             begin
1854                Get_First_Interp (P, I, It);
1855                while Present (It.Nam) loop
1856                   if Comes_From_Source (It.Nam) then
1857                      Count := Count + 1;
1858                   else
1859                      Remove_Interp (I);
1860                   end if;
1861
1862                   Get_Next_Interp (I, It);
1863                end loop;
1864
1865                if Count > 1 then
1866                   Error_Attr ("ambiguous prefix for % attribute", P);
1867                else
1868                   Set_Is_Overloaded (P, False);
1869                end if;
1870             end;
1871
1872          else
1873             Error_Attr ("ambiguous prefix for % attribute", P);
1874          end if;
1875       end if;
1876
1877       --  Remaining processing depends on attribute
1878
1879       case Attr_Id is
1880
1881       ------------------
1882       -- Abort_Signal --
1883       ------------------
1884
1885       when Attribute_Abort_Signal =>
1886          Check_Standard_Prefix;
1887          Rewrite (N,
1888            New_Reference_To (Stand.Abort_Signal, Loc));
1889          Analyze (N);
1890
1891       ------------
1892       -- Access --
1893       ------------
1894
1895       when Attribute_Access =>
1896          Analyze_Access_Attribute;
1897
1898       -------------
1899       -- Address --
1900       -------------
1901
1902       when Attribute_Address =>
1903          Check_E0;
1904
1905          --  Check for some junk cases, where we have to allow the address
1906          --  attribute but it does not make much sense, so at least for now
1907          --  just replace with Null_Address.
1908
1909          --  We also do this if the prefix is a reference to the AST_Entry
1910          --  attribute. If expansion is active, the attribute will be
1911          --  replaced by a function call, and address will work fine and
1912          --  get the proper value, but if expansion is not active, then
1913          --  the check here allows proper semantic analysis of the reference.
1914
1915          --  An Address attribute created by expansion is legal even when it
1916          --  applies to other entity-denoting expressions.
1917
1918          if Is_Entity_Name (P) then
1919             declare
1920                Ent : constant Entity_Id := Entity (P);
1921
1922             begin
1923                if Is_Subprogram (Ent) then
1924                   if not Is_Library_Level_Entity (Ent) then
1925                      Check_Restriction (No_Implicit_Dynamic_Code, P);
1926                   end if;
1927
1928                   Set_Address_Taken (Ent);
1929                   Kill_Current_Values (Ent);
1930
1931                   --  An Address attribute is accepted when generated by the
1932                   --  compiler for dispatching operation, and an error is
1933                   --  issued once the subprogram is frozen (to avoid confusing
1934                   --  errors about implicit uses of Address in the dispatch
1935                   --  table initialization).
1936
1937                   if Is_Always_Inlined (Entity (P))
1938                     and then Comes_From_Source (P)
1939                   then
1940                      Error_Attr_P
1941                        ("prefix of % attribute cannot be Inline_Always" &
1942                         " subprogram");
1943                   end if;
1944
1945                elsif Is_Object (Ent)
1946                  or else Ekind (Ent) = E_Label
1947                then
1948                   Set_Address_Taken (Ent);
1949
1950                --  If we have an address of an object, and the attribute
1951                --  comes from source, then set the object as potentially
1952                --  source modified. We do this because the resulting address
1953                --  can potentially be used to modify the variable and we
1954                --  might not detect this, leading to some junk warnings.
1955
1956                   Set_Never_Set_In_Source (Ent, False);
1957
1958                elsif (Is_Concurrent_Type (Etype (Ent))
1959                        and then Etype (Ent) = Base_Type (Ent))
1960                  or else Ekind (Ent) = E_Package
1961                  or else Is_Generic_Unit (Ent)
1962                then
1963                   Rewrite (N,
1964                     New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
1965
1966                else
1967                   Error_Attr ("invalid prefix for % attribute", P);
1968                end if;
1969             end;
1970
1971          elsif Nkind (P) = N_Attribute_Reference
1972            and then Attribute_Name (P) = Name_AST_Entry
1973          then
1974             Rewrite (N,
1975               New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
1976
1977          elsif Is_Object_Reference (P) then
1978             null;
1979
1980          elsif Nkind (P) = N_Selected_Component
1981            and then Is_Subprogram (Entity (Selector_Name (P)))
1982          then
1983             null;
1984
1985          --  What exactly are we allowing here ??? and is this properly
1986          --  documented in the sinfo documentation for this node ???
1987
1988          elsif not Comes_From_Source (N) then
1989             null;
1990
1991          else
1992             Error_Attr ("invalid prefix for % attribute", P);
1993          end if;
1994
1995          Set_Etype (N, RTE (RE_Address));
1996
1997       ------------------
1998       -- Address_Size --
1999       ------------------
2000
2001       when Attribute_Address_Size =>
2002          Standard_Attribute (System_Address_Size);
2003
2004       --------------
2005       -- Adjacent --
2006       --------------
2007
2008       when Attribute_Adjacent =>
2009          Check_Floating_Point_Type_2;
2010          Set_Etype (N, P_Base_Type);
2011          Resolve (E1, P_Base_Type);
2012          Resolve (E2, P_Base_Type);
2013
2014       ---------
2015       -- Aft --
2016       ---------
2017
2018       when Attribute_Aft =>
2019          Check_Fixed_Point_Type_0;
2020          Set_Etype (N, Universal_Integer);
2021
2022       ---------------
2023       -- Alignment --
2024       ---------------
2025
2026       when Attribute_Alignment =>
2027
2028          --  Don't we need more checking here, cf Size ???
2029
2030          Check_E0;
2031          Check_Not_Incomplete_Type;
2032          Set_Etype (N, Universal_Integer);
2033
2034       ---------------
2035       -- Asm_Input --
2036       ---------------
2037
2038       when Attribute_Asm_Input =>
2039          Check_Asm_Attribute;
2040          Set_Etype (N, RTE (RE_Asm_Input_Operand));
2041
2042       ----------------
2043       -- Asm_Output --
2044       ----------------
2045
2046       when Attribute_Asm_Output =>
2047          Check_Asm_Attribute;
2048
2049          if Etype (E2) = Any_Type then
2050             return;
2051
2052          elsif Aname = Name_Asm_Output then
2053             if not Is_Variable (E2) then
2054                Error_Attr
2055                  ("second argument for Asm_Output is not variable", E2);
2056             end if;
2057          end if;
2058
2059          Note_Possible_Modification (E2);
2060          Set_Etype (N, RTE (RE_Asm_Output_Operand));
2061
2062       ---------------
2063       -- AST_Entry --
2064       ---------------
2065
2066       when Attribute_AST_Entry => AST_Entry : declare
2067          Ent  : Entity_Id;
2068          Pref : Node_Id;
2069          Ptyp : Entity_Id;
2070
2071          Indexed : Boolean;
2072          --  Indicates if entry family index is present. Note the coding
2073          --  here handles the entry family case, but in fact it cannot be
2074          --  executed currently, because pragma AST_Entry does not permit
2075          --  the specification of an entry family.
2076
2077          procedure Bad_AST_Entry;
2078          --  Signal a bad AST_Entry pragma
2079
2080          function OK_Entry (E : Entity_Id) return Boolean;
2081          --  Checks that E is of an appropriate entity kind for an entry
2082          --  (i.e. E_Entry if Index is False, or E_Entry_Family if Index
2083          --  is set True for the entry family case). In the True case,
2084          --  makes sure that Is_AST_Entry is set on the entry.
2085
2086          procedure Bad_AST_Entry is
2087          begin
2088             Error_Attr_P ("prefix for % attribute must be task entry");
2089          end Bad_AST_Entry;
2090
2091          function OK_Entry (E : Entity_Id) return Boolean is
2092             Result : Boolean;
2093
2094          begin
2095             if Indexed then
2096                Result := (Ekind (E) = E_Entry_Family);
2097             else
2098                Result := (Ekind (E) = E_Entry);
2099             end if;
2100
2101             if Result then
2102                if not Is_AST_Entry (E) then
2103                   Error_Msg_Name_2 := Aname;
2104                   Error_Attr ("% attribute requires previous % pragma", P);
2105                end if;
2106             end if;
2107
2108             return Result;
2109          end OK_Entry;
2110
2111       --  Start of processing for AST_Entry
2112
2113       begin
2114          Check_VMS (N);
2115          Check_E0;
2116
2117          --  Deal with entry family case
2118
2119          if Nkind (P) = N_Indexed_Component then
2120             Pref := Prefix (P);
2121             Indexed := True;
2122          else
2123             Pref := P;
2124             Indexed := False;
2125          end if;
2126
2127          Ptyp := Etype (Pref);
2128
2129          if Ptyp = Any_Type or else Error_Posted (Pref) then
2130             return;
2131          end if;
2132
2133          --  If the prefix is a selected component whose prefix is of an
2134          --  access type, then introduce an explicit dereference.
2135          --  ??? Could we reuse Check_Dereference here?
2136
2137          if Nkind (Pref) = N_Selected_Component
2138            and then Is_Access_Type (Ptyp)
2139          then
2140             Rewrite (Pref,
2141               Make_Explicit_Dereference (Sloc (Pref),
2142                 Relocate_Node (Pref)));
2143             Analyze_And_Resolve (Pref, Designated_Type (Ptyp));
2144          end if;
2145
2146          --  Prefix can be of the form a.b, where a is a task object
2147          --  and b is one of the entries of the corresponding task type.
2148
2149          if Nkind (Pref) = N_Selected_Component
2150            and then OK_Entry (Entity (Selector_Name (Pref)))
2151            and then Is_Object_Reference (Prefix (Pref))
2152            and then Is_Task_Type (Etype (Prefix (Pref)))
2153          then
2154             null;
2155
2156          --  Otherwise the prefix must be an entry of a containing task,
2157          --  or of a variable of the enclosing task type.
2158
2159          else
2160             if Nkind (Pref) = N_Identifier
2161               or else Nkind (Pref) = N_Expanded_Name
2162             then
2163                Ent := Entity (Pref);
2164
2165                if not OK_Entry (Ent)
2166                  or else not In_Open_Scopes (Scope (Ent))
2167                then
2168                   Bad_AST_Entry;
2169                end if;
2170
2171             else
2172                Bad_AST_Entry;
2173             end if;
2174          end if;
2175
2176          Set_Etype (N, RTE (RE_AST_Handler));
2177       end AST_Entry;
2178
2179       ----------
2180       -- Base --
2181       ----------
2182
2183       --  Note: when the base attribute appears in the context of a subtype
2184       --  mark, the analysis is done by Sem_Ch8.Find_Type, rather than by
2185       --  the following circuit.
2186
2187       when Attribute_Base => Base : declare
2188          Typ : Entity_Id;
2189
2190       begin
2191          Check_Either_E0_Or_E1;
2192          Find_Type (P);
2193          Typ := Entity (P);
2194
2195          if Ada_Version >= Ada_95
2196            and then not Is_Scalar_Type (Typ)
2197            and then not Is_Generic_Type (Typ)
2198          then
2199             Error_Attr_P ("prefix of Base attribute must be scalar type");
2200
2201          elsif Sloc (Typ) = Standard_Location
2202            and then Base_Type (Typ) = Typ
2203            and then Warn_On_Redundant_Constructs
2204          then
2205                Error_Msg_NE
2206                  ("?redudant attribute, & is its own base type", N, Typ);
2207          end if;
2208
2209          Set_Etype (N, Base_Type (Entity (P)));
2210
2211          --  If we have an expression present, then really this is a conversion
2212          --  and the tree must be reformed. Note that this is one of the cases
2213          --  in which we do a replace rather than a rewrite, because the
2214          --  original tree is junk.
2215
2216          if Present (E1) then
2217             Replace (N,
2218               Make_Type_Conversion (Loc,
2219                 Subtype_Mark =>
2220                   Make_Attribute_Reference (Loc,
2221                     Prefix => Prefix (N),
2222                     Attribute_Name => Name_Base),
2223                 Expression => Relocate_Node (E1)));
2224
2225             --  E1 may be overloaded, and its interpretations preserved
2226
2227             Save_Interps (E1, Expression (N));
2228             Analyze (N);
2229
2230          --  For other cases, set the proper type as the entity of the
2231          --  attribute reference, and then rewrite the node to be an
2232          --  occurrence of the referenced base type. This way, no one
2233          --  else in the compiler has to worry about the base attribute.
2234
2235          else
2236             Set_Entity (N, Base_Type (Entity (P)));
2237             Rewrite (N,
2238               New_Reference_To (Entity (N), Loc));
2239             Analyze (N);
2240          end if;
2241       end Base;
2242
2243       ---------
2244       -- Bit --
2245       ---------
2246
2247       when Attribute_Bit => Bit :
2248       begin
2249          Check_E0;
2250
2251          if not Is_Object_Reference (P) then
2252             Error_Attr_P ("prefix for % attribute must be object");
2253
2254          --  What about the access object cases ???
2255
2256          else
2257             null;
2258          end if;
2259
2260          Set_Etype (N, Universal_Integer);
2261       end Bit;
2262
2263       ---------------
2264       -- Bit_Order --
2265       ---------------
2266
2267       when Attribute_Bit_Order => Bit_Order :
2268       begin
2269          Check_E0;
2270          Check_Type;
2271
2272          if not Is_Record_Type (P_Type) then
2273             Error_Attr_P ("prefix of % attribute must be record type");
2274          end if;
2275
2276          if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then
2277             Rewrite (N,
2278               New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
2279          else
2280             Rewrite (N,
2281               New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
2282          end if;
2283
2284          Set_Etype (N, RTE (RE_Bit_Order));
2285          Resolve (N);
2286
2287          --  Reset incorrect indication of staticness
2288
2289          Set_Is_Static_Expression (N, False);
2290       end Bit_Order;
2291
2292       ------------------
2293       -- Bit_Position --
2294       ------------------
2295
2296       --  Note: in generated code, we can have a Bit_Position attribute
2297       --  applied to a (naked) record component (i.e. the prefix is an
2298       --  identifier that references an E_Component or E_Discriminant
2299       --  entity directly, and this is interpreted as expected by Gigi.
2300       --  The following code will not tolerate such usage, but when the
2301       --  expander creates this special case, it marks it as analyzed
2302       --  immediately and sets an appropriate type.
2303
2304       when Attribute_Bit_Position =>
2305          if Comes_From_Source (N) then
2306             Check_Component;
2307          end if;
2308
2309          Set_Etype (N, Universal_Integer);
2310
2311       ------------------
2312       -- Body_Version --
2313       ------------------
2314
2315       when Attribute_Body_Version =>
2316          Check_E0;
2317          Check_Program_Unit;
2318          Set_Etype (N, RTE (RE_Version_String));
2319
2320       --------------
2321       -- Callable --
2322       --------------
2323
2324       when Attribute_Callable =>
2325          Check_E0;
2326          Set_Etype (N, Standard_Boolean);
2327          Check_Task_Prefix;
2328
2329       ------------
2330       -- Caller --
2331       ------------
2332
2333       when Attribute_Caller => Caller : declare
2334          Ent        : Entity_Id;
2335          S          : Entity_Id;
2336
2337       begin
2338          Check_E0;
2339
2340          if Nkind (P) = N_Identifier
2341            or else Nkind (P) = N_Expanded_Name
2342          then
2343             Ent := Entity (P);
2344
2345             if not Is_Entry (Ent) then
2346                Error_Attr ("invalid entry name", N);
2347             end if;
2348
2349          else
2350             Error_Attr ("invalid entry name", N);
2351             return;
2352          end if;
2353
2354          for J in reverse 0 .. Scope_Stack.Last loop
2355             S := Scope_Stack.Table (J).Entity;
2356
2357             if S = Scope (Ent) then
2358                Error_Attr ("Caller must appear in matching accept or body", N);
2359             elsif S = Ent then
2360                exit;
2361             end if;
2362          end loop;
2363
2364          Set_Etype (N, RTE (RO_AT_Task_Id));
2365       end Caller;
2366
2367       -------------
2368       -- Ceiling --
2369       -------------
2370
2371       when Attribute_Ceiling =>
2372          Check_Floating_Point_Type_1;
2373          Set_Etype (N, P_Base_Type);
2374          Resolve (E1, P_Base_Type);
2375
2376       -----------
2377       -- Class --
2378       -----------
2379
2380       when Attribute_Class => Class : declare
2381          P : constant Entity_Id := Prefix (N);
2382
2383       begin
2384          Check_Restriction (No_Dispatch, N);
2385          Check_Either_E0_Or_E1;
2386
2387          --  If we have an expression present, then really this is a conversion
2388          --  and the tree must be reformed into a proper conversion. This is a
2389          --  Replace rather than a Rewrite, because the original tree is junk.
2390          --  If expression is overloaded, propagate interpretations to new one.
2391
2392          if Present (E1) then
2393             Replace (N,
2394               Make_Type_Conversion (Loc,
2395                 Subtype_Mark =>
2396                   Make_Attribute_Reference (Loc,
2397                     Prefix => P,
2398                     Attribute_Name => Name_Class),
2399                 Expression => Relocate_Node (E1)));
2400
2401             Save_Interps (E1, Expression (N));
2402
2403             --  Ada 2005 (AI-251): In case of abstract interfaces we have to
2404             --  analyze and resolve the type conversion to generate the code
2405             --  that displaces the reference to the base of the object.
2406
2407             if Is_Interface (Etype (P))
2408               or else Is_Interface (Etype (E1))
2409             then
2410                Analyze_And_Resolve (N, Etype (P));
2411
2412                --  However, the attribute is a name that occurs in a context
2413                --  that imposes its own type. Leave the result unanalyzed,
2414                --  so that type checking with the context type take place.
2415                --  on the new conversion node, otherwise Resolve is a noop.
2416
2417                Set_Analyzed (N, False);
2418
2419             else
2420                Analyze (N);
2421             end if;
2422
2423          --  Otherwise we just need to find the proper type
2424
2425          else
2426             Find_Type (N);
2427          end if;
2428       end Class;
2429
2430       ------------------
2431       -- Code_Address --
2432       ------------------
2433
2434       when Attribute_Code_Address =>
2435          Check_E0;
2436
2437          if Nkind (P) = N_Attribute_Reference
2438            and then (Attribute_Name (P) = Name_Elab_Body
2439                        or else
2440                      Attribute_Name (P) = Name_Elab_Spec)
2441          then
2442             null;
2443
2444          elsif not Is_Entity_Name (P)
2445            or else (Ekind (Entity (P)) /= E_Function
2446                       and then
2447                     Ekind (Entity (P)) /= E_Procedure)
2448          then
2449             Error_Attr ("invalid prefix for % attribute", P);
2450             Set_Address_Taken (Entity (P));
2451          end if;
2452
2453          Set_Etype (N, RTE (RE_Address));
2454
2455       --------------------
2456       -- Component_Size --
2457       --------------------
2458
2459       when Attribute_Component_Size =>
2460          Check_E0;
2461          Set_Etype (N, Universal_Integer);
2462
2463          --  Note: unlike other array attributes, unconstrained arrays are OK
2464
2465          if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then
2466             null;
2467          else
2468             Check_Array_Type;
2469          end if;
2470
2471       -------------
2472       -- Compose --
2473       -------------
2474
2475       when Attribute_Compose =>
2476          Check_Floating_Point_Type_2;
2477          Set_Etype (N, P_Base_Type);
2478          Resolve (E1, P_Base_Type);
2479          Resolve (E2, Any_Integer);
2480
2481       -----------------
2482       -- Constrained --
2483       -----------------
2484
2485       when Attribute_Constrained =>
2486          Check_E0;
2487          Set_Etype (N, Standard_Boolean);
2488
2489          --  Case from RM J.4(2) of constrained applied to private type
2490
2491          if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
2492             Check_Restriction (No_Obsolescent_Features, N);
2493
2494             if Warn_On_Obsolescent_Feature then
2495                Error_Msg_N
2496                  ("constrained for private type is an " &
2497                   "obsolescent feature (RM J.4)?", N);
2498             end if;
2499
2500             --  If we are within an instance, the attribute must be legal
2501             --  because it was valid in the generic unit. Ditto if this is
2502             --  an inlining of a function declared in an instance.
2503
2504             if In_Instance
2505               or else In_Inlined_Body
2506             then
2507                return;
2508
2509             --  For sure OK if we have a real private type itself, but must
2510             --  be completed, cannot apply Constrained to incomplete type.
2511
2512             elsif Is_Private_Type (Entity (P)) then
2513
2514                --  Note: this is one of the Annex J features that does not
2515                --  generate a warning from -gnatwj, since in fact it seems
2516                --  very useful, and is used in the GNAT runtime.
2517
2518                Check_Not_Incomplete_Type;
2519                return;
2520             end if;
2521
2522          --  Normal (non-obsolescent case) of application to object of
2523          --  a discriminated type.
2524
2525          else
2526             Check_Object_Reference (P);
2527
2528             --  If N does not come from source, then we allow the
2529             --  the attribute prefix to be of a private type whose
2530             --  full type has discriminants. This occurs in cases
2531             --  involving expanded calls to stream attributes.
2532
2533             if not Comes_From_Source (N) then
2534                P_Type := Underlying_Type (P_Type);
2535             end if;
2536
2537             --  Must have discriminants or be an access type designating
2538             --  a type with discriminants. If it is a classwide type is ???
2539             --  has unknown discriminants.
2540
2541             if Has_Discriminants (P_Type)
2542                or else Has_Unknown_Discriminants (P_Type)
2543                or else
2544                  (Is_Access_Type (P_Type)
2545                    and then Has_Discriminants (Designated_Type (P_Type)))
2546             then
2547                return;
2548
2549             --  Also allow an object of a generic type if extensions allowed
2550             --  and allow this for any type at all.
2551
2552             elsif (Is_Generic_Type (P_Type)
2553                      or else Is_Generic_Actual_Type (P_Type))
2554               and then Extensions_Allowed
2555             then
2556                return;
2557             end if;
2558          end if;
2559
2560          --  Fall through if bad prefix
2561
2562          Error_Attr_P
2563            ("prefix of % attribute must be object of discriminated type");
2564
2565       ---------------
2566       -- Copy_Sign --
2567       ---------------
2568
2569       when Attribute_Copy_Sign =>
2570          Check_Floating_Point_Type_2;
2571          Set_Etype (N, P_Base_Type);
2572          Resolve (E1, P_Base_Type);
2573          Resolve (E2, P_Base_Type);
2574
2575       -----------
2576       -- Count --
2577       -----------
2578
2579       when Attribute_Count => Count :
2580       declare
2581          Ent : Entity_Id;
2582          S   : Entity_Id;
2583          Tsk : Entity_Id;
2584
2585       begin
2586          Check_E0;
2587
2588          if Nkind (P) = N_Identifier
2589            or else Nkind (P) = N_Expanded_Name
2590          then
2591             Ent := Entity (P);
2592
2593             if Ekind (Ent) /= E_Entry then
2594                Error_Attr ("invalid entry name", N);
2595             end if;
2596
2597          elsif Nkind (P) = N_Indexed_Component then
2598             if not Is_Entity_Name (Prefix (P))
2599               or else  No (Entity (Prefix (P)))
2600               or else Ekind (Entity (Prefix (P))) /= E_Entry_Family
2601             then
2602                if Nkind (Prefix (P)) = N_Selected_Component
2603                  and then Present (Entity (Selector_Name (Prefix (P))))
2604                  and then Ekind (Entity (Selector_Name (Prefix (P)))) =
2605                                                              E_Entry_Family
2606                then
2607                   Error_Attr
2608                     ("attribute % must apply to entry of current task", P);
2609
2610                else
2611                   Error_Attr ("invalid entry family name", P);
2612                end if;
2613                return;
2614
2615             else
2616                Ent := Entity (Prefix (P));
2617             end if;
2618
2619          elsif Nkind (P) = N_Selected_Component
2620            and then Present (Entity (Selector_Name (P)))
2621            and then Ekind (Entity (Selector_Name (P))) = E_Entry
2622          then
2623             Error_Attr
2624               ("attribute % must apply to entry of current task", P);
2625
2626          else
2627             Error_Attr ("invalid entry name", N);
2628             return;
2629          end if;
2630
2631          for J in reverse 0 .. Scope_Stack.Last loop
2632             S := Scope_Stack.Table (J).Entity;
2633
2634             if S = Scope (Ent) then
2635                if Nkind (P) = N_Expanded_Name then
2636                   Tsk := Entity (Prefix (P));
2637
2638                   --  The prefix denotes either the task type, or else a
2639                   --  single task whose task type is being analyzed.
2640
2641                   if (Is_Type (Tsk)
2642                       and then Tsk = S)
2643
2644                     or else (not Is_Type (Tsk)
2645                       and then Etype (Tsk) = S
2646                       and then not (Comes_From_Source (S)))
2647                   then
2648                      null;
2649                   else
2650                      Error_Attr
2651                        ("Attribute % must apply to entry of current task", N);
2652                   end if;
2653                end if;
2654
2655                exit;
2656
2657             elsif Ekind (Scope (Ent)) in Task_Kind
2658               and then Ekind (S) /= E_Loop
2659               and then Ekind (S) /= E_Block
2660               and then Ekind (S) /= E_Entry
2661               and then Ekind (S) /= E_Entry_Family
2662             then
2663                Error_Attr ("Attribute % cannot appear in inner unit", N);
2664
2665             elsif Ekind (Scope (Ent)) = E_Protected_Type
2666               and then not Has_Completion (Scope (Ent))
2667             then
2668                Error_Attr ("attribute % can only be used inside body", N);
2669             end if;
2670          end loop;
2671
2672          if Is_Overloaded (P) then
2673             declare
2674                Index : Interp_Index;
2675                It    : Interp;
2676
2677             begin
2678                Get_First_Interp (P, Index, It);
2679
2680                while Present (It.Nam) loop
2681                   if It.Nam = Ent then
2682                      null;
2683
2684                   --  Ada 2005 (AI-345): Do not consider primitive entry
2685                   --  wrappers generated for task or protected types.
2686
2687                   elsif Ada_Version >= Ada_05
2688                     and then not Comes_From_Source (It.Nam)
2689                   then
2690                      null;
2691
2692                   else
2693                      Error_Attr ("ambiguous entry name", N);
2694                   end if;
2695
2696                   Get_Next_Interp (Index, It);
2697                end loop;
2698             end;
2699          end if;
2700
2701          Set_Etype (N, Universal_Integer);
2702       end Count;
2703
2704       -----------------------
2705       -- Default_Bit_Order --
2706       -----------------------
2707
2708       when Attribute_Default_Bit_Order => Default_Bit_Order :
2709       begin
2710          Check_Standard_Prefix;
2711          Check_E0;
2712
2713          if Bytes_Big_Endian then
2714             Rewrite (N,
2715               Make_Integer_Literal (Loc, False_Value));
2716          else
2717             Rewrite (N,
2718               Make_Integer_Literal (Loc, True_Value));
2719          end if;
2720
2721          Set_Etype (N, Universal_Integer);
2722          Set_Is_Static_Expression (N);
2723       end Default_Bit_Order;
2724
2725       --------------
2726       -- Definite --
2727       --------------
2728
2729       when Attribute_Definite =>
2730          Legal_Formal_Attribute;
2731
2732       -----------
2733       -- Delta --
2734       -----------
2735
2736       when Attribute_Delta =>
2737          Check_Fixed_Point_Type_0;
2738          Set_Etype (N, Universal_Real);
2739
2740       ------------
2741       -- Denorm --
2742       ------------
2743
2744       when Attribute_Denorm =>
2745          Check_Floating_Point_Type_0;
2746          Set_Etype (N, Standard_Boolean);
2747
2748       ------------
2749       -- Digits --
2750       ------------
2751
2752       when Attribute_Digits =>
2753          Check_E0;
2754          Check_Type;
2755
2756          if not Is_Floating_Point_Type (P_Type)
2757            and then not Is_Decimal_Fixed_Point_Type (P_Type)
2758          then
2759             Error_Attr_P
2760               ("prefix of % attribute must be float or decimal type");
2761          end if;
2762
2763          Set_Etype (N, Universal_Integer);
2764
2765       ---------------
2766       -- Elab_Body --
2767       ---------------
2768
2769       --  Also handles processing for Elab_Spec
2770
2771       when Attribute_Elab_Body | Attribute_Elab_Spec =>
2772          Check_E0;
2773          Check_Unit_Name (P);
2774          Set_Etype (N, Standard_Void_Type);
2775
2776          --  We have to manually call the expander in this case to get
2777          --  the necessary expansion (normally attributes that return
2778          --  entities are not expanded).
2779
2780          Expand (N);
2781
2782       ---------------
2783       -- Elab_Spec --
2784       ---------------
2785
2786       --  Shares processing with Elab_Body
2787
2788       ----------------
2789       -- Elaborated --
2790       ----------------
2791
2792       when Attribute_Elaborated =>
2793          Check_E0;
2794          Check_Library_Unit;
2795          Set_Etype (N, Standard_Boolean);
2796
2797       ----------
2798       -- Emax --
2799       ----------
2800
2801       when Attribute_Emax =>
2802          Check_Floating_Point_Type_0;
2803          Set_Etype (N, Universal_Integer);
2804
2805       -------------
2806       -- Enabled --
2807       -------------
2808
2809       when Attribute_Enabled =>
2810          Check_Either_E0_Or_E1;
2811
2812          if Present (E1) then
2813             if not Is_Entity_Name (E1) or else No (Entity (E1)) then
2814                Error_Msg_N ("entity name expected for Enabled attribute", E1);
2815                E1 := Empty;
2816             end if;
2817          end if;
2818
2819          if Nkind (P) /= N_Identifier then
2820             Error_Msg_N ("identifier expected (check name)", P);
2821
2822          elsif Get_Check_Id (Chars (P)) = No_Check_Id then
2823             Error_Msg_N ("& is not a recognized check name", P);
2824          end if;
2825
2826          Set_Etype (N, Standard_Boolean);
2827
2828       --------------
2829       -- Enum_Rep --
2830       --------------
2831
2832       when Attribute_Enum_Rep => Enum_Rep : declare
2833       begin
2834          if Present (E1) then
2835             Check_E1;
2836             Check_Discrete_Type;
2837             Resolve (E1, P_Base_Type);
2838
2839          else
2840             if not Is_Entity_Name (P)
2841               or else (not Is_Object (Entity (P))
2842                          and then
2843                        Ekind (Entity (P)) /= E_Enumeration_Literal)
2844             then
2845                Error_Attr_P
2846                  ("prefix of %attribute must be " &
2847                   "discrete type/object or enum literal");
2848             end if;
2849          end if;
2850
2851          Set_Etype (N, Universal_Integer);
2852       end Enum_Rep;
2853
2854       -------------
2855       -- Epsilon --
2856       -------------
2857
2858       when Attribute_Epsilon =>
2859          Check_Floating_Point_Type_0;
2860          Set_Etype (N, Universal_Real);
2861
2862       --------------
2863       -- Exponent --
2864       --------------
2865
2866       when Attribute_Exponent =>
2867          Check_Floating_Point_Type_1;
2868          Set_Etype (N, Universal_Integer);
2869          Resolve (E1, P_Base_Type);
2870
2871       ------------------
2872       -- External_Tag --
2873       ------------------
2874
2875       when Attribute_External_Tag =>
2876          Check_E0;
2877          Check_Type;
2878
2879          Set_Etype (N, Standard_String);
2880
2881          if not Is_Tagged_Type (P_Type) then
2882             Error_Attr_P ("prefix of % attribute must be tagged");
2883          end if;
2884
2885       -----------
2886       -- First --
2887       -----------
2888
2889       when Attribute_First =>
2890          Check_Array_Or_Scalar_Type;
2891
2892       ---------------
2893       -- First_Bit --
2894       ---------------
2895
2896       when Attribute_First_Bit =>
2897          Check_Component;
2898          Set_Etype (N, Universal_Integer);
2899
2900       -----------------
2901       -- Fixed_Value --
2902       -----------------
2903
2904       when Attribute_Fixed_Value =>
2905          Check_E1;
2906          Check_Fixed_Point_Type;
2907          Resolve (E1, Any_Integer);
2908          Set_Etype (N, P_Base_Type);
2909
2910       -----------
2911       -- Floor --
2912       -----------
2913
2914       when Attribute_Floor =>
2915          Check_Floating_Point_Type_1;
2916          Set_Etype (N, P_Base_Type);
2917          Resolve (E1, P_Base_Type);
2918
2919       ----------
2920       -- Fore --
2921       ----------
2922
2923       when Attribute_Fore =>
2924          Check_Fixed_Point_Type_0;
2925          Set_Etype (N, Universal_Integer);
2926
2927       --------------
2928       -- Fraction --
2929       --------------
2930
2931       when Attribute_Fraction =>
2932          Check_Floating_Point_Type_1;
2933          Set_Etype (N, P_Base_Type);
2934          Resolve (E1, P_Base_Type);
2935
2936       -----------------------
2937       -- Has_Access_Values --
2938       -----------------------
2939
2940       when Attribute_Has_Access_Values =>
2941          Check_Type;
2942          Check_E0;
2943          Set_Etype (N, Standard_Boolean);
2944
2945       -----------------------
2946       -- Has_Discriminants --
2947       -----------------------
2948
2949       when Attribute_Has_Discriminants =>
2950          Legal_Formal_Attribute;
2951
2952       --------------
2953       -- Identity --
2954       --------------
2955
2956       when Attribute_Identity =>
2957          Check_E0;
2958          Analyze (P);
2959
2960          if Etype (P) =  Standard_Exception_Type then
2961             Set_Etype (N, RTE (RE_Exception_Id));
2962
2963          --  Ada 2005 (AI-345): Attribute 'Identity may be applied to
2964          --  task interface class-wide types.
2965
2966          elsif Is_Task_Type (Etype (P))
2967            or else (Is_Access_Type (Etype (P))
2968                       and then Is_Task_Type (Designated_Type (Etype (P))))
2969            or else (Ada_Version >= Ada_05
2970                       and then Ekind (Etype (P)) = E_Class_Wide_Type
2971                       and then Is_Interface (Etype (P))
2972                       and then Is_Task_Interface (Etype (P)))
2973          then
2974             Resolve (P);
2975             Set_Etype (N, RTE (RO_AT_Task_Id));
2976
2977          else
2978             if Ada_Version >= Ada_05 then
2979                Error_Attr_P
2980                  ("prefix of % attribute must be an exception, a " &
2981                   "task or a task interface class-wide object");
2982             else
2983                Error_Attr_P
2984                  ("prefix of % attribute must be a task or an exception");
2985             end if;
2986          end if;
2987
2988       -----------
2989       -- Image --
2990       -----------
2991
2992       when Attribute_Image => Image :
2993       begin
2994          Set_Etype (N, Standard_String);
2995          Check_Scalar_Type;
2996
2997          if Is_Real_Type (P_Type) then
2998             if Ada_Version = Ada_83 and then Comes_From_Source (N) then
2999                Error_Msg_Name_1 := Aname;
3000                Error_Msg_N
3001                  ("(Ada 83) % attribute not allowed for real types", N);
3002             end if;
3003          end if;
3004
3005          if Is_Enumeration_Type (P_Type) then
3006             Check_Restriction (No_Enumeration_Maps, N);
3007          end if;
3008
3009          Check_E1;
3010          Resolve (E1, P_Base_Type);
3011          Check_Enum_Image;
3012          Validate_Non_Static_Attribute_Function_Call;
3013       end Image;
3014
3015       ---------
3016       -- Img --
3017       ---------
3018
3019       when Attribute_Img => Img :
3020       begin
3021          Set_Etype (N, Standard_String);
3022
3023          if not Is_Scalar_Type (P_Type)
3024            or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
3025          then
3026             Error_Attr_P
3027               ("prefix of % attribute must be scalar object name");
3028          end if;
3029
3030          Check_Enum_Image;
3031       end Img;
3032
3033       -----------
3034       -- Input --
3035       -----------
3036
3037       when Attribute_Input =>
3038          Check_E1;
3039          Check_Stream_Attribute (TSS_Stream_Input);
3040          Set_Etype (N, P_Base_Type);
3041
3042       -------------------
3043       -- Integer_Value --
3044       -------------------
3045
3046       when Attribute_Integer_Value =>
3047          Check_E1;
3048          Check_Integer_Type;
3049          Resolve (E1, Any_Fixed);
3050          Set_Etype (N, P_Base_Type);
3051
3052       -----------
3053       -- Large --
3054       -----------
3055
3056       when Attribute_Large =>
3057          Check_E0;
3058          Check_Real_Type;
3059          Set_Etype (N, Universal_Real);
3060
3061       ----------
3062       -- Last --
3063       ----------
3064
3065       when Attribute_Last =>
3066          Check_Array_Or_Scalar_Type;
3067
3068       --------------
3069       -- Last_Bit --
3070       --------------
3071
3072       when Attribute_Last_Bit =>
3073          Check_Component;
3074          Set_Etype (N, Universal_Integer);
3075
3076       ------------------
3077       -- Leading_Part --
3078       ------------------
3079
3080       when Attribute_Leading_Part =>
3081          Check_Floating_Point_Type_2;
3082          Set_Etype (N, P_Base_Type);
3083          Resolve (E1, P_Base_Type);
3084          Resolve (E2, Any_Integer);
3085
3086       ------------
3087       -- Length --
3088       ------------
3089
3090       when Attribute_Length =>
3091          Check_Array_Type;
3092          Set_Etype (N, Universal_Integer);
3093
3094       -------------
3095       -- Machine --
3096       -------------
3097
3098       when Attribute_Machine =>
3099          Check_Floating_Point_Type_1;
3100          Set_Etype (N, P_Base_Type);
3101          Resolve (E1, P_Base_Type);
3102
3103       ------------------
3104       -- Machine_Emax --
3105       ------------------
3106
3107       when Attribute_Machine_Emax =>
3108          Check_Floating_Point_Type_0;
3109          Set_Etype (N, Universal_Integer);
3110
3111       ------------------
3112       -- Machine_Emin --
3113       ------------------
3114
3115       when Attribute_Machine_Emin =>
3116          Check_Floating_Point_Type_0;
3117          Set_Etype (N, Universal_Integer);
3118
3119       ----------------------
3120       -- Machine_Mantissa --
3121       ----------------------
3122
3123       when Attribute_Machine_Mantissa =>
3124          Check_Floating_Point_Type_0;
3125          Set_Etype (N, Universal_Integer);
3126
3127       -----------------------
3128       -- Machine_Overflows --
3129       -----------------------
3130
3131       when Attribute_Machine_Overflows =>
3132          Check_Real_Type;
3133          Check_E0;
3134          Set_Etype (N, Standard_Boolean);
3135
3136       -------------------
3137       -- Machine_Radix --
3138       -------------------
3139
3140       when Attribute_Machine_Radix =>
3141          Check_Real_Type;
3142          Check_E0;
3143          Set_Etype (N, Universal_Integer);
3144
3145       ----------------------
3146       -- Machine_Rounding --
3147       ----------------------
3148
3149       when Attribute_Machine_Rounding =>
3150          Check_Floating_Point_Type_1;
3151          Set_Etype (N, P_Base_Type);
3152          Resolve (E1, P_Base_Type);
3153
3154       --------------------
3155       -- Machine_Rounds --
3156       --------------------
3157
3158       when Attribute_Machine_Rounds =>
3159          Check_Real_Type;
3160          Check_E0;
3161          Set_Etype (N, Standard_Boolean);
3162
3163       ------------------
3164       -- Machine_Size --
3165       ------------------
3166
3167       when Attribute_Machine_Size =>
3168          Check_E0;
3169          Check_Type;
3170          Check_Not_Incomplete_Type;
3171          Set_Etype (N, Universal_Integer);
3172
3173       --------------
3174       -- Mantissa --
3175       --------------
3176
3177       when Attribute_Mantissa =>
3178          Check_E0;
3179          Check_Real_Type;
3180          Set_Etype (N, Universal_Integer);
3181
3182       ---------
3183       -- Max --
3184       ---------
3185
3186       when Attribute_Max =>
3187          Check_E2;
3188          Check_Scalar_Type;
3189          Resolve (E1, P_Base_Type);
3190          Resolve (E2, P_Base_Type);
3191          Set_Etype (N, P_Base_Type);
3192
3193       ----------------------------------
3194       -- Max_Size_In_Storage_Elements --
3195       ----------------------------------
3196
3197       when Attribute_Max_Size_In_Storage_Elements =>
3198          Check_E0;
3199          Check_Type;
3200          Check_Not_Incomplete_Type;
3201          Set_Etype (N, Universal_Integer);
3202
3203       -----------------------
3204       -- Maximum_Alignment --
3205       -----------------------
3206
3207       when Attribute_Maximum_Alignment =>
3208          Standard_Attribute (Ttypes.Maximum_Alignment);
3209
3210       --------------------
3211       -- Mechanism_Code --
3212       --------------------
3213
3214       when Attribute_Mechanism_Code =>
3215          if not Is_Entity_Name (P)
3216            or else not Is_Subprogram (Entity (P))
3217          then
3218             Error_Attr_P ("prefix of % attribute must be subprogram");
3219          end if;
3220
3221          Check_Either_E0_Or_E1;
3222
3223          if Present (E1) then
3224             Resolve (E1, Any_Integer);
3225             Set_Etype (E1, Standard_Integer);
3226
3227             if not Is_Static_Expression (E1) then
3228                Flag_Non_Static_Expr
3229                  ("expression for parameter number must be static!", E1);
3230                Error_Attr;
3231
3232             elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
3233               or else UI_To_Int (Intval (E1)) < 0
3234             then
3235                Error_Attr ("invalid parameter number for %attribute", E1);
3236             end if;
3237          end if;
3238
3239          Set_Etype (N, Universal_Integer);
3240
3241       ---------
3242       -- Min --
3243       ---------
3244
3245       when Attribute_Min =>
3246          Check_E2;
3247          Check_Scalar_Type;
3248          Resolve (E1, P_Base_Type);
3249          Resolve (E2, P_Base_Type);
3250          Set_Etype (N, P_Base_Type);
3251
3252       ---------
3253       -- Mod --
3254       ---------
3255
3256       when Attribute_Mod =>
3257
3258          --  Note: this attribute is only allowed in Ada 2005 mode, but
3259          --  we do not need to test that here, since Mod is only recognized
3260          --  as an attribute name in Ada 2005 mode during the parse.
3261
3262          Check_E1;
3263          Check_Modular_Integer_Type;
3264          Resolve (E1, Any_Integer);
3265          Set_Etype (N, P_Base_Type);
3266
3267       -----------
3268       -- Model --
3269       -----------
3270
3271       when Attribute_Model =>
3272          Check_Floating_Point_Type_1;
3273          Set_Etype (N, P_Base_Type);
3274          Resolve (E1, P_Base_Type);
3275
3276       ----------------
3277       -- Model_Emin --
3278       ----------------
3279
3280       when Attribute_Model_Emin =>
3281          Check_Floating_Point_Type_0;
3282          Set_Etype (N, Universal_Integer);
3283
3284       -------------------
3285       -- Model_Epsilon --
3286       -------------------
3287
3288       when Attribute_Model_Epsilon =>
3289          Check_Floating_Point_Type_0;
3290          Set_Etype (N, Universal_Real);
3291
3292       --------------------
3293       -- Model_Mantissa --
3294       --------------------
3295
3296       when Attribute_Model_Mantissa =>
3297          Check_Floating_Point_Type_0;
3298          Set_Etype (N, Universal_Integer);
3299
3300       -----------------
3301       -- Model_Small --
3302       -----------------
3303
3304       when Attribute_Model_Small =>
3305          Check_Floating_Point_Type_0;
3306          Set_Etype (N, Universal_Real);
3307
3308       -------------
3309       -- Modulus --
3310       -------------
3311
3312       when Attribute_Modulus =>
3313          Check_E0;
3314          Check_Modular_Integer_Type;
3315          Set_Etype (N, Universal_Integer);
3316
3317       --------------------
3318       -- Null_Parameter --
3319       --------------------
3320
3321       when Attribute_Null_Parameter => Null_Parameter : declare
3322          Parnt  : constant Node_Id := Parent (N);
3323          GParnt : constant Node_Id := Parent (Parnt);
3324
3325          procedure Bad_Null_Parameter (Msg : String);
3326          --  Used if bad Null parameter attribute node is found. Issues
3327          --  given error message, and also sets the type to Any_Type to
3328          --  avoid blowups later on from dealing with a junk node.
3329
3330          procedure Must_Be_Imported (Proc_Ent : Entity_Id);
3331          --  Called to check that Proc_Ent is imported subprogram
3332
3333          ------------------------
3334          -- Bad_Null_Parameter --
3335          ------------------------
3336
3337          procedure Bad_Null_Parameter (Msg : String) is
3338          begin
3339             Error_Msg_N (Msg, N);
3340             Set_Etype (N, Any_Type);
3341          end Bad_Null_Parameter;
3342
3343          ----------------------
3344          -- Must_Be_Imported --
3345          ----------------------
3346
3347          procedure Must_Be_Imported (Proc_Ent : Entity_Id) is
3348             Pent : Entity_Id := Proc_Ent;
3349
3350          begin
3351             while Present (Alias (Pent)) loop
3352                Pent := Alias (Pent);
3353             end loop;
3354
3355             --  Ignore check if procedure not frozen yet (we will get
3356             --  another chance when the default parameter is reanalyzed)
3357
3358             if not Is_Frozen (Pent) then
3359                return;
3360
3361             elsif not Is_Imported (Pent) then
3362                Bad_Null_Parameter
3363                  ("Null_Parameter can only be used with imported subprogram");
3364
3365             else
3366                return;
3367             end if;
3368          end Must_Be_Imported;
3369
3370       --  Start of processing for Null_Parameter
3371
3372       begin
3373          Check_Type;
3374          Check_E0;
3375          Set_Etype (N, P_Type);
3376
3377          --  Case of attribute used as default expression
3378
3379          if Nkind (Parnt) = N_Parameter_Specification then
3380             Must_Be_Imported (Defining_Entity (GParnt));
3381
3382          --  Case of attribute used as actual for subprogram (positional)
3383
3384          elsif (Nkind (Parnt) = N_Procedure_Call_Statement
3385                  or else
3386                 Nkind (Parnt) = N_Function_Call)
3387             and then Is_Entity_Name (Name (Parnt))
3388          then
3389             Must_Be_Imported (Entity (Name (Parnt)));
3390
3391          --  Case of attribute used as actual for subprogram (named)
3392
3393          elsif Nkind (Parnt) = N_Parameter_Association
3394            and then (Nkind (GParnt) = N_Procedure_Call_Statement
3395                        or else
3396                      Nkind (GParnt) = N_Function_Call)
3397            and then Is_Entity_Name (Name (GParnt))
3398          then
3399             Must_Be_Imported (Entity (Name (GParnt)));
3400
3401          --  Not an allowed case
3402
3403          else
3404             Bad_Null_Parameter
3405               ("Null_Parameter must be actual or default parameter");
3406          end if;
3407
3408       end Null_Parameter;
3409
3410       -----------------
3411       -- Object_Size --
3412       -----------------
3413
3414       when Attribute_Object_Size =>
3415          Check_E0;
3416          Check_Type;
3417          Check_Not_Incomplete_Type;
3418          Set_Etype (N, Universal_Integer);
3419
3420       ------------
3421       -- Output --
3422       ------------
3423
3424       when Attribute_Output =>
3425          Check_E2;
3426          Check_Stream_Attribute (TSS_Stream_Output);
3427          Set_Etype (N, Standard_Void_Type);
3428          Resolve (N, Standard_Void_Type);
3429
3430       ------------------
3431       -- Partition_ID --
3432       ------------------
3433
3434       when Attribute_Partition_ID =>
3435          Check_E0;
3436
3437          if P_Type /= Any_Type then
3438             if not Is_Library_Level_Entity (Entity (P)) then
3439                Error_Attr_P
3440                  ("prefix of % attribute must be library-level entity");
3441
3442             --  The defining entity of prefix should not be declared inside
3443             --  a Pure unit. RM E.1(8).
3444             --  The Is_Pure flag has been set during declaration.
3445
3446             elsif Is_Entity_Name (P)
3447               and then Is_Pure (Entity (P))
3448             then
3449                Error_Attr_P
3450                  ("prefix of % attribute must not be declared pure");
3451             end if;
3452          end if;
3453
3454          Set_Etype (N, Universal_Integer);
3455
3456       -------------------------
3457       -- Passed_By_Reference --
3458       -------------------------
3459
3460       when Attribute_Passed_By_Reference =>
3461          Check_E0;
3462          Check_Type;
3463          Set_Etype (N, Standard_Boolean);
3464
3465       ------------------
3466       -- Pool_Address --
3467       ------------------
3468
3469       when Attribute_Pool_Address =>
3470          Check_E0;
3471          Set_Etype (N, RTE (RE_Address));
3472
3473       ---------
3474       -- Pos --
3475       ---------
3476
3477       when Attribute_Pos =>
3478          Check_Discrete_Type;
3479          Check_E1;
3480          Resolve (E1, P_Base_Type);
3481          Set_Etype (N, Universal_Integer);
3482
3483       --------------
3484       -- Position --
3485       --------------
3486
3487       when Attribute_Position =>
3488          Check_Component;
3489          Set_Etype (N, Universal_Integer);
3490
3491       ----------
3492       -- Pred --
3493       ----------
3494
3495       when Attribute_Pred =>
3496          Check_Scalar_Type;
3497          Check_E1;
3498          Resolve (E1, P_Base_Type);
3499          Set_Etype (N, P_Base_Type);
3500
3501          --  Nothing to do for real type case
3502
3503          if Is_Real_Type (P_Type) then
3504             null;
3505
3506          --  If not modular type, test for overflow check required
3507
3508          else
3509             if not Is_Modular_Integer_Type (P_Type)
3510               and then not Range_Checks_Suppressed (P_Base_Type)
3511             then
3512                Enable_Range_Check (E1);
3513             end if;
3514          end if;
3515
3516       --------------
3517       -- Priority --
3518       --------------
3519
3520       --  Ada 2005 (AI-327): Dynamic ceiling priorities
3521
3522       when Attribute_Priority =>
3523          if Ada_Version < Ada_05 then
3524             Error_Attr ("% attribute is allowed only in Ada 2005 mode", P);
3525          end if;
3526
3527          Check_E0;
3528
3529          --  The prefix must be a protected object (AARM D.5.2 (2/2))
3530
3531          Analyze (P);
3532
3533          if Is_Protected_Type (Etype (P))
3534            or else (Is_Access_Type (Etype (P))
3535                       and then Is_Protected_Type (Designated_Type (Etype (P))))
3536          then
3537             Resolve (P, Etype (P));
3538          else
3539             Error_Attr_P ("prefix of % attribute must be a protected object");
3540          end if;
3541
3542          Set_Etype (N, Standard_Integer);
3543
3544          --  Must be called from within a protected procedure or entry of the
3545          --  protected object.
3546
3547          declare
3548             S : Entity_Id;
3549
3550          begin
3551             S := Current_Scope;
3552             while S /= Etype (P)
3553                and then S /= Standard_Standard
3554             loop
3555                S := Scope (S);
3556             end loop;
3557
3558             if S = Standard_Standard then
3559                Error_Attr ("the attribute % is only allowed inside protected "
3560                            & "operations", P);
3561             end if;
3562          end;
3563
3564          Validate_Non_Static_Attribute_Function_Call;
3565
3566       -----------
3567       -- Range --
3568       -----------
3569
3570       when Attribute_Range =>
3571          Check_Array_Or_Scalar_Type;
3572
3573          if Ada_Version = Ada_83
3574            and then Is_Scalar_Type (P_Type)
3575            and then Comes_From_Source (N)
3576          then
3577             Error_Attr
3578               ("(Ada 83) % attribute not allowed for scalar type", P);
3579          end if;
3580
3581       ------------------
3582       -- Range_Length --
3583       ------------------
3584
3585       when Attribute_Range_Length =>
3586          Check_Discrete_Type;
3587          Set_Etype (N, Universal_Integer);
3588
3589       ----------
3590       -- Read --
3591       ----------
3592
3593       when Attribute_Read =>
3594          Check_E2;
3595          Check_Stream_Attribute (TSS_Stream_Read);
3596          Set_Etype (N, Standard_Void_Type);
3597          Resolve (N, Standard_Void_Type);
3598          Note_Possible_Modification (E2);
3599
3600       ---------------
3601       -- Remainder --
3602       ---------------
3603
3604       when Attribute_Remainder =>
3605          Check_Floating_Point_Type_2;
3606          Set_Etype (N, P_Base_Type);
3607          Resolve (E1, P_Base_Type);
3608          Resolve (E2, P_Base_Type);
3609
3610       -----------
3611       -- Round --
3612       -----------
3613
3614       when Attribute_Round =>
3615          Check_E1;
3616          Check_Decimal_Fixed_Point_Type;
3617          Set_Etype (N, P_Base_Type);
3618
3619          --  Because the context is universal_real (3.5.10(12)) it is a legal
3620          --  context for a universal fixed expression. This is the only
3621          --  attribute whose functional description involves U_R.
3622
3623          if Etype (E1) = Universal_Fixed then
3624             declare
3625                Conv : constant Node_Id := Make_Type_Conversion (Loc,
3626                   Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc),
3627                   Expression   => Relocate_Node (E1));
3628
3629             begin
3630                Rewrite (E1, Conv);
3631                Analyze (E1);
3632             end;
3633          end if;
3634
3635          Resolve (E1, Any_Real);
3636
3637       --------------
3638       -- Rounding --
3639       --------------
3640
3641       when Attribute_Rounding =>
3642          Check_Floating_Point_Type_1;
3643          Set_Etype (N, P_Base_Type);
3644          Resolve (E1, P_Base_Type);
3645
3646       ---------------
3647       -- Safe_Emax --
3648       ---------------
3649
3650       when Attribute_Safe_Emax =>
3651          Check_Floating_Point_Type_0;
3652          Set_Etype (N, Universal_Integer);
3653
3654       ----------------
3655       -- Safe_First --
3656       ----------------
3657
3658       when Attribute_Safe_First =>
3659          Check_Floating_Point_Type_0;
3660          Set_Etype (N, Universal_Real);
3661
3662       ----------------
3663       -- Safe_Large --
3664       ----------------
3665
3666       when Attribute_Safe_Large =>
3667          Check_E0;
3668          Check_Real_Type;
3669          Set_Etype (N, Universal_Real);
3670
3671       ---------------
3672       -- Safe_Last --
3673       ---------------
3674
3675       when Attribute_Safe_Last =>
3676          Check_Floating_Point_Type_0;
3677          Set_Etype (N, Universal_Real);
3678
3679       ----------------
3680       -- Safe_Small --
3681       ----------------
3682
3683       when Attribute_Safe_Small =>
3684          Check_E0;
3685          Check_Real_Type;
3686          Set_Etype (N, Universal_Real);
3687
3688       -----------
3689       -- Scale --
3690       -----------
3691
3692       when Attribute_Scale =>
3693          Check_E0;
3694          Check_Decimal_Fixed_Point_Type;
3695          Set_Etype (N, Universal_Integer);
3696
3697       -------------
3698       -- Scaling --
3699       -------------
3700
3701       when Attribute_Scaling =>
3702          Check_Floating_Point_Type_2;
3703          Set_Etype (N, P_Base_Type);
3704          Resolve (E1, P_Base_Type);
3705
3706       ------------------
3707       -- Signed_Zeros --
3708       ------------------
3709
3710       when Attribute_Signed_Zeros =>
3711          Check_Floating_Point_Type_0;
3712          Set_Etype (N, Standard_Boolean);
3713
3714       ----------
3715       -- Size --
3716       ----------
3717
3718       when Attribute_Size | Attribute_VADS_Size =>
3719          Check_E0;
3720
3721          --  If prefix is parameterless function call, rewrite and resolve
3722          --  as such.
3723
3724          if Is_Entity_Name (P)
3725            and then Ekind (Entity (P)) = E_Function
3726          then
3727             Resolve (P);
3728
3729          --  Similar processing for a protected function call
3730
3731          elsif Nkind (P) = N_Selected_Component
3732            and then Ekind (Entity (Selector_Name (P))) = E_Function
3733          then
3734             Resolve (P);
3735          end if;
3736
3737          if Is_Object_Reference (P) then
3738             Check_Object_Reference (P);
3739
3740          elsif Is_Entity_Name (P)
3741            and then (Is_Type (Entity (P))
3742                        or else Ekind (Entity (P)) = E_Enumeration_Literal)
3743          then
3744             null;
3745
3746          elsif Nkind (P) = N_Type_Conversion
3747            and then not Comes_From_Source (P)
3748          then
3749             null;
3750
3751          else
3752             Error_Attr_P ("invalid prefix for % attribute");
3753          end if;
3754
3755          Check_Not_Incomplete_Type;
3756          Set_Etype (N, Universal_Integer);
3757
3758       -----------
3759       -- Small --
3760       -----------
3761
3762       when Attribute_Small =>
3763          Check_E0;
3764          Check_Real_Type;
3765          Set_Etype (N, Universal_Real);
3766
3767       ------------------
3768       -- Storage_Pool --
3769       ------------------
3770
3771       when Attribute_Storage_Pool =>
3772          if Is_Access_Type (P_Type) then
3773             Check_E0;
3774
3775             if Ekind (P_Type) = E_Access_Subprogram_Type then
3776                Error_Attr_P
3777                  ("cannot use % attribute for access-to-subprogram type");
3778             end if;
3779
3780             --  Set appropriate entity
3781
3782             if Present (Associated_Storage_Pool (Root_Type (P_Type))) then
3783                Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type)));
3784             else
3785                Set_Entity (N, RTE (RE_Global_Pool_Object));
3786             end if;
3787
3788             Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
3789
3790             --  Validate_Remote_Access_To_Class_Wide_Type for attribute
3791             --  Storage_Pool since this attribute is not defined for such
3792             --  types (RM E.2.3(22)).
3793
3794             Validate_Remote_Access_To_Class_Wide_Type (N);
3795
3796          else
3797             Error_Attr_P ("prefix of % attribute must be access type");
3798          end if;
3799
3800       ------------------
3801       -- Storage_Size --
3802       ------------------
3803
3804       when Attribute_Storage_Size =>
3805          if Is_Task_Type (P_Type) then
3806             Check_E0;
3807             Set_Etype (N, Universal_Integer);
3808
3809          elsif Is_Access_Type (P_Type) then
3810             if Ekind (P_Type) = E_Access_Subprogram_Type then
3811                Error_Attr_P
3812                  ("cannot use % attribute for access-to-subprogram type");
3813             end if;
3814
3815             if Is_Entity_Name (P)
3816               and then Is_Type (Entity (P))
3817             then
3818                Check_E0;
3819                Check_Type;
3820                Set_Etype (N, Universal_Integer);
3821
3822                --   Validate_Remote_Access_To_Class_Wide_Type for attribute
3823                --   Storage_Size since this attribute is not defined for
3824                --   such types (RM E.2.3(22)).
3825
3826                Validate_Remote_Access_To_Class_Wide_Type (N);
3827
3828             --  The prefix is allowed to be an implicit dereference
3829             --  of an access value designating a task.
3830
3831             else
3832                Check_E0;
3833                Check_Task_Prefix;
3834                Set_Etype (N, Universal_Integer);
3835             end if;
3836
3837          else
3838             Error_Attr_P ("prefix of % attribute must be access or task type");
3839          end if;
3840
3841       ------------------
3842       -- Storage_Unit --
3843       ------------------
3844
3845       when Attribute_Storage_Unit =>
3846          Standard_Attribute (Ttypes.System_Storage_Unit);
3847
3848       -----------------
3849       -- Stream_Size --
3850       -----------------
3851
3852       when Attribute_Stream_Size =>
3853          Check_E0;
3854          Check_Type;
3855
3856          if Is_Entity_Name (P)
3857            and then Is_Elementary_Type (Entity (P))
3858          then
3859             Set_Etype (N, Universal_Integer);
3860          else
3861             Error_Attr_P ("invalid prefix for % attribute");
3862          end if;
3863
3864       ---------------
3865       -- Stub_Type --
3866       ---------------
3867
3868       when Attribute_Stub_Type =>
3869          Check_Type;
3870          Check_E0;
3871
3872          if Is_Remote_Access_To_Class_Wide_Type (P_Type) then
3873             Rewrite (N,
3874               New_Occurrence_Of (Corresponding_Stub_Type (P_Type), Loc));
3875          else
3876             Error_Attr_P
3877               ("prefix of% attribute must be remote access to classwide");
3878          end if;
3879
3880       ----------
3881       -- Succ --
3882       ----------
3883
3884       when Attribute_Succ =>
3885          Check_Scalar_Type;
3886          Check_E1;
3887          Resolve (E1, P_Base_Type);
3888          Set_Etype (N, P_Base_Type);
3889
3890          --  Nothing to do for real type case
3891
3892          if Is_Real_Type (P_Type) then
3893             null;
3894
3895          --  If not modular type, test for overflow check required
3896
3897          else
3898             if not Is_Modular_Integer_Type (P_Type)
3899               and then not Range_Checks_Suppressed (P_Base_Type)
3900             then
3901                Enable_Range_Check (E1);
3902             end if;
3903          end if;
3904
3905       ---------
3906       -- Tag --
3907       ---------
3908
3909       when Attribute_Tag =>
3910          Check_E0;
3911          Check_Dereference;
3912
3913          if not Is_Tagged_Type (P_Type) then
3914             Error_Attr_P ("prefix of % attribute must be tagged");
3915
3916          --  Next test does not apply to generated code
3917          --  why not, and what does the illegal reference mean???
3918
3919          elsif Is_Object_Reference (P)
3920            and then not Is_Class_Wide_Type (P_Type)
3921            and then Comes_From_Source (N)
3922          then
3923             Error_Attr_P
3924               ("% attribute can only be applied to objects " &
3925                "of class - wide type");
3926          end if;
3927
3928          --  The prefix cannot be an incomplete type. However, references
3929          --  to 'Tag can be generated when expanding interface conversions,
3930          --  and this is legal.
3931
3932          if Comes_From_Source (N) then
3933             Check_Not_Incomplete_Type;
3934          end if;
3935          Set_Etype (N, RTE (RE_Tag));
3936
3937       -----------------
3938       -- Target_Name --
3939       -----------------
3940
3941       when Attribute_Target_Name => Target_Name : declare
3942          TN : constant String := Sdefault.Target_Name.all;
3943          TL : Natural;
3944
3945       begin
3946          Check_Standard_Prefix;
3947          Check_E0;
3948
3949          TL := TN'Last;
3950
3951          if TN (TL) = '/' or else TN (TL) = '\' then
3952             TL := TL - 1;
3953          end if;
3954
3955          Rewrite (N,
3956            Make_String_Literal (Loc,
3957              Strval => TN (TN'First .. TL)));
3958          Analyze_And_Resolve (N, Standard_String);
3959       end Target_Name;