OSDN Git Service

gcc/ada/
[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_E0;
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          Set_Entity (N, Base_Type (Entity (P)));
2211          Rewrite (N, New_Reference_To (Entity (N), Loc));
2212          Analyze (N);
2213       end Base;
2214
2215       ---------
2216       -- Bit --
2217       ---------
2218
2219       when Attribute_Bit => Bit :
2220       begin
2221          Check_E0;
2222
2223          if not Is_Object_Reference (P) then
2224             Error_Attr_P ("prefix for % attribute must be object");
2225
2226          --  What about the access object cases ???
2227
2228          else
2229             null;
2230          end if;
2231
2232          Set_Etype (N, Universal_Integer);
2233       end Bit;
2234
2235       ---------------
2236       -- Bit_Order --
2237       ---------------
2238
2239       when Attribute_Bit_Order => Bit_Order :
2240       begin
2241          Check_E0;
2242          Check_Type;
2243
2244          if not Is_Record_Type (P_Type) then
2245             Error_Attr_P ("prefix of % attribute must be record type");
2246          end if;
2247
2248          if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then
2249             Rewrite (N,
2250               New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
2251          else
2252             Rewrite (N,
2253               New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
2254          end if;
2255
2256          Set_Etype (N, RTE (RE_Bit_Order));
2257          Resolve (N);
2258
2259          --  Reset incorrect indication of staticness
2260
2261          Set_Is_Static_Expression (N, False);
2262       end Bit_Order;
2263
2264       ------------------
2265       -- Bit_Position --
2266       ------------------
2267
2268       --  Note: in generated code, we can have a Bit_Position attribute
2269       --  applied to a (naked) record component (i.e. the prefix is an
2270       --  identifier that references an E_Component or E_Discriminant
2271       --  entity directly, and this is interpreted as expected by Gigi.
2272       --  The following code will not tolerate such usage, but when the
2273       --  expander creates this special case, it marks it as analyzed
2274       --  immediately and sets an appropriate type.
2275
2276       when Attribute_Bit_Position =>
2277          if Comes_From_Source (N) then
2278             Check_Component;
2279          end if;
2280
2281          Set_Etype (N, Universal_Integer);
2282
2283       ------------------
2284       -- Body_Version --
2285       ------------------
2286
2287       when Attribute_Body_Version =>
2288          Check_E0;
2289          Check_Program_Unit;
2290          Set_Etype (N, RTE (RE_Version_String));
2291
2292       --------------
2293       -- Callable --
2294       --------------
2295
2296       when Attribute_Callable =>
2297          Check_E0;
2298          Set_Etype (N, Standard_Boolean);
2299          Check_Task_Prefix;
2300
2301       ------------
2302       -- Caller --
2303       ------------
2304
2305       when Attribute_Caller => Caller : declare
2306          Ent        : Entity_Id;
2307          S          : Entity_Id;
2308
2309       begin
2310          Check_E0;
2311
2312          if Nkind (P) = N_Identifier
2313            or else Nkind (P) = N_Expanded_Name
2314          then
2315             Ent := Entity (P);
2316
2317             if not Is_Entry (Ent) then
2318                Error_Attr ("invalid entry name", N);
2319             end if;
2320
2321          else
2322             Error_Attr ("invalid entry name", N);
2323             return;
2324          end if;
2325
2326          for J in reverse 0 .. Scope_Stack.Last loop
2327             S := Scope_Stack.Table (J).Entity;
2328
2329             if S = Scope (Ent) then
2330                Error_Attr ("Caller must appear in matching accept or body", N);
2331             elsif S = Ent then
2332                exit;
2333             end if;
2334          end loop;
2335
2336          Set_Etype (N, RTE (RO_AT_Task_Id));
2337       end Caller;
2338
2339       -------------
2340       -- Ceiling --
2341       -------------
2342
2343       when Attribute_Ceiling =>
2344          Check_Floating_Point_Type_1;
2345          Set_Etype (N, P_Base_Type);
2346          Resolve (E1, P_Base_Type);
2347
2348       -----------
2349       -- Class --
2350       -----------
2351
2352       when Attribute_Class =>
2353          Check_Restriction (No_Dispatch, N);
2354          Check_E0;
2355          Find_Type (N);
2356
2357       ------------------
2358       -- Code_Address --
2359       ------------------
2360
2361       when Attribute_Code_Address =>
2362          Check_E0;
2363
2364          if Nkind (P) = N_Attribute_Reference
2365            and then (Attribute_Name (P) = Name_Elab_Body
2366                        or else
2367                      Attribute_Name (P) = Name_Elab_Spec)
2368          then
2369             null;
2370
2371          elsif not Is_Entity_Name (P)
2372            or else (Ekind (Entity (P)) /= E_Function
2373                       and then
2374                     Ekind (Entity (P)) /= E_Procedure)
2375          then
2376             Error_Attr ("invalid prefix for % attribute", P);
2377             Set_Address_Taken (Entity (P));
2378          end if;
2379
2380          Set_Etype (N, RTE (RE_Address));
2381
2382       --------------------
2383       -- Component_Size --
2384       --------------------
2385
2386       when Attribute_Component_Size =>
2387          Check_E0;
2388          Set_Etype (N, Universal_Integer);
2389
2390          --  Note: unlike other array attributes, unconstrained arrays are OK
2391
2392          if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then
2393             null;
2394          else
2395             Check_Array_Type;
2396          end if;
2397
2398       -------------
2399       -- Compose --
2400       -------------
2401
2402       when Attribute_Compose =>
2403          Check_Floating_Point_Type_2;
2404          Set_Etype (N, P_Base_Type);
2405          Resolve (E1, P_Base_Type);
2406          Resolve (E2, Any_Integer);
2407
2408       -----------------
2409       -- Constrained --
2410       -----------------
2411
2412       when Attribute_Constrained =>
2413          Check_E0;
2414          Set_Etype (N, Standard_Boolean);
2415
2416          --  Case from RM J.4(2) of constrained applied to private type
2417
2418          if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
2419             Check_Restriction (No_Obsolescent_Features, N);
2420
2421             if Warn_On_Obsolescent_Feature then
2422                Error_Msg_N
2423                  ("constrained for private type is an " &
2424                   "obsolescent feature (RM J.4)?", N);
2425             end if;
2426
2427             --  If we are within an instance, the attribute must be legal
2428             --  because it was valid in the generic unit. Ditto if this is
2429             --  an inlining of a function declared in an instance.
2430
2431             if In_Instance
2432               or else In_Inlined_Body
2433             then
2434                return;
2435
2436             --  For sure OK if we have a real private type itself, but must
2437             --  be completed, cannot apply Constrained to incomplete type.
2438
2439             elsif Is_Private_Type (Entity (P)) then
2440
2441                --  Note: this is one of the Annex J features that does not
2442                --  generate a warning from -gnatwj, since in fact it seems
2443                --  very useful, and is used in the GNAT runtime.
2444
2445                Check_Not_Incomplete_Type;
2446                return;
2447             end if;
2448
2449          --  Normal (non-obsolescent case) of application to object of
2450          --  a discriminated type.
2451
2452          else
2453             Check_Object_Reference (P);
2454
2455             --  If N does not come from source, then we allow the
2456             --  the attribute prefix to be of a private type whose
2457             --  full type has discriminants. This occurs in cases
2458             --  involving expanded calls to stream attributes.
2459
2460             if not Comes_From_Source (N) then
2461                P_Type := Underlying_Type (P_Type);
2462             end if;
2463
2464             --  Must have discriminants or be an access type designating
2465             --  a type with discriminants. If it is a classwide type is ???
2466             --  has unknown discriminants.
2467
2468             if Has_Discriminants (P_Type)
2469                or else Has_Unknown_Discriminants (P_Type)
2470                or else
2471                  (Is_Access_Type (P_Type)
2472                    and then Has_Discriminants (Designated_Type (P_Type)))
2473             then
2474                return;
2475
2476             --  Also allow an object of a generic type if extensions allowed
2477             --  and allow this for any type at all.
2478
2479             elsif (Is_Generic_Type (P_Type)
2480                      or else Is_Generic_Actual_Type (P_Type))
2481               and then Extensions_Allowed
2482             then
2483                return;
2484             end if;
2485          end if;
2486
2487          --  Fall through if bad prefix
2488
2489          Error_Attr_P
2490            ("prefix of % attribute must be object of discriminated type");
2491
2492       ---------------
2493       -- Copy_Sign --
2494       ---------------
2495
2496       when Attribute_Copy_Sign =>
2497          Check_Floating_Point_Type_2;
2498          Set_Etype (N, P_Base_Type);
2499          Resolve (E1, P_Base_Type);
2500          Resolve (E2, P_Base_Type);
2501
2502       -----------
2503       -- Count --
2504       -----------
2505
2506       when Attribute_Count => Count :
2507       declare
2508          Ent : Entity_Id;
2509          S   : Entity_Id;
2510          Tsk : Entity_Id;
2511
2512       begin
2513          Check_E0;
2514
2515          if Nkind (P) = N_Identifier
2516            or else Nkind (P) = N_Expanded_Name
2517          then
2518             Ent := Entity (P);
2519
2520             if Ekind (Ent) /= E_Entry then
2521                Error_Attr ("invalid entry name", N);
2522             end if;
2523
2524          elsif Nkind (P) = N_Indexed_Component then
2525             if not Is_Entity_Name (Prefix (P))
2526               or else  No (Entity (Prefix (P)))
2527               or else Ekind (Entity (Prefix (P))) /= E_Entry_Family
2528             then
2529                if Nkind (Prefix (P)) = N_Selected_Component
2530                  and then Present (Entity (Selector_Name (Prefix (P))))
2531                  and then Ekind (Entity (Selector_Name (Prefix (P)))) =
2532                                                              E_Entry_Family
2533                then
2534                   Error_Attr
2535                     ("attribute % must apply to entry of current task", P);
2536
2537                else
2538                   Error_Attr ("invalid entry family name", P);
2539                end if;
2540                return;
2541
2542             else
2543                Ent := Entity (Prefix (P));
2544             end if;
2545
2546          elsif Nkind (P) = N_Selected_Component
2547            and then Present (Entity (Selector_Name (P)))
2548            and then Ekind (Entity (Selector_Name (P))) = E_Entry
2549          then
2550             Error_Attr
2551               ("attribute % must apply to entry of current task", P);
2552
2553          else
2554             Error_Attr ("invalid entry name", N);
2555             return;
2556          end if;
2557
2558          for J in reverse 0 .. Scope_Stack.Last loop
2559             S := Scope_Stack.Table (J).Entity;
2560
2561             if S = Scope (Ent) then
2562                if Nkind (P) = N_Expanded_Name then
2563                   Tsk := Entity (Prefix (P));
2564
2565                   --  The prefix denotes either the task type, or else a
2566                   --  single task whose task type is being analyzed.
2567
2568                   if (Is_Type (Tsk)
2569                       and then Tsk = S)
2570
2571                     or else (not Is_Type (Tsk)
2572                       and then Etype (Tsk) = S
2573                       and then not (Comes_From_Source (S)))
2574                   then
2575                      null;
2576                   else
2577                      Error_Attr
2578                        ("Attribute % must apply to entry of current task", N);
2579                   end if;
2580                end if;
2581
2582                exit;
2583
2584             elsif Ekind (Scope (Ent)) in Task_Kind
2585               and then Ekind (S) /= E_Loop
2586               and then Ekind (S) /= E_Block
2587               and then Ekind (S) /= E_Entry
2588               and then Ekind (S) /= E_Entry_Family
2589             then
2590                Error_Attr ("Attribute % cannot appear in inner unit", N);
2591
2592             elsif Ekind (Scope (Ent)) = E_Protected_Type
2593               and then not Has_Completion (Scope (Ent))
2594             then
2595                Error_Attr ("attribute % can only be used inside body", N);
2596             end if;
2597          end loop;
2598
2599          if Is_Overloaded (P) then
2600             declare
2601                Index : Interp_Index;
2602                It    : Interp;
2603
2604             begin
2605                Get_First_Interp (P, Index, It);
2606
2607                while Present (It.Nam) loop
2608                   if It.Nam = Ent then
2609                      null;
2610
2611                   --  Ada 2005 (AI-345): Do not consider primitive entry
2612                   --  wrappers generated for task or protected types.
2613
2614                   elsif Ada_Version >= Ada_05
2615                     and then not Comes_From_Source (It.Nam)
2616                   then
2617                      null;
2618
2619                   else
2620                      Error_Attr ("ambiguous entry name", N);
2621                   end if;
2622
2623                   Get_Next_Interp (Index, It);
2624                end loop;
2625             end;
2626          end if;
2627
2628          Set_Etype (N, Universal_Integer);
2629       end Count;
2630
2631       -----------------------
2632       -- Default_Bit_Order --
2633       -----------------------
2634
2635       when Attribute_Default_Bit_Order => Default_Bit_Order :
2636       begin
2637          Check_Standard_Prefix;
2638          Check_E0;
2639
2640          if Bytes_Big_Endian then
2641             Rewrite (N,
2642               Make_Integer_Literal (Loc, False_Value));
2643          else
2644             Rewrite (N,
2645               Make_Integer_Literal (Loc, True_Value));
2646          end if;
2647
2648          Set_Etype (N, Universal_Integer);
2649          Set_Is_Static_Expression (N);
2650       end Default_Bit_Order;
2651
2652       --------------
2653       -- Definite --
2654       --------------
2655
2656       when Attribute_Definite =>
2657          Legal_Formal_Attribute;
2658
2659       -----------
2660       -- Delta --
2661       -----------
2662
2663       when Attribute_Delta =>
2664          Check_Fixed_Point_Type_0;
2665          Set_Etype (N, Universal_Real);
2666
2667       ------------
2668       -- Denorm --
2669       ------------
2670
2671       when Attribute_Denorm =>
2672          Check_Floating_Point_Type_0;
2673          Set_Etype (N, Standard_Boolean);
2674
2675       ------------
2676       -- Digits --
2677       ------------
2678
2679       when Attribute_Digits =>
2680          Check_E0;
2681          Check_Type;
2682
2683          if not Is_Floating_Point_Type (P_Type)
2684            and then not Is_Decimal_Fixed_Point_Type (P_Type)
2685          then
2686             Error_Attr_P
2687               ("prefix of % attribute must be float or decimal type");
2688          end if;
2689
2690          Set_Etype (N, Universal_Integer);
2691
2692       ---------------
2693       -- Elab_Body --
2694       ---------------
2695
2696       --  Also handles processing for Elab_Spec
2697
2698       when Attribute_Elab_Body | Attribute_Elab_Spec =>
2699          Check_E0;
2700          Check_Unit_Name (P);
2701          Set_Etype (N, Standard_Void_Type);
2702
2703          --  We have to manually call the expander in this case to get
2704          --  the necessary expansion (normally attributes that return
2705          --  entities are not expanded).
2706
2707          Expand (N);
2708
2709       ---------------
2710       -- Elab_Spec --
2711       ---------------
2712
2713       --  Shares processing with Elab_Body
2714
2715       ----------------
2716       -- Elaborated --
2717       ----------------
2718
2719       when Attribute_Elaborated =>
2720          Check_E0;
2721          Check_Library_Unit;
2722          Set_Etype (N, Standard_Boolean);
2723
2724       ----------
2725       -- Emax --
2726       ----------
2727
2728       when Attribute_Emax =>
2729          Check_Floating_Point_Type_0;
2730          Set_Etype (N, Universal_Integer);
2731
2732       -------------
2733       -- Enabled --
2734       -------------
2735
2736       when Attribute_Enabled =>
2737          Check_Either_E0_Or_E1;
2738
2739          if Present (E1) then
2740             if not Is_Entity_Name (E1) or else No (Entity (E1)) then
2741                Error_Msg_N ("entity name expected for Enabled attribute", E1);
2742                E1 := Empty;
2743             end if;
2744          end if;
2745
2746          if Nkind (P) /= N_Identifier then
2747             Error_Msg_N ("identifier expected (check name)", P);
2748
2749          elsif Get_Check_Id (Chars (P)) = No_Check_Id then
2750             Error_Msg_N ("& is not a recognized check name", P);
2751          end if;
2752
2753          Set_Etype (N, Standard_Boolean);
2754
2755       --------------
2756       -- Enum_Rep --
2757       --------------
2758
2759       when Attribute_Enum_Rep => Enum_Rep : declare
2760       begin
2761          if Present (E1) then
2762             Check_E1;
2763             Check_Discrete_Type;
2764             Resolve (E1, P_Base_Type);
2765
2766          else
2767             if not Is_Entity_Name (P)
2768               or else (not Is_Object (Entity (P))
2769                          and then
2770                        Ekind (Entity (P)) /= E_Enumeration_Literal)
2771             then
2772                Error_Attr_P
2773                  ("prefix of %attribute must be " &
2774                   "discrete type/object or enum literal");
2775             end if;
2776          end if;
2777
2778          Set_Etype (N, Universal_Integer);
2779       end Enum_Rep;
2780
2781       -------------
2782       -- Epsilon --
2783       -------------
2784
2785       when Attribute_Epsilon =>
2786          Check_Floating_Point_Type_0;
2787          Set_Etype (N, Universal_Real);
2788
2789       --------------
2790       -- Exponent --
2791       --------------
2792
2793       when Attribute_Exponent =>
2794          Check_Floating_Point_Type_1;
2795          Set_Etype (N, Universal_Integer);
2796          Resolve (E1, P_Base_Type);
2797
2798       ------------------
2799       -- External_Tag --
2800       ------------------
2801
2802       when Attribute_External_Tag =>
2803          Check_E0;
2804          Check_Type;
2805
2806          Set_Etype (N, Standard_String);
2807
2808          if not Is_Tagged_Type (P_Type) then
2809             Error_Attr_P ("prefix of % attribute must be tagged");
2810          end if;
2811
2812       -----------
2813       -- First --
2814       -----------
2815
2816       when Attribute_First =>
2817          Check_Array_Or_Scalar_Type;
2818
2819       ---------------
2820       -- First_Bit --
2821       ---------------
2822
2823       when Attribute_First_Bit =>
2824          Check_Component;
2825          Set_Etype (N, Universal_Integer);
2826
2827       -----------------
2828       -- Fixed_Value --
2829       -----------------
2830
2831       when Attribute_Fixed_Value =>
2832          Check_E1;
2833          Check_Fixed_Point_Type;
2834          Resolve (E1, Any_Integer);
2835          Set_Etype (N, P_Base_Type);
2836
2837       -----------
2838       -- Floor --
2839       -----------
2840
2841       when Attribute_Floor =>
2842          Check_Floating_Point_Type_1;
2843          Set_Etype (N, P_Base_Type);
2844          Resolve (E1, P_Base_Type);
2845
2846       ----------
2847       -- Fore --
2848       ----------
2849
2850       when Attribute_Fore =>
2851          Check_Fixed_Point_Type_0;
2852          Set_Etype (N, Universal_Integer);
2853
2854       --------------
2855       -- Fraction --
2856       --------------
2857
2858       when Attribute_Fraction =>
2859          Check_Floating_Point_Type_1;
2860          Set_Etype (N, P_Base_Type);
2861          Resolve (E1, P_Base_Type);
2862
2863       -----------------------
2864       -- Has_Access_Values --
2865       -----------------------
2866
2867       when Attribute_Has_Access_Values =>
2868          Check_Type;
2869          Check_E0;
2870          Set_Etype (N, Standard_Boolean);
2871
2872       -----------------------
2873       -- Has_Discriminants --
2874       -----------------------
2875
2876       when Attribute_Has_Discriminants =>
2877          Legal_Formal_Attribute;
2878
2879       --------------
2880       -- Identity --
2881       --------------
2882
2883       when Attribute_Identity =>
2884          Check_E0;
2885          Analyze (P);
2886
2887          if Etype (P) =  Standard_Exception_Type then
2888             Set_Etype (N, RTE (RE_Exception_Id));
2889
2890          --  Ada 2005 (AI-345): Attribute 'Identity may be applied to
2891          --  task interface class-wide types.
2892
2893          elsif Is_Task_Type (Etype (P))
2894            or else (Is_Access_Type (Etype (P))
2895                       and then Is_Task_Type (Designated_Type (Etype (P))))
2896            or else (Ada_Version >= Ada_05
2897                       and then Ekind (Etype (P)) = E_Class_Wide_Type
2898                       and then Is_Interface (Etype (P))
2899                       and then Is_Task_Interface (Etype (P)))
2900          then
2901             Resolve (P);
2902             Set_Etype (N, RTE (RO_AT_Task_Id));
2903
2904          else
2905             if Ada_Version >= Ada_05 then
2906                Error_Attr_P
2907                  ("prefix of % attribute must be an exception, a " &
2908                   "task or a task interface class-wide object");
2909             else
2910                Error_Attr_P
2911                  ("prefix of % attribute must be a task or an exception");
2912             end if;
2913          end if;
2914
2915       -----------
2916       -- Image --
2917       -----------
2918
2919       when Attribute_Image => Image :
2920       begin
2921          Set_Etype (N, Standard_String);
2922          Check_Scalar_Type;
2923
2924          if Is_Real_Type (P_Type) then
2925             if Ada_Version = Ada_83 and then Comes_From_Source (N) then
2926                Error_Msg_Name_1 := Aname;
2927                Error_Msg_N
2928                  ("(Ada 83) % attribute not allowed for real types", N);
2929             end if;
2930          end if;
2931
2932          if Is_Enumeration_Type (P_Type) then
2933             Check_Restriction (No_Enumeration_Maps, N);
2934          end if;
2935
2936          Check_E1;
2937          Resolve (E1, P_Base_Type);
2938          Check_Enum_Image;
2939          Validate_Non_Static_Attribute_Function_Call;
2940       end Image;
2941
2942       ---------
2943       -- Img --
2944       ---------
2945
2946       when Attribute_Img => Img :
2947       begin
2948          Check_E0;
2949          Set_Etype (N, Standard_String);
2950
2951          if not Is_Scalar_Type (P_Type)
2952            or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
2953          then
2954             Error_Attr_P
2955               ("prefix of % attribute must be scalar object name");
2956          end if;
2957
2958          Check_Enum_Image;
2959       end Img;
2960
2961       -----------
2962       -- Input --
2963       -----------
2964
2965       when Attribute_Input =>
2966          Check_E1;
2967          Check_Stream_Attribute (TSS_Stream_Input);
2968          Set_Etype (N, P_Base_Type);
2969
2970       -------------------
2971       -- Integer_Value --
2972       -------------------
2973
2974       when Attribute_Integer_Value =>
2975          Check_E1;
2976          Check_Integer_Type;
2977          Resolve (E1, Any_Fixed);
2978          Set_Etype (N, P_Base_Type);
2979
2980       -----------
2981       -- Large --
2982       -----------
2983
2984       when Attribute_Large =>
2985          Check_E0;
2986          Check_Real_Type;
2987          Set_Etype (N, Universal_Real);
2988
2989       ----------
2990       -- Last --
2991       ----------
2992
2993       when Attribute_Last =>
2994          Check_Array_Or_Scalar_Type;
2995
2996       --------------
2997       -- Last_Bit --
2998       --------------
2999
3000       when Attribute_Last_Bit =>
3001          Check_Component;
3002          Set_Etype (N, Universal_Integer);
3003
3004       ------------------
3005       -- Leading_Part --
3006       ------------------
3007
3008       when Attribute_Leading_Part =>
3009          Check_Floating_Point_Type_2;
3010          Set_Etype (N, P_Base_Type);
3011          Resolve (E1, P_Base_Type);
3012          Resolve (E2, Any_Integer);
3013
3014       ------------
3015       -- Length --
3016       ------------
3017
3018       when Attribute_Length =>
3019          Check_Array_Type;
3020          Set_Etype (N, Universal_Integer);
3021
3022       -------------
3023       -- Machine --
3024       -------------
3025
3026       when Attribute_Machine =>
3027          Check_Floating_Point_Type_1;
3028          Set_Etype (N, P_Base_Type);
3029          Resolve (E1, P_Base_Type);
3030
3031       ------------------
3032       -- Machine_Emax --
3033       ------------------
3034
3035       when Attribute_Machine_Emax =>
3036          Check_Floating_Point_Type_0;
3037          Set_Etype (N, Universal_Integer);
3038
3039       ------------------
3040       -- Machine_Emin --
3041       ------------------
3042
3043       when Attribute_Machine_Emin =>
3044          Check_Floating_Point_Type_0;
3045          Set_Etype (N, Universal_Integer);
3046
3047       ----------------------
3048       -- Machine_Mantissa --
3049       ----------------------
3050
3051       when Attribute_Machine_Mantissa =>
3052          Check_Floating_Point_Type_0;
3053          Set_Etype (N, Universal_Integer);
3054
3055       -----------------------
3056       -- Machine_Overflows --
3057       -----------------------
3058
3059       when Attribute_Machine_Overflows =>
3060          Check_Real_Type;
3061          Check_E0;
3062          Set_Etype (N, Standard_Boolean);
3063
3064       -------------------
3065       -- Machine_Radix --
3066       -------------------
3067
3068       when Attribute_Machine_Radix =>
3069          Check_Real_Type;
3070          Check_E0;
3071          Set_Etype (N, Universal_Integer);
3072
3073       ----------------------
3074       -- Machine_Rounding --
3075       ----------------------
3076
3077       when Attribute_Machine_Rounding =>
3078          Check_Floating_Point_Type_1;
3079          Set_Etype (N, P_Base_Type);
3080          Resolve (E1, P_Base_Type);
3081
3082       --------------------
3083       -- Machine_Rounds --
3084       --------------------
3085
3086       when Attribute_Machine_Rounds =>
3087          Check_Real_Type;
3088          Check_E0;
3089          Set_Etype (N, Standard_Boolean);
3090
3091       ------------------
3092       -- Machine_Size --
3093       ------------------
3094
3095       when Attribute_Machine_Size =>
3096          Check_E0;
3097          Check_Type;
3098          Check_Not_Incomplete_Type;
3099          Set_Etype (N, Universal_Integer);
3100
3101       --------------
3102       -- Mantissa --
3103       --------------
3104
3105       when Attribute_Mantissa =>
3106          Check_E0;
3107          Check_Real_Type;
3108          Set_Etype (N, Universal_Integer);
3109
3110       ---------
3111       -- Max --
3112       ---------
3113
3114       when Attribute_Max =>
3115          Check_E2;
3116          Check_Scalar_Type;
3117          Resolve (E1, P_Base_Type);
3118          Resolve (E2, P_Base_Type);
3119          Set_Etype (N, P_Base_Type);
3120
3121       ----------------------------------
3122       -- Max_Size_In_Storage_Elements --
3123       ----------------------------------
3124
3125       when Attribute_Max_Size_In_Storage_Elements =>
3126          Check_E0;
3127          Check_Type;
3128          Check_Not_Incomplete_Type;
3129          Set_Etype (N, Universal_Integer);
3130
3131       -----------------------
3132       -- Maximum_Alignment --
3133       -----------------------
3134
3135       when Attribute_Maximum_Alignment =>
3136          Standard_Attribute (Ttypes.Maximum_Alignment);
3137
3138       --------------------
3139       -- Mechanism_Code --
3140       --------------------
3141
3142       when Attribute_Mechanism_Code =>
3143          if not Is_Entity_Name (P)
3144            or else not Is_Subprogram (Entity (P))
3145          then
3146             Error_Attr_P ("prefix of % attribute must be subprogram");
3147          end if;
3148
3149          Check_Either_E0_Or_E1;
3150
3151          if Present (E1) then
3152             Resolve (E1, Any_Integer);
3153             Set_Etype (E1, Standard_Integer);
3154
3155             if not Is_Static_Expression (E1) then
3156                Flag_Non_Static_Expr
3157                  ("expression for parameter number must be static!", E1);
3158                Error_Attr;
3159
3160             elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
3161               or else UI_To_Int (Intval (E1)) < 0
3162             then
3163                Error_Attr ("invalid parameter number for %attribute", E1);
3164             end if;
3165          end if;
3166
3167          Set_Etype (N, Universal_Integer);
3168
3169       ---------
3170       -- Min --
3171       ---------
3172
3173       when Attribute_Min =>
3174          Check_E2;
3175          Check_Scalar_Type;
3176          Resolve (E1, P_Base_Type);
3177          Resolve (E2, P_Base_Type);
3178          Set_Etype (N, P_Base_Type);
3179
3180       ---------
3181       -- Mod --
3182       ---------
3183
3184       when Attribute_Mod =>
3185
3186          --  Note: this attribute is only allowed in Ada 2005 mode, but
3187          --  we do not need to test that here, since Mod is only recognized
3188          --  as an attribute name in Ada 2005 mode during the parse.
3189
3190          Check_E1;
3191          Check_Modular_Integer_Type;
3192          Resolve (E1, Any_Integer);
3193          Set_Etype (N, P_Base_Type);
3194
3195       -----------
3196       -- Model --
3197       -----------
3198
3199       when Attribute_Model =>
3200          Check_Floating_Point_Type_1;
3201          Set_Etype (N, P_Base_Type);
3202          Resolve (E1, P_Base_Type);
3203
3204       ----------------
3205       -- Model_Emin --
3206       ----------------
3207
3208       when Attribute_Model_Emin =>
3209          Check_Floating_Point_Type_0;
3210          Set_Etype (N, Universal_Integer);
3211
3212       -------------------
3213       -- Model_Epsilon --
3214       -------------------
3215
3216       when Attribute_Model_Epsilon =>
3217          Check_Floating_Point_Type_0;
3218          Set_Etype (N, Universal_Real);
3219
3220       --------------------
3221       -- Model_Mantissa --
3222       --------------------
3223
3224       when Attribute_Model_Mantissa =>
3225          Check_Floating_Point_Type_0;
3226          Set_Etype (N, Universal_Integer);
3227
3228       -----------------
3229       -- Model_Small --
3230       -----------------
3231
3232       when Attribute_Model_Small =>
3233          Check_Floating_Point_Type_0;
3234          Set_Etype (N, Universal_Real);
3235
3236       -------------
3237       -- Modulus --
3238       -------------
3239
3240       when Attribute_Modulus =>
3241          Check_E0;
3242          Check_Modular_Integer_Type;
3243          Set_Etype (N, Universal_Integer);
3244
3245       --------------------
3246       -- Null_Parameter --
3247       --------------------
3248
3249       when Attribute_Null_Parameter => Null_Parameter : declare
3250          Parnt  : constant Node_Id := Parent (N);
3251          GParnt : constant Node_Id := Parent (Parnt);
3252
3253          procedure Bad_Null_Parameter (Msg : String);
3254          --  Used if bad Null parameter attribute node is found. Issues
3255          --  given error message, and also sets the type to Any_Type to
3256          --  avoid blowups later on from dealing with a junk node.
3257
3258          procedure Must_Be_Imported (Proc_Ent : Entity_Id);
3259          --  Called to check that Proc_Ent is imported subprogram
3260
3261          ------------------------
3262          -- Bad_Null_Parameter --
3263          ------------------------
3264
3265          procedure Bad_Null_Parameter (Msg : String) is
3266          begin
3267             Error_Msg_N (Msg, N);
3268             Set_Etype (N, Any_Type);
3269          end Bad_Null_Parameter;
3270
3271          ----------------------
3272          -- Must_Be_Imported --
3273          ----------------------
3274
3275          procedure Must_Be_Imported (Proc_Ent : Entity_Id) is
3276             Pent : Entity_Id := Proc_Ent;
3277
3278          begin
3279             while Present (Alias (Pent)) loop
3280                Pent := Alias (Pent);
3281             end loop;
3282
3283             --  Ignore check if procedure not frozen yet (we will get
3284             --  another chance when the default parameter is reanalyzed)
3285
3286             if not Is_Frozen (Pent) then
3287                return;
3288
3289             elsif not Is_Imported (Pent) then
3290                Bad_Null_Parameter
3291                  ("Null_Parameter can only be used with imported subprogram");
3292
3293             else
3294                return;
3295             end if;
3296          end Must_Be_Imported;
3297
3298       --  Start of processing for Null_Parameter
3299
3300       begin
3301          Check_Type;
3302          Check_E0;
3303          Set_Etype (N, P_Type);
3304
3305          --  Case of attribute used as default expression
3306
3307          if Nkind (Parnt) = N_Parameter_Specification then
3308             Must_Be_Imported (Defining_Entity (GParnt));
3309
3310          --  Case of attribute used as actual for subprogram (positional)
3311
3312          elsif (Nkind (Parnt) = N_Procedure_Call_Statement
3313                  or else
3314                 Nkind (Parnt) = N_Function_Call)
3315             and then Is_Entity_Name (Name (Parnt))
3316          then
3317             Must_Be_Imported (Entity (Name (Parnt)));
3318
3319          --  Case of attribute used as actual for subprogram (named)
3320
3321          elsif Nkind (Parnt) = N_Parameter_Association
3322            and then (Nkind (GParnt) = N_Procedure_Call_Statement
3323                        or else
3324                      Nkind (GParnt) = N_Function_Call)
3325            and then Is_Entity_Name (Name (GParnt))
3326          then
3327             Must_Be_Imported (Entity (Name (GParnt)));
3328
3329          --  Not an allowed case
3330
3331          else
3332             Bad_Null_Parameter
3333               ("Null_Parameter must be actual or default parameter");
3334          end if;
3335
3336       end Null_Parameter;
3337
3338       -----------------
3339       -- Object_Size --
3340       -----------------
3341
3342       when Attribute_Object_Size =>
3343          Check_E0;
3344          Check_Type;
3345          Check_Not_Incomplete_Type;
3346          Set_Etype (N, Universal_Integer);
3347
3348       ------------
3349       -- Output --
3350       ------------
3351
3352       when Attribute_Output =>
3353          Check_E2;
3354          Check_Stream_Attribute (TSS_Stream_Output);
3355          Set_Etype (N, Standard_Void_Type);
3356          Resolve (N, Standard_Void_Type);
3357
3358       ------------------
3359       -- Partition_ID --
3360       ------------------
3361
3362       when Attribute_Partition_ID =>
3363          Check_E0;
3364
3365          if P_Type /= Any_Type then
3366             if not Is_Library_Level_Entity (Entity (P)) then
3367                Error_Attr_P
3368                  ("prefix of % attribute must be library-level entity");
3369
3370             --  The defining entity of prefix should not be declared inside
3371             --  a Pure unit. RM E.1(8).
3372             --  The Is_Pure flag has been set during declaration.
3373
3374             elsif Is_Entity_Name (P)