File : sem_ch13.adb


   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ C H 1 3                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2016, 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 Aspects;  use Aspects;
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Errout;   use Errout;
  33 with Exp_Disp; use Exp_Disp;
  34 with Exp_Tss;  use Exp_Tss;
  35 with Exp_Util; use Exp_Util;
  36 with Freeze;   use Freeze;
  37 with Ghost;    use Ghost;
  38 with Lib;      use Lib;
  39 with Lib.Xref; use Lib.Xref;
  40 with Namet;    use Namet;
  41 with Nlists;   use Nlists;
  42 with Nmake;    use Nmake;
  43 with Opt;      use Opt;
  44 with Restrict; use Restrict;
  45 with Rident;   use Rident;
  46 with Rtsfind;  use Rtsfind;
  47 with Sem;      use Sem;
  48 with Sem_Aux;  use Sem_Aux;
  49 with Sem_Case; use Sem_Case;
  50 with Sem_Ch3;  use Sem_Ch3;
  51 with Sem_Ch6;  use Sem_Ch6;
  52 with Sem_Ch8;  use Sem_Ch8;
  53 with Sem_Dim;  use Sem_Dim;
  54 with Sem_Disp; use Sem_Disp;
  55 with Sem_Eval; use Sem_Eval;
  56 with Sem_Prag; use Sem_Prag;
  57 with Sem_Res;  use Sem_Res;
  58 with Sem_Type; use Sem_Type;
  59 with Sem_Util; use Sem_Util;
  60 with Sem_Warn; use Sem_Warn;
  61 with Sinput;   use Sinput;
  62 with Snames;   use Snames;
  63 with Stand;    use Stand;
  64 with Sinfo;    use Sinfo;
  65 with Targparm; use Targparm;
  66 with Ttypes;   use Ttypes;
  67 with Tbuild;   use Tbuild;
  68 with Urealp;   use Urealp;
  69 with Warnsw;   use Warnsw;
  70 
  71 with GNAT.Heap_Sort_G;
  72 
  73 package body Sem_Ch13 is
  74 
  75    SSU : constant Pos := System_Storage_Unit;
  76    --  Convenient short hand for commonly used constant
  77 
  78    -----------------------
  79    -- Local Subprograms --
  80    -----------------------
  81 
  82    procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint);
  83    --  This routine is called after setting one of the sizes of type entity
  84    --  Typ to Size. The purpose is to deal with the situation of a derived
  85    --  type whose inherited alignment is no longer appropriate for the new
  86    --  size value. In this case, we reset the Alignment to unknown.
  87 
  88    procedure Build_Discrete_Static_Predicate
  89      (Typ  : Entity_Id;
  90       Expr : Node_Id;
  91       Nam  : Name_Id);
  92    --  Given a predicated type Typ, where Typ is a discrete static subtype,
  93    --  whose predicate expression is Expr, tests if Expr is a static predicate,
  94    --  and if so, builds the predicate range list. Nam is the name of the one
  95    --  argument to the predicate function. Occurrences of the type name in the
  96    --  predicate expression have been replaced by identifier references to this
  97    --  name, which is unique, so any identifier with Chars matching Nam must be
  98    --  a reference to the type. If the predicate is non-static, this procedure
  99    --  returns doing nothing. If the predicate is static, then the predicate
 100    --  list is stored in Static_Discrete_Predicate (Typ), and the Expr is
 101    --  rewritten as a canonicalized membership operation.
 102 
 103    function Build_Export_Import_Pragma
 104      (Asp : Node_Id;
 105       Id  : Entity_Id) return Node_Id;
 106    --  Create the corresponding pragma for aspect Export or Import denoted by
 107    --  Asp. Id is the related entity subject to the aspect. Return Empty when
 108    --  the expression of aspect Asp evaluates to False or is erroneous.
 109 
 110    function Build_Predicate_Function_Declaration
 111       (Typ : Entity_Id) return Node_Id;
 112    --  Build the declaration for a predicate function. The declaration is built
 113    --  at the end of the declarative part containing the type definition, which
 114    --  may be before the freeze point of the type. The predicate expression is
 115    --  pre-analyzed at this point, to catch visibility errors.
 116 
 117    procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id);
 118    --  If Typ has predicates (indicated by Has_Predicates being set for Typ),
 119    --  then either there are pragma Predicate entries on the rep chain for the
 120    --  type (note that Predicate aspects are converted to pragma Predicate), or
 121    --  there are inherited aspects from a parent type, or ancestor subtypes.
 122    --  This procedure builds body for the Predicate function that tests these
 123    --  predicates. N is the freeze node for the type. The spec of the function
 124    --  is inserted before the freeze node, and the body of the function is
 125    --  inserted after the freeze node. If the predicate expression has a least
 126    --  one Raise_Expression, then this procedure also builds the M version of
 127    --  the predicate function for use in membership tests.
 128 
 129    procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id);
 130    --  Called if both Storage_Pool and Storage_Size attribute definition
 131    --  clauses (SP and SS) are present for entity Ent. Issue error message.
 132 
 133    procedure Freeze_Entity_Checks (N : Node_Id);
 134    --  Called from Analyze_Freeze_Entity and Analyze_Generic_Freeze Entity
 135    --  to generate appropriate semantic checks that are delayed until this
 136    --  point (they had to be delayed this long for cases of delayed aspects,
 137    --  e.g. analysis of statically predicated subtypes in choices, for which
 138    --  we have to be sure the subtypes in question are frozen before checking).
 139 
 140    function Get_Alignment_Value (Expr : Node_Id) return Uint;
 141    --  Given the expression for an alignment value, returns the corresponding
 142    --  Uint value. If the value is inappropriate, then error messages are
 143    --  posted as required, and a value of No_Uint is returned.
 144 
 145    procedure Get_Interfacing_Aspects
 146      (Iface_Asp : Node_Id;
 147       Conv_Asp  : out Node_Id;
 148       EN_Asp    : out Node_Id;
 149       Expo_Asp  : out Node_Id;
 150       Imp_Asp   : out Node_Id;
 151       LN_Asp    : out Node_Id;
 152       Do_Checks : Boolean := False);
 153    --  Given a single interfacing aspect Iface_Asp, retrieve other interfacing
 154    --  aspects that apply to the same related entity. The aspects considered by
 155    --  this routine are as follows:
 156    --
 157    --    Conv_Asp - aspect Convention
 158    --    EN_Asp   - aspect External_Name
 159    --    Expo_Asp - aspect Export
 160    --    Imp_Asp  - aspect Import
 161    --    LN_Asp   - aspect Link_Name
 162    --
 163    --  When flag Do_Checks is set, this routine will flag duplicate uses of
 164    --  aspects.
 165 
 166    function Is_Operational_Item (N : Node_Id) return Boolean;
 167    --  A specification for a stream attribute is allowed before the full type
 168    --  is declared, as explained in AI-00137 and the corrigendum. Attributes
 169    --  that do not specify a representation characteristic are operational
 170    --  attributes.
 171 
 172    function Is_Predicate_Static
 173      (Expr : Node_Id;
 174       Nam  : Name_Id) return Boolean;
 175    --  Given predicate expression Expr, tests if Expr is predicate-static in
 176    --  the sense of the rules in (RM 3.2.4 (15-24)). Occurrences of the type
 177    --  name in the predicate expression have been replaced by references to
 178    --  an identifier whose Chars field is Nam. This name is unique, so any
 179    --  identifier with Chars matching Nam must be a reference to the type.
 180    --  Returns True if the expression is predicate-static and False otherwise,
 181    --  but is not in the business of setting flags or issuing error messages.
 182    --
 183    --  Only scalar types can have static predicates, so False is always
 184    --  returned for non-scalar types.
 185    --
 186    --  Note: the RM seems to suggest that string types can also have static
 187    --  predicates. But that really makes lttle sense as very few useful
 188    --  predicates can be constructed for strings. Remember that:
 189    --
 190    --     "ABC" < "DEF"
 191    --
 192    --  is not a static expression. So even though the clearly faulty RM wording
 193    --  allows the following:
 194    --
 195    --     subtype S is String with Static_Predicate => S < "DEF"
 196    --
 197    --  We can't allow this, otherwise we have predicate-static applying to a
 198    --  larger class than static expressions, which was never intended.
 199 
 200    procedure New_Stream_Subprogram
 201      (N    : Node_Id;
 202       Ent  : Entity_Id;
 203       Subp : Entity_Id;
 204       Nam  : TSS_Name_Type);
 205    --  Create a subprogram renaming of a given stream attribute to the
 206    --  designated subprogram and then in the tagged case, provide this as a
 207    --  primitive operation, or in the untagged case make an appropriate TSS
 208    --  entry. This is more properly an expansion activity than just semantics,
 209    --  but the presence of user-defined stream functions for limited types
 210    --  is a legality check, which is why this takes place here rather than in
 211    --  exp_ch13, where it was previously. Nam indicates the name of the TSS
 212    --  function to be generated.
 213    --
 214    --  To avoid elaboration anomalies with freeze nodes, for untagged types
 215    --  we generate both a subprogram declaration and a subprogram renaming
 216    --  declaration, so that the attribute specification is handled as a
 217    --  renaming_as_body. For tagged types, the specification is one of the
 218    --  primitive specs.
 219 
 220    procedure Resolve_Iterable_Operation
 221      (N      : Node_Id;
 222       Cursor : Entity_Id;
 223       Typ    : Entity_Id;
 224       Nam    : Name_Id);
 225    --  If the name of a primitive operation for an Iterable aspect is
 226    --  overloaded, resolve according to required signature.
 227 
 228    procedure Set_Biased
 229      (E      : Entity_Id;
 230       N      : Node_Id;
 231       Msg    : String;
 232       Biased : Boolean := True);
 233    --  If Biased is True, sets Has_Biased_Representation flag for E, and
 234    --  outputs a warning message at node N if Warn_On_Biased_Representation is
 235    --  is True. This warning inserts the string Msg to describe the construct
 236    --  causing biasing.
 237 
 238    ----------------------------------------------
 239    -- Table for Validate_Unchecked_Conversions --
 240    ----------------------------------------------
 241 
 242    --  The following table collects unchecked conversions for validation.
 243    --  Entries are made by Validate_Unchecked_Conversion and then the call
 244    --  to Validate_Unchecked_Conversions does the actual error checking and
 245    --  posting of warnings. The reason for this delayed processing is to take
 246    --  advantage of back-annotations of size and alignment values performed by
 247    --  the back end.
 248 
 249    --  Note: the reason we store a Source_Ptr value instead of a Node_Id is
 250    --  that by the time Validate_Unchecked_Conversions is called, Sprint will
 251    --  already have modified all Sloc values if the -gnatD option is set.
 252 
 253    type UC_Entry is record
 254       Eloc     : Source_Ptr; -- node used for posting warnings
 255       Source   : Entity_Id;  -- source type for unchecked conversion
 256       Target   : Entity_Id;  -- target type for unchecked conversion
 257       Act_Unit : Entity_Id;  -- actual function instantiated
 258    end record;
 259 
 260    package Unchecked_Conversions is new Table.Table (
 261      Table_Component_Type => UC_Entry,
 262      Table_Index_Type     => Int,
 263      Table_Low_Bound      => 1,
 264      Table_Initial        => 50,
 265      Table_Increment      => 200,
 266      Table_Name           => "Unchecked_Conversions");
 267 
 268    ----------------------------------------
 269    -- Table for Validate_Address_Clauses --
 270    ----------------------------------------
 271 
 272    --  If an address clause has the form
 273 
 274    --    for X'Address use Expr
 275 
 276    --  where Expr has a value known at compile time or is of the form Y'Address
 277    --  or recursively is a reference to a constant initialized with either of
 278    --  these forms, and the value of Expr is not a multiple of X's alignment,
 279    --  or if Y has a smaller alignment than X, then that merits a warning about
 280    --  possible bad alignment. The following table collects address clauses of
 281    --  this kind. We put these in a table so that they can be checked after the
 282    --  back end has completed annotation of the alignments of objects, since we
 283    --  can catch more cases that way.
 284 
 285    type Address_Clause_Check_Record is record
 286       N : Node_Id;
 287       --  The address clause
 288 
 289       X : Entity_Id;
 290       --  The entity of the object subject to the address clause
 291 
 292       A : Uint;
 293       --  The value of the address in the first case
 294 
 295       Y : Entity_Id;
 296       --  The entity of the object being overlaid in the second case
 297 
 298       Off : Boolean;
 299       --  Whether the address is offset within Y in the second case
 300    end record;
 301 
 302    package Address_Clause_Checks is new Table.Table (
 303      Table_Component_Type => Address_Clause_Check_Record,
 304      Table_Index_Type     => Int,
 305      Table_Low_Bound      => 1,
 306      Table_Initial        => 20,
 307      Table_Increment      => 200,
 308      Table_Name           => "Address_Clause_Checks");
 309 
 310    -----------------------------------------
 311    -- Adjust_Record_For_Reverse_Bit_Order --
 312    -----------------------------------------
 313 
 314    procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is
 315       Comp : Node_Id;
 316       CC   : Node_Id;
 317 
 318    begin
 319       --  Processing depends on version of Ada
 320 
 321       --  For Ada 95, we just renumber bits within a storage unit. We do the
 322       --  same for Ada 83 mode, since we recognize the Bit_Order attribute in
 323       --  Ada 83, and are free to add this extension.
 324 
 325       if Ada_Version < Ada_2005 then
 326          Comp := First_Component_Or_Discriminant (R);
 327          while Present (Comp) loop
 328             CC := Component_Clause (Comp);
 329 
 330             --  If component clause is present, then deal with the non-default
 331             --  bit order case for Ada 95 mode.
 332 
 333             --  We only do this processing for the base type, and in fact that
 334             --  is important, since otherwise if there are record subtypes, we
 335             --  could reverse the bits once for each subtype, which is wrong.
 336 
 337             if Present (CC) and then Ekind (R) = E_Record_Type then
 338                declare
 339                   CFB : constant Uint    := Component_Bit_Offset (Comp);
 340                   CSZ : constant Uint    := Esize (Comp);
 341                   CLC : constant Node_Id := Component_Clause (Comp);
 342                   Pos : constant Node_Id := Position (CLC);
 343                   FB  : constant Node_Id := First_Bit (CLC);
 344 
 345                   Storage_Unit_Offset : constant Uint :=
 346                                           CFB / System_Storage_Unit;
 347 
 348                   Start_Bit : constant Uint :=
 349                                 CFB mod System_Storage_Unit;
 350 
 351                begin
 352                   --  Cases where field goes over storage unit boundary
 353 
 354                   if Start_Bit + CSZ > System_Storage_Unit then
 355 
 356                      --  Allow multi-byte field but generate warning
 357 
 358                      if Start_Bit mod System_Storage_Unit = 0
 359                        and then CSZ mod System_Storage_Unit = 0
 360                      then
 361                         Error_Msg_N
 362                           ("info: multi-byte field specified with "
 363                            & "non-standard Bit_Order?V?", CLC);
 364 
 365                         if Bytes_Big_Endian then
 366                            Error_Msg_N
 367                              ("\bytes are not reversed "
 368                               & "(component is big-endian)?V?", CLC);
 369                         else
 370                            Error_Msg_N
 371                              ("\bytes are not reversed "
 372                               & "(component is little-endian)?V?", CLC);
 373                         end if;
 374 
 375                      --  Do not allow non-contiguous field
 376 
 377                      else
 378                         Error_Msg_N
 379                           ("attempt to specify non-contiguous field "
 380                            & "not permitted", CLC);
 381                         Error_Msg_N
 382                           ("\caused by non-standard Bit_Order "
 383                            & "specified", CLC);
 384                         Error_Msg_N
 385                           ("\consider possibility of using "
 386                            & "Ada 2005 mode here", CLC);
 387                      end if;
 388 
 389                   --  Case where field fits in one storage unit
 390 
 391                   else
 392                      --  Give warning if suspicious component clause
 393 
 394                      if Intval (FB) >= System_Storage_Unit
 395                        and then Warn_On_Reverse_Bit_Order
 396                      then
 397                         Error_Msg_N
 398                           ("info: Bit_Order clause does not affect " &
 399                            "byte ordering?V?", Pos);
 400                         Error_Msg_Uint_1 :=
 401                           Intval (Pos) + Intval (FB) /
 402                           System_Storage_Unit;
 403                         Error_Msg_N
 404                           ("info: position normalized to ^ before bit " &
 405                            "order interpreted?V?", Pos);
 406                      end if;
 407 
 408                      --  Here is where we fix up the Component_Bit_Offset value
 409                      --  to account for the reverse bit order. Some examples of
 410                      --  what needs to be done are:
 411 
 412                      --    First_Bit .. Last_Bit     Component_Bit_Offset
 413                      --      old          new          old       new
 414 
 415                      --     0 .. 0       7 .. 7         0         7
 416                      --     0 .. 1       6 .. 7         0         6
 417                      --     0 .. 2       5 .. 7         0         5
 418                      --     0 .. 7       0 .. 7         0         4
 419 
 420                      --     1 .. 1       6 .. 6         1         6
 421                      --     1 .. 4       3 .. 6         1         3
 422                      --     4 .. 7       0 .. 3         4         0
 423 
 424                      --  The rule is that the first bit is is obtained by
 425                      --  subtracting the old ending bit from storage_unit - 1.
 426 
 427                      Set_Component_Bit_Offset
 428                        (Comp,
 429                         (Storage_Unit_Offset * System_Storage_Unit) +
 430                           (System_Storage_Unit - 1) -
 431                           (Start_Bit + CSZ - 1));
 432 
 433                      Set_Normalized_First_Bit
 434                        (Comp,
 435                         Component_Bit_Offset (Comp) mod
 436                           System_Storage_Unit);
 437                   end if;
 438                end;
 439             end if;
 440 
 441             Next_Component_Or_Discriminant (Comp);
 442          end loop;
 443 
 444       --  For Ada 2005, we do machine scalar processing, as fully described In
 445       --  AI-133. This involves gathering all components which start at the
 446       --  same byte offset and processing them together. Same approach is still
 447       --  valid in later versions including Ada 2012.
 448 
 449       else
 450          declare
 451             Max_Machine_Scalar_Size : constant Uint :=
 452                                         UI_From_Int
 453                                           (Standard_Long_Long_Integer_Size);
 454             --  We use this as the maximum machine scalar size
 455 
 456             Num_CC : Natural;
 457             SSU    : constant Uint := UI_From_Int (System_Storage_Unit);
 458 
 459          begin
 460             --  This first loop through components does two things. First it
 461             --  deals with the case of components with component clauses whose
 462             --  length is greater than the maximum machine scalar size (either
 463             --  accepting them or rejecting as needed). Second, it counts the
 464             --  number of components with component clauses whose length does
 465             --  not exceed this maximum for later processing.
 466 
 467             Num_CC := 0;
 468             Comp   := First_Component_Or_Discriminant (R);
 469             while Present (Comp) loop
 470                CC := Component_Clause (Comp);
 471 
 472                if Present (CC) then
 473                   declare
 474                      Fbit : constant Uint := Static_Integer (First_Bit (CC));
 475                      Lbit : constant Uint := Static_Integer (Last_Bit (CC));
 476 
 477                   begin
 478                      --  Case of component with last bit >= max machine scalar
 479 
 480                      if Lbit >= Max_Machine_Scalar_Size then
 481 
 482                         --  This is allowed only if first bit is zero, and
 483                         --  last bit + 1 is a multiple of storage unit size.
 484 
 485                         if Fbit = 0 and then (Lbit + 1) mod SSU = 0 then
 486 
 487                            --  This is the case to give a warning if enabled
 488 
 489                            if Warn_On_Reverse_Bit_Order then
 490                               Error_Msg_N
 491                                 ("info: multi-byte field specified with "
 492                                  & "non-standard Bit_Order?V?", CC);
 493 
 494                               if Bytes_Big_Endian then
 495                                  Error_Msg_N
 496                                    ("\bytes are not reversed "
 497                                     & "(component is big-endian)?V?", CC);
 498                               else
 499                                  Error_Msg_N
 500                                    ("\bytes are not reversed "
 501                                     & "(component is little-endian)?V?", CC);
 502                               end if;
 503                            end if;
 504 
 505                         --  Give error message for RM 13.5.1(10) violation
 506 
 507                         else
 508                            Error_Msg_FE
 509                              ("machine scalar rules not followed for&",
 510                               First_Bit (CC), Comp);
 511 
 512                            Error_Msg_Uint_1 := Lbit + 1;
 513                            Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
 514                            Error_Msg_F
 515                              ("\last bit + 1 (^) exceeds maximum machine "
 516                               & "scalar size (^)",
 517                               First_Bit (CC));
 518 
 519                            if (Lbit + 1) mod SSU /= 0 then
 520                               Error_Msg_Uint_1 := SSU;
 521                               Error_Msg_F
 522                                 ("\and is not a multiple of Storage_Unit (^) "
 523                                  & "(RM 13.5.1(10))",
 524                                  First_Bit (CC));
 525 
 526                            else
 527                               Error_Msg_Uint_1 := Fbit;
 528                               Error_Msg_F
 529                                 ("\and first bit (^) is non-zero "
 530                                  & "(RM 13.4.1(10))",
 531                                  First_Bit (CC));
 532                            end if;
 533                         end if;
 534 
 535                      --  OK case of machine scalar related component clause,
 536                      --  For now, just count them.
 537 
 538                      else
 539                         Num_CC := Num_CC + 1;
 540                      end if;
 541                   end;
 542                end if;
 543 
 544                Next_Component_Or_Discriminant (Comp);
 545             end loop;
 546 
 547             --  We need to sort the component clauses on the basis of the
 548             --  Position values in the clause, so we can group clauses with
 549             --  the same Position together to determine the relevant machine
 550             --  scalar size.
 551 
 552             Sort_CC : declare
 553                Comps : array (0 .. Num_CC) of Entity_Id;
 554                --  Array to collect component and discriminant entities. The
 555                --  data starts at index 1, the 0'th entry is for the sort
 556                --  routine.
 557 
 558                function CP_Lt (Op1, Op2 : Natural) return Boolean;
 559                --  Compare routine for Sort
 560 
 561                procedure CP_Move (From : Natural; To : Natural);
 562                --  Move routine for Sort
 563 
 564                package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
 565 
 566                Start : Natural;
 567                Stop  : Natural;
 568                --  Start and stop positions in the component list of the set of
 569                --  components with the same starting position (that constitute
 570                --  components in a single machine scalar).
 571 
 572                MaxL  : Uint;
 573                --  Maximum last bit value of any component in this set
 574 
 575                MSS   : Uint;
 576                --  Corresponding machine scalar size
 577 
 578                -----------
 579                -- CP_Lt --
 580                -----------
 581 
 582                function CP_Lt (Op1, Op2 : Natural) return Boolean is
 583                begin
 584                   return Position (Component_Clause (Comps (Op1))) <
 585                     Position (Component_Clause (Comps (Op2)));
 586                end CP_Lt;
 587 
 588                -------------
 589                -- CP_Move --
 590                -------------
 591 
 592                procedure CP_Move (From : Natural; To : Natural) is
 593                begin
 594                   Comps (To) := Comps (From);
 595                end CP_Move;
 596 
 597             --  Start of processing for Sort_CC
 598 
 599             begin
 600                --  Collect the machine scalar relevant component clauses
 601 
 602                Num_CC := 0;
 603                Comp   := First_Component_Or_Discriminant (R);
 604                while Present (Comp) loop
 605                   declare
 606                      CC   : constant Node_Id := Component_Clause (Comp);
 607 
 608                   begin
 609                      --  Collect only component clauses whose last bit is less
 610                      --  than machine scalar size. Any component clause whose
 611                      --  last bit exceeds this value does not take part in
 612                      --  machine scalar layout considerations. The test for
 613                      --  Error_Posted makes sure we exclude component clauses
 614                      --  for which we already posted an error.
 615 
 616                      if Present (CC)
 617                        and then not Error_Posted (Last_Bit (CC))
 618                        and then Static_Integer (Last_Bit (CC)) <
 619                                                     Max_Machine_Scalar_Size
 620                      then
 621                         Num_CC := Num_CC + 1;
 622                         Comps (Num_CC) := Comp;
 623                      end if;
 624                   end;
 625 
 626                   Next_Component_Or_Discriminant (Comp);
 627                end loop;
 628 
 629                --  Sort by ascending position number
 630 
 631                Sorting.Sort (Num_CC);
 632 
 633                --  We now have all the components whose size does not exceed
 634                --  the max machine scalar value, sorted by starting position.
 635                --  In this loop we gather groups of clauses starting at the
 636                --  same position, to process them in accordance with AI-133.
 637 
 638                Stop := 0;
 639                while Stop < Num_CC loop
 640                   Start := Stop + 1;
 641                   Stop  := Start;
 642                   MaxL  :=
 643                     Static_Integer
 644                       (Last_Bit (Component_Clause (Comps (Start))));
 645                   while Stop < Num_CC loop
 646                      if Static_Integer
 647                           (Position (Component_Clause (Comps (Stop + 1)))) =
 648                         Static_Integer
 649                           (Position (Component_Clause (Comps (Stop))))
 650                      then
 651                         Stop := Stop + 1;
 652                         MaxL :=
 653                           UI_Max
 654                             (MaxL,
 655                              Static_Integer
 656                                (Last_Bit
 657                                   (Component_Clause (Comps (Stop)))));
 658                      else
 659                         exit;
 660                      end if;
 661                   end loop;
 662 
 663                   --  Now we have a group of component clauses from Start to
 664                   --  Stop whose positions are identical, and MaxL is the
 665                   --  maximum last bit value of any of these components.
 666 
 667                   --  We need to determine the corresponding machine scalar
 668                   --  size. This loop assumes that machine scalar sizes are
 669                   --  even, and that each possible machine scalar has twice
 670                   --  as many bits as the next smaller one.
 671 
 672                   MSS := Max_Machine_Scalar_Size;
 673                   while MSS mod 2 = 0
 674                     and then (MSS / 2) >= SSU
 675                     and then (MSS / 2) > MaxL
 676                   loop
 677                      MSS := MSS / 2;
 678                   end loop;
 679 
 680                   --  Here is where we fix up the Component_Bit_Offset value
 681                   --  to account for the reverse bit order. Some examples of
 682                   --  what needs to be done for the case of a machine scalar
 683                   --  size of 8 are:
 684 
 685                   --    First_Bit .. Last_Bit     Component_Bit_Offset
 686                   --      old          new          old       new
 687 
 688                   --     0 .. 0       7 .. 7         0         7
 689                   --     0 .. 1       6 .. 7         0         6
 690                   --     0 .. 2       5 .. 7         0         5
 691                   --     0 .. 7       0 .. 7         0         4
 692 
 693                   --     1 .. 1       6 .. 6         1         6
 694                   --     1 .. 4       3 .. 6         1         3
 695                   --     4 .. 7       0 .. 3         4         0
 696 
 697                   --  The rule is that the first bit is obtained by subtracting
 698                   --  the old ending bit from machine scalar size - 1.
 699 
 700                   for C in Start .. Stop loop
 701                      declare
 702                         Comp : constant Entity_Id := Comps (C);
 703                         CC   : constant Node_Id   := Component_Clause (Comp);
 704 
 705                         LB   : constant Uint := Static_Integer (Last_Bit (CC));
 706                         NFB  : constant Uint := MSS - Uint_1 - LB;
 707                         NLB  : constant Uint := NFB + Esize (Comp) - 1;
 708                         Pos  : constant Uint := Static_Integer (Position (CC));
 709 
 710                      begin
 711                         if Warn_On_Reverse_Bit_Order then
 712                            Error_Msg_Uint_1 := MSS;
 713                            Error_Msg_N
 714                              ("info: reverse bit order in machine " &
 715                               "scalar of length^?V?", First_Bit (CC));
 716                            Error_Msg_Uint_1 := NFB;
 717                            Error_Msg_Uint_2 := NLB;
 718 
 719                            if Bytes_Big_Endian then
 720                               Error_Msg_NE
 721                                 ("\big-endian range for component "
 722                                  & "& is ^ .. ^?V?", First_Bit (CC), Comp);
 723                            else
 724                               Error_Msg_NE
 725                                 ("\little-endian range for component"
 726                                  & "& is ^ .. ^?V?", First_Bit (CC), Comp);
 727                            end if;
 728                         end if;
 729 
 730                         Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
 731                         Set_Normalized_First_Bit (Comp, NFB mod SSU);
 732                      end;
 733                   end loop;
 734                end loop;
 735             end Sort_CC;
 736          end;
 737       end if;
 738    end Adjust_Record_For_Reverse_Bit_Order;
 739 
 740    -------------------------------------
 741    -- Alignment_Check_For_Size_Change --
 742    -------------------------------------
 743 
 744    procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint) is
 745    begin
 746       --  If the alignment is known, and not set by a rep clause, and is
 747       --  inconsistent with the size being set, then reset it to unknown,
 748       --  we assume in this case that the size overrides the inherited
 749       --  alignment, and that the alignment must be recomputed.
 750 
 751       if Known_Alignment (Typ)
 752         and then not Has_Alignment_Clause (Typ)
 753         and then Size mod (Alignment (Typ) * SSU) /= 0
 754       then
 755          Init_Alignment (Typ);
 756       end if;
 757    end Alignment_Check_For_Size_Change;
 758 
 759    -------------------------------------
 760    -- Analyze_Aspects_At_Freeze_Point --
 761    -------------------------------------
 762 
 763    procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id) is
 764       procedure Analyze_Aspect_Default_Value (ASN : Node_Id);
 765       --  This routine analyzes an Aspect_Default_[Component_]Value denoted by
 766       --  the aspect specification node ASN.
 767 
 768       procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id);
 769       --  As discussed in the spec of Aspects (see Aspect_Delay declaration),
 770       --  a derived type can inherit aspects from its parent which have been
 771       --  specified at the time of the derivation using an aspect, as in:
 772       --
 773       --    type A is range 1 .. 10
 774       --      with Size => Not_Defined_Yet;
 775       --    ..
 776       --    type B is new A;
 777       --    ..
 778       --    Not_Defined_Yet : constant := 64;
 779       --
 780       --  In this example, the Size of A is considered to be specified prior
 781       --  to the derivation, and thus inherited, even though the value is not
 782       --  known at the time of derivation. To deal with this, we use two entity
 783       --  flags. The flag Has_Derived_Rep_Aspects is set in the parent type (A
 784       --  here), and then the flag May_Inherit_Delayed_Rep_Aspects is set in
 785       --  the derived type (B here). If this flag is set when the derived type
 786       --  is frozen, then this procedure is called to ensure proper inheritance
 787       --  of all delayed aspects from the parent type. The derived type is E,
 788       --  the argument to Analyze_Aspects_At_Freeze_Point. ASN is the first
 789       --  aspect specification node in the Rep_Item chain for the parent type.
 790 
 791       procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id);
 792       --  Given an aspect specification node ASN whose expression is an
 793       --  optional Boolean, this routines creates the corresponding pragma
 794       --  at the freezing point.
 795 
 796       ----------------------------------
 797       -- Analyze_Aspect_Default_Value --
 798       ----------------------------------
 799 
 800       procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is
 801          A_Id : constant Aspect_Id := Get_Aspect_Id (ASN);
 802          Ent  : constant Entity_Id := Entity (ASN);
 803          Expr : constant Node_Id   := Expression (ASN);
 804          Id   : constant Node_Id   := Identifier (ASN);
 805 
 806       begin
 807          Error_Msg_Name_1 := Chars (Id);
 808 
 809          if not Is_Type (Ent) then
 810             Error_Msg_N ("aspect% can only apply to a type", Id);
 811             return;
 812 
 813          elsif not Is_First_Subtype (Ent) then
 814             Error_Msg_N ("aspect% cannot apply to subtype", Id);
 815             return;
 816 
 817          elsif A_Id = Aspect_Default_Value
 818            and then not Is_Scalar_Type (Ent)
 819          then
 820             Error_Msg_N ("aspect% can only be applied to scalar type", Id);
 821             return;
 822 
 823          elsif A_Id = Aspect_Default_Component_Value then
 824             if not Is_Array_Type (Ent) then
 825                Error_Msg_N ("aspect% can only be applied to array type", Id);
 826                return;
 827 
 828             elsif not Is_Scalar_Type (Component_Type (Ent)) then
 829                Error_Msg_N ("aspect% requires scalar components", Id);
 830                return;
 831             end if;
 832          end if;
 833 
 834          Set_Has_Default_Aspect (Base_Type (Ent));
 835 
 836          if Is_Scalar_Type (Ent) then
 837             Set_Default_Aspect_Value (Base_Type (Ent), Expr);
 838          else
 839             Set_Default_Aspect_Component_Value (Base_Type (Ent), Expr);
 840          end if;
 841       end Analyze_Aspect_Default_Value;
 842 
 843       ---------------------------------
 844       -- Inherit_Delayed_Rep_Aspects --
 845       ---------------------------------
 846 
 847       procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id) is
 848          A_Id : constant Aspect_Id := Get_Aspect_Id (ASN);
 849          P    : constant Entity_Id := Entity (ASN);
 850          --  Entithy for parent type
 851 
 852          N : Node_Id;
 853          --  Item from Rep_Item chain
 854 
 855          A : Aspect_Id;
 856 
 857       begin
 858          --  Loop through delayed aspects for the parent type
 859 
 860          N := ASN;
 861          while Present (N) loop
 862             if Nkind (N) = N_Aspect_Specification then
 863                exit when Entity (N) /= P;
 864 
 865                if Is_Delayed_Aspect (N) then
 866                   A := Get_Aspect_Id (Chars (Identifier (N)));
 867 
 868                   --  Process delayed rep aspect. For Boolean attributes it is
 869                   --  not possible to cancel an attribute once set (the attempt
 870                   --  to use an aspect with xxx => False is an error) for a
 871                   --  derived type. So for those cases, we do not have to check
 872                   --  if a clause has been given for the derived type, since it
 873                   --  is harmless to set it again if it is already set.
 874 
 875                   case A is
 876 
 877                      --  Alignment
 878 
 879                      when Aspect_Alignment =>
 880                         if not Has_Alignment_Clause (E) then
 881                            Set_Alignment (E, Alignment (P));
 882                         end if;
 883 
 884                      --  Atomic
 885 
 886                      when Aspect_Atomic =>
 887                         if Is_Atomic (P) then
 888                            Set_Is_Atomic (E);
 889                         end if;
 890 
 891                      --  Atomic_Components
 892 
 893                      when Aspect_Atomic_Components =>
 894                         if Has_Atomic_Components (P) then
 895                            Set_Has_Atomic_Components (Base_Type (E));
 896                         end if;
 897 
 898                      --  Bit_Order
 899 
 900                      when Aspect_Bit_Order =>
 901                         if Is_Record_Type (E)
 902                           and then No (Get_Attribute_Definition_Clause
 903                                          (E, Attribute_Bit_Order))
 904                           and then Reverse_Bit_Order (P)
 905                         then
 906                            Set_Reverse_Bit_Order (Base_Type (E));
 907                         end if;
 908 
 909                      --  Component_Size
 910 
 911                      when Aspect_Component_Size =>
 912                         if Is_Array_Type (E)
 913                           and then not Has_Component_Size_Clause (E)
 914                         then
 915                            Set_Component_Size
 916                              (Base_Type (E), Component_Size (P));
 917                         end if;
 918 
 919                      --  Machine_Radix
 920 
 921                      when Aspect_Machine_Radix =>
 922                         if Is_Decimal_Fixed_Point_Type (E)
 923                           and then not Has_Machine_Radix_Clause (E)
 924                         then
 925                            Set_Machine_Radix_10 (E, Machine_Radix_10 (P));
 926                         end if;
 927 
 928                      --  Object_Size (also Size which also sets Object_Size)
 929 
 930                      when Aspect_Object_Size | Aspect_Size =>
 931                         if not Has_Size_Clause (E)
 932                           and then
 933                             No (Get_Attribute_Definition_Clause
 934                                   (E, Attribute_Object_Size))
 935                         then
 936                            Set_Esize (E, Esize (P));
 937                         end if;
 938 
 939                      --  Pack
 940 
 941                      when Aspect_Pack =>
 942                         if not Is_Packed (E) then
 943                            Set_Is_Packed (Base_Type (E));
 944 
 945                            if Is_Bit_Packed_Array (P) then
 946                               Set_Is_Bit_Packed_Array (Base_Type (E));
 947                               Set_Packed_Array_Impl_Type
 948                                 (E, Packed_Array_Impl_Type (P));
 949                            end if;
 950                         end if;
 951 
 952                      --  Scalar_Storage_Order
 953 
 954                      when Aspect_Scalar_Storage_Order =>
 955                         if (Is_Record_Type (E) or else Is_Array_Type (E))
 956                           and then No (Get_Attribute_Definition_Clause
 957                                          (E, Attribute_Scalar_Storage_Order))
 958                           and then Reverse_Storage_Order (P)
 959                         then
 960                            Set_Reverse_Storage_Order (Base_Type (E));
 961 
 962                            --  Clear default SSO indications, since the aspect
 963                            --  overrides the default.
 964 
 965                            Set_SSO_Set_Low_By_Default  (Base_Type (E), False);
 966                            Set_SSO_Set_High_By_Default (Base_Type (E), False);
 967                         end if;
 968 
 969                      --  Small
 970 
 971                      when Aspect_Small =>
 972                         if Is_Fixed_Point_Type (E)
 973                           and then not Has_Small_Clause (E)
 974                         then
 975                            Set_Small_Value (E, Small_Value (P));
 976                         end if;
 977 
 978                      --  Storage_Size
 979 
 980                      when Aspect_Storage_Size =>
 981                         if (Is_Access_Type (E) or else Is_Task_Type (E))
 982                           and then not Has_Storage_Size_Clause (E)
 983                         then
 984                            Set_Storage_Size_Variable
 985                              (Base_Type (E), Storage_Size_Variable (P));
 986                         end if;
 987 
 988                      --  Value_Size
 989 
 990                      when Aspect_Value_Size =>
 991 
 992                         --  Value_Size is never inherited, it is either set by
 993                         --  default, or it is explicitly set for the derived
 994                         --  type. So nothing to do here.
 995 
 996                         null;
 997 
 998                      --  Volatile
 999 
1000                      when Aspect_Volatile =>
1001                         if Is_Volatile (P) then
1002                            Set_Is_Volatile (E);
1003                         end if;
1004 
1005                      --  Volatile_Full_Access
1006 
1007                      when Aspect_Volatile_Full_Access =>
1008                         if Is_Volatile_Full_Access (P) then
1009                            Set_Is_Volatile_Full_Access (E);
1010                         end if;
1011 
1012                      --  Volatile_Components
1013 
1014                      when Aspect_Volatile_Components =>
1015                         if Has_Volatile_Components (P) then
1016                            Set_Has_Volatile_Components (Base_Type (E));
1017                         end if;
1018 
1019                      --  That should be all the Rep Aspects
1020 
1021                      when others =>
1022                         pragma Assert (Aspect_Delay (A_Id) /= Rep_Aspect);
1023                         null;
1024 
1025                   end case;
1026                end if;
1027             end if;
1028 
1029             N := Next_Rep_Item (N);
1030          end loop;
1031       end Inherit_Delayed_Rep_Aspects;
1032 
1033       -------------------------------------
1034       -- Make_Pragma_From_Boolean_Aspect --
1035       -------------------------------------
1036 
1037       procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id) is
1038          Ident  : constant Node_Id    := Identifier (ASN);
1039          A_Name : constant Name_Id    := Chars (Ident);
1040          A_Id   : constant Aspect_Id  := Get_Aspect_Id (A_Name);
1041          Ent    : constant Entity_Id  := Entity (ASN);
1042          Expr   : constant Node_Id    := Expression (ASN);
1043          Loc    : constant Source_Ptr := Sloc (ASN);
1044 
1045          procedure Check_False_Aspect_For_Derived_Type;
1046          --  This procedure checks for the case of a false aspect for a derived
1047          --  type, which improperly tries to cancel an aspect inherited from
1048          --  the parent.
1049 
1050          -----------------------------------------
1051          -- Check_False_Aspect_For_Derived_Type --
1052          -----------------------------------------
1053 
1054          procedure Check_False_Aspect_For_Derived_Type is
1055             Par : Node_Id;
1056 
1057          begin
1058             --  We are only checking derived types
1059 
1060             if not Is_Derived_Type (E) then
1061                return;
1062             end if;
1063 
1064             Par := Nearest_Ancestor (E);
1065 
1066             case A_Id is
1067                when Aspect_Atomic | Aspect_Shared =>
1068                   if not Is_Atomic (Par) then
1069                      return;
1070                   end if;
1071 
1072                when Aspect_Atomic_Components =>
1073                   if not Has_Atomic_Components (Par) then
1074                      return;
1075                   end if;
1076 
1077                when Aspect_Discard_Names =>
1078                   if not Discard_Names (Par) then
1079                      return;
1080                   end if;
1081 
1082                when Aspect_Pack =>
1083                   if not Is_Packed (Par) then
1084                      return;
1085                   end if;
1086 
1087                when Aspect_Unchecked_Union =>
1088                   if not Is_Unchecked_Union (Par) then
1089                      return;
1090                   end if;
1091 
1092                when Aspect_Volatile =>
1093                   if not Is_Volatile (Par) then
1094                      return;
1095                   end if;
1096 
1097                when Aspect_Volatile_Components =>
1098                   if not Has_Volatile_Components (Par) then
1099                      return;
1100                   end if;
1101 
1102                when Aspect_Volatile_Full_Access =>
1103                   if not Is_Volatile_Full_Access (Par) then
1104                      return;
1105                   end if;
1106 
1107                when others =>
1108                   return;
1109             end case;
1110 
1111             --  Fall through means we are canceling an inherited aspect
1112 
1113             Error_Msg_Name_1 := A_Name;
1114             Error_Msg_NE
1115               ("derived type& inherits aspect%, cannot cancel", Expr, E);
1116          end Check_False_Aspect_For_Derived_Type;
1117 
1118          --  Local variables
1119 
1120          Prag : Node_Id;
1121 
1122       --  Start of processing for Make_Pragma_From_Boolean_Aspect
1123 
1124       begin
1125          --  Note that we know Expr is present, because for a missing Expr
1126          --  argument, we knew it was True and did not need to delay the
1127          --  evaluation to the freeze point.
1128 
1129          if Is_False (Static_Boolean (Expr)) then
1130             Check_False_Aspect_For_Derived_Type;
1131 
1132          else
1133             Prag :=
1134               Make_Pragma (Loc,
1135                 Pragma_Identifier            =>
1136                   Make_Identifier (Sloc (Ident), Chars (Ident)),
1137                 Pragma_Argument_Associations => New_List (
1138                   Make_Pragma_Argument_Association (Sloc (Ident),
1139                     Expression => New_Occurrence_Of (Ent, Sloc (Ident)))));
1140 
1141             Set_From_Aspect_Specification (Prag, True);
1142             Set_Corresponding_Aspect (Prag, ASN);
1143             Set_Aspect_Rep_Item (ASN, Prag);
1144             Set_Is_Delayed_Aspect (Prag);
1145             Set_Parent (Prag, ASN);
1146          end if;
1147       end Make_Pragma_From_Boolean_Aspect;
1148 
1149       --  Local variables
1150 
1151       A_Id  : Aspect_Id;
1152       ASN   : Node_Id;
1153       Ritem : Node_Id;
1154 
1155    --  Start of processing for Analyze_Aspects_At_Freeze_Point
1156 
1157    begin
1158       --  Must be visible in current scope
1159 
1160       if not Scope_Within_Or_Same (Current_Scope, Scope (E)) then
1161          return;
1162       end if;
1163 
1164       --  Look for aspect specification entries for this entity
1165 
1166       ASN := First_Rep_Item (E);
1167       while Present (ASN) loop
1168          if Nkind (ASN) = N_Aspect_Specification then
1169             exit when Entity (ASN) /= E;
1170 
1171             if Is_Delayed_Aspect (ASN) then
1172                A_Id := Get_Aspect_Id (ASN);
1173 
1174                case A_Id is
1175 
1176                   --  For aspects whose expression is an optional Boolean, make
1177                   --  the corresponding pragma at the freeze point.
1178 
1179                   when Boolean_Aspects      |
1180                        Library_Unit_Aspects =>
1181 
1182                      --  Aspects Export and Import require special handling.
1183                      --  Both are by definition Boolean and may benefit from
1184                      --  forward references, however their expressions are
1185                      --  treated as static. In addition, the syntax of their
1186                      --  corresponding pragmas requires extra "pieces" which
1187                      --  may also contain forward references. To account for
1188                      --  all of this, the corresponding pragma is created by
1189                      --  Analyze_Aspect_Export_Import, but is not analyzed as
1190                      --  the complete analysis must happen now.
1191 
1192                      if A_Id = Aspect_Export or else A_Id = Aspect_Import then
1193                         null;
1194 
1195                      --  Otherwise create a corresponding pragma
1196 
1197                      else
1198                         Make_Pragma_From_Boolean_Aspect (ASN);
1199                      end if;
1200 
1201                   --  Special handling for aspects that don't correspond to
1202                   --  pragmas/attributes.
1203 
1204                   when Aspect_Default_Value           |
1205                        Aspect_Default_Component_Value =>
1206 
1207                      --  Do not inherit aspect for anonymous base type of a
1208                      --  scalar or array type, because they apply to the first
1209                      --  subtype of the type, and will be processed when that
1210                      --  first subtype is frozen.
1211 
1212                      if Is_Derived_Type (E)
1213                        and then not Comes_From_Source (E)
1214                        and then E /= First_Subtype (E)
1215                      then
1216                         null;
1217                      else
1218                         Analyze_Aspect_Default_Value (ASN);
1219                      end if;
1220 
1221                   --  Ditto for iterator aspects, because the corresponding
1222                   --  attributes may not have been analyzed yet.
1223 
1224                   when Aspect_Constant_Indexing |
1225                        Aspect_Variable_Indexing |
1226                        Aspect_Default_Iterator  |
1227                        Aspect_Iterator_Element  =>
1228                      Analyze (Expression (ASN));
1229 
1230                      if Etype (Expression (ASN)) = Any_Type then
1231                         Error_Msg_NE
1232                           ("\aspect must be fully defined before & is frozen",
1233                            ASN, E);
1234                      end if;
1235 
1236                   when Aspect_Iterable =>
1237                      Validate_Iterable_Aspect (E, ASN);
1238 
1239                   when others =>
1240                      null;
1241                end case;
1242 
1243                Ritem := Aspect_Rep_Item (ASN);
1244 
1245                if Present (Ritem) then
1246                   Analyze (Ritem);
1247                end if;
1248             end if;
1249          end if;
1250 
1251          Next_Rep_Item (ASN);
1252       end loop;
1253 
1254       --  This is where we inherit delayed rep aspects from our parent. Note
1255       --  that if we fell out of the above loop with ASN non-empty, it means
1256       --  we hit an aspect for an entity other than E, and it must be the
1257       --  type from which we were derived.
1258 
1259       if May_Inherit_Delayed_Rep_Aspects (E) then
1260          Inherit_Delayed_Rep_Aspects (ASN);
1261       end if;
1262    end Analyze_Aspects_At_Freeze_Point;
1263 
1264    -----------------------------------
1265    -- Analyze_Aspect_Specifications --
1266    -----------------------------------
1267 
1268    procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is
1269       procedure Decorate (Asp : Node_Id; Prag : Node_Id);
1270       --  Establish linkages between an aspect and its corresponding pragma
1271 
1272       procedure Insert_Pragma
1273         (Prag        : Node_Id;
1274          Is_Instance : Boolean := False);
1275       --  Subsidiary to the analysis of aspects
1276       --    Abstract_State
1277       --    Attach_Handler
1278       --    Contract_Cases
1279       --    Depends
1280       --    Ghost
1281       --    Global
1282       --    Initial_Condition
1283       --    Initializes
1284       --    Post
1285       --    Pre
1286       --    Refined_Depends
1287       --    Refined_Global
1288       --    Refined_State
1289       --    SPARK_Mode
1290       --    Warnings
1291       --  Insert pragma Prag such that it mimics the placement of a source
1292       --  pragma of the same kind. Flag Is_Generic should be set when the
1293       --  context denotes a generic instance.
1294 
1295       --------------
1296       -- Decorate --
1297       --------------
1298 
1299       procedure Decorate (Asp : Node_Id; Prag : Node_Id) is
1300       begin
1301          Set_Aspect_Rep_Item           (Asp, Prag);
1302          Set_Corresponding_Aspect      (Prag, Asp);
1303          Set_From_Aspect_Specification (Prag);
1304          Set_Parent                    (Prag, Asp);
1305       end Decorate;
1306 
1307       -------------------
1308       -- Insert_Pragma --
1309       -------------------
1310 
1311       procedure Insert_Pragma
1312         (Prag        : Node_Id;
1313          Is_Instance : Boolean := False)
1314       is
1315          Aux      : Node_Id;
1316          Decl     : Node_Id;
1317          Decls    : List_Id;
1318          Def      : Node_Id;
1319          Inserted : Boolean := False;
1320 
1321       begin
1322          --  When the aspect appears on an entry, package, protected unit,
1323          --  subprogram, or task unit body, insert the generated pragma at the
1324          --  top of the body declarations to emulate the behavior of a source
1325          --  pragma.
1326 
1327          --    package body Pack with Aspect is
1328 
1329          --    package body Pack is
1330          --       pragma Prag;
1331 
1332          if Nkind_In (N, N_Entry_Body,
1333                          N_Package_Body,
1334                          N_Protected_Body,
1335                          N_Subprogram_Body,
1336                          N_Task_Body)
1337          then
1338             Decls := Declarations (N);
1339 
1340             if No (Decls) then
1341                Decls := New_List;
1342                Set_Declarations (N, Decls);
1343             end if;
1344 
1345             Prepend_To (Decls, Prag);
1346 
1347          --  When the aspect is associated with a [generic] package declaration
1348          --  insert the generated pragma at the top of the visible declarations
1349          --  to emulate the behavior of a source pragma.
1350 
1351          --    package Pack with Aspect is
1352 
1353          --    package Pack is
1354          --       pragma Prag;
1355 
1356          elsif Nkind_In (N, N_Generic_Package_Declaration,
1357                             N_Package_Declaration)
1358          then
1359             Decls := Visible_Declarations (Specification (N));
1360 
1361             if No (Decls) then
1362                Decls := New_List;
1363                Set_Visible_Declarations (Specification (N), Decls);
1364             end if;
1365 
1366             --  The visible declarations of a generic instance have the
1367             --  following structure:
1368 
1369             --    <renamings of generic formals>
1370             --    <renamings of internally-generated spec and body>
1371             --    <first source declaration>
1372 
1373             --  Insert the pragma before the first source declaration by
1374             --  skipping the instance "header" to ensure proper visibility of
1375             --  all formals.
1376 
1377             if Is_Instance then
1378                Decl := First (Decls);
1379                while Present (Decl) loop
1380                   if Comes_From_Source (Decl) then
1381                      Insert_Before (Decl, Prag);
1382                      Inserted := True;
1383                      exit;
1384                   else
1385                      Next (Decl);
1386                   end if;
1387                end loop;
1388 
1389                --  The pragma is placed after the instance "header"
1390 
1391                if not Inserted then
1392                   Append_To (Decls, Prag);
1393                end if;
1394 
1395             --  Otherwise this is not a generic instance
1396 
1397             else
1398                Prepend_To (Decls, Prag);
1399             end if;
1400 
1401          --  When the aspect is associated with a protected unit declaration,
1402          --  insert the generated pragma at the top of the visible declarations
1403          --  the emulate the behavior of a source pragma.
1404 
1405          --    protected [type] Prot with Aspect is
1406 
1407          --    protected [type] Prot is
1408          --       pragma Prag;
1409 
1410          elsif Nkind (N) = N_Protected_Type_Declaration then
1411             Def := Protected_Definition (N);
1412 
1413             if No (Def) then
1414                Def :=
1415                  Make_Protected_Definition (Sloc (N),
1416                    Visible_Declarations => New_List,
1417                    End_Label            => Empty);
1418 
1419                Set_Protected_Definition (N, Def);
1420             end if;
1421 
1422             Decls := Visible_Declarations (Def);
1423 
1424             if No (Decls) then
1425                Decls := New_List;
1426                Set_Visible_Declarations (Def, Decls);
1427             end if;
1428 
1429             Prepend_To (Decls, Prag);
1430 
1431          --  When the aspect is associated with a task unit declaration, insert
1432          --  insert the generated pragma at the top of the visible declarations
1433          --  the emulate the behavior of a source pragma.
1434 
1435          --    task [type] Prot with Aspect is
1436 
1437          --    task [type] Prot is
1438          --       pragma Prag;
1439 
1440          elsif Nkind (N) = N_Task_Type_Declaration then
1441             Def := Task_Definition (N);
1442 
1443             if No (Def) then
1444                Def :=
1445                  Make_Task_Definition (Sloc (N),
1446                    Visible_Declarations => New_List,
1447                    End_Label            => Empty);
1448 
1449                Set_Task_Definition (N, Def);
1450             end if;
1451 
1452             Decls := Visible_Declarations (Def);
1453 
1454             if No (Decls) then
1455                Decls := New_List;
1456                Set_Visible_Declarations (Def, Decls);
1457             end if;
1458 
1459             Prepend_To (Decls, Prag);
1460 
1461          --  When the context is a library unit, the pragma is added to the
1462          --  Pragmas_After list.
1463 
1464          elsif Nkind (Parent (N)) = N_Compilation_Unit then
1465             Aux := Aux_Decls_Node (Parent (N));
1466 
1467             if No (Pragmas_After (Aux)) then
1468                Set_Pragmas_After (Aux, New_List);
1469             end if;
1470 
1471             Prepend (Prag, Pragmas_After (Aux));
1472 
1473          --  Default, the pragma is inserted after the context
1474 
1475          else
1476             Insert_After (N, Prag);
1477          end if;
1478       end Insert_Pragma;
1479 
1480       --  Local variables
1481 
1482       Aspect : Node_Id;
1483       Aitem  : Node_Id;
1484       Ent    : Node_Id;
1485 
1486       L : constant List_Id := Aspect_Specifications (N);
1487 
1488       Ins_Node : Node_Id := N;
1489       --  Insert pragmas/attribute definition clause after this node when no
1490       --  delayed analysis is required.
1491 
1492    --  Start of processing for Analyze_Aspect_Specifications
1493 
1494    begin
1495       --  The general processing involves building an attribute definition
1496       --  clause or a pragma node that corresponds to the aspect. Then in order
1497       --  to delay the evaluation of this aspect to the freeze point, we attach
1498       --  the corresponding pragma/attribute definition clause to the aspect
1499       --  specification node, which is then placed in the Rep Item chain. In
1500       --  this case we mark the entity by setting the flag Has_Delayed_Aspects
1501       --  and we evaluate the rep item at the freeze point. When the aspect
1502       --  doesn't have a corresponding pragma/attribute definition clause, then
1503       --  its analysis is simply delayed at the freeze point.
1504 
1505       --  Some special cases don't require delay analysis, thus the aspect is
1506       --  analyzed right now.
1507 
1508       --  Note that there is a special handling for Pre, Post, Test_Case,
1509       --  Contract_Cases aspects. In these cases, we do not have to worry
1510       --  about delay issues, since the pragmas themselves deal with delay
1511       --  of visibility for the expression analysis. Thus, we just insert
1512       --  the pragma after the node N.
1513 
1514       pragma Assert (Present (L));
1515 
1516       --  Loop through aspects
1517 
1518       Aspect := First (L);
1519       Aspect_Loop : while Present (Aspect) loop
1520          Analyze_One_Aspect : declare
1521             Expr : constant Node_Id    := Expression (Aspect);
1522             Id   : constant Node_Id    := Identifier (Aspect);
1523             Loc  : constant Source_Ptr := Sloc (Aspect);
1524             Nam  : constant Name_Id    := Chars (Id);
1525             A_Id : constant Aspect_Id  := Get_Aspect_Id (Nam);
1526             Anod : Node_Id;
1527 
1528             Delay_Required : Boolean;
1529             --  Set False if delay is not required
1530 
1531             Eloc : Source_Ptr := No_Location;
1532             --  Source location of expression, modified when we split PPC's. It
1533             --  is set below when Expr is present.
1534 
1535             procedure Analyze_Aspect_Convention;
1536             --  Perform analysis of aspect Convention
1537 
1538             procedure Analyze_Aspect_Export_Import;
1539             --  Perform analysis of aspects Export or Import
1540 
1541             procedure Analyze_Aspect_External_Link_Name;
1542             --  Perform analysis of aspects External_Name or Link_Name
1543 
1544             procedure Analyze_Aspect_Implicit_Dereference;
1545             --  Perform analysis of the Implicit_Dereference aspects
1546 
1547             procedure Make_Aitem_Pragma
1548               (Pragma_Argument_Associations : List_Id;
1549                Pragma_Name                  : Name_Id);
1550             --  This is a wrapper for Make_Pragma used for converting aspects
1551             --  to pragmas. It takes care of Sloc (set from Loc) and building
1552             --  the pragma identifier from the given name. In addition the
1553             --  flags Class_Present and Split_PPC are set from the aspect
1554             --  node, as well as Is_Ignored. This routine also sets the
1555             --  From_Aspect_Specification in the resulting pragma node to
1556             --  True, and sets Corresponding_Aspect to point to the aspect.
1557             --  The resulting pragma is assigned to Aitem.
1558 
1559             -------------------------------
1560             -- Analyze_Aspect_Convention --
1561             -------------------------------
1562 
1563             procedure Analyze_Aspect_Convention is
1564                Conv    : Node_Id;
1565                Dummy_1 : Node_Id;
1566                Dummy_2 : Node_Id;
1567                Dummy_3 : Node_Id;
1568                Expo    : Node_Id;
1569                Imp     : Node_Id;
1570 
1571             begin
1572                --  Obtain all interfacing aspects that apply to the related
1573                --  entity.
1574 
1575                Get_Interfacing_Aspects
1576                  (Iface_Asp => Aspect,
1577                   Conv_Asp  => Dummy_1,
1578                   EN_Asp    => Dummy_2,
1579                   Expo_Asp  => Expo,
1580                   Imp_Asp   => Imp,
1581                   LN_Asp    => Dummy_3,
1582                   Do_Checks => True);
1583 
1584                --  The related entity is subject to aspect Export or Import.
1585                --  Do not process Convention now because it must be analysed
1586                --  as part of Export or Import.
1587 
1588                if Present (Expo) or else Present (Imp) then
1589                   return;
1590 
1591                --  Otherwise Convention appears by itself
1592 
1593                else
1594                   --  The aspect specifies a particular convention
1595 
1596                   if Present (Expr) then
1597                      Conv := New_Copy_Tree (Expr);
1598 
1599                   --  Otherwise assume convention Ada
1600 
1601                   else
1602                      Conv := Make_Identifier (Loc, Name_Ada);
1603                   end if;
1604 
1605                   --  Generate:
1606                   --    pragma Convention (<Conv>, <E>);
1607 
1608                   Make_Aitem_Pragma
1609                     (Pragma_Name => Name_Convention,
1610                      Pragma_Argument_Associations => New_List (
1611                        Make_Pragma_Argument_Association (Loc,
1612                          Expression => Conv),
1613                        Make_Pragma_Argument_Association (Loc,
1614                          Expression => New_Occurrence_Of (E, Loc))));
1615 
1616                   Decorate (Aspect, Aitem);
1617                   Insert_Pragma (Aitem);
1618                end if;
1619             end Analyze_Aspect_Convention;
1620 
1621             ----------------------------------
1622             -- Analyze_Aspect_Export_Import --
1623             ----------------------------------
1624 
1625             procedure Analyze_Aspect_Export_Import is
1626                Dummy_1 : Node_Id;
1627                Dummy_2 : Node_Id;
1628                Dummy_3 : Node_Id;
1629                Expo    : Node_Id;
1630                Imp     : Node_Id;
1631 
1632             begin
1633                --  Obtain all interfacing aspects that apply to the related
1634                --  entity.
1635 
1636                Get_Interfacing_Aspects
1637                  (Iface_Asp => Aspect,
1638                   Conv_Asp  => Dummy_1,
1639                   EN_Asp    => Dummy_2,
1640                   Expo_Asp  => Expo,
1641                   Imp_Asp   => Imp,
1642                   LN_Asp    => Dummy_3,
1643                   Do_Checks => True);
1644 
1645                --  The related entity cannot be subject to both aspects Export
1646                --  and Import.
1647 
1648                if Present (Expo) and then Present (Imp) then
1649                   Error_Msg_N
1650                     ("incompatible interfacing aspects given for &", E);
1651                   Error_Msg_Sloc := Sloc (Expo);
1652                   Error_Msg_N ("\aspect `Export` #", E);
1653                   Error_Msg_Sloc := Sloc (Imp);
1654                   Error_Msg_N ("\aspect `Import` #", E);
1655                end if;
1656 
1657                --  A variable is most likely modified from the outside. Take
1658                --  Take the optimistic approach to avoid spurious errors.
1659 
1660                if Ekind (E) = E_Variable then
1661                   Set_Never_Set_In_Source (E, False);
1662                end if;
1663 
1664                --  Resolve the expression of an Import or Export here, and
1665                --  require it to be of type Boolean and static. This is not
1666                --  quite right, because in general this should be delayed,
1667                --  but that seems tricky for these, because normally Boolean
1668                --  aspects are replaced with pragmas at the freeze point in
1669                --  Make_Pragma_From_Boolean_Aspect.
1670 
1671                if not Present (Expr)
1672                  or else Is_True (Static_Boolean (Expr))
1673                then
1674                   if A_Id = Aspect_Import then
1675                      Set_Has_Completion (E);
1676                      Set_Is_Imported (E);
1677 
1678                      --  An imported object cannot be explicitly initialized
1679 
1680                      if Nkind (N) = N_Object_Declaration
1681                        and then Present (Expression (N))
1682                      then
1683                         Error_Msg_N
1684                           ("imported entities cannot be initialized "
1685                            & "(RM B.1(24))", Expression (N));
1686                      end if;
1687 
1688                   else
1689                      pragma Assert (A_Id = Aspect_Export);
1690                      Set_Is_Exported (E);
1691                   end if;
1692 
1693                   --  Create the proper form of pragma Export or Import taking
1694                   --  into account Conversion, External_Name, and Link_Name.
1695 
1696                   Aitem := Build_Export_Import_Pragma (Aspect, E);
1697 
1698                --  Otherwise the expression is either False or erroneous. There
1699                --  is no corresponding pragma.
1700 
1701                else
1702                   Aitem := Empty;
1703                end if;
1704             end Analyze_Aspect_Export_Import;
1705 
1706             ---------------------------------------
1707             -- Analyze_Aspect_External_Link_Name --
1708             ---------------------------------------
1709 
1710             procedure Analyze_Aspect_External_Link_Name is
1711                Dummy_1 : Node_Id;
1712                Dummy_2 : Node_Id;
1713                Dummy_3 : Node_Id;
1714                Expo    : Node_Id;
1715                Imp     : Node_Id;
1716 
1717             begin
1718                --  Obtain all interfacing aspects that apply to the related
1719                --  entity.
1720 
1721                Get_Interfacing_Aspects
1722                  (Iface_Asp => Aspect,
1723                   Conv_Asp  => Dummy_1,
1724                   EN_Asp    => Dummy_2,
1725                   Expo_Asp  => Expo,
1726                   Imp_Asp   => Imp,
1727                   LN_Asp    => Dummy_3,
1728                   Do_Checks => True);
1729 
1730                --  Ensure that aspect External_Name applies to aspect Export or
1731                --  Import.
1732 
1733                if A_Id = Aspect_External_Name then
1734                   if No (Expo) and then No (Imp) then
1735                      Error_Msg_N
1736                        ("aspect `External_Name` requires aspect `Import` or "
1737                         & "`Export`", Aspect);
1738                   end if;
1739 
1740                --  Otherwise ensure that aspect Link_Name applies to aspect
1741                --  Export or Import.
1742 
1743                else
1744                   pragma Assert (A_Id = Aspect_Link_Name);
1745                   if No (Expo) and then No (Imp) then
1746                      Error_Msg_N
1747                        ("aspect `Link_Name` requires aspect `Import` or "
1748                         & "`Export`", Aspect);
1749                   end if;
1750                end if;
1751             end Analyze_Aspect_External_Link_Name;
1752 
1753             -----------------------------------------
1754             -- Analyze_Aspect_Implicit_Dereference --
1755             -----------------------------------------
1756 
1757             procedure Analyze_Aspect_Implicit_Dereference is
1758                Disc        : Entity_Id;
1759                Parent_Disc : Entity_Id;
1760 
1761             begin
1762                if not Is_Type (E) or else not Has_Discriminants (E) then
1763                   Error_Msg_N
1764                     ("aspect must apply to a type with discriminants", Expr);
1765 
1766                elsif not Is_Entity_Name (Expr) then
1767                   Error_Msg_N
1768                     ("aspect must name a discriminant of current type", Expr);
1769 
1770                else
1771                   Disc := First_Discriminant (E);
1772                   while Present (Disc) loop
1773                      if Chars (Expr) = Chars (Disc)
1774                        and then Ekind (Etype (Disc)) =
1775                                   E_Anonymous_Access_Type
1776                      then
1777                         Set_Has_Implicit_Dereference (E);
1778                         Set_Has_Implicit_Dereference (Disc);
1779                         exit;
1780                      end if;
1781 
1782                      Next_Discriminant (Disc);
1783                   end loop;
1784 
1785                   --  Error if no proper access discriminant
1786 
1787                   if No (Disc) then
1788                      Error_Msg_NE ("not an access discriminant of&", Expr, E);
1789                      return;
1790                   end if;
1791                end if;
1792 
1793                --  For a type extension, check whether parent has a
1794                --  reference discriminant, to verify that use is proper.
1795 
1796                if Is_Derived_Type (E)
1797                  and then Has_Discriminants (Etype (E))
1798                then
1799                   Parent_Disc := Get_Reference_Discriminant (Etype (E));
1800 
1801                   if Present (Parent_Disc)
1802                     and then Corresponding_Discriminant (Disc) /= Parent_Disc
1803                   then
1804                      Error_Msg_N
1805                        ("reference discriminant does not match discriminant "
1806                         & "of parent type", Expr);
1807                   end if;
1808                end if;
1809             end Analyze_Aspect_Implicit_Dereference;
1810 
1811             -----------------------
1812             -- Make_Aitem_Pragma --
1813             -----------------------
1814 
1815             procedure Make_Aitem_Pragma
1816               (Pragma_Argument_Associations : List_Id;
1817                Pragma_Name                  : Name_Id)
1818             is
1819                Args : List_Id := Pragma_Argument_Associations;
1820 
1821             begin
1822                --  We should never get here if aspect was disabled
1823 
1824                pragma Assert (not Is_Disabled (Aspect));
1825 
1826                --  Certain aspects allow for an optional name or expression. Do
1827                --  not generate a pragma with empty argument association list.
1828 
1829                if No (Args) or else No (Expression (First (Args))) then
1830                   Args := No_List;
1831                end if;
1832 
1833                --  Build the pragma
1834 
1835                Aitem :=
1836                  Make_Pragma (Loc,
1837                    Pragma_Argument_Associations => Args,
1838                    Pragma_Identifier =>
1839                      Make_Identifier (Sloc (Id), Pragma_Name),
1840                    Class_Present     => Class_Present (Aspect),
1841                    Split_PPC         => Split_PPC (Aspect));
1842 
1843                --  Set additional semantic fields
1844 
1845                if Is_Ignored (Aspect) then
1846                   Set_Is_Ignored (Aitem);
1847                elsif Is_Checked (Aspect) then
1848                   Set_Is_Checked (Aitem);
1849                end if;
1850 
1851                Set_Corresponding_Aspect (Aitem, Aspect);
1852                Set_From_Aspect_Specification (Aitem);
1853             end Make_Aitem_Pragma;
1854 
1855          --  Start of processing for Analyze_One_Aspect
1856 
1857          begin
1858             --  Skip aspect if already analyzed, to avoid looping in some cases
1859 
1860             if Analyzed (Aspect) then
1861                goto Continue;
1862             end if;
1863 
1864             --  Skip looking at aspect if it is totally disabled. Just mark it
1865             --  as such for later reference in the tree. This also sets the
1866             --  Is_Ignored and Is_Checked flags appropriately.
1867 
1868             Check_Applicable_Policy (Aspect);
1869 
1870             if Is_Disabled (Aspect) then
1871                goto Continue;
1872             end if;
1873 
1874             --  Set the source location of expression, used in the case of
1875             --  a failed precondition/postcondition or invariant. Note that
1876             --  the source location of the expression is not usually the best
1877             --  choice here. For example, it gets located on the last AND
1878             --  keyword in a chain of boolean expressiond AND'ed together.
1879             --  It is best to put the message on the first character of the
1880             --  assertion, which is the effect of the First_Node call here.
1881 
1882             if Present (Expr) then
1883                Eloc := Sloc (First_Node (Expr));
1884             end if;
1885 
1886             --  Check restriction No_Implementation_Aspect_Specifications
1887 
1888             if Implementation_Defined_Aspect (A_Id) then
1889                Check_Restriction
1890                  (No_Implementation_Aspect_Specifications, Aspect);
1891             end if;
1892 
1893             --  Check restriction No_Specification_Of_Aspect
1894 
1895             Check_Restriction_No_Specification_Of_Aspect (Aspect);
1896 
1897             --  Mark aspect analyzed (actual analysis is delayed till later)
1898 
1899             Set_Analyzed (Aspect);
1900             Set_Entity (Aspect, E);
1901             Ent := New_Occurrence_Of (E, Sloc (Id));
1902 
1903             --  Check for duplicate aspect. Note that the Comes_From_Source
1904             --  test allows duplicate Pre/Post's that we generate internally
1905             --  to escape being flagged here.
1906 
1907             if No_Duplicates_Allowed (A_Id) then
1908                Anod := First (L);
1909                while Anod /= Aspect loop
1910                   if Comes_From_Source (Aspect)
1911                     and then Same_Aspect (A_Id, Get_Aspect_Id (Anod))
1912                   then
1913                      Error_Msg_Name_1 := Nam;
1914                      Error_Msg_Sloc := Sloc (Anod);
1915 
1916                      --  Case of same aspect specified twice
1917 
1918                      if Class_Present (Anod) = Class_Present (Aspect) then
1919                         if not Class_Present (Anod) then
1920                            Error_Msg_NE
1921                              ("aspect% for & previously given#",
1922                               Id, E);
1923                         else
1924                            Error_Msg_NE
1925                              ("aspect `%''Class` for & previously given#",
1926                               Id, E);
1927                         end if;
1928                      end if;
1929                   end if;
1930 
1931                   Next (Anod);
1932                end loop;
1933             end if;
1934 
1935             --  Check some general restrictions on language defined aspects
1936 
1937             if not Implementation_Defined_Aspect (A_Id) then
1938                Error_Msg_Name_1 := Nam;
1939 
1940                --  Not allowed for renaming declarations. Examine original
1941                --  node because a subprogram renaming may have been rewritten
1942                --  as a body.
1943 
1944                if Nkind (Original_Node (N)) in N_Renaming_Declaration then
1945                   Error_Msg_N
1946                     ("aspect % not allowed for renaming declaration",
1947                      Aspect);
1948                end if;
1949 
1950                --  Not allowed for formal type declarations
1951 
1952                if Nkind (N) = N_Formal_Type_Declaration then
1953                   Error_Msg_N
1954                     ("aspect % not allowed for formal type declaration",
1955                      Aspect);
1956                end if;
1957             end if;
1958 
1959             --  Copy expression for later processing by the procedures
1960             --  Check_Aspect_At_[Freeze_Point | End_Of_Declarations]
1961 
1962             Set_Entity (Id, New_Copy_Tree (Expr));
1963 
1964             --  Set Delay_Required as appropriate to aspect
1965 
1966             case Aspect_Delay (A_Id) is
1967                when Always_Delay =>
1968                   Delay_Required := True;
1969 
1970                when Never_Delay =>
1971                   Delay_Required := False;
1972 
1973                when Rep_Aspect =>
1974 
1975                   --  If expression has the form of an integer literal, then
1976                   --  do not delay, since we know the value cannot change.
1977                   --  This optimization catches most rep clause cases.
1978 
1979                   --  For Boolean aspects, don't delay if no expression
1980 
1981                   if A_Id in Boolean_Aspects and then No (Expr) then
1982                      Delay_Required := False;
1983 
1984                   --  For non-Boolean aspects, don't delay if integer literal
1985 
1986                   elsif A_Id not in Boolean_Aspects
1987                     and then Present (Expr)
1988                     and then Nkind (Expr) = N_Integer_Literal
1989                   then
1990                      Delay_Required := False;
1991 
1992                   --  All other cases are delayed
1993 
1994                   else
1995                      Delay_Required := True;
1996                      Set_Has_Delayed_Rep_Aspects (E);
1997                   end if;
1998             end case;
1999 
2000             --  Processing based on specific aspect
2001 
2002             case A_Id is
2003                when Aspect_Unimplemented =>
2004                   null; -- ??? temp for now
2005 
2006                --  No_Aspect should be impossible
2007 
2008                when No_Aspect =>
2009                   raise Program_Error;
2010 
2011                --  Case 1: Aspects corresponding to attribute definition
2012                --  clauses.
2013 
2014                when Aspect_Address              |
2015                     Aspect_Alignment            |
2016                     Aspect_Bit_Order            |
2017                     Aspect_Component_Size       |
2018                     Aspect_Constant_Indexing    |
2019                     Aspect_Default_Iterator     |
2020                     Aspect_Dispatching_Domain   |
2021                     Aspect_External_Tag         |
2022                     Aspect_Input                |
2023                     Aspect_Iterable             |
2024                     Aspect_Iterator_Element     |
2025                     Aspect_Machine_Radix        |
2026                     Aspect_Object_Size          |
2027                     Aspect_Output               |
2028                     Aspect_Read                 |
2029                     Aspect_Scalar_Storage_Order |
2030                     Aspect_Size                 |
2031                     Aspect_Small                |
2032                     Aspect_Simple_Storage_Pool  |
2033                     Aspect_Storage_Pool         |
2034                     Aspect_Stream_Size          |
2035                     Aspect_Value_Size           |
2036                     Aspect_Variable_Indexing    |
2037                     Aspect_Write                =>
2038 
2039                   --  Indexing aspects apply only to tagged type
2040 
2041                   if (A_Id = Aspect_Constant_Indexing
2042                         or else
2043                       A_Id = Aspect_Variable_Indexing)
2044                     and then not (Is_Type (E)
2045                                    and then Is_Tagged_Type (E))
2046                   then
2047                      Error_Msg_N
2048                        ("indexing aspect can only apply to a tagged type",
2049                         Aspect);
2050                      goto Continue;
2051                   end if;
2052 
2053                   --  For the case of aspect Address, we don't consider that we
2054                   --  know the entity is never set in the source, since it is
2055                   --  is likely aliasing is occurring.
2056 
2057                   --  Note: one might think that the analysis of the resulting
2058                   --  attribute definition clause would take care of that, but
2059                   --  that's not the case since it won't be from source.
2060 
2061                   if A_Id = Aspect_Address then
2062                      Set_Never_Set_In_Source (E, False);
2063                   end if;
2064 
2065                   --  Correctness of the profile of a stream operation is
2066                   --  verified at the freeze point, but we must detect the
2067                   --  illegal specification of this aspect for a subtype now,
2068                   --  to prevent malformed rep_item chains.
2069 
2070                   if A_Id = Aspect_Input  or else
2071                      A_Id = Aspect_Output or else
2072                      A_Id = Aspect_Read   or else
2073                      A_Id = Aspect_Write
2074                   then
2075                      if not Is_First_Subtype (E) then
2076                         Error_Msg_N
2077                           ("local name must be a first subtype", Aspect);
2078                         goto Continue;
2079 
2080                      --  If stream aspect applies to the class-wide type,
2081                      --  the generated attribute definition applies to the
2082                      --  class-wide type as well.
2083 
2084                      elsif Class_Present (Aspect) then
2085                         Ent :=
2086                           Make_Attribute_Reference (Loc,
2087                             Prefix         => Ent,
2088                             Attribute_Name => Name_Class);
2089                      end if;
2090                   end if;
2091 
2092                   --  Construct the attribute definition clause
2093 
2094                   Aitem :=
2095                     Make_Attribute_Definition_Clause (Loc,
2096                       Name       => Ent,
2097                       Chars      => Chars (Id),
2098                       Expression => Relocate_Node (Expr));
2099 
2100                   --  If the address is specified, then we treat the entity as
2101                   --  referenced, to avoid spurious warnings. This is analogous
2102                   --  to what is done with an attribute definition clause, but
2103                   --  here we don't want to generate a reference because this
2104                   --  is the point of definition of the entity.
2105 
2106                   if A_Id = Aspect_Address then
2107                      Set_Referenced (E);
2108                   end if;
2109 
2110                --  Case 2: Aspects corresponding to pragmas
2111 
2112                --  Case 2a: Aspects corresponding to pragmas with two
2113                --  arguments, where the first argument is a local name
2114                --  referring to the entity, and the second argument is the
2115                --  aspect definition expression.
2116 
2117                --  Linker_Section/Suppress/Unsuppress
2118 
2119                when Aspect_Linker_Section |
2120                     Aspect_Suppress       |
2121                     Aspect_Unsuppress     =>
2122 
2123                   Make_Aitem_Pragma
2124                     (Pragma_Argument_Associations => New_List (
2125                        Make_Pragma_Argument_Association (Loc,
2126                          Expression => New_Occurrence_Of (E, Loc)),
2127                        Make_Pragma_Argument_Association (Sloc (Expr),
2128                          Expression => Relocate_Node (Expr))),
2129                      Pragma_Name                  => Chars (Id));
2130 
2131                --  Synchronization
2132 
2133                --  Corresponds to pragma Implemented, construct the pragma
2134 
2135                when Aspect_Synchronization =>
2136                   Make_Aitem_Pragma
2137                     (Pragma_Argument_Associations => New_List (
2138                        Make_Pragma_Argument_Association (Loc,
2139                          Expression => New_Occurrence_Of (E, Loc)),
2140                        Make_Pragma_Argument_Association (Sloc (Expr),
2141                          Expression => Relocate_Node (Expr))),
2142                      Pragma_Name                  => Name_Implemented);
2143 
2144                --  Attach_Handler
2145 
2146                when Aspect_Attach_Handler =>
2147                   Make_Aitem_Pragma
2148                     (Pragma_Argument_Associations => New_List (
2149                        Make_Pragma_Argument_Association (Sloc (Ent),
2150                          Expression => Ent),
2151                        Make_Pragma_Argument_Association (Sloc (Expr),
2152                          Expression => Relocate_Node (Expr))),
2153                      Pragma_Name                  => Name_Attach_Handler);
2154 
2155                   --  We need to insert this pragma into the tree to get proper
2156                   --  processing and to look valid from a placement viewpoint.
2157 
2158                   Insert_Pragma (Aitem);
2159                   goto Continue;
2160 
2161                --  Dynamic_Predicate, Predicate, Static_Predicate
2162 
2163                when Aspect_Dynamic_Predicate |
2164                     Aspect_Predicate         |
2165                     Aspect_Static_Predicate  =>
2166 
2167                   --  These aspects apply only to subtypes
2168 
2169                   if not Is_Type (E) then
2170                      Error_Msg_N
2171                        ("predicate can only be specified for a subtype",
2172                         Aspect);
2173                      goto Continue;
2174 
2175                   elsif Is_Incomplete_Type (E) then
2176                      Error_Msg_N
2177                        ("predicate cannot apply to incomplete view", Aspect);
2178                      goto Continue;
2179                   end if;
2180 
2181                   --  Construct the pragma (always a pragma Predicate, with
2182                   --  flags recording whether it is static/dynamic). We also
2183                   --  set flags recording this in the type itself.
2184 
2185                   Make_Aitem_Pragma
2186                     (Pragma_Argument_Associations => New_List (
2187                        Make_Pragma_Argument_Association (Sloc (Ent),
2188                          Expression => Ent),
2189                        Make_Pragma_Argument_Association (Sloc (Expr),
2190                          Expression => Relocate_Node (Expr))),
2191                      Pragma_Name => Name_Predicate);
2192 
2193                   --  Mark type has predicates, and remember what kind of
2194                   --  aspect lead to this predicate (we need this to access
2195                   --  the right set of check policies later on).
2196 
2197                   Set_Has_Predicates (E);
2198 
2199                   if A_Id = Aspect_Dynamic_Predicate then
2200                      Set_Has_Dynamic_Predicate_Aspect (E);
2201                   elsif A_Id = Aspect_Static_Predicate then
2202                      Set_Has_Static_Predicate_Aspect (E);
2203                   end if;
2204 
2205                   --  If the type is private, indicate that its completion
2206                   --  has a freeze node, because that is the one that will
2207                   --  be visible at freeze time.
2208 
2209                   if Is_Private_Type (E) and then Present (Full_View (E)) then
2210                      Set_Has_Predicates (Full_View (E));
2211 
2212                      if A_Id = Aspect_Dynamic_Predicate then
2213                         Set_Has_Dynamic_Predicate_Aspect (Full_View (E));
2214                      elsif A_Id = Aspect_Static_Predicate then
2215                         Set_Has_Static_Predicate_Aspect (Full_View (E));
2216                      end if;
2217 
2218                      Set_Has_Delayed_Aspects (Full_View (E));
2219                      Ensure_Freeze_Node (Full_View (E));
2220                   end if;
2221 
2222                --  Predicate_Failure
2223 
2224                when Aspect_Predicate_Failure =>
2225 
2226                   --  This aspect applies only to subtypes
2227 
2228                   if not Is_Type (E) then
2229                      Error_Msg_N
2230                        ("predicate can only be specified for a subtype",
2231                         Aspect);
2232                      goto Continue;
2233 
2234                   elsif Is_Incomplete_Type (E) then
2235                      Error_Msg_N
2236                        ("predicate cannot apply to incomplete view", Aspect);
2237                      goto Continue;
2238                   end if;
2239 
2240                   --  Construct the pragma
2241 
2242                   Make_Aitem_Pragma
2243                     (Pragma_Argument_Associations => New_List (
2244                        Make_Pragma_Argument_Association (Sloc (Ent),
2245                          Expression => Ent),
2246                        Make_Pragma_Argument_Association (Sloc (Expr),
2247                          Expression => Relocate_Node (Expr))),
2248                      Pragma_Name => Name_Predicate_Failure);
2249 
2250                   Set_Has_Predicates (E);
2251 
2252                   --  If the type is private, indicate that its completion
2253                   --  has a freeze node, because that is the one that will
2254                   --  be visible at freeze time.
2255 
2256                   if Is_Private_Type (E) and then Present (Full_View (E)) then
2257                      Set_Has_Predicates (Full_View (E));
2258                      Set_Has_Delayed_Aspects (Full_View (E));
2259                      Ensure_Freeze_Node (Full_View (E));
2260                   end if;
2261 
2262                --  Case 2b: Aspects corresponding to pragmas with two
2263                --  arguments, where the second argument is a local name
2264                --  referring to the entity, and the first argument is the
2265                --  aspect definition expression.
2266 
2267                --  Convention
2268 
2269                when Aspect_Convention =>
2270                   Analyze_Aspect_Convention;
2271                   goto Continue;
2272 
2273                --  External_Name, Link_Name
2274 
2275                when Aspect_External_Name |
2276                     Aspect_Link_Name     =>
2277                   Analyze_Aspect_External_Link_Name;
2278                   goto Continue;
2279 
2280                --  CPU, Interrupt_Priority, Priority
2281 
2282                --  These three aspects can be specified for a subprogram spec
2283                --  or body, in which case we analyze the expression and export
2284                --  the value of the aspect.
2285 
2286                --  Previously, we generated an equivalent pragma for bodies
2287                --  (note that the specs cannot contain these pragmas). The
2288                --  pragma was inserted ahead of local declarations, rather than
2289                --  after the body. This leads to a certain duplication between
2290                --  the processing performed for the aspect and the pragma, but
2291                --  given the straightforward handling required it is simpler
2292                --  to duplicate than to translate the aspect in the spec into
2293                --  a pragma in the declarative part of the body.
2294 
2295                when Aspect_CPU                |
2296                     Aspect_Interrupt_Priority |
2297                     Aspect_Priority           =>
2298 
2299                   if Nkind_In (N, N_Subprogram_Body,
2300                                   N_Subprogram_Declaration)
2301                   then
2302                      --  Analyze the aspect expression
2303 
2304                      Analyze_And_Resolve (Expr, Standard_Integer);
2305 
2306                      --  Interrupt_Priority aspect not allowed for main
2307                      --  subprograms. RM D.1 does not forbid this explicitly,
2308                      --  but RM J.15.11(6/3) does not permit pragma
2309                      --  Interrupt_Priority for subprograms.
2310 
2311                      if A_Id = Aspect_Interrupt_Priority then
2312                         Error_Msg_N
2313                           ("Interrupt_Priority aspect cannot apply to "
2314                            & "subprogram", Expr);
2315 
2316                      --  The expression must be static
2317 
2318                      elsif not Is_OK_Static_Expression (Expr) then
2319                         Flag_Non_Static_Expr
2320                           ("aspect requires static expression!", Expr);
2321 
2322                      --  Check whether this is the main subprogram. Issue a
2323                      --  warning only if it is obviously not a main program
2324                      --  (when it has parameters or when the subprogram is
2325                      --  within a package).
2326 
2327                      elsif Present (Parameter_Specifications
2328                                       (Specification (N)))
2329                        or else not Is_Compilation_Unit (Defining_Entity (N))
2330                      then
2331                         --  See RM D.1(14/3) and D.16(12/3)
2332 
2333                         Error_Msg_N
2334                           ("aspect applied to subprogram other than the "
2335                            & "main subprogram has no effect??", Expr);
2336 
2337                      --  Otherwise check in range and export the value
2338 
2339                      --  For the CPU aspect
2340 
2341                      elsif A_Id = Aspect_CPU then
2342                         if Is_In_Range (Expr, RTE (RE_CPU_Range)) then
2343 
2344                            --  Value is correct so we export the value to make
2345                            --  it available at execution time.
2346 
2347                            Set_Main_CPU
2348                              (Main_Unit, UI_To_Int (Expr_Value (Expr)));
2349 
2350                         else
2351                            Error_Msg_N
2352                              ("main subprogram CPU is out of range", Expr);
2353                         end if;
2354 
2355                      --  For the Priority aspect
2356 
2357                      elsif A_Id = Aspect_Priority then
2358                         if Is_In_Range (Expr, RTE (RE_Priority)) then
2359 
2360                            --  Value is correct so we export the value to make
2361                            --  it available at execution time.
2362 
2363                            Set_Main_Priority
2364                              (Main_Unit, UI_To_Int (Expr_Value (Expr)));
2365 
2366                         --  Ignore pragma if Relaxed_RM_Semantics to support
2367                         --  other targets/non GNAT compilers.
2368 
2369                         elsif not Relaxed_RM_Semantics then
2370                            Error_Msg_N
2371                              ("main subprogram priority is out of range",
2372                               Expr);
2373                         end if;
2374                      end if;
2375 
2376                      --  Load an arbitrary entity from System.Tasking.Stages
2377                      --  or System.Tasking.Restricted.Stages (depending on
2378                      --  the supported profile) to make sure that one of these
2379                      --  packages is implicitly with'ed, since we need to have
2380                      --  the tasking run time active for the pragma Priority to
2381                      --  have any effect. Previously we with'ed the package
2382                      --  System.Tasking, but this package does not trigger the
2383                      --  required initialization of the run-time library.
2384 
2385                      declare
2386                         Discard : Entity_Id;
2387                      begin
2388                         if Restricted_Profile then
2389                            Discard := RTE (RE_Activate_Restricted_Tasks);
2390                         else
2391                            Discard := RTE (RE_Activate_Tasks);
2392                         end if;
2393                      end;
2394 
2395                      --  Handling for these Aspects in subprograms is complete
2396 
2397                      goto Continue;
2398 
2399                   --  For tasks pass the aspect as an attribute
2400 
2401                   else
2402                      Aitem :=
2403                        Make_Attribute_Definition_Clause (Loc,
2404                          Name       => Ent,
2405                          Chars      => Chars (Id),
2406                          Expression => Relocate_Node (Expr));
2407                   end if;
2408 
2409                --  Warnings
2410 
2411                when Aspect_Warnings =>
2412                   Make_Aitem_Pragma
2413                     (Pragma_Argument_Associations => New_List (
2414                        Make_Pragma_Argument_Association (Sloc (Expr),
2415                          Expression => Relocate_Node (Expr)),
2416                        Make_Pragma_Argument_Association (Loc,
2417                          Expression => New_Occurrence_Of (E, Loc))),
2418                      Pragma_Name                  => Chars (Id));
2419 
2420                   Decorate (Aspect, Aitem);
2421                   Insert_Pragma (Aitem);
2422                   goto Continue;
2423 
2424                --  Case 2c: Aspects corresponding to pragmas with three
2425                --  arguments.
2426 
2427                --  Invariant aspects have a first argument that references the
2428                --  entity, a second argument that is the expression and a third
2429                --  argument that is an appropriate message.
2430 
2431                --  Invariant, Type_Invariant
2432 
2433                when Aspect_Invariant      |
2434                     Aspect_Type_Invariant =>
2435 
2436                   --  Analysis of the pragma will verify placement legality:
2437                   --  an invariant must apply to a private type, or appear in
2438                   --  the private part of a spec and apply to a completion.
2439 
2440                   Make_Aitem_Pragma
2441                     (Pragma_Argument_Associations => New_List (
2442                        Make_Pragma_Argument_Association (Sloc (Ent),
2443                          Expression => Ent),
2444                        Make_Pragma_Argument_Association (Sloc (Expr),
2445                          Expression => Relocate_Node (Expr))),
2446                      Pragma_Name                  => Name_Invariant);
2447 
2448                   --  Add message unless exception messages are suppressed
2449 
2450                   if not Opt.Exception_Locations_Suppressed then
2451                      Append_To (Pragma_Argument_Associations (Aitem),
2452                        Make_Pragma_Argument_Association (Eloc,
2453                          Chars      => Name_Message,
2454                          Expression =>
2455                            Make_String_Literal (Eloc,
2456                              Strval => "failed invariant from "
2457                                        & Build_Location_String (Eloc))));
2458                   end if;
2459 
2460                   --  For Invariant case, insert immediately after the entity
2461                   --  declaration. We do not have to worry about delay issues
2462                   --  since the pragma processing takes care of this.
2463 
2464                   Delay_Required := False;
2465 
2466                --  Case 2d : Aspects that correspond to a pragma with one
2467                --  argument.
2468 
2469                --  Abstract_State
2470 
2471                --  Aspect Abstract_State introduces implicit declarations for
2472                --  all state abstraction entities it defines. To emulate this
2473                --  behavior, insert the pragma at the beginning of the visible
2474                --  declarations of the related package so that it is analyzed
2475                --  immediately.
2476 
2477                when Aspect_Abstract_State => Abstract_State : declare
2478                   Context : Node_Id := N;
2479 
2480                begin
2481                   --  When aspect Abstract_State appears on a generic package,
2482                   --  it is propageted to the package instance. The context in
2483                   --  this case is the instance spec.
2484 
2485                   if Nkind (Context) = N_Package_Instantiation then
2486                      Context := Instance_Spec (Context);
2487                   end if;
2488 
2489                   if Nkind_In (Context, N_Generic_Package_Declaration,
2490                                         N_Package_Declaration)
2491                   then
2492                      Make_Aitem_Pragma
2493                        (Pragma_Argument_Associations => New_List (
2494                           Make_Pragma_Argument_Association (Loc,
2495                             Expression => Relocate_Node (Expr))),
2496                         Pragma_Name                  => Name_Abstract_State);
2497 
2498                      Decorate (Aspect, Aitem);
2499                      Insert_Pragma
2500                        (Prag        => Aitem,
2501                         Is_Instance =>
2502                           Is_Generic_Instance (Defining_Entity (Context)));
2503 
2504                   else
2505                      Error_Msg_NE
2506                        ("aspect & must apply to a package declaration",
2507                         Aspect, Id);
2508                   end if;
2509 
2510                   goto Continue;
2511                end Abstract_State;
2512 
2513                --  Aspect Async_Readers is never delayed because it is
2514                --  equivalent to a source pragma which appears after the
2515                --  related object declaration.
2516 
2517                when Aspect_Async_Readers =>
2518                   Make_Aitem_Pragma
2519                     (Pragma_Argument_Associations => New_List (
2520                        Make_Pragma_Argument_Association (Loc,
2521                          Expression => Relocate_Node (Expr))),
2522                      Pragma_Name                  => Name_Async_Readers);
2523 
2524                   Decorate (Aspect, Aitem);
2525                   Insert_Pragma (Aitem);
2526                   goto Continue;
2527 
2528                --  Aspect Async_Writers is never delayed because it is
2529                --  equivalent to a source pragma which appears after the
2530                --  related object declaration.
2531 
2532                when Aspect_Async_Writers =>
2533                   Make_Aitem_Pragma
2534                     (Pragma_Argument_Associations => New_List (
2535                        Make_Pragma_Argument_Association (Loc,
2536                          Expression => Relocate_Node (Expr))),
2537                      Pragma_Name                  => Name_Async_Writers);
2538 
2539                   Decorate (Aspect, Aitem);
2540                   Insert_Pragma (Aitem);
2541                   goto Continue;
2542 
2543                --  Aspect Constant_After_Elaboration is never delayed because
2544                --  it is equivalent to a source pragma which appears after the
2545                --  related object declaration.
2546 
2547                when Aspect_Constant_After_Elaboration =>
2548                   Make_Aitem_Pragma
2549                     (Pragma_Argument_Associations => New_List (
2550                        Make_Pragma_Argument_Association (Loc,
2551                          Expression => Relocate_Node (Expr))),
2552                      Pragma_Name                  =>
2553                        Name_Constant_After_Elaboration);
2554 
2555                   Decorate (Aspect, Aitem);
2556                   Insert_Pragma (Aitem);
2557                   goto Continue;
2558 
2559                --  Aspect Default_Internal_Condition is never delayed because
2560                --  it is equivalent to a source pragma which appears after the
2561                --  related private type. To deal with forward references, the
2562                --  generated pragma is stored in the rep chain of the related
2563                --  private type as types do not carry contracts. The pragma is
2564                --  wrapped inside of a procedure at the freeze point of the
2565                --  private type's full view.
2566 
2567                when Aspect_Default_Initial_Condition =>
2568                   Make_Aitem_Pragma
2569                     (Pragma_Argument_Associations => New_List (
2570                        Make_Pragma_Argument_Association (Loc,
2571                          Expression => Relocate_Node (Expr))),
2572                      Pragma_Name                  =>
2573                        Name_Default_Initial_Condition);
2574 
2575                   Decorate (Aspect, Aitem);
2576                   Insert_Pragma (Aitem);
2577                   goto Continue;
2578 
2579                --  Default_Storage_Pool
2580 
2581                when Aspect_Default_Storage_Pool =>
2582                   Make_Aitem_Pragma
2583                     (Pragma_Argument_Associations => New_List (
2584                        Make_Pragma_Argument_Association (Loc,
2585                          Expression => Relocate_Node (Expr))),
2586                      Pragma_Name                  =>
2587                        Name_Default_Storage_Pool);
2588 
2589                   Decorate (Aspect, Aitem);
2590                   Insert_Pragma (Aitem);
2591                   goto Continue;
2592 
2593                --  Depends
2594 
2595                --  Aspect Depends is never delayed because it is equivalent to
2596                --  a source pragma which appears after the related subprogram.
2597                --  To deal with forward references, the generated pragma is
2598                --  stored in the contract of the related subprogram and later
2599                --  analyzed at the end of the declarative region. See routine
2600                --  Analyze_Depends_In_Decl_Part for details.
2601 
2602                when Aspect_Depends =>
2603                   Make_Aitem_Pragma
2604                     (Pragma_Argument_Associations => New_List (
2605                        Make_Pragma_Argument_Association (Loc,
2606                          Expression => Relocate_Node (Expr))),
2607                      Pragma_Name                  => Name_Depends);
2608 
2609                   Decorate (Aspect, Aitem);
2610                   Insert_Pragma (Aitem);
2611                   goto Continue;
2612 
2613                --  Aspect Effecitve_Reads is never delayed because it is
2614                --  equivalent to a source pragma which appears after the
2615                --  related object declaration.
2616 
2617                when Aspect_Effective_Reads =>
2618                   Make_Aitem_Pragma
2619                     (Pragma_Argument_Associations => New_List (
2620                        Make_Pragma_Argument_Association (Loc,
2621                          Expression => Relocate_Node (Expr))),
2622                      Pragma_Name                  => Name_Effective_Reads);
2623 
2624                   Decorate (Aspect, Aitem);
2625                   Insert_Pragma (Aitem);
2626                   goto Continue;
2627 
2628                --  Aspect Effective_Writes is never delayed because it is
2629                --  equivalent to a source pragma which appears after the
2630                --  related object declaration.
2631 
2632                when Aspect_Effective_Writes =>
2633                   Make_Aitem_Pragma
2634                     (Pragma_Argument_Associations => New_List (
2635                        Make_Pragma_Argument_Association (Loc,
2636                          Expression => Relocate_Node (Expr))),
2637                      Pragma_Name                  => Name_Effective_Writes);
2638 
2639                   Decorate (Aspect, Aitem);
2640                   Insert_Pragma (Aitem);
2641                   goto Continue;
2642 
2643                --  Aspect Extensions_Visible is never delayed because it is
2644                --  equivalent to a source pragma which appears after the
2645                --  related subprogram.
2646 
2647                when Aspect_Extensions_Visible =>
2648                   Make_Aitem_Pragma
2649                     (Pragma_Argument_Associations => New_List (
2650                        Make_Pragma_Argument_Association (Loc,
2651                          Expression => Relocate_Node (Expr))),
2652                      Pragma_Name                  => Name_Extensions_Visible);
2653 
2654                   Decorate (Aspect, Aitem);
2655                   Insert_Pragma (Aitem);
2656                   goto Continue;
2657 
2658                --  Aspect Ghost is never delayed because it is equivalent to a
2659                --  source pragma which appears at the top of [generic] package
2660                --  declarations or after an object, a [generic] subprogram, or
2661                --  a type declaration.
2662 
2663                when Aspect_Ghost =>
2664                   Make_Aitem_Pragma
2665                     (Pragma_Argument_Associations => New_List (
2666                        Make_Pragma_Argument_Association (Loc,
2667                          Expression => Relocate_Node (Expr))),
2668                      Pragma_Name                  => Name_Ghost);
2669 
2670                   Decorate (Aspect, Aitem);
2671                   Insert_Pragma (Aitem);
2672                   goto Continue;
2673 
2674                --  Global
2675 
2676                --  Aspect Global is never delayed because it is equivalent to
2677                --  a source pragma which appears after the related subprogram.
2678                --  To deal with forward references, the generated pragma is
2679                --  stored in the contract of the related subprogram and later
2680                --  analyzed at the end of the declarative region. See routine
2681                --  Analyze_Global_In_Decl_Part for details.
2682 
2683                when Aspect_Global =>
2684                   Make_Aitem_Pragma
2685                     (Pragma_Argument_Associations => New_List (
2686                        Make_Pragma_Argument_Association (Loc,
2687                          Expression => Relocate_Node (Expr))),
2688                      Pragma_Name                  => Name_Global);
2689 
2690                   Decorate (Aspect, Aitem);
2691                   Insert_Pragma (Aitem);
2692                   goto Continue;
2693 
2694                --  Initial_Condition
2695 
2696                --  Aspect Initial_Condition is never delayed because it is
2697                --  equivalent to a source pragma which appears after the
2698                --  related package. To deal with forward references, the
2699                --  generated pragma is stored in the contract of the related
2700                --  package and later analyzed at the end of the declarative
2701                --  region. See routine Analyze_Initial_Condition_In_Decl_Part
2702                --  for details.
2703 
2704                when Aspect_Initial_Condition => Initial_Condition : declare
2705                   Context : Node_Id := N;
2706 
2707                begin
2708                   --  When aspect Initial_Condition appears on a generic
2709                   --  package, it is propageted to the package instance. The
2710                   --  context in this case is the instance spec.
2711 
2712                   if Nkind (Context) = N_Package_Instantiation then
2713                      Context := Instance_Spec (Context);
2714                   end if;
2715 
2716                   if Nkind_In (Context, N_Generic_Package_Declaration,
2717                                         N_Package_Declaration)
2718                   then
2719                      Make_Aitem_Pragma
2720                        (Pragma_Argument_Associations => New_List (
2721                           Make_Pragma_Argument_Association (Loc,
2722                             Expression => Relocate_Node (Expr))),
2723                         Pragma_Name                  =>
2724                           Name_Initial_Condition);
2725 
2726                      Decorate (Aspect, Aitem);
2727                      Insert_Pragma
2728                        (Prag        => Aitem,
2729                         Is_Instance =>
2730                           Is_Generic_Instance (Defining_Entity (Context)));
2731 
2732                   --  Otherwise the context is illegal
2733 
2734                   else
2735                      Error_Msg_NE
2736                        ("aspect & must apply to a package declaration",
2737                         Aspect, Id);
2738                   end if;
2739 
2740                   goto Continue;
2741                end Initial_Condition;
2742 
2743                --  Initializes
2744 
2745                --  Aspect Initializes is never delayed because it is equivalent
2746                --  to a source pragma appearing after the related package. To
2747                --  deal with forward references, the generated pragma is stored
2748                --  in the contract of the related package and later analyzed at
2749                --  the end of the declarative region. For details, see routine
2750                --  Analyze_Initializes_In_Decl_Part.
2751 
2752                when Aspect_Initializes => Initializes : declare
2753                   Context : Node_Id := N;
2754 
2755                begin
2756                   --  When aspect Initializes appears on a generic package,
2757                   --  it is propageted to the package instance. The context
2758                   --  in this case is the instance spec.
2759 
2760                   if Nkind (Context) = N_Package_Instantiation then
2761                      Context := Instance_Spec (Context);
2762                   end if;
2763 
2764                   if Nkind_In (Context, N_Generic_Package_Declaration,
2765                                         N_Package_Declaration)
2766                   then
2767                      Make_Aitem_Pragma
2768                        (Pragma_Argument_Associations => New_List (
2769                           Make_Pragma_Argument_Association (Loc,
2770                             Expression => Relocate_Node (Expr))),
2771                         Pragma_Name                  => Name_Initializes);
2772 
2773                      Decorate (Aspect, Aitem);
2774                      Insert_Pragma
2775                        (Prag        => Aitem,
2776                         Is_Instance =>
2777                           Is_Generic_Instance (Defining_Entity (Context)));
2778 
2779                   --  Otherwise the context is illegal
2780 
2781                   else
2782                      Error_Msg_NE
2783                        ("aspect & must apply to a package declaration",
2784                         Aspect, Id);
2785                   end if;
2786 
2787                   goto Continue;
2788                end Initializes;
2789 
2790                --  Obsolescent
2791 
2792                when Aspect_Obsolescent => declare
2793                   Args : List_Id;
2794 
2795                begin
2796                   if No (Expr) then
2797                      Args := No_List;
2798                   else
2799                      Args := New_List (
2800                        Make_Pragma_Argument_Association (Sloc (Expr),
2801                          Expression => Relocate_Node (Expr)));
2802                   end if;
2803 
2804                   Make_Aitem_Pragma
2805                     (Pragma_Argument_Associations => Args,
2806                      Pragma_Name                  => Chars (Id));
2807                end;
2808 
2809                --  Part_Of
2810 
2811                when Aspect_Part_Of =>
2812                   if Nkind_In (N, N_Object_Declaration,
2813                                   N_Package_Instantiation)
2814                     or else Is_Single_Concurrent_Type_Declaration (N)
2815                   then
2816                      Make_Aitem_Pragma
2817                        (Pragma_Argument_Associations => New_List (
2818                           Make_Pragma_Argument_Association (Loc,
2819                             Expression => Relocate_Node (Expr))),
2820                         Pragma_Name                  => Name_Part_Of);
2821 
2822                      Decorate (Aspect, Aitem);
2823                      Insert_Pragma (Aitem);
2824 
2825                   else
2826                      Error_Msg_NE
2827                        ("aspect & must apply to package instantiation, "
2828                         & "object, single protected type or single task type",
2829                         Aspect, Id);
2830                   end if;
2831 
2832                   goto Continue;
2833 
2834                --  SPARK_Mode
2835 
2836                when Aspect_SPARK_Mode =>
2837                   Make_Aitem_Pragma
2838                     (Pragma_Argument_Associations => New_List (
2839                        Make_Pragma_Argument_Association (Loc,
2840                          Expression => Relocate_Node (Expr))),
2841                      Pragma_Name                  => Name_SPARK_Mode);
2842 
2843                   Decorate (Aspect, Aitem);
2844                   Insert_Pragma (Aitem);
2845                   goto Continue;
2846 
2847                --  Refined_Depends
2848 
2849                --  Aspect Refined_Depends is never delayed because it is
2850                --  equivalent to a source pragma which appears in the
2851                --  declarations of the related subprogram body. To deal with
2852                --  forward references, the generated pragma is stored in the
2853                --  contract of the related subprogram body and later analyzed
2854                --  at the end of the declarative region. For details, see
2855                --  routine Analyze_Refined_Depends_In_Decl_Part.
2856 
2857                when Aspect_Refined_Depends =>
2858                   Make_Aitem_Pragma
2859                     (Pragma_Argument_Associations => New_List (
2860                        Make_Pragma_Argument_Association (Loc,
2861                          Expression => Relocate_Node (Expr))),
2862                      Pragma_Name                  => Name_Refined_Depends);
2863 
2864                   Decorate (Aspect, Aitem);
2865                   Insert_Pragma (Aitem);
2866                   goto Continue;
2867 
2868                --  Refined_Global
2869 
2870                --  Aspect Refined_Global is never delayed because it is
2871                --  equivalent to a source pragma which appears in the
2872                --  declarations of the related subprogram body. To deal with
2873                --  forward references, the generated pragma is stored in the
2874                --  contract of the related subprogram body and later analyzed
2875                --  at the end of the declarative region. For details, see
2876                --  routine Analyze_Refined_Global_In_Decl_Part.
2877 
2878                when Aspect_Refined_Global =>
2879                   Make_Aitem_Pragma
2880                     (Pragma_Argument_Associations => New_List (
2881                        Make_Pragma_Argument_Association (Loc,
2882                          Expression => Relocate_Node (Expr))),
2883                      Pragma_Name                  => Name_Refined_Global);
2884 
2885                   Decorate (Aspect, Aitem);
2886                   Insert_Pragma (Aitem);
2887                   goto Continue;
2888 
2889                --  Refined_Post
2890 
2891                when Aspect_Refined_Post =>
2892                   Make_Aitem_Pragma
2893                     (Pragma_Argument_Associations => New_List (
2894                        Make_Pragma_Argument_Association (Loc,
2895                          Expression => Relocate_Node (Expr))),
2896                      Pragma_Name                  => Name_Refined_Post);
2897 
2898                   Decorate (Aspect, Aitem);
2899                   Insert_Pragma (Aitem);
2900                   goto Continue;
2901 
2902                --  Refined_State
2903 
2904                when Aspect_Refined_State =>
2905 
2906                   --  The corresponding pragma for Refined_State is inserted in
2907                   --  the declarations of the related package body. This action
2908                   --  synchronizes both the source and from-aspect versions of
2909                   --  the pragma.
2910 
2911                   if Nkind (N) = N_Package_Body then
2912                      Make_Aitem_Pragma
2913                        (Pragma_Argument_Associations => New_List (
2914                           Make_Pragma_Argument_Association (Loc,
2915                             Expression => Relocate_Node (Expr))),
2916                         Pragma_Name                  => Name_Refined_State);
2917 
2918                      Decorate (Aspect, Aitem);
2919                      Insert_Pragma (Aitem);
2920 
2921                   --  Otherwise the context is illegal
2922 
2923                   else
2924                      Error_Msg_NE
2925                        ("aspect & must apply to a package body", Aspect, Id);
2926                   end if;
2927 
2928                   goto Continue;
2929 
2930                --  Relative_Deadline
2931 
2932                when Aspect_Relative_Deadline =>
2933                   Make_Aitem_Pragma
2934                     (Pragma_Argument_Associations => New_List (
2935                        Make_Pragma_Argument_Association (Loc,
2936                          Expression => Relocate_Node (Expr))),
2937                       Pragma_Name                 => Name_Relative_Deadline);
2938 
2939                   --  If the aspect applies to a task, the corresponding pragma
2940                   --  must appear within its declarations, not after.
2941 
2942                   if Nkind (N) = N_Task_Type_Declaration then
2943                      declare
2944                         Def : Node_Id;
2945                         V   : List_Id;
2946 
2947                      begin
2948                         if No (Task_Definition (N)) then
2949                            Set_Task_Definition (N,
2950                              Make_Task_Definition (Loc,
2951                                 Visible_Declarations => New_List,
2952                                 End_Label => Empty));
2953                         end if;
2954 
2955                         Def := Task_Definition (N);
2956                         V  := Visible_Declarations (Def);
2957                         if not Is_Empty_List (V) then
2958                            Insert_Before (First (V), Aitem);
2959 
2960                         else
2961                            Set_Visible_Declarations (Def, New_List (Aitem));
2962                         end if;
2963 
2964                         goto Continue;
2965                      end;
2966                   end if;
2967 
2968                --  Aspect Volatile_Function is never delayed because it is
2969                --  equivalent to a source pragma which appears after the
2970                --  related subprogram.
2971 
2972                when Aspect_Volatile_Function =>
2973                   Make_Aitem_Pragma
2974                     (Pragma_Argument_Associations => New_List (
2975                        Make_Pragma_Argument_Association (Loc,
2976                          Expression => Relocate_Node (Expr))),
2977                      Pragma_Name                  => Name_Volatile_Function);
2978 
2979                   Decorate (Aspect, Aitem);
2980                   Insert_Pragma (Aitem);
2981                   goto Continue;
2982 
2983                --  Case 2e: Annotate aspect
2984 
2985                when Aspect_Annotate =>
2986                   declare
2987                      Args  : List_Id;
2988                      Pargs : List_Id;
2989                      Arg   : Node_Id;
2990 
2991                   begin
2992                      --  The argument can be a single identifier
2993 
2994                      if Nkind (Expr) = N_Identifier then
2995 
2996                         --  One level of parens is allowed
2997 
2998                         if Paren_Count (Expr) > 1 then
2999                            Error_Msg_F ("extra parentheses ignored", Expr);
3000                         end if;
3001 
3002                         Set_Paren_Count (Expr, 0);
3003 
3004                         --  Add the single item to the list
3005 
3006                         Args := New_List (Expr);
3007 
3008                      --  Otherwise we must have an aggregate
3009 
3010                      elsif Nkind (Expr) = N_Aggregate then
3011 
3012                         --  Must be positional
3013 
3014                         if Present (Component_Associations (Expr)) then
3015                            Error_Msg_F
3016                              ("purely positional aggregate required", Expr);
3017                            goto Continue;
3018                         end if;
3019 
3020                         --  Must not be parenthesized
3021 
3022                         if Paren_Count (Expr) /= 0 then
3023                            Error_Msg_F ("extra parentheses ignored", Expr);
3024                         end if;
3025 
3026                         --  List of arguments is list of aggregate expressions
3027 
3028                         Args := Expressions (Expr);
3029 
3030                      --  Anything else is illegal
3031 
3032                      else
3033                         Error_Msg_F ("wrong form for Annotate aspect", Expr);
3034                         goto Continue;
3035                      end if;
3036 
3037                      --  Prepare pragma arguments
3038 
3039                      Pargs := New_List;
3040                      Arg := First (Args);
3041                      while Present (Arg) loop
3042                         Append_To (Pargs,
3043                           Make_Pragma_Argument_Association (Sloc (Arg),
3044                             Expression => Relocate_Node (Arg)));
3045                         Next (Arg);
3046                      end loop;
3047 
3048                      Append_To (Pargs,
3049                        Make_Pragma_Argument_Association (Sloc (Ent),
3050                          Chars      => Name_Entity,
3051                          Expression => Ent));
3052 
3053                      Make_Aitem_Pragma
3054                        (Pragma_Argument_Associations => Pargs,
3055                         Pragma_Name                  => Name_Annotate);
3056                   end;
3057 
3058                --  Case 3 : Aspects that don't correspond to pragma/attribute
3059                --  definition clause.
3060 
3061                --  Case 3a: The aspects listed below don't correspond to
3062                --  pragmas/attributes but do require delayed analysis.
3063 
3064                --  Default_Value can only apply to a scalar type
3065 
3066                when Aspect_Default_Value =>
3067                   if not Is_Scalar_Type (E) then
3068                      Error_Msg_N
3069                        ("aspect Default_Value must apply to a scalar type", N);
3070                   end if;
3071 
3072                   Aitem := Empty;
3073 
3074                --  Default_Component_Value can only apply to an array type
3075                --  with scalar components.
3076 
3077                when Aspect_Default_Component_Value =>
3078                   if not (Is_Array_Type (E)
3079                            and then Is_Scalar_Type (Component_Type (E)))
3080                   then
3081                      Error_Msg_N
3082                        ("aspect Default_Component_Value can only apply to an "
3083                         & "array of scalar components", N);
3084                   end if;
3085 
3086                   Aitem := Empty;
3087 
3088                --  Case 3b: The aspects listed below don't correspond to
3089                --  pragmas/attributes and don't need delayed analysis.
3090 
3091                --  Implicit_Dereference
3092 
3093                --  For Implicit_Dereference, External_Name and Link_Name, only
3094                --  the legality checks are done during the analysis, thus no
3095                --  delay is required.
3096 
3097                when Aspect_Implicit_Dereference =>
3098                   Analyze_Aspect_Implicit_Dereference;
3099                   goto Continue;
3100 
3101                --  Dimension
3102 
3103                when Aspect_Dimension =>
3104                   Analyze_Aspect_Dimension (N, Id, Expr);
3105                   goto Continue;
3106 
3107                --  Dimension_System
3108 
3109                when Aspect_Dimension_System =>
3110                   Analyze_Aspect_Dimension_System (N, Id, Expr);
3111                   goto Continue;
3112 
3113                --  Case 4: Aspects requiring special handling
3114 
3115                --  Pre/Post/Test_Case/Contract_Cases whose corresponding
3116                --  pragmas take care of the delay.
3117 
3118                --  Pre/Post
3119 
3120                --  Aspects Pre/Post generate Precondition/Postcondition pragmas
3121                --  with a first argument that is the expression, and a second
3122                --  argument that is an informative message if the test fails.
3123                --  This is inserted right after the declaration, to get the
3124                --  required pragma placement. The processing for the pragmas
3125                --  takes care of the required delay.
3126 
3127                when Pre_Post_Aspects => Pre_Post : declare
3128                   Pname : Name_Id;
3129 
3130                begin
3131                   if A_Id = Aspect_Pre or else A_Id = Aspect_Precondition then
3132                      Pname := Name_Precondition;
3133                   else
3134                      Pname := Name_Postcondition;
3135                   end if;
3136 
3137                   --  Check that the class-wide predicate cannot be applied to
3138                   --  an operation of a synchronized type that is not a tagged
3139                   --  type. Other legality checks are performed when analyzing
3140                   --  the contract of the operation.
3141 
3142                   if Class_Present (Aspect)
3143                     and then Is_Concurrent_Type (Current_Scope)
3144                     and then not Is_Tagged_Type (Current_Scope)
3145                     and then Ekind_In (E, E_Entry, E_Function, E_Procedure)
3146                   then
3147                      Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Aspect);
3148                      Error_Msg_N
3149                        ("aspect % can only be specified for a primitive "
3150                         & "operation of a tagged type", Aspect);
3151 
3152                      goto Continue;
3153                   end if;
3154 
3155                   --  If the expressions is of the form A and then B, then
3156                   --  we generate separate Pre/Post aspects for the separate
3157                   --  clauses. Since we allow multiple pragmas, there is no
3158                   --  problem in allowing multiple Pre/Post aspects internally.
3159                   --  These should be treated in reverse order (B first and
3160                   --  A second) since they are later inserted just after N in
3161                   --  the order they are treated. This way, the pragma for A
3162                   --  ends up preceding the pragma for B, which may have an
3163                   --  importance for the error raised (either constraint error
3164                   --  or precondition error).
3165 
3166                   --  We do not do this for Pre'Class, since we have to put
3167                   --  these conditions together in a complex OR expression.
3168 
3169                   --  We do not do this in ASIS mode, as ASIS relies on the
3170                   --  original node representing the complete expression, when
3171                   --  retrieving it through the source aspect table.
3172 
3173                   if not ASIS_Mode
3174                     and then (Pname = Name_Postcondition
3175                                or else not Class_Present (Aspect))
3176                   then
3177                      while Nkind (Expr) = N_And_Then loop
3178                         Insert_After (Aspect,
3179                           Make_Aspect_Specification (Sloc (Left_Opnd (Expr)),
3180                             Identifier    => Identifier (Aspect),
3181                             Expression    => Relocate_Node (Left_Opnd (Expr)),
3182                             Class_Present => Class_Present (Aspect),
3183                             Split_PPC     => True));
3184                         Rewrite (Expr, Relocate_Node (Right_Opnd (Expr)));
3185                         Eloc := Sloc (Expr);
3186                      end loop;
3187                   end if;
3188 
3189                   --  Build the precondition/postcondition pragma
3190 
3191                   --  Add note about why we do NOT need Copy_Tree here???
3192 
3193                   Make_Aitem_Pragma
3194                     (Pragma_Argument_Associations => New_List (
3195                        Make_Pragma_Argument_Association (Eloc,
3196                          Chars      => Name_Check,
3197                          Expression => Relocate_Node (Expr))),
3198                        Pragma_Name                => Pname);
3199 
3200                   --  Add message unless exception messages are suppressed
3201 
3202                   if not Opt.Exception_Locations_Suppressed then
3203                      Append_To (Pragma_Argument_Associations (Aitem),
3204                        Make_Pragma_Argument_Association (Eloc,
3205                          Chars      => Name_Message,
3206                          Expression =>
3207                            Make_String_Literal (Eloc,
3208                              Strval => "failed "
3209                                        & Get_Name_String (Pname)
3210                                        & " from "
3211                                        & Build_Location_String (Eloc))));
3212                   end if;
3213 
3214                   Set_Is_Delayed_Aspect (Aspect);
3215 
3216                   --  For Pre/Post cases, insert immediately after the entity
3217                   --  declaration, since that is the required pragma placement.
3218                   --  Note that for these aspects, we do not have to worry
3219                   --  about delay issues, since the pragmas themselves deal
3220                   --  with delay of visibility for the expression analysis.
3221 
3222                   Insert_Pragma (Aitem);
3223 
3224                   goto Continue;
3225                end Pre_Post;
3226 
3227                --  Test_Case
3228 
3229                when Aspect_Test_Case => Test_Case : declare
3230                   Args      : List_Id;
3231                   Comp_Expr : Node_Id;
3232                   Comp_Assn : Node_Id;
3233                   New_Expr  : Node_Id;
3234 
3235                begin
3236                   Args := New_List;
3237 
3238                   if Nkind (Parent (N)) = N_Compilation_Unit then
3239                      Error_Msg_Name_1 := Nam;
3240                      Error_Msg_N ("incorrect placement of aspect `%`", E);
3241                      goto Continue;
3242                   end if;
3243 
3244                   if Nkind (Expr) /= N_Aggregate then
3245                      Error_Msg_Name_1 := Nam;
3246                      Error_Msg_NE
3247                        ("wrong syntax for aspect `%` for &", Id, E);
3248                      goto Continue;
3249                   end if;
3250 
3251                   --  Make pragma expressions refer to the original aspect
3252                   --  expressions through the Original_Node link. This is used
3253                   --  in semantic analysis for ASIS mode, so that the original
3254                   --  expression also gets analyzed.
3255 
3256                   Comp_Expr := First (Expressions (Expr));
3257                   while Present (Comp_Expr) loop
3258                      New_Expr := Relocate_Node (Comp_Expr);
3259                      Append_To (Args,
3260                        Make_Pragma_Argument_Association (Sloc (Comp_Expr),
3261                          Expression => New_Expr));
3262                      Next (Comp_Expr);
3263                   end loop;
3264 
3265                   Comp_Assn := First (Component_Associations (Expr));
3266                   while Present (Comp_Assn) loop
3267                      if List_Length (Choices (Comp_Assn)) /= 1
3268                        or else
3269                          Nkind (First (Choices (Comp_Assn))) /= N_Identifier
3270                      then
3271                         Error_Msg_Name_1 := Nam;
3272                         Error_Msg_NE
3273                           ("wrong syntax for aspect `%` for &", Id, E);
3274                         goto Continue;
3275                      end if;
3276 
3277                      Append_To (Args,
3278                        Make_Pragma_Argument_Association (Sloc (Comp_Assn),
3279                          Chars      => Chars (First (Choices (Comp_Assn))),
3280                          Expression =>
3281                            Relocate_Node (Expression (Comp_Assn))));
3282                      Next (Comp_Assn);
3283                   end loop;
3284 
3285                   --  Build the test-case pragma
3286 
3287                   Make_Aitem_Pragma
3288                     (Pragma_Argument_Associations => Args,
3289                      Pragma_Name                  => Nam);
3290                end Test_Case;
3291 
3292                --  Contract_Cases
3293 
3294                when Aspect_Contract_Cases =>
3295                   Make_Aitem_Pragma
3296                     (Pragma_Argument_Associations => New_List (
3297                        Make_Pragma_Argument_Association (Loc,
3298                          Expression => Relocate_Node (Expr))),
3299                      Pragma_Name                  => Nam);
3300 
3301                   Decorate (Aspect, Aitem);
3302                   Insert_Pragma (Aitem);
3303                   goto Continue;
3304 
3305                --  Case 5: Special handling for aspects with an optional
3306                --  boolean argument.
3307 
3308                --  In the delayed case, the corresponding pragma cannot be
3309                --  generated yet because the evaluation of the boolean needs
3310                --  to be delayed till the freeze point.
3311 
3312                when Boolean_Aspects      |
3313                     Library_Unit_Aspects =>
3314 
3315                   Set_Is_Boolean_Aspect (Aspect);
3316 
3317                   --  Lock_Free aspect only apply to protected objects
3318 
3319                   if A_Id = Aspect_Lock_Free then
3320                      if Ekind (E) /= E_Protected_Type then
3321                         Error_Msg_Name_1 := Nam;
3322                         Error_Msg_N
3323                           ("aspect % only applies to a protected object",
3324                            Aspect);
3325 
3326                      else
3327                         --  Set the Uses_Lock_Free flag to True if there is no
3328                         --  expression or if the expression is True. The
3329                         --  evaluation of this aspect should be delayed to the
3330                         --  freeze point (why???)
3331 
3332                         if No (Expr)
3333                           or else Is_True (Static_Boolean (Expr))
3334                         then
3335                            Set_Uses_Lock_Free (E);
3336                         end if;
3337 
3338                         Record_Rep_Item (E, Aspect);
3339                      end if;
3340 
3341                      goto Continue;
3342 
3343                   elsif A_Id = Aspect_Export or else A_Id = Aspect_Import then
3344                      Analyze_Aspect_Export_Import;
3345 
3346                   --  Disable_Controlled
3347 
3348                   elsif A_Id = Aspect_Disable_Controlled then
3349                      if Ekind (E) /= E_Record_Type
3350                        or else not Is_Controlled (E)
3351                      then
3352                         Error_Msg_N
3353                           ("aspect % requires controlled record type", Aspect);
3354                         goto Continue;
3355                      end if;
3356 
3357                      --  If we're in a generic template, we don't want to try
3358                      --  to disable controlled types, because typical usage is
3359                      --  "Disable_Controlled => not <some_check>'Enabled", and
3360                      --  the value of Enabled is not known until we see a
3361                      --  particular instance. In such a context, we just need
3362                      --  to preanalyze the expression for legality.
3363 
3364                      if Expander_Active then
3365                         Analyze_And_Resolve (Expr, Standard_Boolean);
3366 
3367                         if not Present (Expr)
3368                           or else Is_True (Static_Boolean (Expr))
3369                         then
3370                            Set_Disable_Controlled (E);
3371                         end if;
3372 
3373                      elsif Serious_Errors_Detected = 0 then
3374                         Preanalyze_And_Resolve (Expr, Standard_Boolean);
3375                      end if;
3376 
3377                      goto Continue;
3378                   end if;
3379 
3380                   --  Library unit aspects require special handling in the case
3381                   --  of a package declaration, the pragma needs to be inserted
3382                   --  in the list of declarations for the associated package.
3383                   --  There is no issue of visibility delay for these aspects.
3384 
3385                   if A_Id in Library_Unit_Aspects
3386                     and then
3387                       Nkind_In (N, N_Package_Declaration,
3388                                    N_Generic_Package_Declaration)
3389                     and then Nkind (Parent (N)) /= N_Compilation_Unit
3390 
3391                     --  Aspect is legal on a local instantiation of a library-
3392                     --  level generic unit.
3393 
3394                     and then not Is_Generic_Instance (Defining_Entity (N))
3395                   then
3396                      Error_Msg_N
3397                        ("incorrect context for library unit aspect&", Id);
3398                      goto Continue;
3399                   end if;
3400 
3401                   --  Cases where we do not delay, includes all cases where the
3402                   --  expression is missing other than the above cases.
3403 
3404                   if not Delay_Required or else No (Expr) then
3405 
3406                      --  Exclude aspects Export and Import because their pragma
3407                      --  syntax does not map directly to a Boolean aspect.
3408 
3409                      if A_Id /= Aspect_Export
3410                        and then A_Id /= Aspect_Import
3411                      then
3412                         Make_Aitem_Pragma
3413                           (Pragma_Argument_Associations => New_List (
3414                              Make_Pragma_Argument_Association (Sloc (Ent),
3415                                Expression => Ent)),
3416                            Pragma_Name                  => Chars (Id));
3417                      end if;
3418 
3419                      Delay_Required := False;
3420 
3421                   --  In general cases, the corresponding pragma/attribute
3422                   --  definition clause will be inserted later at the freezing
3423                   --  point, and we do not need to build it now.
3424 
3425                   else
3426                      Aitem := Empty;
3427                   end if;
3428 
3429                --  Storage_Size
3430 
3431                --  This is special because for access types we need to generate
3432                --  an attribute definition clause. This also works for single
3433                --  task declarations, but it does not work for task type
3434                --  declarations, because we have the case where the expression
3435                --  references a discriminant of the task type. That can't use
3436                --  an attribute definition clause because we would not have
3437                --  visibility on the discriminant. For that case we must
3438                --  generate a pragma in the task definition.
3439 
3440                when Aspect_Storage_Size =>
3441 
3442                   --  Task type case
3443 
3444                   if Ekind (E) = E_Task_Type then
3445                      declare
3446                         Decl : constant Node_Id := Declaration_Node (E);
3447 
3448                      begin
3449                         pragma Assert (Nkind (Decl) = N_Task_Type_Declaration);
3450 
3451                         --  If no task definition, create one
3452 
3453                         if No (Task_Definition (Decl)) then
3454                            Set_Task_Definition (Decl,
3455                              Make_Task_Definition (Loc,
3456                                Visible_Declarations => Empty_List,
3457                                End_Label            => Empty));
3458                         end if;
3459 
3460                         --  Create a pragma and put it at the start of the task
3461                         --  definition for the task type declaration.
3462 
3463                         Make_Aitem_Pragma
3464                           (Pragma_Argument_Associations => New_List (
3465                              Make_Pragma_Argument_Association (Loc,
3466                                Expression => Relocate_Node (Expr))),
3467                            Pragma_Name                  => Name_Storage_Size);
3468 
3469                         Prepend
3470                           (Aitem,
3471                            Visible_Declarations (Task_Definition (Decl)));
3472                         goto Continue;
3473                      end;
3474 
3475                   --  All other cases, generate attribute definition
3476 
3477                   else
3478                      Aitem :=
3479                        Make_Attribute_Definition_Clause (Loc,
3480                          Name       => Ent,
3481                          Chars      => Chars (Id),
3482                          Expression => Relocate_Node (Expr));
3483                   end if;
3484             end case;
3485 
3486             --  Attach the corresponding pragma/attribute definition clause to
3487             --  the aspect specification node.
3488 
3489             if Present (Aitem) then
3490                Set_From_Aspect_Specification (Aitem);
3491             end if;
3492 
3493             --  In the context of a compilation unit, we directly put the
3494             --  pragma in the Pragmas_After list of the N_Compilation_Unit_Aux
3495             --  node (no delay is required here) except for aspects on a
3496             --  subprogram body (see below) and a generic package, for which we
3497             --  need to introduce the pragma before building the generic copy
3498             --  (see sem_ch12), and for package instantiations, where the
3499             --  library unit pragmas are better handled early.
3500 
3501             if Nkind (Parent (N)) = N_Compilation_Unit
3502               and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect))
3503             then
3504                declare
3505                   Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
3506 
3507                begin
3508                   pragma Assert (Nkind (Aux) = N_Compilation_Unit_Aux);
3509 
3510                   --  For a Boolean aspect, create the corresponding pragma if
3511                   --  no expression or if the value is True.
3512 
3513                   if Is_Boolean_Aspect (Aspect) and then No (Aitem) then
3514                      if Is_True (Static_Boolean (Expr)) then
3515                         Make_Aitem_Pragma
3516                           (Pragma_Argument_Associations => New_List (
3517                              Make_Pragma_Argument_Association (Sloc (Ent),
3518                                Expression => Ent)),
3519                            Pragma_Name                  => Chars (Id));
3520 
3521                         Set_From_Aspect_Specification (Aitem, True);
3522                         Set_Corresponding_Aspect (Aitem, Aspect);
3523 
3524                      else
3525                         goto Continue;
3526                      end if;
3527                   end if;
3528 
3529                   --  If the aspect is on a subprogram body (relevant aspect
3530                   --  is Inline), add the pragma in front of the declarations.
3531 
3532                   if Nkind (N) = N_Subprogram_Body then
3533                      if No (Declarations (N)) then
3534                         Set_Declarations (N, New_List);
3535                      end if;
3536 
3537                      Prepend (Aitem, Declarations (N));
3538 
3539                   elsif Nkind (N) = N_Generic_Package_Declaration then
3540                      if No (Visible_Declarations (Specification (N))) then
3541                         Set_Visible_Declarations (Specification (N), New_List);
3542                      end if;
3543 
3544                      Prepend (Aitem,
3545                        Visible_Declarations (Specification (N)));
3546 
3547                   elsif Nkind (N) = N_Package_Instantiation then
3548                      declare
3549                         Spec : constant Node_Id :=
3550                                  Specification (Instance_Spec (N));
3551                      begin
3552                         if No (Visible_Declarations (Spec)) then
3553                            Set_Visible_Declarations (Spec, New_List);
3554                         end if;
3555 
3556                         Prepend (Aitem, Visible_Declarations (Spec));
3557                      end;
3558 
3559                   else
3560                      if No (Pragmas_After (Aux)) then
3561                         Set_Pragmas_After (Aux, New_List);
3562                      end if;
3563 
3564                      Append (Aitem, Pragmas_After (Aux));
3565                   end if;
3566 
3567                   goto Continue;
3568                end;
3569             end if;
3570 
3571             --  The evaluation of the aspect is delayed to the freezing point.
3572             --  The pragma or attribute clause if there is one is then attached
3573             --  to the aspect specification which is put in the rep item list.
3574 
3575             if Delay_Required then
3576                if Present (Aitem) then
3577                   Set_Is_Delayed_Aspect (Aitem);
3578                   Set_Aspect_Rep_Item (Aspect, Aitem);
3579                   Set_Parent (Aitem, Aspect);
3580                end if;
3581 
3582                Set_Is_Delayed_Aspect (Aspect);
3583 
3584                --  In the case of Default_Value, link the aspect to base type
3585                --  as well, even though it appears on a first subtype. This is
3586                --  mandated by the semantics of the aspect. Do not establish
3587                --  the link when processing the base type itself as this leads
3588                --  to a rep item circularity. Verify that we are dealing with
3589                --  a scalar type to prevent cascaded errors.
3590 
3591                if A_Id = Aspect_Default_Value
3592                  and then Is_Scalar_Type (E)
3593                  and then Base_Type (E) /= E
3594                then
3595                   Set_Has_Delayed_Aspects (Base_Type (E));
3596                   Record_Rep_Item (Base_Type (E), Aspect);
3597                end if;
3598 
3599                Set_Has_Delayed_Aspects (E);
3600                Record_Rep_Item (E, Aspect);
3601 
3602             --  When delay is not required and the context is a package or a
3603             --  subprogram body, insert the pragma in the body declarations.
3604 
3605             elsif Nkind_In (N, N_Package_Body, N_Subprogram_Body) then
3606                if No (Declarations (N)) then
3607                   Set_Declarations (N, New_List);
3608                end if;
3609 
3610                --  The pragma is added before source declarations
3611 
3612                Prepend_To (Declarations (N), Aitem);
3613 
3614             --  When delay is not required and the context is not a compilation
3615             --  unit, we simply insert the pragma/attribute definition clause
3616             --  in sequence.
3617 
3618             elsif Present (Aitem) then
3619                Insert_After (Ins_Node, Aitem);
3620                Ins_Node := Aitem;
3621             end if;
3622          end Analyze_One_Aspect;
3623 
3624       <<Continue>>
3625          Next (Aspect);
3626       end loop Aspect_Loop;
3627 
3628       if Has_Delayed_Aspects (E) then
3629          Ensure_Freeze_Node (E);
3630       end if;
3631    end Analyze_Aspect_Specifications;
3632 
3633    ---------------------------------------------------
3634    -- Analyze_Aspect_Specifications_On_Body_Or_Stub --
3635    ---------------------------------------------------
3636 
3637    procedure Analyze_Aspect_Specifications_On_Body_Or_Stub (N : Node_Id) is
3638       Body_Id : constant Entity_Id := Defining_Entity (N);
3639 
3640       procedure Diagnose_Misplaced_Aspects (Spec_Id : Entity_Id);
3641       --  Body [stub] N has aspects, but they are not properly placed. Emit an
3642       --  error message depending on the aspects involved. Spec_Id denotes the
3643       --  entity of the corresponding spec.
3644 
3645       --------------------------------
3646       -- Diagnose_Misplaced_Aspects --
3647       --------------------------------
3648 
3649       procedure Diagnose_Misplaced_Aspects (Spec_Id : Entity_Id) is
3650          procedure Misplaced_Aspect_Error
3651            (Asp     : Node_Id;
3652             Ref_Nam : Name_Id);
3653          --  Emit an error message concerning misplaced aspect Asp. Ref_Nam is
3654          --  the name of the refined version of the aspect.
3655 
3656          ----------------------------
3657          -- Misplaced_Aspect_Error --
3658          ----------------------------
3659 
3660          procedure Misplaced_Aspect_Error
3661            (Asp     : Node_Id;
3662             Ref_Nam : Name_Id)
3663          is
3664             Asp_Nam : constant Name_Id   := Chars (Identifier (Asp));
3665             Asp_Id  : constant Aspect_Id := Get_Aspect_Id (Asp_Nam);
3666 
3667          begin
3668             --  The corresponding spec already contains the aspect in question
3669             --  and the one appearing on the body must be the refined form:
3670 
3671             --    procedure P with Global ...;
3672             --    procedure P with Global ... is ... end P;
3673             --                     ^
3674             --                     Refined_Global
3675 
3676             if Has_Aspect (Spec_Id, Asp_Id) then
3677                Error_Msg_Name_1 := Asp_Nam;
3678 
3679                --  Subunits cannot carry aspects that apply to a subprogram
3680                --  declaration.
3681 
3682                if Nkind (Parent (N)) = N_Subunit then
3683                   Error_Msg_N ("aspect % cannot apply to a subunit", Asp);
3684 
3685                --  Otherwise suggest the refined form
3686 
3687                else
3688                   Error_Msg_Name_2 := Ref_Nam;
3689                   Error_Msg_N ("aspect % should be %", Asp);
3690                end if;
3691 
3692             --  Otherwise the aspect must appear on the spec, not on the body
3693 
3694             --    procedure P;
3695             --    procedure P with Global ... is ... end P;
3696 
3697             else
3698                Error_Msg_N
3699                  ("aspect specification must appear on initial declaration",
3700                   Asp);
3701             end if;
3702          end Misplaced_Aspect_Error;
3703 
3704          --  Local variables
3705 
3706          Asp     : Node_Id;
3707          Asp_Nam : Name_Id;
3708 
3709       --  Start of processing for Diagnose_Misplaced_Aspects
3710 
3711       begin
3712          --  Iterate over the aspect specifications and emit specific errors
3713          --  where applicable.
3714 
3715          Asp := First (Aspect_Specifications (N));
3716          while Present (Asp) loop
3717             Asp_Nam := Chars (Identifier (Asp));
3718 
3719             --  Do not emit errors on aspects that can appear on a subprogram
3720             --  body. This scenario occurs when the aspect specification list
3721             --  contains both misplaced and properly placed aspects.
3722 
3723             if Aspect_On_Body_Or_Stub_OK (Get_Aspect_Id (Asp_Nam)) then
3724                null;
3725 
3726             --  Special diagnostics for SPARK aspects
3727 
3728             elsif Asp_Nam = Name_Depends then
3729                Misplaced_Aspect_Error (Asp, Name_Refined_Depends);
3730 
3731             elsif Asp_Nam = Name_Global then
3732                Misplaced_Aspect_Error (Asp, Name_Refined_Global);
3733 
3734             elsif Asp_Nam = Name_Post then
3735                Misplaced_Aspect_Error (Asp, Name_Refined_Post);
3736 
3737             --  Otherwise a language-defined aspect is misplaced
3738 
3739             else
3740                Error_Msg_N
3741                  ("aspect specification must appear on initial declaration",
3742                   Asp);
3743             end if;
3744 
3745             Next (Asp);
3746          end loop;
3747       end Diagnose_Misplaced_Aspects;
3748 
3749       --  Local variables
3750 
3751       Spec_Id : constant Entity_Id := Unique_Defining_Entity (N);
3752 
3753    --  Start of processing for Analyze_Aspects_On_Body_Or_Stub
3754 
3755    begin
3756       --  Language-defined aspects cannot be associated with a subprogram body
3757       --  [stub] if the subprogram has a spec. Certain implementation defined
3758       --  aspects are allowed to break this rule (for all applicable cases, see
3759       --  table Aspects.Aspect_On_Body_Or_Stub_OK).
3760 
3761       if Spec_Id /= Body_Id and then not Aspects_On_Body_Or_Stub_OK (N) then
3762          Diagnose_Misplaced_Aspects (Spec_Id);
3763       else
3764          Analyze_Aspect_Specifications (N, Body_Id);
3765       end if;
3766    end Analyze_Aspect_Specifications_On_Body_Or_Stub;
3767 
3768    -----------------------
3769    -- Analyze_At_Clause --
3770    -----------------------
3771 
3772    --  An at clause is replaced by the corresponding Address attribute
3773    --  definition clause that is the preferred approach in Ada 95.
3774 
3775    procedure Analyze_At_Clause (N : Node_Id) is
3776       CS : constant Boolean := Comes_From_Source (N);
3777 
3778    begin
3779       --  This is an obsolescent feature
3780 
3781       Check_Restriction (No_Obsolescent_Features, N);
3782 
3783       if Warn_On_Obsolescent_Feature then
3784          Error_Msg_N
3785            ("?j?at clause is an obsolescent feature (RM J.7(2))", N);
3786          Error_Msg_N
3787            ("\?j?use address attribute definition clause instead", N);
3788       end if;
3789 
3790       --  Rewrite as address clause
3791 
3792       Rewrite (N,
3793         Make_Attribute_Definition_Clause (Sloc (N),
3794           Name       => Identifier (N),
3795           Chars      => Name_Address,
3796           Expression => Expression (N)));
3797 
3798       --  We preserve Comes_From_Source, since logically the clause still comes
3799       --  from the source program even though it is changed in form.
3800 
3801       Set_Comes_From_Source (N, CS);
3802 
3803       --  Analyze rewritten clause
3804 
3805       Analyze_Attribute_Definition_Clause (N);
3806    end Analyze_At_Clause;
3807 
3808    -----------------------------------------
3809    -- Analyze_Attribute_Definition_Clause --
3810    -----------------------------------------
3811 
3812    procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is
3813       Loc   : constant Source_Ptr   := Sloc (N);
3814       Nam   : constant Node_Id      := Name (N);
3815       Attr  : constant Name_Id      := Chars (N);
3816       Expr  : constant Node_Id      := Expression (N);
3817       Id    : constant Attribute_Id := Get_Attribute_Id (Attr);
3818 
3819       Ent : Entity_Id;
3820       --  The entity of Nam after it is analyzed. In the case of an incomplete
3821       --  type, this is the underlying type.
3822 
3823       U_Ent : Entity_Id;
3824       --  The underlying entity to which the attribute applies. Generally this
3825       --  is the Underlying_Type of Ent, except in the case where the clause
3826       --  applies to full view of incomplete type or private type in which case
3827       --  U_Ent is just a copy of Ent.
3828 
3829       FOnly : Boolean := False;
3830       --  Reset to True for subtype specific attribute (Alignment, Size)
3831       --  and for stream attributes, i.e. those cases where in the call to
3832       --  Rep_Item_Too_Late, FOnly is set True so that only the freezing rules
3833       --  are checked. Note that the case of stream attributes is not clear
3834       --  from the RM, but see AI95-00137. Also, the RM seems to disallow
3835       --  Storage_Size for derived task types, but that is also clearly
3836       --  unintentional.
3837 
3838       procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type);
3839       --  Common processing for 'Read, 'Write, 'Input and 'Output attribute
3840       --  definition clauses.
3841 
3842       function Duplicate_Clause return Boolean;
3843       --  This routine checks if the aspect for U_Ent being given by attribute
3844       --  definition clause N is for an aspect that has already been specified,
3845       --  and if so gives an error message. If there is a duplicate, True is
3846       --  returned, otherwise if there is no error, False is returned.
3847 
3848       procedure Check_Indexing_Functions;
3849       --  Check that the function in Constant_Indexing or Variable_Indexing
3850       --  attribute has the proper type structure. If the name is overloaded,
3851       --  check that some interpretation is legal.
3852 
3853       procedure Check_Iterator_Functions;
3854       --  Check that there is a single function in Default_Iterator attribute
3855       --  has the proper type structure.
3856 
3857       function Check_Primitive_Function (Subp : Entity_Id) return Boolean;
3858       --  Common legality check for the previous two
3859 
3860       -----------------------------------
3861       -- Analyze_Stream_TSS_Definition --
3862       -----------------------------------
3863 
3864       procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is
3865          Subp : Entity_Id := Empty;
3866          I    : Interp_Index;
3867          It   : Interp;
3868          Pnam : Entity_Id;
3869 
3870          Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read);
3871          --  True for Read attribute, False for other attributes
3872 
3873          function Has_Good_Profile
3874            (Subp   : Entity_Id;
3875             Report : Boolean := False) return Boolean;
3876          --  Return true if the entity is a subprogram with an appropriate
3877          --  profile for the attribute being defined. If result is False and
3878          --  Report is True, function emits appropriate error.
3879 
3880          ----------------------
3881          -- Has_Good_Profile --
3882          ----------------------
3883 
3884          function Has_Good_Profile
3885            (Subp   : Entity_Id;
3886             Report : Boolean := False) return Boolean
3887          is
3888             Expected_Ekind : constant array (Boolean) of Entity_Kind :=
3889                                (False => E_Procedure, True => E_Function);
3890             Is_Function    : constant Boolean := (TSS_Nam = TSS_Stream_Input);
3891             F              : Entity_Id;
3892             Typ            : Entity_Id;
3893 
3894          begin
3895             if Ekind (Subp) /= Expected_Ekind (Is_Function) then
3896                return False;
3897             end if;
3898 
3899             F := First_Formal (Subp);
3900 
3901             if No (F)
3902               or else Ekind (Etype (F)) /= E_Anonymous_Access_Type
3903               or else Designated_Type (Etype (F)) /=
3904                         Class_Wide_Type (RTE (RE_Root_Stream_Type))
3905             then
3906                return False;
3907             end if;
3908 
3909             if not Is_Function then
3910                Next_Formal (F);
3911 
3912                declare
3913                   Expected_Mode : constant array (Boolean) of Entity_Kind :=
3914                                     (False => E_In_Parameter,
3915                                      True  => E_Out_Parameter);
3916                begin
3917                   if Parameter_Mode (F) /= Expected_Mode (Is_Read) then
3918                      return False;
3919                   end if;
3920                end;
3921 
3922                Typ := Etype (F);
3923 
3924                --  If the attribute specification comes from an aspect
3925                --  specification for a class-wide stream, the parameter must be
3926                --  a class-wide type of the entity to which the aspect applies.
3927 
3928                if From_Aspect_Specification (N)
3929                  and then Class_Present (Parent (N))
3930                  and then Is_Class_Wide_Type (Typ)
3931                then
3932                   Typ := Etype (Typ);
3933                end if;
3934 
3935             else
3936                Typ := Etype (Subp);
3937             end if;
3938 
3939             --  Verify that the prefix of the attribute and the local name for
3940             --  the type of the formal match, or one is the class-wide of the
3941             --  other, in the case of a class-wide stream operation.
3942 
3943             if Base_Type (Typ) = Base_Type (Ent)
3944               or else (Is_Class_Wide_Type (Typ)
3945                         and then Typ = Class_Wide_Type (Base_Type (Ent)))
3946               or else (Is_Class_Wide_Type (Ent)
3947                         and then Ent = Class_Wide_Type (Base_Type (Typ)))
3948             then
3949                null;
3950             else
3951                return False;
3952             end if;
3953 
3954             if Present (Next_Formal (F)) then
3955                return False;
3956 
3957             elsif not Is_Scalar_Type (Typ)
3958               and then not Is_First_Subtype (Typ)
3959               and then not Is_Class_Wide_Type (Typ)
3960             then
3961                if Report and not Is_First_Subtype (Typ) then
3962                   Error_Msg_N
3963                     ("subtype of formal in stream operation must be a first "
3964                      & "subtype", Parameter_Type (Parent (F)));
3965                end if;
3966 
3967                return False;
3968 
3969             else
3970                return True;
3971             end if;
3972          end Has_Good_Profile;
3973 
3974       --  Start of processing for Analyze_Stream_TSS_Definition
3975 
3976       begin
3977          FOnly := True;
3978 
3979          if not Is_Type (U_Ent) then
3980             Error_Msg_N ("local name must be a subtype", Nam);
3981             return;
3982 
3983          elsif not Is_First_Subtype (U_Ent) then
3984             Error_Msg_N ("local name must be a first subtype", Nam);
3985             return;
3986          end if;
3987 
3988          Pnam := TSS (Base_Type (U_Ent), TSS_Nam);
3989 
3990          --  If Pnam is present, it can be either inherited from an ancestor
3991          --  type (in which case it is legal to redefine it for this type), or
3992          --  be a previous definition of the attribute for the same type (in
3993          --  which case it is illegal).
3994 
3995          --  In the first case, it will have been analyzed already, and we
3996          --  can check that its profile does not match the expected profile
3997          --  for a stream attribute of U_Ent. In the second case, either Pnam
3998          --  has been analyzed (and has the expected profile), or it has not
3999          --  been analyzed yet (case of a type that has not been frozen yet
4000          --  and for which the stream attribute has been set using Set_TSS).
4001 
4002          if Present (Pnam)
4003            and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam))
4004          then
4005             Error_Msg_Sloc := Sloc (Pnam);
4006             Error_Msg_Name_1 := Attr;
4007             Error_Msg_N ("% attribute already defined #", Nam);
4008             return;
4009          end if;
4010 
4011          Analyze (Expr);
4012 
4013          if Is_Entity_Name (Expr) then
4014             if not Is_Overloaded (Expr) then
4015                if Has_Good_Profile (Entity (Expr), Report => True) then
4016                   Subp := Entity (Expr);
4017                end if;
4018 
4019             else
4020                Get_First_Interp (Expr, I, It);
4021                while Present (It.Nam) loop
4022                   if Has_Good_Profile (It.Nam) then
4023                      Subp := It.Nam;
4024                      exit;
4025                   end if;
4026 
4027                   Get_Next_Interp (I, It);
4028                end loop;
4029             end if;
4030          end if;
4031 
4032          if Present (Subp) then
4033             if Is_Abstract_Subprogram (Subp) then
4034                Error_Msg_N ("stream subprogram must not be abstract", Expr);
4035                return;
4036 
4037             --  A stream subprogram for an interface type must be a null
4038             --  procedure (RM 13.13.2 (38/3)). Note that the class-wide type
4039             --  of an interface is not an interface type (3.9.4 (6.b/2)).
4040 
4041             elsif Is_Interface (U_Ent)
4042               and then not Is_Class_Wide_Type (U_Ent)
4043               and then not Inside_A_Generic
4044               and then
4045                 (Ekind (Subp) = E_Function
4046                   or else
4047                     not Null_Present
4048                           (Specification
4049                              (Unit_Declaration_Node (Ultimate_Alias (Subp)))))
4050             then
4051                Error_Msg_N
4052                  ("stream subprogram for interface type must be null "
4053                   & "procedure", Expr);
4054             end if;
4055 
4056             Set_Entity (Expr, Subp);
4057             Set_Etype (Expr, Etype (Subp));
4058 
4059             New_Stream_Subprogram (N, U_Ent, Subp, TSS_Nam);
4060 
4061          else
4062             Error_Msg_Name_1 := Attr;
4063             Error_Msg_N ("incorrect expression for% attribute", Expr);
4064          end if;
4065       end Analyze_Stream_TSS_Definition;
4066 
4067       ------------------------------
4068       -- Check_Indexing_Functions --
4069       ------------------------------
4070 
4071       procedure Check_Indexing_Functions is
4072          Indexing_Found : Boolean := False;
4073 
4074          procedure Check_Inherited_Indexing;
4075          --  For a derived type, check that no indexing aspect is specified
4076          --  for the type if it is also inherited
4077 
4078          procedure Check_One_Function (Subp : Entity_Id);
4079          --  Check one possible interpretation. Sets Indexing_Found True if a
4080          --  legal indexing function is found.
4081 
4082          procedure Illegal_Indexing (Msg : String);
4083          --  Diagnose illegal indexing function if not overloaded. In the
4084          --  overloaded case indicate that no legal interpretation  exists.
4085 
4086          ------------------------------
4087          -- Check_Inherited_Indexing --
4088          ------------------------------
4089 
4090          procedure Check_Inherited_Indexing is
4091             Inherited : Node_Id;
4092 
4093          begin
4094             if Attr = Name_Constant_Indexing then
4095                Inherited :=
4096                  Find_Aspect (Etype (Ent), Aspect_Constant_Indexing);
4097             else pragma Assert (Attr = Name_Variable_Indexing);
4098                Inherited :=
4099                   Find_Aspect (Etype (Ent), Aspect_Variable_Indexing);
4100             end if;
4101 
4102             if Present (Inherited) then
4103                if Debug_Flag_Dot_XX then
4104                   null;
4105 
4106                --  OK if current attribute_definition_clause is expansion of
4107                --  inherited aspect.
4108 
4109                elsif Aspect_Rep_Item (Inherited) = N then
4110                   null;
4111 
4112                --  Indicate the operation that must be overridden, rather than
4113                --  redefining the indexing aspect.
4114 
4115                else
4116                   Illegal_Indexing
4117                     ("indexing function already inherited from parent type");
4118                   Error_Msg_NE
4119                     ("!override & instead",
4120                      N, Entity (Expression (Inherited)));
4121                end if;
4122             end if;
4123          end Check_Inherited_Indexing;
4124 
4125          ------------------------
4126          -- Check_One_Function --
4127          ------------------------
4128 
4129          procedure Check_One_Function (Subp : Entity_Id) is
4130             Default_Element : Node_Id;
4131             Ret_Type        : constant Entity_Id := Etype (Subp);
4132 
4133          begin
4134             if not Is_Overloadable (Subp) then
4135                Illegal_Indexing ("illegal indexing function for type&");
4136                return;
4137 
4138             elsif Scope (Subp) /= Scope (Ent) then
4139                if Nkind (Expr) = N_Expanded_Name then
4140 
4141                   --  Indexing function can't be declared elsewhere
4142 
4143                   Illegal_Indexing
4144                     ("indexing function must be declared in scope of type&");
4145                end if;
4146 
4147                return;
4148 
4149             elsif No (First_Formal (Subp)) then
4150                Illegal_Indexing
4151                  ("Indexing requires a function that applies to type&");
4152                return;
4153 
4154             elsif No (Next_Formal (First_Formal (Subp))) then
4155                Illegal_Indexing
4156                  ("indexing function must have at least two parameters");
4157                return;
4158 
4159             elsif Is_Derived_Type (Ent) then
4160                Check_Inherited_Indexing;
4161             end if;
4162 
4163             if not Check_Primitive_Function (Subp) then
4164                Illegal_Indexing
4165                  ("Indexing aspect requires a function that applies to type&");
4166                return;
4167             end if;
4168 
4169             --  If partial declaration exists, verify that it is not tagged.
4170 
4171             if Ekind (Current_Scope) = E_Package
4172               and then Has_Private_Declaration (Ent)
4173               and then From_Aspect_Specification (N)
4174               and then
4175                 List_Containing (Parent (Ent)) =
4176                   Private_Declarations
4177                     (Specification (Unit_Declaration_Node (Current_Scope)))
4178               and then Nkind (N) = N_Attribute_Definition_Clause
4179             then
4180                declare
4181                   Decl : Node_Id;
4182 
4183                begin
4184                   Decl :=
4185                      First (Visible_Declarations
4186                               (Specification
4187                                  (Unit_Declaration_Node (Current_Scope))));
4188 
4189                   while Present (Decl) loop
4190                      if Nkind (Decl) = N_Private_Type_Declaration
4191                        and then Ent = Full_View (Defining_Identifier (Decl))
4192                        and then Tagged_Present (Decl)
4193                        and then No (Aspect_Specifications (Decl))
4194                      then
4195                         Illegal_Indexing
4196                           ("Indexing aspect cannot be specified on full view "
4197                            & "if partial view is tagged");
4198                         return;
4199                      end if;
4200 
4201                      Next (Decl);
4202                   end loop;
4203                end;
4204             end if;
4205 
4206             --  An indexing function must return either the default element of
4207             --  the container, or a reference type. For variable indexing it
4208             --  must be the latter.
4209 
4210             Default_Element :=
4211               Find_Value_Of_Aspect
4212                (Etype (First_Formal (Subp)), Aspect_Iterator_Element);
4213 
4214             if Present (Default_Element) then
4215                Analyze (Default_Element);
4216 
4217                if Is_Entity_Name (Default_Element)
4218                  and then not Covers (Entity (Default_Element), Ret_Type)
4219                  and then False
4220                then
4221                   Illegal_Indexing
4222                     ("wrong return type for indexing function");
4223                   return;
4224                end if;
4225             end if;
4226 
4227             --  For variable_indexing the return type must be a reference type
4228 
4229             if Attr = Name_Variable_Indexing then
4230                if not Has_Implicit_Dereference (Ret_Type) then
4231                   Illegal_Indexing
4232                      ("variable indexing must return a reference type");
4233                   return;
4234 
4235                elsif Is_Access_Constant
4236                        (Etype (First_Discriminant (Ret_Type)))
4237                then
4238                   Illegal_Indexing
4239                     ("variable indexing must return an access to variable");
4240                   return;
4241                end if;
4242 
4243             else
4244                if  Has_Implicit_Dereference (Ret_Type)
4245                  and then not
4246                    Is_Access_Constant (Etype (First_Discriminant (Ret_Type)))
4247                then
4248                   Illegal_Indexing
4249                     ("constant indexing must return an access to constant");
4250                   return;
4251 
4252                elsif Is_Access_Type (Etype (First_Formal (Subp)))
4253                  and then not Is_Access_Constant (Etype (First_Formal (Subp)))
4254                then
4255                   Illegal_Indexing
4256                     ("constant indexing must apply to an access to constant");
4257                   return;
4258                end if;
4259             end if;
4260 
4261             --  All checks succeeded.
4262 
4263             Indexing_Found := True;
4264          end Check_One_Function;
4265 
4266          -----------------------
4267          --  Illegal_Indexing --
4268          -----------------------
4269 
4270          procedure Illegal_Indexing (Msg : String) is
4271          begin
4272             Error_Msg_NE (Msg, N, Ent);
4273          end Illegal_Indexing;
4274 
4275       --  Start of processing for Check_Indexing_Functions
4276 
4277       begin
4278          if In_Instance then
4279             Check_Inherited_Indexing;
4280          end if;
4281 
4282          Analyze (Expr);
4283 
4284          if not Is_Overloaded (Expr) then
4285             Check_One_Function (Entity (Expr));
4286 
4287          else
4288             declare
4289                I  : Interp_Index;
4290                It : Interp;
4291 
4292             begin
4293                Indexing_Found := False;
4294                Get_First_Interp (Expr, I, It);
4295                while Present (It.Nam) loop
4296 
4297                   --  Note that analysis will have added the interpretation
4298                   --  that corresponds to the dereference. We only check the
4299                   --  subprogram itself.
4300 
4301                   if Is_Overloadable (It.Nam) then
4302                      Check_One_Function (It.Nam);
4303                   end if;
4304 
4305                   Get_Next_Interp (I, It);
4306                end loop;
4307             end;
4308          end if;
4309 
4310          if not Indexing_Found and then not Error_Posted (N) then
4311             Error_Msg_NE
4312               ("aspect Indexing requires a local function that "
4313                & "applies to type&", Expr, Ent);
4314          end if;
4315       end Check_Indexing_Functions;
4316 
4317       ------------------------------
4318       -- Check_Iterator_Functions --
4319       ------------------------------
4320 
4321       procedure Check_Iterator_Functions is
4322          function Valid_Default_Iterator (Subp : Entity_Id) return Boolean;
4323          --  Check one possible interpretation for validity
4324 
4325          ----------------------------
4326          -- Valid_Default_Iterator --
4327          ----------------------------
4328 
4329          function Valid_Default_Iterator (Subp : Entity_Id) return Boolean is
4330             Root_T : constant Entity_Id := Root_Type (Etype (Etype (Subp)));
4331             Formal : Entity_Id;
4332 
4333          begin
4334             if not Check_Primitive_Function (Subp) then
4335                return False;
4336 
4337             --  The return type must be derived from a type in an instance
4338             --  of Iterator.Interfaces, and thus its root type must have a
4339             --  predefined name.
4340 
4341             elsif Chars (Root_T) /= Name_Forward_Iterator
4342              and then Chars (Root_T) /= Name_Reversible_Iterator
4343             then
4344                return False;
4345 
4346             else
4347                Formal := First_Formal (Subp);
4348             end if;
4349 
4350             --  False if any subsequent formal has no default expression
4351 
4352             Formal := Next_Formal (Formal);
4353             while Present (Formal) loop
4354                if No (Expression (Parent (Formal))) then
4355                   return False;
4356                end if;
4357 
4358                Next_Formal (Formal);
4359             end loop;
4360 
4361             --  True if all subsequent formals have default expressions
4362 
4363             return True;
4364          end Valid_Default_Iterator;
4365 
4366       --  Start of processing for Check_Iterator_Functions
4367 
4368       begin
4369          Analyze (Expr);
4370 
4371          if not Is_Entity_Name (Expr) then
4372             Error_Msg_N ("aspect Iterator must be a function name", Expr);
4373          end if;
4374 
4375          if not Is_Overloaded (Expr) then
4376             if not Check_Primitive_Function (Entity (Expr)) then
4377                Error_Msg_NE
4378                  ("aspect Indexing requires a function that applies to type&",
4379                    Entity (Expr), Ent);
4380             end if;
4381 
4382             --  Flag the default_iterator as well as the denoted function.
4383 
4384             if not Valid_Default_Iterator (Entity (Expr)) then
4385                Error_Msg_N ("improper function for default iterator!", Expr);
4386             end if;
4387 
4388          else
4389             declare
4390                Default : Entity_Id := Empty;
4391                I       : Interp_Index;
4392                It      : Interp;
4393 
4394             begin
4395                Get_First_Interp (Expr, I, It);
4396                while Present (It.Nam) loop
4397                   if not Check_Primitive_Function (It.Nam)
4398                     or else not Valid_Default_Iterator (It.Nam)
4399                   then
4400                      Remove_Interp (I);
4401 
4402                   elsif Present (Default) then
4403 
4404                      --  An explicit one should override an implicit one
4405 
4406                      if Comes_From_Source (Default) =
4407                           Comes_From_Source (It.Nam)
4408                      then
4409                         Error_Msg_N ("default iterator must be unique", Expr);
4410                         Error_Msg_Sloc := Sloc (Default);
4411                         Error_Msg_N ("\\possible interpretation#", Expr);
4412                         Error_Msg_Sloc := Sloc (It.Nam);
4413                         Error_Msg_N ("\\possible interpretation#", Expr);
4414 
4415                      elsif Comes_From_Source (It.Nam) then
4416                         Default := It.Nam;
4417                      end if;
4418                   else
4419                      Default := It.Nam;
4420                   end if;
4421 
4422                   Get_Next_Interp (I, It);
4423                end loop;
4424 
4425                if Present (Default) then
4426                   Set_Entity (Expr, Default);
4427                   Set_Is_Overloaded (Expr, False);
4428                else
4429                   Error_Msg_N
4430                     ("no interpretation is a valid default iterator!", Expr);
4431                end if;
4432             end;
4433          end if;
4434       end Check_Iterator_Functions;
4435 
4436       -------------------------------
4437       -- Check_Primitive_Function  --
4438       -------------------------------
4439 
4440       function Check_Primitive_Function (Subp : Entity_Id) return Boolean is
4441          Ctrl : Entity_Id;
4442 
4443       begin
4444          if Ekind (Subp) /= E_Function then
4445             return False;
4446          end if;
4447 
4448          if No (First_Formal (Subp)) then
4449             return False;
4450          else
4451             Ctrl := Etype (First_Formal (Subp));
4452          end if;
4453 
4454          --  To be a primitive operation subprogram has to be in same scope.
4455 
4456          if Scope (Ctrl) /= Scope (Subp) then
4457             return False;
4458          end if;
4459 
4460          --  Type of formal may be the class-wide type, an access to such,
4461          --  or an incomplete view.
4462 
4463          if Ctrl = Ent
4464            or else Ctrl = Class_Wide_Type (Ent)
4465            or else
4466              (Ekind (Ctrl) = E_Anonymous_Access_Type
4467                and then (Designated_Type (Ctrl) = Ent
4468                            or else
4469                          Designated_Type (Ctrl) = Class_Wide_Type (Ent)))
4470            or else
4471              (Ekind (Ctrl) = E_Incomplete_Type
4472                and then Full_View (Ctrl) = Ent)
4473          then
4474             null;
4475          else
4476             return False;
4477          end if;
4478 
4479          return True;
4480       end Check_Primitive_Function;
4481 
4482       ----------------------
4483       -- Duplicate_Clause --
4484       ----------------------
4485 
4486       function Duplicate_Clause return Boolean is
4487          A : Node_Id;
4488 
4489       begin
4490          --  Nothing to do if this attribute definition clause comes from
4491          --  an aspect specification, since we could not be duplicating an
4492          --  explicit clause, and we dealt with the case of duplicated aspects
4493          --  in Analyze_Aspect_Specifications.
4494 
4495          if From_Aspect_Specification (N) then
4496             return False;
4497          end if;
4498 
4499          --  Otherwise current clause may duplicate previous clause, or a
4500          --  previously given pragma or aspect specification for the same
4501          --  aspect.
4502 
4503          A := Get_Rep_Item (U_Ent, Chars (N), Check_Parents => False);
4504 
4505          if Present (A) then
4506             Error_Msg_Name_1 := Chars (N);
4507             Error_Msg_Sloc := Sloc (A);
4508 
4509             Error_Msg_NE ("aspect% for & previously given#", N, U_Ent);
4510             return True;
4511          end if;
4512 
4513          return False;
4514       end Duplicate_Clause;
4515 
4516    --  Start of processing for Analyze_Attribute_Definition_Clause
4517 
4518    begin
4519       --  The following code is a defense against recursion. Not clear that
4520       --  this can happen legitimately, but perhaps some error situations can
4521       --  cause it, and we did see this recursion during testing.
4522 
4523       if Analyzed (N) then
4524          return;
4525       else
4526          Set_Analyzed (N, True);
4527       end if;
4528 
4529       Check_Restriction_No_Use_Of_Attribute (N);
4530 
4531       --  Ignore some selected attributes in CodePeer mode since they are not
4532       --  relevant in this context.
4533 
4534       if CodePeer_Mode then
4535          case Id is
4536 
4537             --  Ignore Component_Size in CodePeer mode, to avoid changing the
4538             --  internal representation of types by implicitly packing them.
4539 
4540             when Attribute_Component_Size =>
4541                Rewrite (N, Make_Null_Statement (Sloc (N)));
4542                return;
4543 
4544             when others =>
4545                null;
4546          end case;
4547       end if;
4548 
4549       --  Process Ignore_Rep_Clauses option
4550 
4551       if Ignore_Rep_Clauses then
4552          case Id is
4553 
4554             --  The following should be ignored. They do not affect legality
4555             --  and may be target dependent. The basic idea of -gnatI is to
4556             --  ignore any rep clauses that may be target dependent but do not
4557             --  affect legality (except possibly to be rejected because they
4558             --  are incompatible with the compilation target).
4559 
4560             when Attribute_Alignment      |
4561                  Attribute_Bit_Order      |
4562                  Attribute_Component_Size |
4563                  Attribute_Machine_Radix  |
4564                  Attribute_Object_Size    |
4565                  Attribute_Size           |
4566                  Attribute_Small          |
4567                  Attribute_Stream_Size    |
4568                  Attribute_Value_Size     =>
4569                Kill_Rep_Clause (N);
4570                return;
4571 
4572             --  The following should not be ignored, because in the first place
4573             --  they are reasonably portable, and should not cause problems
4574             --  in compiling code from another target, and also they do affect
4575             --  legality, e.g. failing to provide a stream attribute for a type
4576             --  may make a program illegal.
4577 
4578             when Attribute_External_Tag        |
4579                  Attribute_Input               |
4580                  Attribute_Output              |
4581                  Attribute_Read                |
4582                  Attribute_Simple_Storage_Pool |
4583                  Attribute_Storage_Pool        |
4584                  Attribute_Storage_Size        |
4585                  Attribute_Write               =>
4586                null;
4587 
4588             --  We do not do anything here with address clauses, they will be
4589             --  removed by Freeze later on, but for now, it works better to
4590             --  keep then in the tree.
4591 
4592             when Attribute_Address =>
4593                null;
4594 
4595             --  Other cases are errors ("attribute& cannot be set with
4596             --  definition clause"), which will be caught below.
4597 
4598             when others =>
4599                null;
4600          end case;
4601       end if;
4602 
4603       Analyze (Nam);
4604       Ent := Entity (Nam);
4605 
4606       if Rep_Item_Too_Early (Ent, N) then
4607          return;
4608       end if;
4609 
4610       --  Rep clause applies to full view of incomplete type or private type if
4611       --  we have one (if not, this is a premature use of the type). However,
4612       --  certain semantic checks need to be done on the specified entity (i.e.
4613       --  the private view), so we save it in Ent.
4614 
4615       if Is_Private_Type (Ent)
4616         and then Is_Derived_Type (Ent)
4617         and then not Is_Tagged_Type (Ent)
4618         and then No (Full_View (Ent))
4619       then
4620          --  If this is a private type whose completion is a derivation from
4621          --  another private type, there is no full view, and the attribute
4622          --  belongs to the type itself, not its underlying parent.
4623 
4624          U_Ent := Ent;
4625 
4626       elsif Ekind (Ent) = E_Incomplete_Type then
4627 
4628          --  The attribute applies to the full view, set the entity of the
4629          --  attribute definition accordingly.
4630 
4631          Ent := Underlying_Type (Ent);
4632          U_Ent := Ent;
4633          Set_Entity (Nam, Ent);
4634 
4635       else
4636          U_Ent := Underlying_Type (Ent);
4637       end if;
4638 
4639       --  Avoid cascaded error
4640 
4641       if Etype (Nam) = Any_Type then
4642          return;
4643 
4644       --  Must be declared in current scope or in case of an aspect
4645       --  specification, must be visible in current scope.
4646 
4647       elsif Scope (Ent) /= Current_Scope
4648         and then
4649           not (From_Aspect_Specification (N)
4650                 and then Scope_Within_Or_Same (Current_Scope, Scope (Ent)))
4651       then
4652          Error_Msg_N ("entity must be declared in this scope", Nam);
4653          return;
4654 
4655       --  Must not be a source renaming (we do have some cases where the
4656       --  expander generates a renaming, and those cases are OK, in such
4657       --  cases any attribute applies to the renamed object as well).
4658 
4659       elsif Is_Object (Ent)
4660         and then Present (Renamed_Object (Ent))
4661       then
4662          --  Case of renamed object from source, this is an error
4663 
4664          if Comes_From_Source (Renamed_Object (Ent)) then
4665             Get_Name_String (Chars (N));
4666             Error_Msg_Strlen := Name_Len;
4667             Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
4668             Error_Msg_N
4669               ("~ clause not allowed for a renaming declaration "
4670                & "(RM 13.1(6))", Nam);
4671             return;
4672 
4673          --  For the case of a compiler generated renaming, the attribute
4674          --  definition clause applies to the renamed object created by the
4675          --  expander. The easiest general way to handle this is to create a
4676          --  copy of the attribute definition clause for this object.
4677 
4678          elsif Is_Entity_Name (Renamed_Object (Ent)) then
4679             Insert_Action (N,
4680               Make_Attribute_Definition_Clause (Loc,
4681                 Name       =>
4682                   New_Occurrence_Of (Entity (Renamed_Object (Ent)), Loc),
4683                 Chars      => Chars (N),
4684                 Expression => Duplicate_Subexpr (Expression (N))));
4685 
4686          --  If the renamed object is not an entity, it must be a dereference
4687          --  of an unconstrained function call, and we must introduce a new
4688          --  declaration to capture the expression. This is needed in the case
4689          --  of 'Alignment, where the original declaration must be rewritten.
4690 
4691          else
4692             pragma Assert
4693               (Nkind (Renamed_Object (Ent)) = N_Explicit_Dereference);
4694             null;
4695          end if;
4696 
4697       --  If no underlying entity, use entity itself, applies to some
4698       --  previously detected error cases ???
4699 
4700       elsif No (U_Ent) then
4701          U_Ent := Ent;
4702 
4703       --  Cannot specify for a subtype (exception Object/Value_Size)
4704 
4705       elsif Is_Type (U_Ent)
4706         and then not Is_First_Subtype (U_Ent)
4707         and then Id /= Attribute_Object_Size
4708         and then Id /= Attribute_Value_Size
4709         and then not From_At_Mod (N)
4710       then
4711          Error_Msg_N ("cannot specify attribute for subtype", Nam);
4712          return;
4713       end if;
4714 
4715       Set_Entity (N, U_Ent);
4716 
4717       --  Switch on particular attribute
4718 
4719       case Id is
4720 
4721          -------------
4722          -- Address --
4723          -------------
4724 
4725          --  Address attribute definition clause
4726 
4727          when Attribute_Address => Address : begin
4728 
4729             --  A little error check, catch for X'Address use X'Address;
4730 
4731             if Nkind (Nam) = N_Identifier
4732               and then Nkind (Expr) = N_Attribute_Reference
4733               and then Attribute_Name (Expr) = Name_Address
4734               and then Nkind (Prefix (Expr)) = N_Identifier
4735               and then Chars (Nam) = Chars (Prefix (Expr))
4736             then
4737                Error_Msg_NE
4738                  ("address for & is self-referencing", Prefix (Expr), Ent);
4739                return;
4740             end if;
4741 
4742             --  Not that special case, carry on with analysis of expression
4743 
4744             Analyze_And_Resolve (Expr, RTE (RE_Address));
4745 
4746             --  Even when ignoring rep clauses we need to indicate that the
4747             --  entity has an address clause and thus it is legal to declare
4748             --  it imported. Freeze will get rid of the address clause later.
4749 
4750             if Ignore_Rep_Clauses then
4751                if Ekind_In (U_Ent, E_Variable, E_Constant) then
4752                   Record_Rep_Item (U_Ent, N);
4753                end if;
4754 
4755                return;
4756             end if;
4757 
4758             if Duplicate_Clause then
4759                null;
4760 
4761             --  Case of address clause for subprogram
4762 
4763             elsif Is_Subprogram (U_Ent) then
4764                if Has_Homonym (U_Ent) then
4765                   Error_Msg_N
4766                     ("address clause cannot be given for overloaded "
4767                      & "subprogram", Nam);
4768                   return;
4769                end if;
4770 
4771                --  For subprograms, all address clauses are permitted, and we
4772                --  mark the subprogram as having a deferred freeze so that Gigi
4773                --  will not elaborate it too soon.
4774 
4775                --  Above needs more comments, what is too soon about???
4776 
4777                Set_Has_Delayed_Freeze (U_Ent);
4778 
4779             --  Case of address clause for entry
4780 
4781             elsif Ekind (U_Ent) = E_Entry then
4782                if Nkind (Parent (N)) = N_Task_Body then
4783                   Error_Msg_N
4784                     ("entry address must be specified in task spec", Nam);
4785                   return;
4786                end if;
4787 
4788                --  For entries, we require a constant address
4789 
4790                Check_Constant_Address_Clause (Expr, U_Ent);
4791 
4792                --  Special checks for task types
4793 
4794                if Is_Task_Type (Scope (U_Ent))
4795                  and then Comes_From_Source (Scope (U_Ent))
4796                then
4797                   Error_Msg_N
4798                     ("??entry address declared for entry in task type", N);
4799                   Error_Msg_N
4800                     ("\??only one task can be declared of this type", N);
4801                end if;
4802 
4803                --  Entry address clauses are obsolescent
4804 
4805                Check_Restriction (No_Obsolescent_Features, N);
4806 
4807                if Warn_On_Obsolescent_Feature then
4808                   Error_Msg_N
4809                     ("?j?attaching interrupt to task entry is an obsolescent "
4810                      & "feature (RM J.7.1)", N);
4811                   Error_Msg_N
4812                     ("\?j?use interrupt procedure instead", N);
4813                end if;
4814 
4815             --  Case of an address clause for a controlled object which we
4816             --  consider to be erroneous.
4817 
4818             elsif Is_Controlled (Etype (U_Ent))
4819               or else Has_Controlled_Component (Etype (U_Ent))
4820             then
4821                Error_Msg_NE
4822                  ("??controlled object& must not be overlaid", Nam, U_Ent);
4823                Error_Msg_N
4824                  ("\??Program_Error will be raised at run time", Nam);
4825                Insert_Action (Declaration_Node (U_Ent),
4826                  Make_Raise_Program_Error (Loc,
4827                    Reason => PE_Overlaid_Controlled_Object));
4828                return;
4829 
4830             --  Case of address clause for a (non-controlled) object
4831 
4832             elsif Ekind_In (U_Ent, E_Variable, E_Constant) then
4833                declare
4834                   Expr  : constant Node_Id := Expression (N);
4835                   O_Ent : Entity_Id;
4836                   Off   : Boolean;
4837 
4838                begin
4839                   --  Exported variables cannot have an address clause, because
4840                   --  this cancels the effect of the pragma Export.
4841 
4842                   if Is_Exported (U_Ent) then
4843                      Error_Msg_N
4844                        ("cannot export object with address clause", Nam);
4845                      return;
4846                   end if;
4847 
4848                   Find_Overlaid_Entity (N, O_Ent, Off);
4849 
4850                   if Present (O_Ent) then
4851 
4852                      --  If the object overlays a constant object, mark it so
4853 
4854                      if Is_Constant_Object (O_Ent) then
4855                         Set_Overlays_Constant (U_Ent);
4856                      end if;
4857 
4858                      --  If the address clause is of the form:
4859 
4860                      --    for X'Address use Y'Address;
4861 
4862                      --  or
4863 
4864                      --    C : constant Address := Y'Address;
4865                      --    ...
4866                      --    for X'Address use C;
4867 
4868                      --  then we make an entry in the table to check the size
4869                      --  and alignment of the overlaying variable. But we defer
4870                      --  this check till after code generation to take full
4871                      --  advantage of the annotation done by the back end.
4872 
4873                      --  If the entity has a generic type, the check will be
4874                      --  performed in the instance if the actual type justifies
4875                      --  it, and we do not insert the clause in the table to
4876                      --  prevent spurious warnings.
4877 
4878                      --  Note: we used to test Comes_From_Source and only give
4879                      --  this warning for source entities, but we have removed
4880                      --  this test. It really seems bogus to generate overlays
4881                      --  that would trigger this warning in generated code.
4882                      --  Furthermore, by removing the test, we handle the
4883                      --  aspect case properly.
4884 
4885                      if Is_Object (O_Ent)
4886                        and then not Is_Generic_Type (Etype (U_Ent))
4887                        and then Address_Clause_Overlay_Warnings
4888                      then
4889                         Address_Clause_Checks.Append
4890                           ((N, U_Ent, No_Uint, O_Ent, Off));
4891                      end if;
4892                   else
4893                      --  If this is not an overlay, mark a variable as being
4894                      --  volatile to prevent unwanted optimizations. It's a
4895                      --  conservative interpretation of RM 13.3(19) for the
4896                      --  cases where the compiler cannot detect potential
4897                      --  aliasing issues easily and it also covers the case
4898                      --  of an absolute address where the volatile aspect is
4899                      --  kind of implicit.
4900 
4901                      if Ekind (U_Ent) = E_Variable then
4902                         Set_Treat_As_Volatile (U_Ent);
4903                      end if;
4904 
4905                      --  Make an entry in the table for an absolute address as
4906                      --  above to check that the value is compatible with the
4907                      --  alignment of the object.
4908 
4909                      declare
4910                         Addr : constant Node_Id := Address_Value (Expr);
4911                      begin
4912                         if Compile_Time_Known_Value (Addr)
4913                           and then Address_Clause_Overlay_Warnings
4914                         then
4915                            Address_Clause_Checks.Append
4916                              ((N, U_Ent, Expr_Value (Addr), Empty, False));
4917                         end if;
4918                      end;
4919                   end if;
4920 
4921                   --  Overlaying controlled objects is erroneous. Emit warning
4922                   --  but continue analysis because program is itself legal,
4923                   --  and back end must see address clause.
4924 
4925                   if Present (O_Ent)
4926                     and then (Has_Controlled_Component (Etype (O_Ent))
4927                                or else Is_Controlled (Etype (O_Ent)))
4928                     and then not Inside_A_Generic
4929                   then
4930                      Error_Msg_N
4931                        ("??cannot use overlays with controlled objects", Expr);
4932                      Error_Msg_N
4933                        ("\??Program_Error will be raised at run time", Expr);
4934                      Insert_Action (Declaration_Node (U_Ent),
4935                        Make_Raise_Program_Error (Loc,
4936                          Reason => PE_Overlaid_Controlled_Object));
4937 
4938                   --  Issue an unconditional warning for a constant overlaying
4939                   --  a variable. For the reverse case, we will issue it only
4940                   --  if the variable is modified.
4941 
4942                   elsif Ekind (U_Ent) = E_Constant
4943                     and then Present (O_Ent)
4944                     and then not Overlays_Constant (U_Ent)
4945                     and then Address_Clause_Overlay_Warnings
4946                   then
4947                      Error_Msg_N ("??constant overlays a variable", Expr);
4948 
4949                   --  Imported variables can have an address clause, but then
4950                   --  the import is pretty meaningless except to suppress
4951                   --  initializations, so we do not need such variables to
4952                   --  be statically allocated (and in fact it causes trouble
4953                   --  if the address clause is a local value).
4954 
4955                   elsif Is_Imported (U_Ent) then
4956                      Set_Is_Statically_Allocated (U_Ent, False);
4957                   end if;
4958 
4959                   --  We mark a possible modification of a variable with an
4960                   --  address clause, since it is likely aliasing is occurring.
4961 
4962                   Note_Possible_Modification (Nam, Sure => False);
4963 
4964                   --  Legality checks on the address clause for initialized
4965                   --  objects is deferred until the freeze point, because
4966                   --  a subsequent pragma might indicate that the object
4967                   --  is imported and thus not initialized. Also, the address
4968                   --  clause might involve entities that have yet to be
4969                   --  elaborated.
4970 
4971                   Set_Has_Delayed_Freeze (U_Ent);
4972 
4973                   --  If an initialization call has been generated for this
4974                   --  object, it needs to be deferred to after the freeze node
4975                   --  we have just now added, otherwise GIGI will see a
4976                   --  reference to the variable (as actual to the IP call)
4977                   --  before its definition.
4978 
4979                   declare
4980                      Init_Call : constant Node_Id :=
4981                                    Remove_Init_Call (U_Ent, N);
4982 
4983                   begin
4984                      if Present (Init_Call) then
4985                         Append_Freeze_Action (U_Ent, Init_Call);
4986 
4987                         --  Reset Initialization_Statements pointer so that
4988                         --  if there is a pragma Import further down, it can
4989                         --  clear any default initialization.
4990 
4991                         Set_Initialization_Statements (U_Ent, Init_Call);
4992                      end if;
4993                   end;
4994 
4995                   --  Entity has delayed freeze, so we will generate an
4996                   --  alignment check at the freeze point unless suppressed.
4997 
4998                   if not Range_Checks_Suppressed (U_Ent)
4999                     and then not Alignment_Checks_Suppressed (U_Ent)
5000                   then
5001                      Set_Check_Address_Alignment (N);
5002                   end if;
5003 
5004                   --  Kill the size check code, since we are not allocating
5005                   --  the variable, it is somewhere else.
5006 
5007                   Kill_Size_Check_Code (U_Ent);
5008                end;
5009 
5010             --  Not a valid entity for an address clause
5011 
5012             else
5013                Error_Msg_N ("address cannot be given for &", Nam);
5014             end if;
5015          end Address;
5016 
5017          ---------------
5018          -- Alignment --
5019          ---------------
5020 
5021          --  Alignment attribute definition clause
5022 
5023          when Attribute_Alignment => Alignment : declare
5024             Align     : constant Uint := Get_Alignment_Value (Expr);
5025             Max_Align : constant Uint := UI_From_Int (Maximum_Alignment);
5026 
5027          begin
5028             FOnly := True;
5029 
5030             if not Is_Type (U_Ent)
5031               and then Ekind (U_Ent) /= E_Variable
5032               and then Ekind (U_Ent) /= E_Constant
5033             then
5034                Error_Msg_N ("alignment cannot be given for &", Nam);
5035 
5036             elsif Duplicate_Clause then
5037                null;
5038 
5039             elsif Align /= No_Uint then
5040                Set_Has_Alignment_Clause (U_Ent);
5041 
5042                --  Tagged type case, check for attempt to set alignment to a
5043                --  value greater than Max_Align, and reset if so. This error
5044                --  is suppressed in ASIS mode to allow for different ASIS
5045                --  back ends or ASIS-based tools to query the illegal clause.
5046 
5047                if Is_Tagged_Type (U_Ent)
5048                  and then Align > Max_Align
5049                  and then not ASIS_Mode
5050                then
5051                   Error_Msg_N
5052                     ("alignment for & set to Maximum_Aligment??", Nam);
5053                   Set_Alignment (U_Ent, Max_Align);
5054 
5055                --  All other cases
5056 
5057                else
5058                   Set_Alignment (U_Ent, Align);
5059                end if;
5060 
5061                --  For an array type, U_Ent is the first subtype. In that case,
5062                --  also set the alignment of the anonymous base type so that
5063                --  other subtypes (such as the itypes for aggregates of the
5064                --  type) also receive the expected alignment.
5065 
5066                if Is_Array_Type (U_Ent) then
5067                   Set_Alignment (Base_Type (U_Ent), Align);
5068                end if;
5069             end if;
5070          end Alignment;
5071 
5072          ---------------
5073          -- Bit_Order --
5074          ---------------
5075 
5076          --  Bit_Order attribute definition clause
5077 
5078          when Attribute_Bit_Order => Bit_Order : declare
5079          begin
5080             if not Is_Record_Type (U_Ent) then
5081                Error_Msg_N
5082                  ("Bit_Order can only be defined for record type", Nam);
5083 
5084             elsif Duplicate_Clause then
5085                null;
5086 
5087             else
5088                Analyze_And_Resolve (Expr, RTE (RE_Bit_Order));
5089 
5090                if Etype (Expr) = Any_Type then
5091                   return;
5092 
5093                elsif not Is_OK_Static_Expression (Expr) then
5094                   Flag_Non_Static_Expr
5095                     ("Bit_Order requires static expression!", Expr);
5096 
5097                else
5098                   if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
5099                      Set_Reverse_Bit_Order (Base_Type (U_Ent), True);
5100                   end if;
5101                end if;
5102             end if;
5103          end Bit_Order;
5104 
5105          --------------------
5106          -- Component_Size --
5107          --------------------
5108 
5109          --  Component_Size attribute definition clause
5110 
5111          when Attribute_Component_Size => Component_Size_Case : declare
5112             Csize    : constant Uint := Static_Integer (Expr);
5113             Ctyp     : Entity_Id;
5114             Btype    : Entity_Id;
5115             Biased   : Boolean;
5116             New_Ctyp : Entity_Id;
5117             Decl     : Node_Id;
5118 
5119          begin
5120             if not Is_Array_Type (U_Ent) then
5121                Error_Msg_N ("component size requires array type", Nam);
5122                return;
5123             end if;
5124 
5125             Btype := Base_Type (U_Ent);
5126             Ctyp  := Component_Type (Btype);
5127 
5128             if Duplicate_Clause then
5129                null;
5130 
5131             elsif Rep_Item_Too_Early (Btype, N) then
5132                null;
5133 
5134             elsif Csize /= No_Uint then
5135                Check_Size (Expr, Ctyp, Csize, Biased);
5136 
5137                --  For the biased case, build a declaration for a subtype that
5138                --  will be used to represent the biased subtype that reflects
5139                --  the biased representation of components. We need the subtype
5140                --  to get proper conversions on referencing elements of the
5141                --  array.
5142 
5143                if Biased then
5144                   New_Ctyp :=
5145                     Make_Defining_Identifier (Loc,
5146                       Chars =>
5147                         New_External_Name (Chars (U_Ent), 'C', 0, 'T'));
5148 
5149                   Decl :=
5150                     Make_Subtype_Declaration (Loc,
5151                       Defining_Identifier => New_Ctyp,
5152                       Subtype_Indication  =>
5153                         New_Occurrence_Of (Component_Type (Btype), Loc));
5154 
5155                   Set_Parent (Decl, N);
5156                   Analyze (Decl, Suppress => All_Checks);
5157 
5158                   Set_Has_Delayed_Freeze        (New_Ctyp, False);
5159                   Set_Esize                     (New_Ctyp, Csize);
5160                   Set_RM_Size                   (New_Ctyp, Csize);
5161                   Init_Alignment                (New_Ctyp);
5162                   Set_Is_Itype                  (New_Ctyp, True);
5163                   Set_Associated_Node_For_Itype (New_Ctyp, U_Ent);
5164 
5165                   Set_Component_Type (Btype, New_Ctyp);
5166                   Set_Biased (New_Ctyp, N, "component size clause");
5167                end if;
5168 
5169                Set_Component_Size (Btype, Csize);
5170 
5171                --  Deal with warning on overridden size
5172 
5173                if Warn_On_Overridden_Size
5174                  and then Has_Size_Clause (Ctyp)
5175                  and then RM_Size (Ctyp) /= Csize
5176                then
5177                   Error_Msg_NE
5178                     ("component size overrides size clause for&?S?", N, Ctyp);
5179                end if;
5180 
5181                Set_Has_Component_Size_Clause (Btype, True);
5182                Set_Has_Non_Standard_Rep (Btype, True);
5183             end if;
5184          end Component_Size_Case;
5185 
5186          -----------------------
5187          -- Constant_Indexing --
5188          -----------------------
5189 
5190          when Attribute_Constant_Indexing =>
5191             Check_Indexing_Functions;
5192 
5193          ---------
5194          -- CPU --
5195          ---------
5196 
5197          when Attribute_CPU => CPU :
5198          begin
5199             --  CPU attribute definition clause not allowed except from aspect
5200             --  specification.
5201 
5202             if From_Aspect_Specification (N) then
5203                if not Is_Task_Type (U_Ent) then
5204                   Error_Msg_N ("CPU can only be defined for task", Nam);
5205 
5206                elsif Duplicate_Clause then
5207                   null;
5208 
5209                else
5210                   --  The expression must be analyzed in the special manner
5211                   --  described in "Handling of Default and Per-Object
5212                   --  Expressions" in sem.ads.
5213 
5214                   --  The visibility to the discriminants must be restored
5215 
5216                   Push_Scope_And_Install_Discriminants (U_Ent);
5217                   Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range));
5218                   Uninstall_Discriminants_And_Pop_Scope (U_Ent);
5219 
5220                   if not Is_OK_Static_Expression (Expr) then
5221                      Check_Restriction (Static_Priorities, Expr);
5222                   end if;
5223                end if;
5224 
5225             else
5226                Error_Msg_N
5227                  ("attribute& cannot be set with definition clause", N);
5228             end if;
5229          end CPU;
5230 
5231          ----------------------
5232          -- Default_Iterator --
5233          ----------------------
5234 
5235          when Attribute_Default_Iterator =>  Default_Iterator : declare
5236             Func : Entity_Id;
5237             Typ  : Entity_Id;
5238 
5239          begin
5240             --  If target type is untagged, further checks are irrelevant
5241 
5242             if not Is_Tagged_Type (U_Ent) then
5243                Error_Msg_N
5244                  ("aspect Default_Iterator applies to tagged type", Nam);
5245                return;
5246             end if;
5247 
5248             Check_Iterator_Functions;
5249 
5250             Analyze (Expr);
5251 
5252             if not Is_Entity_Name (Expr)
5253               or else Ekind (Entity (Expr)) /= E_Function
5254             then
5255                Error_Msg_N ("aspect Iterator must be a function", Expr);
5256                return;
5257             else
5258                Func := Entity (Expr);
5259             end if;
5260 
5261             --  The type of the first parameter must be T, T'class, or a
5262             --  corresponding access type (5.5.1 (8/3). If function is
5263             --  parameterless label type accordingly.
5264 
5265             if No (First_Formal (Func)) then
5266                Typ := Any_Type;
5267             else
5268                Typ := Etype (First_Formal (Func));
5269             end if;
5270 
5271             if Typ = U_Ent
5272               or else Typ = Class_Wide_Type (U_Ent)
5273               or else (Is_Access_Type (Typ)
5274                         and then Designated_Type (Typ) = U_Ent)
5275               or else (Is_Access_Type (Typ)
5276                         and then Designated_Type (Typ) =
5277                                           Class_Wide_Type (U_Ent))
5278             then
5279                null;
5280 
5281             else
5282                Error_Msg_NE
5283                  ("Default Iterator must be a primitive of&", Func, U_Ent);
5284             end if;
5285          end Default_Iterator;
5286 
5287          ------------------------
5288          -- Dispatching_Domain --
5289          ------------------------
5290 
5291          when Attribute_Dispatching_Domain => Dispatching_Domain :
5292          begin
5293             --  Dispatching_Domain attribute definition clause not allowed
5294             --  except from aspect specification.
5295 
5296             if From_Aspect_Specification (N) then
5297                if not Is_Task_Type (U_Ent) then
5298                   Error_Msg_N
5299                     ("Dispatching_Domain can only be defined for task", Nam);
5300 
5301                elsif Duplicate_Clause then
5302                   null;
5303 
5304                else
5305                   --  The expression must be analyzed in the special manner
5306                   --  described in "Handling of Default and Per-Object
5307                   --  Expressions" in sem.ads.
5308 
5309                   --  The visibility to the discriminants must be restored
5310 
5311                   Push_Scope_And_Install_Discriminants (U_Ent);
5312 
5313                   Preanalyze_Spec_Expression
5314                     (Expr, RTE (RE_Dispatching_Domain));
5315 
5316                   Uninstall_Discriminants_And_Pop_Scope (U_Ent);
5317                end if;
5318 
5319             else
5320                Error_Msg_N
5321                  ("attribute& cannot be set with definition clause", N);
5322             end if;
5323          end Dispatching_Domain;
5324 
5325          ------------------
5326          -- External_Tag --
5327          ------------------
5328 
5329          when Attribute_External_Tag => External_Tag :
5330          begin
5331             if not Is_Tagged_Type (U_Ent) then
5332                Error_Msg_N ("should be a tagged type", Nam);
5333             end if;
5334 
5335             if Duplicate_Clause then
5336                null;
5337 
5338             else
5339                Analyze_And_Resolve (Expr, Standard_String);
5340 
5341                if not Is_OK_Static_Expression (Expr) then
5342                   Flag_Non_Static_Expr
5343                     ("static string required for tag name!", Nam);
5344                end if;
5345 
5346                if not Is_Library_Level_Entity (U_Ent) then
5347                   Error_Msg_NE
5348                     ("??non-unique external tag supplied for &", N, U_Ent);
5349                   Error_Msg_N
5350                     ("\??same external tag applies to all subprogram calls",
5351                      N);
5352                   Error_Msg_N
5353                     ("\??corresponding internal tag cannot be obtained", N);
5354                end if;
5355             end if;
5356          end External_Tag;
5357 
5358          --------------------------
5359          -- Implicit_Dereference --
5360          --------------------------
5361 
5362          when Attribute_Implicit_Dereference =>
5363 
5364             --  Legality checks already performed at the point of the type
5365             --  declaration, aspect is not delayed.
5366 
5367             null;
5368 
5369          -----------
5370          -- Input --
5371          -----------
5372 
5373          when Attribute_Input =>
5374             Analyze_Stream_TSS_Definition (TSS_Stream_Input);
5375             Set_Has_Specified_Stream_Input (Ent);
5376 
5377          ------------------------
5378          -- Interrupt_Priority --
5379          ------------------------
5380 
5381          when Attribute_Interrupt_Priority => Interrupt_Priority :
5382          begin
5383             --  Interrupt_Priority attribute definition clause not allowed
5384             --  except from aspect specification.
5385 
5386             if From_Aspect_Specification (N) then
5387                if not Is_Concurrent_Type (U_Ent) then
5388                   Error_Msg_N
5389                     ("Interrupt_Priority can only be defined for task and "
5390                      & "protected object", Nam);
5391 
5392                elsif Duplicate_Clause then
5393                   null;
5394 
5395                else
5396                   --  The expression must be analyzed in the special manner
5397                   --  described in "Handling of Default and Per-Object
5398                   --  Expressions" in sem.ads.
5399 
5400                   --  The visibility to the discriminants must be restored
5401 
5402                   Push_Scope_And_Install_Discriminants (U_Ent);
5403 
5404                   Preanalyze_Spec_Expression
5405                     (Expr, RTE (RE_Interrupt_Priority));
5406 
5407                   Uninstall_Discriminants_And_Pop_Scope (U_Ent);
5408 
5409                   --  Check the No_Task_At_Interrupt_Priority restriction
5410 
5411                   if Is_Task_Type (U_Ent) then
5412                      Check_Restriction (No_Task_At_Interrupt_Priority, N);
5413                   end if;
5414                end if;
5415 
5416             else
5417                Error_Msg_N
5418                  ("attribute& cannot be set with definition clause", N);
5419             end if;
5420          end Interrupt_Priority;
5421 
5422          --------------
5423          -- Iterable --
5424          --------------
5425 
5426          when Attribute_Iterable =>
5427             Analyze (Expr);
5428 
5429             if Nkind (Expr) /= N_Aggregate then
5430                Error_Msg_N ("aspect Iterable must be an aggregate", Expr);
5431             end if;
5432 
5433             declare
5434                Assoc : Node_Id;
5435 
5436             begin
5437                Assoc := First (Component_Associations (Expr));
5438                while Present (Assoc) loop
5439                   if not Is_Entity_Name (Expression (Assoc)) then
5440                      Error_Msg_N ("value must be a function", Assoc);
5441                   end if;
5442 
5443                   Next (Assoc);
5444                end loop;
5445             end;
5446 
5447          ----------------------
5448          -- Iterator_Element --
5449          ----------------------
5450 
5451          when Attribute_Iterator_Element =>
5452             Analyze (Expr);
5453 
5454             if not Is_Entity_Name (Expr)
5455               or else not Is_Type (Entity (Expr))
5456             then
5457                Error_Msg_N ("aspect Iterator_Element must be a type", Expr);
5458             end if;
5459 
5460          -------------------
5461          -- Machine_Radix --
5462          -------------------
5463 
5464          --  Machine radix attribute definition clause
5465 
5466          when Attribute_Machine_Radix => Machine_Radix : declare
5467             Radix : constant Uint := Static_Integer (Expr);
5468 
5469          begin
5470             if not Is_Decimal_Fixed_Point_Type (U_Ent) then
5471                Error_Msg_N ("decimal fixed-point type expected for &", Nam);
5472 
5473             elsif Duplicate_Clause then
5474                null;
5475 
5476             elsif Radix /= No_Uint then
5477                Set_Has_Machine_Radix_Clause (U_Ent);
5478                Set_Has_Non_Standard_Rep (Base_Type (U_Ent));
5479 
5480                if Radix = 2 then
5481                   null;
5482 
5483                elsif Radix = 10 then
5484                   Set_Machine_Radix_10 (U_Ent);
5485 
5486                --  The following error is suppressed in ASIS mode to allow for
5487                --  different ASIS back ends or ASIS-based tools to query the
5488                --  illegal clause.
5489 
5490                elsif not ASIS_Mode then
5491                   Error_Msg_N ("machine radix value must be 2 or 10", Expr);
5492                end if;
5493             end if;
5494          end Machine_Radix;
5495 
5496          -----------------
5497          -- Object_Size --
5498          -----------------
5499 
5500          --  Object_Size attribute definition clause
5501 
5502          when Attribute_Object_Size => Object_Size : declare
5503             Size : constant Uint := Static_Integer (Expr);
5504 
5505             Biased : Boolean;
5506             pragma Warnings (Off, Biased);
5507 
5508          begin
5509             if not Is_Type (U_Ent) then
5510                Error_Msg_N ("Object_Size cannot be given for &", Nam);
5511 
5512             elsif Duplicate_Clause then
5513                null;
5514 
5515             else
5516                Check_Size (Expr, U_Ent, Size, Biased);
5517 
5518                --  The following errors are suppressed in ASIS mode to allow
5519                --  for different ASIS back ends or ASIS-based tools to query
5520                --  the illegal clause.
5521 
5522                if ASIS_Mode then
5523                   null;
5524 
5525                elsif Is_Scalar_Type (U_Ent) then
5526                   if Size /= 8 and then Size /= 16 and then Size /= 32
5527                     and then UI_Mod (Size, 64) /= 0
5528                   then
5529                      Error_Msg_N
5530                        ("Object_Size must be 8, 16, 32, or multiple of 64",
5531                         Expr);
5532                   end if;
5533 
5534                elsif Size mod 8 /= 0 then
5535                   Error_Msg_N ("Object_Size must be a multiple of 8", Expr);
5536                end if;
5537 
5538                Set_Esize (U_Ent, Size);
5539                Set_Has_Object_Size_Clause (U_Ent);
5540                Alignment_Check_For_Size_Change (U_Ent, Size);
5541             end if;
5542          end Object_Size;
5543 
5544          ------------
5545          -- Output --
5546          ------------
5547 
5548          when Attribute_Output =>
5549             Analyze_Stream_TSS_Definition (TSS_Stream_Output);
5550             Set_Has_Specified_Stream_Output (Ent);
5551 
5552          --------------
5553          -- Priority --
5554          --------------
5555 
5556          when Attribute_Priority => Priority :
5557          begin
5558             --  Priority attribute definition clause not allowed except from
5559             --  aspect specification.
5560 
5561             if From_Aspect_Specification (N) then
5562                if not (Is_Concurrent_Type (U_Ent)
5563                         or else Ekind (U_Ent) = E_Procedure)
5564                then
5565                   Error_Msg_N
5566                     ("Priority can only be defined for task and protected "
5567                      & "object", Nam);
5568 
5569                elsif Duplicate_Clause then
5570                   null;
5571 
5572                else
5573                   --  The expression must be analyzed in the special manner
5574                   --  described in "Handling of Default and Per-Object
5575                   --  Expressions" in sem.ads.
5576 
5577                   --  The visibility to the discriminants must be restored
5578 
5579                   Push_Scope_And_Install_Discriminants (U_Ent);
5580                   Preanalyze_Spec_Expression (Expr, Standard_Integer);
5581                   Uninstall_Discriminants_And_Pop_Scope (U_Ent);
5582 
5583                   if not Is_OK_Static_Expression (Expr) then
5584                      Check_Restriction (Static_Priorities, Expr);
5585                   end if;
5586                end if;
5587 
5588             else
5589                Error_Msg_N
5590                  ("attribute& cannot be set with definition clause", N);
5591             end if;
5592          end Priority;
5593 
5594          ----------
5595          -- Read --
5596          ----------
5597 
5598          when Attribute_Read =>
5599             Analyze_Stream_TSS_Definition (TSS_Stream_Read);
5600             Set_Has_Specified_Stream_Read (Ent);
5601 
5602          --------------------------
5603          -- Scalar_Storage_Order --
5604          --------------------------
5605 
5606          --  Scalar_Storage_Order attribute definition clause
5607 
5608          when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : declare
5609          begin
5610             if not (Is_Record_Type (U_Ent) or else Is_Array_Type (U_Ent)) then
5611                Error_Msg_N
5612                  ("Scalar_Storage_Order can only be defined for record or "
5613                   & "array type", Nam);
5614 
5615             elsif Duplicate_Clause then
5616                null;
5617 
5618             else
5619                Analyze_And_Resolve (Expr, RTE (RE_Bit_Order));
5620 
5621                if Etype (Expr) = Any_Type then
5622                   return;
5623 
5624                elsif not Is_OK_Static_Expression (Expr) then
5625                   Flag_Non_Static_Expr
5626                     ("Scalar_Storage_Order requires static expression!", Expr);
5627 
5628                elsif (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
5629 
5630                   --  Here for the case of a non-default (i.e. non-confirming)
5631                   --  Scalar_Storage_Order attribute definition.
5632 
5633                   if Support_Nondefault_SSO_On_Target then
5634                      Set_Reverse_Storage_Order (Base_Type (U_Ent), True);
5635                   else
5636                      Error_Msg_N
5637                        ("non-default Scalar_Storage_Order not supported on "
5638                         & "target", Expr);
5639                   end if;
5640                end if;
5641 
5642                --  Clear SSO default indications since explicit setting of the
5643                --  order overrides the defaults.
5644 
5645                Set_SSO_Set_Low_By_Default  (Base_Type (U_Ent), False);
5646                Set_SSO_Set_High_By_Default (Base_Type (U_Ent), False);
5647             end if;
5648          end Scalar_Storage_Order;
5649 
5650          ----------
5651          -- Size --
5652          ----------
5653 
5654          --  Size attribute definition clause
5655 
5656          when Attribute_Size => Size : declare
5657             Size   : constant Uint := Static_Integer (Expr);
5658             Etyp   : Entity_Id;
5659             Biased : Boolean;
5660 
5661          begin
5662             FOnly := True;
5663 
5664             if Duplicate_Clause then
5665                null;
5666 
5667             elsif not Is_Type (U_Ent)
5668               and then Ekind (U_Ent) /= E_Variable
5669               and then Ekind (U_Ent) /= E_Constant
5670             then
5671                Error_Msg_N ("size cannot be given for &", Nam);
5672 
5673             elsif Is_Array_Type (U_Ent)
5674               and then not Is_Constrained (U_Ent)
5675             then
5676                Error_Msg_N
5677                  ("size cannot be given for unconstrained array", Nam);
5678 
5679             elsif Size /= No_Uint then
5680                if Is_Type (U_Ent) then
5681                   Etyp := U_Ent;
5682                else
5683                   Etyp := Etype (U_Ent);
5684                end if;
5685 
5686                --  Check size, note that Gigi is in charge of checking that the
5687                --  size of an array or record type is OK. Also we do not check
5688                --  the size in the ordinary fixed-point case, since it is too
5689                --  early to do so (there may be subsequent small clause that
5690                --  affects the size). We can check the size if a small clause
5691                --  has already been given.
5692 
5693                if not Is_Ordinary_Fixed_Point_Type (U_Ent)
5694                  or else Has_Small_Clause (U_Ent)
5695                then
5696                   Check_Size (Expr, Etyp, Size, Biased);
5697                   Set_Biased (U_Ent, N, "size clause", Biased);
5698                end if;
5699 
5700                --  For types set RM_Size and Esize if possible
5701 
5702                if Is_Type (U_Ent) then
5703                   Set_RM_Size (U_Ent, Size);
5704 
5705                   --  For elementary types, increase Object_Size to power of 2,
5706                   --  but not less than a storage unit in any case (normally
5707                   --  this means it will be byte addressable).
5708 
5709                   --  For all other types, nothing else to do, we leave Esize
5710                   --  (object size) unset, the back end will set it from the
5711                   --  size and alignment in an appropriate manner.
5712 
5713                   --  In both cases, we check whether the alignment must be
5714                   --  reset in the wake of the size change.
5715 
5716                   if Is_Elementary_Type (U_Ent) then
5717                      if Size <= System_Storage_Unit then
5718                         Init_Esize (U_Ent, System_Storage_Unit);
5719                      elsif Size <= 16 then
5720                         Init_Esize (U_Ent, 16);
5721                      elsif Size <= 32 then
5722                         Init_Esize (U_Ent, 32);
5723                      else
5724                         Set_Esize  (U_Ent, (Size + 63) / 64 * 64);
5725                      end if;
5726 
5727                      Alignment_Check_For_Size_Change (U_Ent, Esize (U_Ent));
5728                   else
5729                      Alignment_Check_For_Size_Change (U_Ent, Size);
5730                   end if;
5731 
5732                --  For objects, set Esize only
5733 
5734                else
5735                   --  The following error is suppressed in ASIS mode to allow
5736                   --  for different ASIS back ends or ASIS-based tools to query
5737                   --  the illegal clause.
5738 
5739                   if Is_Elementary_Type (Etyp)
5740                     and then Size /= System_Storage_Unit
5741                     and then Size /= System_Storage_Unit * 2
5742                     and then Size /= System_Storage_Unit * 4
5743                     and then Size /= System_Storage_Unit * 8
5744                     and then not ASIS_Mode
5745                   then
5746                      Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
5747                      Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
5748                      Error_Msg_N
5749                        ("size for primitive object must be a power of 2 in "
5750                         & "the range ^-^", N);
5751                   end if;
5752 
5753                   Set_Esize (U_Ent, Size);
5754                end if;
5755 
5756                Set_Has_Size_Clause (U_Ent);
5757             end if;
5758          end Size;
5759 
5760          -----------
5761          -- Small --
5762          -----------
5763 
5764          --  Small attribute definition clause
5765 
5766          when Attribute_Small => Small : declare
5767             Implicit_Base : constant Entity_Id := Base_Type (U_Ent);
5768             Small         : Ureal;
5769 
5770          begin
5771             Analyze_And_Resolve (Expr, Any_Real);
5772 
5773             if Etype (Expr) = Any_Type then
5774                return;
5775 
5776             elsif not Is_OK_Static_Expression (Expr) then
5777                Flag_Non_Static_Expr
5778                  ("small requires static expression!", Expr);
5779                return;
5780 
5781             else
5782                Small := Expr_Value_R (Expr);
5783 
5784                if Small <= Ureal_0 then
5785                   Error_Msg_N ("small value must be greater than zero", Expr);
5786                   return;
5787                end if;
5788 
5789             end if;
5790 
5791             if not Is_Ordinary_Fixed_Point_Type (U_Ent) then
5792                Error_Msg_N
5793                  ("small requires an ordinary fixed point type", Nam);
5794 
5795             elsif Has_Small_Clause (U_Ent) then
5796                Error_Msg_N ("small already given for &", Nam);
5797 
5798             elsif Small > Delta_Value (U_Ent) then
5799                Error_Msg_N
5800                  ("small value must not be greater than delta value", Nam);
5801 
5802             else
5803                Set_Small_Value (U_Ent, Small);
5804                Set_Small_Value (Implicit_Base, Small);
5805                Set_Has_Small_Clause (U_Ent);
5806                Set_Has_Small_Clause (Implicit_Base);
5807                Set_Has_Non_Standard_Rep (Implicit_Base);
5808             end if;
5809          end Small;
5810 
5811          ------------------
5812          -- Storage_Pool --
5813          ------------------
5814 
5815          --  Storage_Pool attribute definition clause
5816 
5817          when Attribute_Storage_Pool | Attribute_Simple_Storage_Pool => declare
5818             Pool : Entity_Id;
5819             T    : Entity_Id;
5820 
5821          begin
5822             if Ekind (U_Ent) = E_Access_Subprogram_Type then
5823                Error_Msg_N
5824                  ("storage pool cannot be given for access-to-subprogram type",
5825                   Nam);
5826                return;
5827 
5828             elsif not
5829               Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type)
5830             then
5831                Error_Msg_N
5832                  ("storage pool can only be given for access types", Nam);
5833                return;
5834 
5835             elsif Is_Derived_Type (U_Ent) then
5836                Error_Msg_N
5837                  ("storage pool cannot be given for a derived access type",
5838                   Nam);
5839 
5840             elsif Duplicate_Clause then
5841                return;
5842 
5843             elsif Present (Associated_Storage_Pool (U_Ent)) then
5844                Error_Msg_N ("storage pool already given for &", Nam);
5845                return;
5846             end if;
5847 
5848             --  Check for Storage_Size previously given
5849 
5850             declare
5851                SS : constant Node_Id :=
5852                       Get_Attribute_Definition_Clause
5853                         (U_Ent, Attribute_Storage_Size);
5854             begin
5855                if Present (SS) then
5856                   Check_Pool_Size_Clash (U_Ent, N, SS);
5857                end if;
5858             end;
5859 
5860             --  Storage_Pool case
5861 
5862             if Id = Attribute_Storage_Pool then
5863                Analyze_And_Resolve
5864                  (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
5865 
5866             --  In the Simple_Storage_Pool case, we allow a variable of any
5867             --  simple storage pool type, so we Resolve without imposing an
5868             --  expected type.
5869 
5870             else
5871                Analyze_And_Resolve (Expr);
5872 
5873                if not Present (Get_Rep_Pragma
5874                                  (Etype (Expr), Name_Simple_Storage_Pool_Type))
5875                then
5876                   Error_Msg_N
5877                     ("expression must be of a simple storage pool type", Expr);
5878                end if;
5879             end if;
5880 
5881             if not Denotes_Variable (Expr) then
5882                Error_Msg_N ("storage pool must be a variable", Expr);
5883                return;
5884             end if;
5885 
5886             if Nkind (Expr) = N_Type_Conversion then
5887                T := Etype (Expression (Expr));
5888             else
5889                T := Etype (Expr);
5890             end if;
5891 
5892             --  The Stack_Bounded_Pool is used internally for implementing
5893             --  access types with a Storage_Size. Since it only work properly
5894             --  when used on one specific type, we need to check that it is not
5895             --  hijacked improperly:
5896 
5897             --    type T is access Integer;
5898             --    for T'Storage_Size use n;
5899             --    type Q is access Float;
5900             --    for Q'Storage_Size use T'Storage_Size; -- incorrect
5901 
5902             if RTE_Available (RE_Stack_Bounded_Pool)
5903               and then Base_Type (T) = RTE (RE_Stack_Bounded_Pool)
5904             then
5905                Error_Msg_N ("non-shareable internal Pool", Expr);
5906                return;
5907             end if;
5908 
5909             --  If the argument is a name that is not an entity name, then
5910             --  we construct a renaming operation to define an entity of
5911             --  type storage pool.
5912 
5913             if not Is_Entity_Name (Expr)
5914               and then Is_Object_Reference (Expr)
5915             then
5916                Pool := Make_Temporary (Loc, 'P', Expr);
5917 
5918                declare
5919                   Rnode : constant Node_Id :=
5920                             Make_Object_Renaming_Declaration (Loc,
5921                               Defining_Identifier => Pool,
5922                               Subtype_Mark        =>
5923                                 New_Occurrence_Of (Etype (Expr), Loc),
5924                               Name                => Expr);
5925 
5926                begin
5927                   --  If the attribute definition clause comes from an aspect
5928                   --  clause, then insert the renaming before the associated
5929                   --  entity's declaration, since the attribute clause has
5930                   --  not yet been appended to the declaration list.
5931 
5932                   if From_Aspect_Specification (N) then
5933                      Insert_Before (Parent (Entity (N)), Rnode);
5934                   else
5935                      Insert_Before (N, Rnode);
5936                   end if;
5937 
5938                   Analyze (Rnode);
5939                   Set_Associated_Storage_Pool (U_Ent, Pool);
5940                end;
5941 
5942             elsif Is_Entity_Name (Expr) then
5943                Pool := Entity (Expr);
5944 
5945                --  If pool is a renamed object, get original one. This can
5946                --  happen with an explicit renaming, and within instances.
5947 
5948                while Present (Renamed_Object (Pool))
5949                  and then Is_Entity_Name (Renamed_Object (Pool))
5950                loop
5951                   Pool := Entity (Renamed_Object (Pool));
5952                end loop;
5953 
5954                if Present (Renamed_Object (Pool))
5955                  and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion
5956                  and then Is_Entity_Name (Expression (Renamed_Object (Pool)))
5957                then
5958                   Pool := Entity (Expression (Renamed_Object (Pool)));
5959                end if;
5960 
5961                Set_Associated_Storage_Pool (U_Ent, Pool);
5962 
5963             elsif Nkind (Expr) = N_Type_Conversion
5964               and then Is_Entity_Name (Expression (Expr))
5965               and then Nkind (Original_Node (Expr)) = N_Attribute_Reference
5966             then
5967                Pool := Entity (Expression (Expr));
5968                Set_Associated_Storage_Pool (U_Ent, Pool);
5969 
5970             else
5971                Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
5972                return;
5973             end if;
5974          end;
5975 
5976          ------------------
5977          -- Storage_Size --
5978          ------------------
5979 
5980          --  Storage_Size attribute definition clause
5981 
5982          when Attribute_Storage_Size => Storage_Size : declare
5983             Btype : constant Entity_Id := Base_Type (U_Ent);
5984 
5985          begin
5986             if Is_Task_Type (U_Ent) then
5987 
5988                --  Check obsolescent (but never obsolescent if from aspect)
5989 
5990                if not From_Aspect_Specification (N) then
5991                   Check_Restriction (No_Obsolescent_Features, N);
5992 
5993                   if Warn_On_Obsolescent_Feature then
5994                      Error_Msg_N
5995                        ("?j?storage size clause for task is an obsolescent "
5996                         & "feature (RM J.9)", N);
5997                      Error_Msg_N ("\?j?use Storage_Size pragma instead", N);
5998                   end if;
5999                end if;
6000 
6001                FOnly := True;
6002             end if;
6003 
6004             if not Is_Access_Type (U_Ent)
6005               and then Ekind (U_Ent) /= E_Task_Type
6006             then
6007                Error_Msg_N ("storage size cannot be given for &", Nam);
6008 
6009             elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then
6010                Error_Msg_N
6011                  ("storage size cannot be given for a derived access type",
6012                   Nam);
6013 
6014             elsif Duplicate_Clause then
6015                null;
6016 
6017             else
6018                Analyze_And_Resolve (Expr, Any_Integer);
6019 
6020                if Is_Access_Type (U_Ent) then
6021 
6022                   --  Check for Storage_Pool previously given
6023 
6024                   declare
6025                      SP : constant Node_Id :=
6026                             Get_Attribute_Definition_Clause
6027                               (U_Ent, Attribute_Storage_Pool);
6028 
6029                   begin
6030                      if Present (SP) then
6031                         Check_Pool_Size_Clash (U_Ent, SP, N);
6032                      end if;
6033                   end;
6034 
6035                   --  Special case of for x'Storage_Size use 0
6036 
6037                   if Is_OK_Static_Expression (Expr)
6038                     and then Expr_Value (Expr) = 0
6039                   then
6040                      Set_No_Pool_Assigned (Btype);
6041                   end if;
6042                end if;
6043 
6044                Set_Has_Storage_Size_Clause (Btype);
6045             end if;
6046          end Storage_Size;
6047 
6048          -----------------
6049          -- Stream_Size --
6050          -----------------
6051 
6052          when Attribute_Stream_Size => Stream_Size : declare
6053             Size : constant Uint := Static_Integer (Expr);
6054 
6055          begin
6056             if Ada_Version <= Ada_95 then
6057                Check_Restriction (No_Implementation_Attributes, N);
6058             end if;
6059 
6060             if Duplicate_Clause then
6061                null;
6062 
6063             elsif Is_Elementary_Type (U_Ent) then
6064 
6065                --  The following errors are suppressed in ASIS mode to allow
6066                --  for different ASIS back ends or ASIS-based tools to query
6067                --  the illegal clause.
6068 
6069                if ASIS_Mode then
6070                   null;
6071 
6072                elsif Size /= System_Storage_Unit
6073                  and then Size /= System_Storage_Unit * 2
6074                  and then Size /= System_Storage_Unit * 4
6075                  and then Size /= System_Storage_Unit * 8
6076                then
6077                   Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
6078                   Error_Msg_N
6079                     ("stream size for elementary type must be a power of 2 "
6080                      & "and at least ^", N);
6081 
6082                elsif RM_Size (U_Ent) > Size then
6083                   Error_Msg_Uint_1 := RM_Size (U_Ent);
6084                   Error_Msg_N
6085                     ("stream size for elementary type must be a power of 2 "
6086                      & "and at least ^", N);
6087                end if;
6088 
6089                Set_Has_Stream_Size_Clause (U_Ent);
6090 
6091             else
6092                Error_Msg_N ("Stream_Size cannot be given for &", Nam);
6093             end if;
6094          end Stream_Size;
6095 
6096          ----------------
6097          -- Value_Size --
6098          ----------------
6099 
6100          --  Value_Size attribute definition clause
6101 
6102          when Attribute_Value_Size => Value_Size : declare
6103             Size   : constant Uint := Static_Integer (Expr);
6104             Biased : Boolean;
6105 
6106          begin
6107             if not Is_Type (U_Ent) then
6108                Error_Msg_N ("Value_Size cannot be given for &", Nam);
6109 
6110             elsif Duplicate_Clause then
6111                null;
6112 
6113             elsif Is_Array_Type (U_Ent)
6114               and then not Is_Constrained (U_Ent)
6115             then
6116                Error_Msg_N
6117                  ("Value_Size cannot be given for unconstrained array", Nam);
6118 
6119             else
6120                if Is_Elementary_Type (U_Ent) then
6121                   Check_Size (Expr, U_Ent, Size, Biased);
6122                   Set_Biased (U_Ent, N, "value size clause", Biased);
6123                end if;
6124 
6125                Set_RM_Size (U_Ent, Size);
6126             end if;
6127          end Value_Size;
6128 
6129          -----------------------
6130          -- Variable_Indexing --
6131          -----------------------
6132 
6133          when Attribute_Variable_Indexing =>
6134             Check_Indexing_Functions;
6135 
6136          -----------
6137          -- Write --
6138          -----------
6139 
6140          when Attribute_Write =>
6141             Analyze_Stream_TSS_Definition (TSS_Stream_Write);
6142             Set_Has_Specified_Stream_Write (Ent);
6143 
6144          --  All other attributes cannot be set
6145 
6146          when others =>
6147             Error_Msg_N
6148               ("attribute& cannot be set with definition clause", N);
6149       end case;
6150 
6151       --  The test for the type being frozen must be performed after any
6152       --  expression the clause has been analyzed since the expression itself
6153       --  might cause freezing that makes the clause illegal.
6154 
6155       if Rep_Item_Too_Late (U_Ent, N, FOnly) then
6156          return;
6157       end if;
6158    end Analyze_Attribute_Definition_Clause;
6159 
6160    ----------------------------
6161    -- Analyze_Code_Statement --
6162    ----------------------------
6163 
6164    procedure Analyze_Code_Statement (N : Node_Id) is
6165       HSS   : constant Node_Id   := Parent (N);
6166       SBody : constant Node_Id   := Parent (HSS);
6167       Subp  : constant Entity_Id := Current_Scope;
6168       Stmt  : Node_Id;
6169       Decl  : Node_Id;
6170       StmtO : Node_Id;
6171       DeclO : Node_Id;
6172 
6173    begin
6174       --  Accept foreign code statements for CodePeer. The analysis is skipped
6175       --  to avoid rejecting unrecognized constructs.
6176 
6177       if CodePeer_Mode then
6178          Set_Analyzed (N);
6179          return;
6180       end if;
6181 
6182       --  Analyze and check we get right type, note that this implements the
6183       --  requirement (RM 13.8(1)) that Machine_Code be with'ed, since that is
6184       --  the only way that Asm_Insn could possibly be visible.
6185 
6186       Analyze_And_Resolve (Expression (N));
6187 
6188       if Etype (Expression (N)) = Any_Type then
6189          return;
6190       elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then
6191          Error_Msg_N ("incorrect type for code statement", N);
6192          return;
6193       end if;
6194 
6195       Check_Code_Statement (N);
6196 
6197       --  Make sure we appear in the handled statement sequence of a subprogram
6198       --  (RM 13.8(3)).
6199 
6200       if Nkind (HSS) /= N_Handled_Sequence_Of_Statements
6201         or else Nkind (SBody) /= N_Subprogram_Body
6202       then
6203          Error_Msg_N
6204            ("code statement can only appear in body of subprogram", N);
6205          return;
6206       end if;
6207 
6208       --  Do remaining checks (RM 13.8(3)) if not already done
6209 
6210       if not Is_Machine_Code_Subprogram (Subp) then
6211          Set_Is_Machine_Code_Subprogram (Subp);
6212 
6213          --  No exception handlers allowed
6214 
6215          if Present (Exception_Handlers (HSS)) then
6216             Error_Msg_N
6217               ("exception handlers not permitted in machine code subprogram",
6218                First (Exception_Handlers (HSS)));
6219          end if;
6220 
6221          --  No declarations other than use clauses and pragmas (we allow
6222          --  certain internally generated declarations as well).
6223 
6224          Decl := First (Declarations (SBody));
6225          while Present (Decl) loop
6226             DeclO := Original_Node (Decl);
6227             if Comes_From_Source (DeclO)
6228               and not Nkind_In (DeclO, N_Pragma,
6229                                        N_Use_Package_Clause,
6230                                        N_Use_Type_Clause,
6231                                        N_Implicit_Label_Declaration)
6232             then
6233                Error_Msg_N
6234                  ("this declaration not allowed in machine code subprogram",
6235                   DeclO);
6236             end if;
6237 
6238             Next (Decl);
6239          end loop;
6240 
6241          --  No statements other than code statements, pragmas, and labels.
6242          --  Again we allow certain internally generated statements.
6243 
6244          --  In Ada 2012, qualified expressions are names, and the code
6245          --  statement is initially parsed as a procedure call.
6246 
6247          Stmt := First (Statements (HSS));
6248          while Present (Stmt) loop
6249             StmtO := Original_Node (Stmt);
6250 
6251             --  A procedure call transformed into a code statement is OK
6252 
6253             if Ada_Version >= Ada_2012
6254               and then Nkind (StmtO) = N_Procedure_Call_Statement
6255               and then Nkind (Name (StmtO)) = N_Qualified_Expression
6256             then
6257                null;
6258 
6259             elsif Comes_From_Source (StmtO)
6260               and then not Nkind_In (StmtO, N_Pragma,
6261                                             N_Label,
6262                                             N_Code_Statement)
6263             then
6264                Error_Msg_N
6265                  ("this statement is not allowed in machine code subprogram",
6266                   StmtO);
6267             end if;
6268 
6269             Next (Stmt);
6270          end loop;
6271       end if;
6272    end Analyze_Code_Statement;
6273 
6274    -----------------------------------------------
6275    -- Analyze_Enumeration_Representation_Clause --
6276    -----------------------------------------------
6277 
6278    procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is
6279       Ident    : constant Node_Id := Identifier (N);
6280       Aggr     : constant Node_Id := Array_Aggregate (N);
6281       Enumtype : Entity_Id;
6282       Elit     : Entity_Id;
6283       Expr     : Node_Id;
6284       Assoc    : Node_Id;
6285       Choice   : Node_Id;
6286       Val      : Uint;
6287 
6288       Err : Boolean := False;
6289       --  Set True to avoid cascade errors and crashes on incorrect source code
6290 
6291       Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer));
6292       Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer));
6293       --  Allowed range of universal integer (= allowed range of enum lit vals)
6294 
6295       Min : Uint;
6296       Max : Uint;
6297       --  Minimum and maximum values of entries
6298 
6299       Max_Node : Node_Id;
6300       --  Pointer to node for literal providing max value
6301 
6302    begin
6303       if Ignore_Rep_Clauses then
6304          Kill_Rep_Clause (N);
6305          return;
6306       end if;
6307 
6308       --  Ignore enumeration rep clauses by default in CodePeer mode,
6309       --  unless -gnatd.I is specified, as a work around for potential false
6310       --  positive messages.
6311 
6312       if CodePeer_Mode and not Debug_Flag_Dot_II then
6313          return;
6314       end if;
6315 
6316       --  First some basic error checks
6317 
6318       Find_Type (Ident);
6319       Enumtype := Entity (Ident);
6320 
6321       if Enumtype = Any_Type
6322         or else Rep_Item_Too_Early (Enumtype, N)
6323       then
6324          return;
6325       else
6326          Enumtype := Underlying_Type (Enumtype);
6327       end if;
6328 
6329       if not Is_Enumeration_Type (Enumtype) then
6330          Error_Msg_NE
6331            ("enumeration type required, found}",
6332             Ident, First_Subtype (Enumtype));
6333          return;
6334       end if;
6335 
6336       --  Ignore rep clause on generic actual type. This will already have
6337       --  been flagged on the template as an error, and this is the safest
6338       --  way to ensure we don't get a junk cascaded message in the instance.
6339 
6340       if Is_Generic_Actual_Type (Enumtype) then
6341          return;
6342 
6343       --  Type must be in current scope
6344 
6345       elsif Scope (Enumtype) /= Current_Scope then
6346          Error_Msg_N ("type must be declared in this scope", Ident);
6347          return;
6348 
6349       --  Type must be a first subtype
6350 
6351       elsif not Is_First_Subtype (Enumtype) then
6352          Error_Msg_N ("cannot give enumeration rep clause for subtype", N);
6353          return;
6354 
6355       --  Ignore duplicate rep clause
6356 
6357       elsif Has_Enumeration_Rep_Clause (Enumtype) then
6358          Error_Msg_N ("duplicate enumeration rep clause ignored", N);
6359          return;
6360 
6361       --  Don't allow rep clause for standard [wide_[wide_]]character
6362 
6363       elsif Is_Standard_Character_Type (Enumtype) then
6364          Error_Msg_N ("enumeration rep clause not allowed for this type", N);
6365          return;
6366 
6367       --  Check that the expression is a proper aggregate (no parentheses)
6368 
6369       elsif Paren_Count (Aggr) /= 0 then
6370          Error_Msg
6371            ("extra parentheses surrounding aggregate not allowed",
6372             First_Sloc (Aggr));
6373          return;
6374 
6375       --  All tests passed, so set rep clause in place
6376 
6377       else
6378          Set_Has_Enumeration_Rep_Clause (Enumtype);
6379          Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype));
6380       end if;
6381 
6382       --  Now we process the aggregate. Note that we don't use the normal
6383       --  aggregate code for this purpose, because we don't want any of the
6384       --  normal expansion activities, and a number of special semantic
6385       --  rules apply (including the component type being any integer type)
6386 
6387       Elit := First_Literal (Enumtype);
6388 
6389       --  First the positional entries if any
6390 
6391       if Present (Expressions (Aggr)) then
6392          Expr := First (Expressions (Aggr));
6393          while Present (Expr) loop
6394             if No (Elit) then
6395                Error_Msg_N ("too many entries in aggregate", Expr);
6396                return;
6397             end if;
6398 
6399             Val := Static_Integer (Expr);
6400 
6401             --  Err signals that we found some incorrect entries processing
6402             --  the list. The final checks for completeness and ordering are
6403             --  skipped in this case.
6404 
6405             if Val = No_Uint then
6406                Err := True;
6407 
6408             elsif Val < Lo or else Hi < Val then
6409                Error_Msg_N ("value outside permitted range", Expr);
6410                Err := True;
6411             end if;
6412 
6413             Set_Enumeration_Rep (Elit, Val);
6414             Set_Enumeration_Rep_Expr (Elit, Expr);
6415             Next (Expr);
6416             Next (Elit);
6417          end loop;
6418       end if;
6419 
6420       --  Now process the named entries if present
6421 
6422       if Present (Component_Associations (Aggr)) then
6423          Assoc := First (Component_Associations (Aggr));
6424          while Present (Assoc) loop
6425             Choice := First (Choices (Assoc));
6426 
6427             if Present (Next (Choice)) then
6428                Error_Msg_N
6429                  ("multiple choice not allowed here", Next (Choice));
6430                Err := True;
6431             end if;
6432 
6433             if Nkind (Choice) = N_Others_Choice then
6434                Error_Msg_N ("others choice not allowed here", Choice);
6435                Err := True;
6436 
6437             elsif Nkind (Choice) = N_Range then
6438 
6439                --  ??? should allow zero/one element range here
6440 
6441                Error_Msg_N ("range not allowed here", Choice);
6442                Err := True;
6443 
6444             else
6445                Analyze_And_Resolve (Choice, Enumtype);
6446 
6447                if Error_Posted (Choice) then
6448                   Err := True;
6449                end if;
6450 
6451                if not Err then
6452                   if Is_Entity_Name (Choice)
6453                     and then Is_Type (Entity (Choice))
6454                   then
6455                      Error_Msg_N ("subtype name not allowed here", Choice);
6456                      Err := True;
6457 
6458                      --  ??? should allow static subtype with zero/one entry
6459 
6460                   elsif Etype (Choice) = Base_Type (Enumtype) then
6461                      if not Is_OK_Static_Expression (Choice) then
6462                         Flag_Non_Static_Expr
6463                           ("non-static expression used for choice!", Choice);
6464                         Err := True;
6465 
6466                      else
6467                         Elit := Expr_Value_E (Choice);
6468 
6469                         if Present (Enumeration_Rep_Expr (Elit)) then
6470                            Error_Msg_Sloc :=
6471                              Sloc (Enumeration_Rep_Expr (Elit));
6472                            Error_Msg_NE
6473                              ("representation for& previously given#",
6474                               Choice, Elit);
6475                            Err := True;
6476                         end if;
6477 
6478                         Set_Enumeration_Rep_Expr (Elit, Expression (Assoc));
6479 
6480                         Expr := Expression (Assoc);
6481                         Val := Static_Integer (Expr);
6482 
6483                         if Val = No_Uint then
6484                            Err := True;
6485 
6486                         elsif Val < Lo or else Hi < Val then
6487                            Error_Msg_N ("value outside permitted range", Expr);
6488                            Err := True;
6489                         end if;
6490 
6491                         Set_Enumeration_Rep (Elit, Val);
6492                      end if;
6493                   end if;
6494                end if;
6495             end if;
6496 
6497             Next (Assoc);
6498          end loop;
6499       end if;
6500 
6501       --  Aggregate is fully processed. Now we check that a full set of
6502       --  representations was given, and that they are in range and in order.
6503       --  These checks are only done if no other errors occurred.
6504 
6505       if not Err then
6506          Min  := No_Uint;
6507          Max  := No_Uint;
6508 
6509          Elit := First_Literal (Enumtype);
6510          while Present (Elit) loop
6511             if No (Enumeration_Rep_Expr (Elit)) then
6512                Error_Msg_NE ("missing representation for&!", N, Elit);
6513 
6514             else
6515                Val := Enumeration_Rep (Elit);
6516 
6517                if Min = No_Uint then
6518                   Min := Val;
6519                end if;
6520 
6521                if Val /= No_Uint then
6522                   if Max /= No_Uint and then Val <= Max then
6523                      Error_Msg_NE
6524                        ("enumeration value for& not ordered!",
6525                         Enumeration_Rep_Expr (Elit), Elit);
6526                   end if;
6527 
6528                   Max_Node := Enumeration_Rep_Expr (Elit);
6529                   Max := Val;
6530                end if;
6531 
6532                --  If there is at least one literal whose representation is not
6533                --  equal to the Pos value, then note that this enumeration type
6534                --  has a non-standard representation.
6535 
6536                if Val /= Enumeration_Pos (Elit) then
6537                   Set_Has_Non_Standard_Rep (Base_Type (Enumtype));
6538                end if;
6539             end if;
6540 
6541             Next (Elit);
6542          end loop;
6543 
6544          --  Now set proper size information
6545 
6546          declare
6547             Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype));
6548 
6549          begin
6550             if Has_Size_Clause (Enumtype) then
6551 
6552                --  All OK, if size is OK now
6553 
6554                if RM_Size (Enumtype) >= Minsize then
6555                   null;
6556 
6557                else
6558                   --  Try if we can get by with biasing
6559 
6560                   Minsize :=
6561                     UI_From_Int (Minimum_Size (Enumtype, Biased => True));
6562 
6563                   --  Error message if even biasing does not work
6564 
6565                   if RM_Size (Enumtype) < Minsize then
6566                      Error_Msg_Uint_1 := RM_Size (Enumtype);
6567                      Error_Msg_Uint_2 := Max;
6568                      Error_Msg_N
6569                        ("previously given size (^) is too small "
6570                         & "for this value (^)", Max_Node);
6571 
6572                   --  If biasing worked, indicate that we now have biased rep
6573 
6574                   else
6575                      Set_Biased
6576                        (Enumtype, Size_Clause (Enumtype), "size clause");
6577                   end if;
6578                end if;
6579 
6580             else
6581                Set_RM_Size    (Enumtype, Minsize);
6582                Set_Enum_Esize (Enumtype);
6583             end if;
6584 
6585             Set_RM_Size   (Base_Type (Enumtype), RM_Size   (Enumtype));
6586             Set_Esize     (Base_Type (Enumtype), Esize     (Enumtype));
6587             Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype));
6588          end;
6589       end if;
6590 
6591       --  We repeat the too late test in case it froze itself
6592 
6593       if Rep_Item_Too_Late (Enumtype, N) then
6594          null;
6595       end if;
6596    end Analyze_Enumeration_Representation_Clause;
6597 
6598    ----------------------------
6599    -- Analyze_Free_Statement --
6600    ----------------------------
6601 
6602    procedure Analyze_Free_Statement (N : Node_Id) is
6603    begin
6604       Analyze (Expression (N));
6605    end Analyze_Free_Statement;
6606 
6607    ---------------------------
6608    -- Analyze_Freeze_Entity --
6609    ---------------------------
6610 
6611    procedure Analyze_Freeze_Entity (N : Node_Id) is
6612    begin
6613       Freeze_Entity_Checks (N);
6614    end Analyze_Freeze_Entity;
6615 
6616    -----------------------------------
6617    -- Analyze_Freeze_Generic_Entity --
6618    -----------------------------------
6619 
6620    procedure Analyze_Freeze_Generic_Entity (N : Node_Id) is
6621    begin
6622       Freeze_Entity_Checks (N);
6623    end Analyze_Freeze_Generic_Entity;
6624 
6625    ------------------------------------------
6626    -- Analyze_Record_Representation_Clause --
6627    ------------------------------------------
6628 
6629    --  Note: we check as much as we can here, but we can't do any checks
6630    --  based on the position values (e.g. overlap checks) until freeze time
6631    --  because especially in Ada 2005 (machine scalar mode), the processing
6632    --  for non-standard bit order can substantially change the positions.
6633    --  See procedure Check_Record_Representation_Clause (called from Freeze)
6634    --  for the remainder of this processing.
6635 
6636    procedure Analyze_Record_Representation_Clause (N : Node_Id) is
6637       Ident   : constant Node_Id := Identifier (N);
6638       Biased  : Boolean;
6639       CC      : Node_Id;
6640       Comp    : Entity_Id;
6641       Fbit    : Uint;
6642       Hbit    : Uint := Uint_0;
6643       Lbit    : Uint;
6644       Ocomp   : Entity_Id;
6645       Posit   : Uint;
6646       Rectype : Entity_Id;
6647       Recdef  : Node_Id;
6648 
6649       function Is_Inherited (Comp : Entity_Id) return Boolean;
6650       --  True if Comp is an inherited component in a record extension
6651 
6652       ------------------
6653       -- Is_Inherited --
6654       ------------------
6655 
6656       function Is_Inherited (Comp : Entity_Id) return Boolean is
6657          Comp_Base : Entity_Id;
6658 
6659       begin
6660          if Ekind (Rectype) = E_Record_Subtype then
6661             Comp_Base := Original_Record_Component (Comp);
6662          else
6663             Comp_Base := Comp;
6664          end if;
6665 
6666          return Comp_Base /= Original_Record_Component (Comp_Base);
6667       end Is_Inherited;
6668 
6669       --  Local variables
6670 
6671       Is_Record_Extension : Boolean;
6672       --  True if Rectype is a record extension
6673 
6674       CR_Pragma : Node_Id := Empty;
6675       --  Points to N_Pragma node if Complete_Representation pragma present
6676 
6677    --  Start of processing for Analyze_Record_Representation_Clause
6678 
6679    begin
6680       if Ignore_Rep_Clauses then
6681          Kill_Rep_Clause (N);
6682          return;
6683       end if;
6684 
6685       Find_Type (Ident);
6686       Rectype := Entity (Ident);
6687 
6688       if Rectype = Any_Type or else Rep_Item_Too_Early (Rectype, N) then
6689          return;
6690       else
6691          Rectype := Underlying_Type (Rectype);
6692       end if;
6693 
6694       --  First some basic error checks
6695 
6696       if not Is_Record_Type (Rectype) then
6697          Error_Msg_NE
6698            ("record type required, found}", Ident, First_Subtype (Rectype));
6699          return;
6700 
6701       elsif Scope (Rectype) /= Current_Scope then
6702          Error_Msg_N ("type must be declared in this scope", N);
6703          return;
6704 
6705       elsif not Is_First_Subtype (Rectype) then
6706          Error_Msg_N ("cannot give record rep clause for subtype", N);
6707          return;
6708 
6709       elsif Has_Record_Rep_Clause (Rectype) then
6710          Error_Msg_N ("duplicate record rep clause ignored", N);
6711          return;
6712 
6713       elsif Rep_Item_Too_Late (Rectype, N) then
6714          return;
6715       end if;
6716 
6717       --  We know we have a first subtype, now possibly go to the anonymous
6718       --  base type to determine whether Rectype is a record extension.
6719 
6720       Recdef := Type_Definition (Declaration_Node (Base_Type (Rectype)));
6721       Is_Record_Extension :=
6722         Nkind (Recdef) = N_Derived_Type_Definition
6723           and then Present (Record_Extension_Part (Recdef));
6724 
6725       if Present (Mod_Clause (N)) then
6726          declare
6727             Loc     : constant Source_Ptr := Sloc (N);
6728             M       : constant Node_Id := Mod_Clause (N);
6729             P       : constant List_Id := Pragmas_Before (M);
6730             AtM_Nod : Node_Id;
6731 
6732             Mod_Val : Uint;
6733             pragma Warnings (Off, Mod_Val);
6734 
6735          begin
6736             Check_Restriction (No_Obsolescent_Features, Mod_Clause (N));
6737 
6738             if Warn_On_Obsolescent_Feature then
6739                Error_Msg_N
6740                  ("?j?mod clause is an obsolescent feature (RM J.8)", N);
6741                Error_Msg_N
6742                  ("\?j?use alignment attribute definition clause instead", N);
6743             end if;
6744 
6745             if Present (P) then
6746                Analyze_List (P);
6747             end if;
6748 
6749             --  In ASIS_Mode mode, expansion is disabled, but we must convert
6750             --  the Mod clause into an alignment clause anyway, so that the
6751             --  back end can compute and back-annotate properly the size and
6752             --  alignment of types that may include this record.
6753 
6754             --  This seems dubious, this destroys the source tree in a manner
6755             --  not detectable by ASIS ???
6756 
6757             if Operating_Mode = Check_Semantics and then ASIS_Mode then
6758                AtM_Nod :=
6759                  Make_Attribute_Definition_Clause (Loc,
6760                    Name       => New_Occurrence_Of (Base_Type (Rectype), Loc),
6761                    Chars      => Name_Alignment,
6762                    Expression => Relocate_Node (Expression (M)));
6763 
6764                Set_From_At_Mod (AtM_Nod);
6765                Insert_After (N, AtM_Nod);
6766                Mod_Val := Get_Alignment_Value (Expression (AtM_Nod));
6767                Set_Mod_Clause (N, Empty);
6768 
6769             else
6770                --  Get the alignment value to perform error checking
6771 
6772                Mod_Val := Get_Alignment_Value (Expression (M));
6773             end if;
6774          end;
6775       end if;
6776 
6777       --  For untagged types, clear any existing component clauses for the
6778       --  type. If the type is derived, this is what allows us to override
6779       --  a rep clause for the parent. For type extensions, the representation
6780       --  of the inherited components is inherited, so we want to keep previous
6781       --  component clauses for completeness.
6782 
6783       if not Is_Tagged_Type (Rectype) then
6784          Comp := First_Component_Or_Discriminant (Rectype);
6785          while Present (Comp) loop
6786             Set_Component_Clause (Comp, Empty);
6787             Next_Component_Or_Discriminant (Comp);
6788          end loop;
6789       end if;
6790 
6791       --  All done if no component clauses
6792 
6793       CC := First (Component_Clauses (N));
6794 
6795       if No (CC) then
6796          return;
6797       end if;
6798 
6799       --  A representation like this applies to the base type
6800 
6801       Set_Has_Record_Rep_Clause (Base_Type (Rectype));
6802       Set_Has_Non_Standard_Rep  (Base_Type (Rectype));
6803       Set_Has_Specified_Layout  (Base_Type (Rectype));
6804 
6805       --  Process the component clauses
6806 
6807       while Present (CC) loop
6808 
6809          --  Pragma
6810 
6811          if Nkind (CC) = N_Pragma then
6812             Analyze (CC);
6813 
6814             --  The only pragma of interest is Complete_Representation
6815 
6816             if Pragma_Name (CC) = Name_Complete_Representation then
6817                CR_Pragma := CC;
6818             end if;
6819 
6820          --  Processing for real component clause
6821 
6822          else
6823             Posit := Static_Integer (Position  (CC));
6824             Fbit  := Static_Integer (First_Bit (CC));
6825             Lbit  := Static_Integer (Last_Bit  (CC));
6826 
6827             if Posit /= No_Uint
6828               and then Fbit /= No_Uint
6829               and then Lbit /= No_Uint
6830             then
6831                if Posit < 0 then
6832                   Error_Msg_N ("position cannot be negative", Position (CC));
6833 
6834                elsif Fbit < 0 then
6835                   Error_Msg_N ("first bit cannot be negative", First_Bit (CC));
6836 
6837                --  The Last_Bit specified in a component clause must not be
6838                --  less than the First_Bit minus one (RM-13.5.1(10)).
6839 
6840                elsif Lbit < Fbit - 1 then
6841                   Error_Msg_N
6842                     ("last bit cannot be less than first bit minus one",
6843                      Last_Bit (CC));
6844 
6845                --  Values look OK, so find the corresponding record component
6846                --  Even though the syntax allows an attribute reference for
6847                --  implementation-defined components, GNAT does not allow the
6848                --  tag to get an explicit position.
6849 
6850                elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then
6851                   if Attribute_Name (Component_Name (CC)) = Name_Tag then
6852                      Error_Msg_N ("position of tag cannot be specified", CC);
6853                   else
6854                      Error_Msg_N ("illegal component name", CC);
6855                   end if;
6856 
6857                else
6858                   Comp := First_Entity (Rectype);
6859                   while Present (Comp) loop
6860                      exit when Chars (Comp) = Chars (Component_Name (CC));
6861                      Next_Entity (Comp);
6862                   end loop;
6863 
6864                   if No (Comp) then
6865 
6866                      --  Maybe component of base type that is absent from
6867                      --  statically constrained first subtype.
6868 
6869                      Comp := First_Entity (Base_Type (Rectype));
6870                      while Present (Comp) loop
6871                         exit when Chars (Comp) = Chars (Component_Name (CC));
6872                         Next_Entity (Comp);
6873                      end loop;
6874                   end if;
6875 
6876                   if No (Comp) then
6877                      Error_Msg_N
6878                        ("component clause is for non-existent field", CC);
6879 
6880                   --  Ada 2012 (AI05-0026): Any name that denotes a
6881                   --  discriminant of an object of an unchecked union type
6882                   --  shall not occur within a record_representation_clause.
6883 
6884                   --  The general restriction of using record rep clauses on
6885                   --  Unchecked_Union types has now been lifted. Since it is
6886                   --  possible to introduce a record rep clause which mentions
6887                   --  the discriminant of an Unchecked_Union in non-Ada 2012
6888                   --  code, this check is applied to all versions of the
6889                   --  language.
6890 
6891                   elsif Ekind (Comp) = E_Discriminant
6892                     and then Is_Unchecked_Union (Rectype)
6893                   then
6894                      Error_Msg_N
6895                        ("cannot reference discriminant of unchecked union",
6896                         Component_Name (CC));
6897 
6898                   elsif Is_Record_Extension and then Is_Inherited (Comp) then
6899                      Error_Msg_NE
6900                        ("component clause not allowed for inherited "
6901                         & "component&", CC, Comp);
6902 
6903                   elsif Present (Component_Clause (Comp)) then
6904 
6905                      --  Diagnose duplicate rep clause, or check consistency
6906                      --  if this is an inherited component. In a double fault,
6907                      --  there may be a duplicate inconsistent clause for an
6908                      --  inherited component.
6909 
6910                      if Scope (Original_Record_Component (Comp)) = Rectype
6911                        or else Parent (Component_Clause (Comp)) = N
6912                      then
6913                         Error_Msg_Sloc := Sloc (Component_Clause (Comp));
6914                         Error_Msg_N ("component clause previously given#", CC);
6915 
6916                      else
6917                         declare
6918                            Rep1 : constant Node_Id := Component_Clause (Comp);
6919                         begin
6920                            if Intval (Position (Rep1)) /=
6921                                                    Intval (Position (CC))
6922                              or else Intval (First_Bit (Rep1)) /=
6923                                                    Intval (First_Bit (CC))
6924                              or else Intval (Last_Bit (Rep1)) /=
6925                                                    Intval (Last_Bit (CC))
6926                            then
6927                               Error_Msg_N
6928                                 ("component clause inconsistent with "
6929                                  & "representation of ancestor", CC);
6930 
6931                            elsif Warn_On_Redundant_Constructs then
6932                               Error_Msg_N
6933                                 ("?r?redundant confirming component clause "
6934                                  & "for component!", CC);
6935                            end if;
6936                         end;
6937                      end if;
6938 
6939                   --  Normal case where this is the first component clause we
6940                   --  have seen for this entity, so set it up properly.
6941 
6942                   else
6943                      --  Make reference for field in record rep clause and set
6944                      --  appropriate entity field in the field identifier.
6945 
6946                      Generate_Reference
6947                        (Comp, Component_Name (CC), Set_Ref => False);
6948                      Set_Entity (Component_Name (CC), Comp);
6949 
6950                      --  Update Fbit and Lbit to the actual bit number
6951 
6952                      Fbit := Fbit + UI_From_Int (SSU) * Posit;
6953                      Lbit := Lbit + UI_From_Int (SSU) * Posit;
6954 
6955                      if Has_Size_Clause (Rectype)
6956                        and then RM_Size (Rectype) <= Lbit
6957                      then
6958                         Error_Msg_N
6959                           ("bit number out of range of specified size",
6960                            Last_Bit (CC));
6961                      else
6962                         Set_Component_Clause     (Comp, CC);
6963                         Set_Component_Bit_Offset (Comp, Fbit);
6964                         Set_Esize                (Comp, 1 + (Lbit - Fbit));
6965                         Set_Normalized_First_Bit (Comp, Fbit mod SSU);
6966                         Set_Normalized_Position  (Comp, Fbit / SSU);
6967 
6968                         if Warn_On_Overridden_Size
6969                           and then Has_Size_Clause (Etype (Comp))
6970                           and then RM_Size (Etype (Comp)) /= Esize (Comp)
6971                         then
6972                            Error_Msg_NE
6973                              ("?S?component size overrides size clause for&",
6974                               Component_Name (CC), Etype (Comp));
6975                         end if;
6976 
6977                         --  This information is also set in the corresponding
6978                         --  component of the base type, found by accessing the
6979                         --  Original_Record_Component link if it is present.
6980 
6981                         Ocomp := Original_Record_Component (Comp);
6982 
6983                         if Hbit < Lbit then
6984                            Hbit := Lbit;
6985                         end if;
6986 
6987                         Check_Size
6988                           (Component_Name (CC),
6989                            Etype (Comp),
6990                            Esize (Comp),
6991                            Biased);
6992 
6993                         Set_Biased
6994                           (Comp, First_Node (CC), "component clause", Biased);
6995 
6996                         if Present (Ocomp) then
6997                            Set_Component_Clause     (Ocomp, CC);
6998                            Set_Component_Bit_Offset (Ocomp, Fbit);
6999                            Set_Normalized_First_Bit (Ocomp, Fbit mod SSU);
7000                            Set_Normalized_Position  (Ocomp, Fbit / SSU);
7001                            Set_Esize                (Ocomp, 1 + (Lbit - Fbit));
7002 
7003                            Set_Normalized_Position_Max
7004                              (Ocomp, Normalized_Position (Ocomp));
7005 
7006                            --  Note: we don't use Set_Biased here, because we
7007                            --  already gave a warning above if needed, and we
7008                            --  would get a duplicate for the same name here.
7009 
7010                            Set_Has_Biased_Representation
7011                              (Ocomp, Has_Biased_Representation (Comp));
7012                         end if;
7013 
7014                         if Esize (Comp) < 0 then
7015                            Error_Msg_N ("component size is negative", CC);
7016                         end if;
7017                      end if;
7018                   end if;
7019                end if;
7020             end if;
7021          end if;
7022 
7023          Next (CC);
7024       end loop;
7025 
7026       --  Check missing components if Complete_Representation pragma appeared
7027 
7028       if Present (CR_Pragma) then
7029          Comp := First_Component_Or_Discriminant (Rectype);
7030          while Present (Comp) loop
7031             if No (Component_Clause (Comp)) then
7032                Error_Msg_NE
7033                  ("missing component clause for &", CR_Pragma, Comp);
7034             end if;
7035 
7036             Next_Component_Or_Discriminant (Comp);
7037          end loop;
7038 
7039       --  Give missing components warning if required
7040 
7041       elsif Warn_On_Unrepped_Components then
7042          declare
7043             Num_Repped_Components   : Nat := 0;
7044             Num_Unrepped_Components : Nat := 0;
7045 
7046          begin
7047             --  First count number of repped and unrepped components
7048 
7049             Comp := First_Component_Or_Discriminant (Rectype);
7050             while Present (Comp) loop
7051                if Present (Component_Clause (Comp)) then
7052                   Num_Repped_Components := Num_Repped_Components + 1;
7053                else
7054                   Num_Unrepped_Components := Num_Unrepped_Components + 1;
7055                end if;
7056 
7057                Next_Component_Or_Discriminant (Comp);
7058             end loop;
7059 
7060             --  We are only interested in the case where there is at least one
7061             --  unrepped component, and at least half the components have rep
7062             --  clauses. We figure that if less than half have them, then the
7063             --  partial rep clause is really intentional. If the component
7064             --  type has no underlying type set at this point (as for a generic
7065             --  formal type), we don't know enough to give a warning on the
7066             --  component.
7067 
7068             if Num_Unrepped_Components > 0
7069               and then Num_Unrepped_Components < Num_Repped_Components
7070             then
7071                Comp := First_Component_Or_Discriminant (Rectype);
7072                while Present (Comp) loop
7073                   if No (Component_Clause (Comp))
7074                     and then Comes_From_Source (Comp)
7075                     and then Present (Underlying_Type (Etype (Comp)))
7076                     and then (Is_Scalar_Type (Underlying_Type (Etype (Comp)))
7077                                or else Size_Known_At_Compile_Time
7078                                          (Underlying_Type (Etype (Comp))))
7079                     and then not Has_Warnings_Off (Rectype)
7080 
7081                     --  Ignore discriminant in unchecked union, since it is
7082                     --  not there, and cannot have a component clause.
7083 
7084                     and then (not Is_Unchecked_Union (Rectype)
7085                                or else Ekind (Comp) /= E_Discriminant)
7086                   then
7087                      Error_Msg_Sloc := Sloc (Comp);
7088                      Error_Msg_NE
7089                        ("?C?no component clause given for & declared #",
7090                         N, Comp);
7091                   end if;
7092 
7093                   Next_Component_Or_Discriminant (Comp);
7094                end loop;
7095             end if;
7096          end;
7097       end if;
7098    end Analyze_Record_Representation_Clause;
7099 
7100    -------------------------------------
7101    -- Build_Discrete_Static_Predicate --
7102    -------------------------------------
7103 
7104    procedure Build_Discrete_Static_Predicate
7105      (Typ  : Entity_Id;
7106       Expr : Node_Id;
7107       Nam  : Name_Id)
7108    is
7109       Loc : constant Source_Ptr := Sloc (Expr);
7110 
7111       Non_Static : exception;
7112       --  Raised if something non-static is found
7113 
7114       Btyp : constant Entity_Id := Base_Type (Typ);
7115 
7116       BLo : constant Uint := Expr_Value (Type_Low_Bound  (Btyp));
7117       BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp));
7118       --  Low bound and high bound value of base type of Typ
7119 
7120       TLo : Uint;
7121       THi : Uint;
7122       --  Bounds for constructing the static predicate. We use the bound of the
7123       --  subtype if it is static, otherwise the corresponding base type bound.
7124       --  Note: a non-static subtype can have a static predicate.
7125 
7126       type REnt is record
7127          Lo, Hi : Uint;
7128       end record;
7129       --  One entry in a Rlist value, a single REnt (range entry) value denotes
7130       --  one range from Lo to Hi. To represent a single value range Lo = Hi =
7131       --  value.
7132 
7133       type RList is array (Nat range <>) of REnt;
7134       --  A list of ranges. The ranges are sorted in increasing order, and are
7135       --  disjoint (there is a gap of at least one value between each range in
7136       --  the table). A value is in the set of ranges in Rlist if it lies
7137       --  within one of these ranges.
7138 
7139       False_Range : constant RList :=
7140         RList'(1 .. 0 => REnt'(No_Uint, No_Uint));
7141       --  An empty set of ranges represents a range list that can never be
7142       --  satisfied, since there are no ranges in which the value could lie,
7143       --  so it does not lie in any of them. False_Range is a canonical value
7144       --  for this empty set, but general processing should test for an Rlist
7145       --  with length zero (see Is_False predicate), since other null ranges
7146       --  may appear which must be treated as False.
7147 
7148       True_Range : constant RList := RList'(1 => REnt'(BLo, BHi));
7149       --  Range representing True, value must be in the base range
7150 
7151       function "and" (Left : RList; Right : RList) return RList;
7152       --  And's together two range lists, returning a range list. This is a set
7153       --  intersection operation.
7154 
7155       function "or" (Left : RList; Right : RList) return RList;
7156       --  Or's together two range lists, returning a range list. This is a set
7157       --  union operation.
7158 
7159       function "not" (Right : RList) return RList;
7160       --  Returns complement of a given range list, i.e. a range list
7161       --  representing all the values in TLo .. THi that are not in the input
7162       --  operand Right.
7163 
7164       function Build_Val (V : Uint) return Node_Id;
7165       --  Return an analyzed N_Identifier node referencing this value, suitable
7166       --  for use as an entry in the Static_Discrte_Predicate list. This node
7167       --  is typed with the base type.
7168 
7169       function Build_Range (Lo : Uint; Hi : Uint) return Node_Id;
7170       --  Return an analyzed N_Range node referencing this range, suitable for
7171       --  use as an entry in the Static_Discrete_Predicate list. This node is
7172       --  typed with the base type.
7173 
7174       function Get_RList (Exp : Node_Id) return RList;
7175       --  This is a recursive routine that converts the given expression into a
7176       --  list of ranges, suitable for use in building the static predicate.
7177 
7178       function Is_False (R : RList) return Boolean;
7179       pragma Inline (Is_False);
7180       --  Returns True if the given range list is empty, and thus represents a
7181       --  False list of ranges that can never be satisfied.
7182 
7183       function Is_True (R : RList) return Boolean;
7184       --  Returns True if R trivially represents the True predicate by having a
7185       --  single range from BLo to BHi.
7186 
7187       function Is_Type_Ref (N : Node_Id) return Boolean;
7188       pragma Inline (Is_Type_Ref);
7189       --  Returns if True if N is a reference to the type for the predicate in
7190       --  the expression (i.e. if it is an identifier whose Chars field matches
7191       --  the Nam given in the call). N must not be parenthesized, if the type
7192       --  name appears in parens, this routine will return False.
7193 
7194       function Lo_Val (N : Node_Id) return Uint;
7195       --  Given an entry from a Static_Discrete_Predicate list that is either
7196       --  a static expression or static range, gets either the expression value
7197       --  or the low bound of the range.
7198 
7199       function Hi_Val (N : Node_Id) return Uint;
7200       --  Given an entry from a Static_Discrete_Predicate list that is either
7201       --  a static expression or static range, gets either the expression value
7202       --  or the high bound of the range.
7203 
7204       function Membership_Entry (N : Node_Id) return RList;
7205       --  Given a single membership entry (range, value, or subtype), returns
7206       --  the corresponding range list. Raises Static_Error if not static.
7207 
7208       function Membership_Entries (N : Node_Id) return RList;
7209       --  Given an element on an alternatives list of a membership operation,
7210       --  returns the range list corresponding to this entry and all following
7211       --  entries (i.e. returns the "or" of this list of values).
7212 
7213       function Stat_Pred (Typ : Entity_Id) return RList;
7214       --  Given a type, if it has a static predicate, then return the predicate
7215       --  as a range list, otherwise raise Non_Static.
7216 
7217       -----------
7218       -- "and" --
7219       -----------
7220 
7221       function "and" (Left : RList; Right : RList) return RList is
7222          FEnt : REnt;
7223          --  First range of result
7224 
7225          SLeft : Nat := Left'First;
7226          --  Start of rest of left entries
7227 
7228          SRight : Nat := Right'First;
7229          --  Start of rest of right entries
7230 
7231       begin
7232          --  If either range is True, return the other
7233 
7234          if Is_True (Left) then
7235             return Right;
7236          elsif Is_True (Right) then
7237             return Left;
7238          end if;
7239 
7240          --  If either range is False, return False
7241 
7242          if Is_False (Left) or else Is_False (Right) then
7243             return False_Range;
7244          end if;
7245 
7246          --  Loop to remove entries at start that are disjoint, and thus just
7247          --  get discarded from the result entirely.
7248 
7249          loop
7250             --  If no operands left in either operand, result is false
7251 
7252             if SLeft > Left'Last or else SRight > Right'Last then
7253                return False_Range;
7254 
7255             --  Discard first left operand entry if disjoint with right
7256 
7257             elsif Left (SLeft).Hi < Right (SRight).Lo then
7258                SLeft := SLeft + 1;
7259 
7260             --  Discard first right operand entry if disjoint with left
7261 
7262             elsif Right (SRight).Hi < Left (SLeft).Lo then
7263                SRight := SRight + 1;
7264 
7265             --  Otherwise we have an overlapping entry
7266 
7267             else
7268                exit;
7269             end if;
7270          end loop;
7271 
7272          --  Now we have two non-null operands, and first entries overlap. The
7273          --  first entry in the result will be the overlapping part of these
7274          --  two entries.
7275 
7276          FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo),
7277                        Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi));
7278 
7279          --  Now we can remove the entry that ended at a lower value, since its
7280          --  contribution is entirely contained in Fent.
7281 
7282          if Left (SLeft).Hi <= Right (SRight).Hi then
7283             SLeft := SLeft + 1;
7284          else
7285             SRight := SRight + 1;
7286          end if;
7287 
7288          --  Compute result by concatenating this first entry with the "and" of
7289          --  the remaining parts of the left and right operands. Note that if
7290          --  either of these is empty, "and" will yield empty, so that we will
7291          --  end up with just Fent, which is what we want in that case.
7292 
7293          return
7294            FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
7295       end "and";
7296 
7297       -----------
7298       -- "not" --
7299       -----------
7300 
7301       function "not" (Right : RList) return RList is
7302       begin
7303          --  Return True if False range
7304 
7305          if Is_False (Right) then
7306             return True_Range;
7307          end if;
7308 
7309          --  Return False if True range
7310 
7311          if Is_True (Right) then
7312             return False_Range;
7313          end if;
7314 
7315          --  Here if not trivial case
7316 
7317          declare
7318             Result : RList (1 .. Right'Length + 1);
7319             --  May need one more entry for gap at beginning and end
7320 
7321             Count : Nat := 0;
7322             --  Number of entries stored in Result
7323 
7324          begin
7325             --  Gap at start
7326 
7327             if Right (Right'First).Lo > TLo then
7328                Count := Count + 1;
7329                Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1);
7330             end if;
7331 
7332             --  Gaps between ranges
7333 
7334             for J in Right'First .. Right'Last - 1 loop
7335                Count := Count + 1;
7336                Result (Count) := REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1);
7337             end loop;
7338 
7339             --  Gap at end
7340 
7341             if Right (Right'Last).Hi < THi then
7342                Count := Count + 1;
7343                Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi);
7344             end if;
7345 
7346             return Result (1 .. Count);
7347          end;
7348       end "not";
7349 
7350       ----------
7351       -- "or" --
7352       ----------
7353 
7354       function "or" (Left : RList; Right : RList) return RList is
7355          FEnt : REnt;
7356          --  First range of result
7357 
7358          SLeft : Nat := Left'First;
7359          --  Start of rest of left entries
7360 
7361          SRight : Nat := Right'First;
7362          --  Start of rest of right entries
7363 
7364       begin
7365          --  If either range is True, return True
7366 
7367          if Is_True (Left) or else Is_True (Right) then
7368             return True_Range;
7369          end if;
7370 
7371          --  If either range is False (empty), return the other
7372 
7373          if Is_False (Left) then
7374             return Right;
7375          elsif Is_False (Right) then
7376             return Left;
7377          end if;
7378 
7379          --  Initialize result first entry from left or right operand depending
7380          --  on which starts with the lower range.
7381 
7382          if Left (SLeft).Lo < Right (SRight).Lo then
7383             FEnt := Left (SLeft);
7384             SLeft := SLeft + 1;
7385          else
7386             FEnt := Right (SRight);
7387             SRight := SRight + 1;
7388          end if;
7389 
7390          --  This loop eats ranges from left and right operands that are
7391          --  contiguous with the first range we are gathering.
7392 
7393          loop
7394             --  Eat first entry in left operand if contiguous or overlapped by
7395             --  gathered first operand of result.
7396 
7397             if SLeft <= Left'Last
7398               and then Left (SLeft).Lo <= FEnt.Hi + 1
7399             then
7400                FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi);
7401                SLeft := SLeft + 1;
7402 
7403             --  Eat first entry in right operand if contiguous or overlapped by
7404             --  gathered right operand of result.
7405 
7406             elsif SRight <= Right'Last
7407               and then Right (SRight).Lo <= FEnt.Hi + 1
7408             then
7409                FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi);
7410                SRight := SRight + 1;
7411 
7412             --  All done if no more entries to eat
7413 
7414             else
7415                exit;
7416             end if;
7417          end loop;
7418 
7419          --  Obtain result as the first entry we just computed, concatenated
7420          --  to the "or" of the remaining results (if one operand is empty,
7421          --  this will just concatenate with the other
7422 
7423          return
7424            FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last));
7425       end "or";
7426 
7427       -----------------
7428       -- Build_Range --
7429       -----------------
7430 
7431       function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is
7432          Result : Node_Id;
7433       begin
7434          Result :=
7435            Make_Range (Loc,
7436               Low_Bound  => Build_Val (Lo),
7437               High_Bound => Build_Val (Hi));
7438          Set_Etype (Result, Btyp);
7439          Set_Analyzed (Result);
7440          return Result;
7441       end Build_Range;
7442 
7443       ---------------
7444       -- Build_Val --
7445       ---------------
7446 
7447       function Build_Val (V : Uint) return Node_Id is
7448          Result : Node_Id;
7449 
7450       begin
7451          if Is_Enumeration_Type (Typ) then
7452             Result := Get_Enum_Lit_From_Pos (Typ, V, Loc);
7453          else
7454             Result := Make_Integer_Literal (Loc, V);
7455          end if;
7456 
7457          Set_Etype (Result, Btyp);
7458          Set_Is_Static_Expression (Result);
7459          Set_Analyzed (Result);
7460          return Result;
7461       end Build_Val;
7462 
7463       ---------------
7464       -- Get_RList --
7465       ---------------
7466 
7467       function Get_RList (Exp : Node_Id) return RList is
7468          Op  : Node_Kind;
7469          Val : Uint;
7470 
7471       begin
7472          --  Static expression can only be true or false
7473 
7474          if Is_OK_Static_Expression (Exp) then
7475             if Expr_Value (Exp) = 0 then
7476                return False_Range;
7477             else
7478                return True_Range;
7479             end if;
7480          end if;
7481 
7482          --  Otherwise test node type
7483 
7484          Op := Nkind (Exp);
7485 
7486          case Op is
7487 
7488             --  And
7489 
7490             when N_Op_And | N_And_Then =>
7491                return Get_RList (Left_Opnd (Exp))
7492                         and
7493                       Get_RList (Right_Opnd (Exp));
7494 
7495             --  Or
7496 
7497             when N_Op_Or | N_Or_Else =>
7498                return Get_RList (Left_Opnd (Exp))
7499                         or
7500                       Get_RList (Right_Opnd (Exp));
7501 
7502             --  Not
7503 
7504             when N_Op_Not =>
7505                return not Get_RList (Right_Opnd (Exp));
7506 
7507                --  Comparisons of type with static value
7508 
7509             when N_Op_Compare =>
7510 
7511                --  Type is left operand
7512 
7513                if Is_Type_Ref (Left_Opnd (Exp))
7514                  and then Is_OK_Static_Expression (Right_Opnd (Exp))
7515                then
7516                   Val := Expr_Value (Right_Opnd (Exp));
7517 
7518                --  Typ is right operand
7519 
7520                elsif Is_Type_Ref (Right_Opnd (Exp))
7521                  and then Is_OK_Static_Expression (Left_Opnd (Exp))
7522                then
7523                   Val := Expr_Value (Left_Opnd (Exp));
7524 
7525                   --  Invert sense of comparison
7526 
7527                   case Op is
7528                      when N_Op_Gt => Op := N_Op_Lt;
7529                      when N_Op_Lt => Op := N_Op_Gt;
7530                      when N_Op_Ge => Op := N_Op_Le;
7531                      when N_Op_Le => Op := N_Op_Ge;
7532                      when others  => null;
7533                   end case;
7534 
7535                --  Other cases are non-static
7536 
7537                else
7538                   raise Non_Static;
7539                end if;
7540 
7541                --  Construct range according to comparison operation
7542 
7543                case Op is
7544                   when N_Op_Eq =>
7545                      return RList'(1 => REnt'(Val, Val));
7546 
7547                   when N_Op_Ge =>
7548                      return RList'(1 => REnt'(Val, BHi));
7549 
7550                   when N_Op_Gt =>
7551                      return RList'(1 => REnt'(Val + 1, BHi));
7552 
7553                   when N_Op_Le =>
7554                      return RList'(1 => REnt'(BLo, Val));
7555 
7556                   when N_Op_Lt =>
7557                      return RList'(1 => REnt'(BLo, Val - 1));
7558 
7559                   when N_Op_Ne =>
7560                      return RList'(REnt'(BLo, Val - 1), REnt'(Val + 1, BHi));
7561 
7562                   when others  =>
7563                      raise Program_Error;
7564                end case;
7565 
7566             --  Membership (IN)
7567 
7568             when N_In =>
7569                if not Is_Type_Ref (Left_Opnd (Exp)) then
7570                   raise Non_Static;
7571                end if;
7572 
7573                if Present (Right_Opnd (Exp)) then
7574                   return Membership_Entry (Right_Opnd (Exp));
7575                else
7576                   return Membership_Entries (First (Alternatives (Exp)));
7577                end if;
7578 
7579             --  Negative membership (NOT IN)
7580 
7581             when N_Not_In =>
7582                if not Is_Type_Ref (Left_Opnd (Exp)) then
7583                   raise Non_Static;
7584                end if;
7585 
7586                if Present (Right_Opnd (Exp)) then
7587                   return not Membership_Entry (Right_Opnd (Exp));
7588                else
7589                   return not Membership_Entries (First (Alternatives (Exp)));
7590                end if;
7591 
7592             --  Function call, may be call to static predicate
7593 
7594             when N_Function_Call =>
7595                if Is_Entity_Name (Name (Exp)) then
7596                   declare
7597                      Ent : constant Entity_Id := Entity (Name (Exp));
7598                   begin
7599                      if Is_Predicate_Function (Ent)
7600                           or else
7601                         Is_Predicate_Function_M (Ent)
7602                      then
7603                         return Stat_Pred (Etype (First_Formal (Ent)));
7604                      end if;
7605                   end;
7606                end if;
7607 
7608                --  Other function call cases are non-static
7609 
7610                raise Non_Static;
7611 
7612             --  Qualified expression, dig out the expression
7613 
7614             when N_Qualified_Expression =>
7615                return Get_RList (Expression (Exp));
7616 
7617             when N_Case_Expression =>
7618                declare
7619                   Alt     : Node_Id;
7620                   Choices : List_Id;
7621                   Dep     : Node_Id;
7622 
7623                begin
7624                   if not Is_Entity_Name (Expression (Expr))
7625                     or else Etype (Expression (Expr)) /= Typ
7626                   then
7627                      Error_Msg_N
7628                        ("expression must denaote subtype", Expression (Expr));
7629                      return False_Range;
7630                   end if;
7631 
7632                   --  Collect discrete choices in all True alternatives
7633 
7634                   Choices := New_List;
7635                   Alt := First (Alternatives (Exp));
7636                   while Present (Alt) loop
7637                      Dep := Expression (Alt);
7638 
7639                      if not Is_OK_Static_Expression (Dep) then
7640                         raise Non_Static;
7641 
7642                      elsif Is_True (Expr_Value (Dep)) then
7643                         Append_List_To (Choices,
7644                           New_Copy_List (Discrete_Choices (Alt)));
7645                      end if;
7646 
7647                      Next (Alt);
7648                   end loop;
7649 
7650                   return Membership_Entries (First (Choices));
7651                end;
7652 
7653             --  Expression with actions: if no actions, dig out expression
7654 
7655             when N_Expression_With_Actions =>
7656                if Is_Empty_List (Actions (Exp)) then
7657                   return Get_RList (Expression (Exp));
7658                else
7659                   raise Non_Static;
7660                end if;
7661 
7662             --  Xor operator
7663 
7664             when N_Op_Xor =>
7665                return (Get_RList (Left_Opnd (Exp))
7666                         and not Get_RList (Right_Opnd (Exp)))
7667                  or   (Get_RList (Right_Opnd (Exp))
7668                         and not Get_RList (Left_Opnd (Exp)));
7669 
7670             --  Any other node type is non-static
7671 
7672             when others =>
7673                raise Non_Static;
7674          end case;
7675       end Get_RList;
7676 
7677       ------------
7678       -- Hi_Val --
7679       ------------
7680 
7681       function Hi_Val (N : Node_Id) return Uint is
7682       begin
7683          if Is_OK_Static_Expression (N) then
7684             return Expr_Value (N);
7685          else
7686             pragma Assert (Nkind (N) = N_Range);
7687             return Expr_Value (High_Bound (N));
7688          end if;
7689       end Hi_Val;
7690 
7691       --------------
7692       -- Is_False --
7693       --------------
7694 
7695       function Is_False (R : RList) return Boolean is
7696       begin
7697          return R'Length = 0;
7698       end Is_False;
7699 
7700       -------------
7701       -- Is_True --
7702       -------------
7703 
7704       function Is_True (R : RList) return Boolean is
7705       begin
7706          return R'Length = 1
7707            and then R (R'First).Lo = BLo
7708            and then R (R'First).Hi = BHi;
7709       end Is_True;
7710 
7711       -----------------
7712       -- Is_Type_Ref --
7713       -----------------
7714 
7715       function Is_Type_Ref (N : Node_Id) return Boolean is
7716       begin
7717          return Nkind (N) = N_Identifier
7718            and then Chars (N) = Nam
7719            and then Paren_Count (N) = 0;
7720       end Is_Type_Ref;
7721 
7722       ------------
7723       -- Lo_Val --
7724       ------------
7725 
7726       function Lo_Val (N : Node_Id) return Uint is
7727       begin
7728          if Is_OK_Static_Expression (N) then
7729             return Expr_Value (N);
7730          else
7731             pragma Assert (Nkind (N) = N_Range);
7732             return Expr_Value (Low_Bound (N));
7733          end if;
7734       end Lo_Val;
7735 
7736       ------------------------
7737       -- Membership_Entries --
7738       ------------------------
7739 
7740       function Membership_Entries (N : Node_Id) return RList is
7741       begin
7742          if No (Next (N)) then
7743             return Membership_Entry (N);
7744          else
7745             return Membership_Entry (N) or Membership_Entries (Next (N));
7746          end if;
7747       end Membership_Entries;
7748 
7749       ----------------------
7750       -- Membership_Entry --
7751       ----------------------
7752 
7753       function Membership_Entry (N : Node_Id) return RList is
7754          Val : Uint;
7755          SLo : Uint;
7756          SHi : Uint;
7757 
7758       begin
7759          --  Range case
7760 
7761          if Nkind (N) = N_Range then
7762             if not Is_OK_Static_Expression (Low_Bound  (N))
7763                  or else
7764                not Is_OK_Static_Expression (High_Bound (N))
7765             then
7766                raise Non_Static;
7767             else
7768                SLo := Expr_Value (Low_Bound  (N));
7769                SHi := Expr_Value (High_Bound (N));
7770                return RList'(1 => REnt'(SLo, SHi));
7771             end if;
7772 
7773          --  Static expression case
7774 
7775          elsif Is_OK_Static_Expression (N) then
7776             Val := Expr_Value (N);
7777             return RList'(1 => REnt'(Val, Val));
7778 
7779          --  Identifier (other than static expression) case
7780 
7781          else pragma Assert (Nkind (N) = N_Identifier);
7782 
7783             --  Type case
7784 
7785             if Is_Type (Entity (N)) then
7786 
7787                --  If type has predicates, process them
7788 
7789                if Has_Predicates (Entity (N)) then
7790                   return Stat_Pred (Entity (N));
7791 
7792                --  For static subtype without predicates, get range
7793 
7794                elsif Is_OK_Static_Subtype (Entity (N)) then
7795                   SLo := Expr_Value (Type_Low_Bound  (Entity (N)));
7796                   SHi := Expr_Value (Type_High_Bound (Entity (N)));
7797                   return RList'(1 => REnt'(SLo, SHi));
7798 
7799                --  Any other type makes us non-static
7800 
7801                else
7802                   raise Non_Static;
7803                end if;
7804 
7805             --  Any other kind of identifier in predicate (e.g. a non-static
7806             --  expression value) means this is not a static predicate.
7807 
7808             else
7809                raise Non_Static;
7810             end if;
7811          end if;
7812       end Membership_Entry;
7813 
7814       ---------------
7815       -- Stat_Pred --
7816       ---------------
7817 
7818       function Stat_Pred (Typ : Entity_Id) return RList is
7819       begin
7820          --  Not static if type does not have static predicates
7821 
7822          if not Has_Static_Predicate (Typ) then
7823             raise Non_Static;
7824          end if;
7825 
7826          --  Otherwise we convert the predicate list to a range list
7827 
7828          declare
7829             Spred  : constant List_Id := Static_Discrete_Predicate (Typ);
7830             Result : RList (1 .. List_Length (Spred));
7831             P      : Node_Id;
7832 
7833          begin
7834             P := First (Static_Discrete_Predicate (Typ));
7835             for J in Result'Range loop
7836                Result (J) := REnt'(Lo_Val (P), Hi_Val (P));
7837                Next (P);
7838             end loop;
7839 
7840             return Result;
7841          end;
7842       end Stat_Pred;
7843 
7844    --  Start of processing for Build_Discrete_Static_Predicate
7845 
7846    begin
7847       --  Establish bounds for the predicate
7848 
7849       if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
7850          TLo := Expr_Value (Type_Low_Bound (Typ));
7851       else
7852          TLo := BLo;
7853       end if;
7854 
7855       if Compile_Time_Known_Value (Type_High_Bound (Typ)) then
7856          THi := Expr_Value (Type_High_Bound (Typ));
7857       else
7858          THi := BHi;
7859       end if;
7860 
7861       --  Analyze the expression to see if it is a static predicate
7862 
7863       declare
7864          Ranges : constant RList := Get_RList (Expr);
7865          --  Range list from expression if it is static
7866 
7867          Plist : List_Id;
7868 
7869       begin
7870          --  Convert range list into a form for the static predicate. In the
7871          --  Ranges array, we just have raw ranges, these must be converted
7872          --  to properly typed and analyzed static expressions or range nodes.
7873 
7874          --  Note: here we limit ranges to the ranges of the subtype, so that
7875          --  a predicate is always false for values outside the subtype. That
7876          --  seems fine, such values are invalid anyway, and considering them
7877          --  to fail the predicate seems allowed and friendly, and furthermore
7878          --  simplifies processing for case statements and loops.
7879 
7880          Plist := New_List;
7881 
7882          for J in Ranges'Range loop
7883             declare
7884                Lo : Uint := Ranges (J).Lo;
7885                Hi : Uint := Ranges (J).Hi;
7886 
7887             begin
7888                --  Ignore completely out of range entry
7889 
7890                if Hi < TLo or else Lo > THi then
7891                   null;
7892 
7893                --  Otherwise process entry
7894 
7895                else
7896                   --  Adjust out of range value to subtype range
7897 
7898                   if Lo < TLo then
7899                      Lo := TLo;
7900                   end if;
7901 
7902                   if Hi > THi then
7903                      Hi := THi;
7904                   end if;
7905 
7906                   --  Convert range into required form
7907 
7908                   Append_To (Plist, Build_Range (Lo, Hi));
7909                end if;
7910             end;
7911          end loop;
7912 
7913          --  Processing was successful and all entries were static, so now we
7914          --  can store the result as the predicate list.
7915 
7916          Set_Static_Discrete_Predicate (Typ, Plist);
7917 
7918          --  The processing for static predicates put the expression into
7919          --  canonical form as a series of ranges. It also eliminated
7920          --  duplicates and collapsed and combined ranges. We might as well
7921          --  replace the alternatives list of the right operand of the
7922          --  membership test with the static predicate list, which will
7923          --  usually be more efficient.
7924 
7925          declare
7926             New_Alts : constant List_Id := New_List;
7927             Old_Node : Node_Id;
7928             New_Node : Node_Id;
7929 
7930          begin
7931             Old_Node := First (Plist);
7932             while Present (Old_Node) loop
7933                New_Node := New_Copy (Old_Node);
7934 
7935                if Nkind (New_Node) = N_Range then
7936                   Set_Low_Bound  (New_Node, New_Copy (Low_Bound  (Old_Node)));
7937                   Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node)));
7938                end if;
7939 
7940                Append_To (New_Alts, New_Node);
7941                Next (Old_Node);
7942             end loop;
7943 
7944             --  If empty list, replace by False
7945 
7946             if Is_Empty_List (New_Alts) then
7947                Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc));
7948 
7949                --  Else replace by set membership test
7950 
7951             else
7952                Rewrite (Expr,
7953                  Make_In (Loc,
7954                    Left_Opnd    => Make_Identifier (Loc, Nam),
7955                    Right_Opnd   => Empty,
7956                    Alternatives => New_Alts));
7957 
7958                --  Resolve new expression in function context
7959 
7960                Install_Formals (Predicate_Function (Typ));
7961                Push_Scope (Predicate_Function (Typ));
7962                Analyze_And_Resolve (Expr, Standard_Boolean);
7963                Pop_Scope;
7964             end if;
7965          end;
7966       end;
7967 
7968       --  If non-static, return doing nothing
7969 
7970    exception
7971       when Non_Static =>
7972          return;
7973    end Build_Discrete_Static_Predicate;
7974 
7975    --------------------------------
7976    -- Build_Export_Import_Pragma --
7977    --------------------------------
7978 
7979    function Build_Export_Import_Pragma
7980      (Asp : Node_Id;
7981       Id  : Entity_Id) return Node_Id
7982    is
7983       Asp_Id : constant Aspect_Id  := Get_Aspect_Id (Asp);
7984       Expr   : constant Node_Id    := Expression (Asp);
7985       Loc    : constant Source_Ptr := Sloc (Asp);
7986 
7987       Args     : List_Id;
7988       Conv     : Node_Id;
7989       Conv_Arg : Node_Id;
7990       Dummy_1  : Node_Id;
7991       Dummy_2  : Node_Id;
7992       EN       : Node_Id;
7993       LN       : Node_Id;
7994       Prag     : Node_Id;
7995 
7996       Create_Pragma : Boolean := False;
7997       --  This flag is set when the aspect form is such that it warrants the
7998       --  creation of a corresponding pragma.
7999 
8000    begin
8001       if Present (Expr) then
8002          if Error_Posted (Expr) then
8003             null;
8004 
8005          elsif Is_True (Expr_Value (Expr)) then
8006             Create_Pragma := True;
8007          end if;
8008 
8009       --  Otherwise the aspect defaults to True
8010 
8011       else
8012          Create_Pragma := True;
8013       end if;
8014 
8015       --  Nothing to do when the expression is False or is erroneous
8016 
8017       if not Create_Pragma then
8018          return Empty;
8019       end if;
8020 
8021       --  Obtain all interfacing aspects that apply to the related entity
8022 
8023       Get_Interfacing_Aspects
8024         (Iface_Asp => Asp,
8025          Conv_Asp  => Conv,
8026          EN_Asp    => EN,
8027          Expo_Asp  => Dummy_1,
8028          Imp_Asp   => Dummy_2,
8029          LN_Asp    => LN);
8030 
8031       Args := New_List;
8032 
8033       --  Handle the convention argument
8034 
8035       if Present (Conv) then
8036          Conv_Arg := New_Copy_Tree (Expression (Conv));
8037 
8038       --  Assume convention "Ada' when aspect Convention is missing
8039 
8040       else
8041          Conv_Arg := Make_Identifier (Loc, Name_Ada);
8042       end if;
8043 
8044       Append_To (Args,
8045         Make_Pragma_Argument_Association (Loc,
8046           Chars      => Name_Convention,
8047           Expression => Conv_Arg));
8048 
8049       --  Handle the entity argument
8050 
8051       Append_To (Args,
8052         Make_Pragma_Argument_Association (Loc,
8053           Chars      => Name_Entity,
8054           Expression => New_Occurrence_Of (Id, Loc)));
8055 
8056       --  Handle the External_Name argument
8057 
8058       if Present (EN) then
8059          Append_To (Args,
8060            Make_Pragma_Argument_Association (Loc,
8061              Chars      => Name_External_Name,
8062              Expression => New_Copy_Tree (Expression (EN))));
8063       end if;
8064 
8065       --  Handle the Link_Name argument
8066 
8067       if Present (LN) then
8068          Append_To (Args,
8069            Make_Pragma_Argument_Association (Loc,
8070              Chars      => Name_Link_Name,
8071              Expression => New_Copy_Tree (Expression (LN))));
8072       end if;
8073 
8074       --  Generate:
8075       --    pragma Export/Import
8076       --      (Convention    => <Conv>/Ada,
8077       --       Entity        => <Id>,
8078       --      [External_Name => <EN>,]
8079       --      [Link_Name     => <LN>]);
8080 
8081       Prag :=
8082         Make_Pragma (Loc,
8083           Pragma_Identifier            =>
8084             Make_Identifier (Loc, Chars (Identifier (Asp))),
8085           Pragma_Argument_Associations => Args);
8086 
8087       --  Decorate the relevant aspect and the pragma
8088 
8089       Set_Aspect_Rep_Item (Asp, Prag);
8090 
8091       Set_Corresponding_Aspect      (Prag, Asp);
8092       Set_From_Aspect_Specification (Prag);
8093       Set_Parent                    (Prag, Asp);
8094 
8095       if Asp_Id = Aspect_Import and then Is_Subprogram (Id) then
8096          Set_Import_Pragma (Id, Prag);
8097       end if;
8098 
8099       return Prag;
8100    end Build_Export_Import_Pragma;
8101 
8102    -------------------------------
8103    -- Build_Predicate_Functions --
8104    -------------------------------
8105 
8106    --  The procedures that are constructed here have the form:
8107 
8108    --    function typPredicate (Ixxx : typ) return Boolean is
8109    --    begin
8110    --       return
8111    --          typ1Predicate (typ1 (Ixxx))
8112    --          and then typ2Predicate (typ2 (Ixxx))
8113    --          and then ...;
8114    --          exp1 and then exp2 and then ...
8115    --    end typPredicate;
8116 
8117    --  Here exp1, and exp2 are expressions from Predicate pragmas. Note that
8118    --  this is the point at which these expressions get analyzed, providing the
8119    --  required delay, and typ1, typ2, are entities from which predicates are
8120    --  inherited. Note that we do NOT generate Check pragmas, that's because we
8121    --  use this function even if checks are off, e.g. for membership tests.
8122 
8123    --  Note that the inherited predicates are evaluated first, as required by
8124    --  AI12-0071-1.
8125 
8126    --  Note that Sem_Eval.Real_Or_String_Static_Predicate_Matches depends on
8127    --  the form of this return expression.
8128 
8129    --  If the expression has at least one Raise_Expression, then we also build
8130    --  the typPredicateM version of the function, in which any occurrence of a
8131    --  Raise_Expression is converted to "return False".
8132 
8133    procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is
8134       Loc : constant Source_Ptr := Sloc (Typ);
8135 
8136       Expr : Node_Id;
8137       --  This is the expression for the result of the function. It is
8138       --  is build by connecting the component predicates with AND THEN.
8139 
8140       Expr_M : Node_Id;
8141       --  This is the corresponding return expression for the Predicate_M
8142       --  function. It differs in that raise expressions are marked for
8143       --  special expansion (see Process_REs).
8144 
8145       Object_Name : Name_Id;
8146       --  Name for argument of Predicate procedure. Note that we use the same
8147       --  name for both predicate functions. That way the reference within the
8148       --  predicate expression is the same in both functions.
8149 
8150       Object_Entity : Entity_Id;
8151       --  Entity for argument of Predicate procedure
8152 
8153       Object_Entity_M : Entity_Id;
8154       --  Entity for argument of separate Predicate procedure when exceptions
8155       --  are present in expression.
8156 
8157       FDecl : Node_Id;
8158       --  The function declaration
8159 
8160       SId : Entity_Id;
8161       --  Its entity
8162 
8163       Raise_Expression_Present : Boolean := False;
8164       --  Set True if Expr has at least one Raise_Expression
8165 
8166       procedure Add_Condition (Cond : Node_Id);
8167       --  Append Cond to Expr using "and then" (or just copy Cond to Expr if
8168       --  Expr is empty).
8169 
8170       procedure Add_Predicates;
8171       --  Appends expressions for any Predicate pragmas in the rep item chain
8172       --  Typ to Expr. Note that we look only at items for this exact entity.
8173       --  Inheritance of predicates for the parent type is done by calling the
8174       --  Predicate_Function of the parent type, using Add_Call above.
8175 
8176       procedure Add_Call (T : Entity_Id);
8177       --  Includes a call to the predicate function for type T in Expr if T
8178       --  has predicates and Predicate_Function (T) is non-empty.
8179 
8180       function Process_RE (N : Node_Id) return Traverse_Result;
8181       --  Used in Process REs, tests if node N is a raise expression, and if
8182       --  so, marks it to be converted to return False.
8183 
8184       procedure Process_REs is new Traverse_Proc (Process_RE);
8185       --  Marks any raise expressions in Expr_M to return False
8186 
8187       function Test_RE (N : Node_Id) return Traverse_Result;
8188       --  Used in Test_REs, tests one node for being a raise expression, and if
8189       --  so sets Raise_Expression_Present True.
8190 
8191       procedure Test_REs is new Traverse_Proc (Test_RE);
8192       --  Tests to see if Expr contains any raise expressions
8193 
8194       --------------
8195       -- Add_Call --
8196       --------------
8197 
8198       procedure Add_Call (T : Entity_Id) is
8199          Exp : Node_Id;
8200 
8201       begin
8202          if Present (T) and then Present (Predicate_Function (T)) then
8203             Set_Has_Predicates (Typ);
8204 
8205             --  Build the call to the predicate function of T
8206 
8207             Exp :=
8208               Make_Predicate_Call
8209                 (T, Convert_To (T, Make_Identifier (Loc, Object_Name)));
8210 
8211             --  "and"-in the call to evolving expression
8212 
8213             Add_Condition (Exp);
8214 
8215             --  Output info message on inheritance if required. Note we do not
8216             --  give this information for generic actual types, since it is
8217             --  unwelcome noise in that case in instantiations. We also
8218             --  generally suppress the message in instantiations, and also
8219             --  if it involves internal names.
8220 
8221             if Opt.List_Inherited_Aspects
8222               and then not Is_Generic_Actual_Type (Typ)
8223               and then Instantiation_Depth (Sloc (Typ)) = 0
8224               and then not Is_Internal_Name (Chars (T))
8225               and then not Is_Internal_Name (Chars (Typ))
8226             then
8227                Error_Msg_Sloc := Sloc (Predicate_Function (T));
8228                Error_Msg_Node_2 := T;
8229                Error_Msg_N ("info: & inherits predicate from & #?L?", Typ);
8230             end if;
8231          end if;
8232       end Add_Call;
8233 
8234       -------------------
8235       -- Add_Condition --
8236       -------------------
8237 
8238       procedure Add_Condition (Cond : Node_Id) is
8239       begin
8240          --  This is the first predicate expression
8241 
8242          if No (Expr) then
8243             Expr := Cond;
8244 
8245          --  Otherwise concatenate to the existing predicate expressions by
8246          --  using "and then".
8247 
8248          else
8249             Expr :=
8250               Make_And_Then (Loc,
8251                 Left_Opnd  => Relocate_Node (Expr),
8252                 Right_Opnd => Cond);
8253          end if;
8254       end Add_Condition;
8255 
8256       --------------------
8257       -- Add_Predicates --
8258       --------------------
8259 
8260       procedure Add_Predicates is
8261          procedure Add_Predicate (Prag : Node_Id);
8262          --  Concatenate the expression of predicate pragma Prag to Expr by
8263          --  using a short circuit "and then" operator.
8264 
8265          -------------------
8266          -- Add_Predicate --
8267          -------------------
8268 
8269          procedure Add_Predicate (Prag : Node_Id) is
8270             procedure Replace_Type_Reference (N : Node_Id);
8271             --  Replace a single occurrence N of the subtype name with a
8272             --  reference to the formal of the predicate function. N can be an
8273             --  identifier referencing the subtype, or a selected component,
8274             --  representing an appropriately qualified occurrence of the
8275             --  subtype name.
8276 
8277             procedure Replace_Type_References is
8278               new Replace_Type_References_Generic (Replace_Type_Reference);
8279             --  Traverse an expression changing every occurrence of an
8280             --  identifier whose name matches the name of the subtype with a
8281             --  reference to the formal parameter of the predicate function.
8282 
8283             ----------------------------
8284             -- Replace_Type_Reference --
8285             ----------------------------
8286 
8287             procedure Replace_Type_Reference (N : Node_Id) is
8288             begin
8289                Rewrite (N, Make_Identifier (Sloc (N), Object_Name));
8290                --  Use the Sloc of the usage name, not the defining name
8291 
8292                Set_Etype (N, Typ);
8293                Set_Entity (N, Object_Entity);
8294 
8295                --  We want to treat the node as if it comes from source, so
8296                --  that ASIS will not ignore it.
8297 
8298                Set_Comes_From_Source (N, True);
8299             end Replace_Type_Reference;
8300 
8301             --  Local variables
8302 
8303             Asp  : constant Node_Id := Corresponding_Aspect (Prag);
8304             Arg1 : Node_Id;
8305             Arg2 : Node_Id;
8306 
8307          --  Start of processing for Add_Predicate
8308 
8309          begin
8310             --  Extract the arguments of the pragma. The expression itself
8311             --  is copied for use in the predicate function, to preserve the
8312             --  original version for ASIS use.
8313 
8314             Arg1 := First (Pragma_Argument_Associations (Prag));
8315             Arg2 := Next (Arg1);
8316 
8317             Arg1 := Get_Pragma_Arg (Arg1);
8318             Arg2 := New_Copy_Tree (Get_Pragma_Arg (Arg2));
8319 
8320             --  When the predicate pragma applies to the current type or its
8321             --  full view, replace all occurrences of the subtype name with
8322             --  references to the formal parameter of the predicate function.
8323 
8324             if Entity (Arg1) = Typ
8325               or else Full_View (Entity (Arg1)) = Typ
8326             then
8327                Replace_Type_References (Arg2, Typ);
8328 
8329                --  If the predicate pragma comes from an aspect, replace the
8330                --  saved expression because we need the subtype references
8331                --  replaced for the calls to Preanalyze_Spec_Expression in
8332                --  Check_Aspect_At_xxx routines.
8333 
8334                if Present (Asp) then
8335                   Set_Entity (Identifier (Asp), New_Copy_Tree (Arg2));
8336                end if;
8337 
8338                --  "and"-in the Arg2 condition to evolving expression
8339 
8340                Add_Condition (Relocate_Node (Arg2));
8341             end if;
8342          end Add_Predicate;
8343 
8344          --  Local variables
8345 
8346          Ritem : Node_Id;
8347 
8348       --  Start of processing for Add_Predicates
8349 
8350       begin
8351          Ritem := First_Rep_Item (Typ);
8352          while Present (Ritem) loop
8353             if Nkind (Ritem) = N_Pragma
8354               and then Pragma_Name (Ritem) = Name_Predicate
8355             then
8356                Add_Predicate (Ritem);
8357 
8358             --  If the type is declared in an inner package it may be frozen
8359             --  outside of the package, and the generated pragma has not been
8360             --  analyzed yet, so capture the expression for the predicate
8361             --  function at this point.
8362 
8363             elsif Nkind (Ritem) = N_Aspect_Specification
8364               and then Present (Aspect_Rep_Item (Ritem))
8365               and then Scope (Typ) /= Current_Scope
8366             then
8367                declare
8368                   Prag : constant Node_Id := Aspect_Rep_Item (Ritem);
8369 
8370                begin
8371                   if Nkind (Prag) = N_Pragma
8372                     and then Pragma_Name (Prag) = Name_Predicate
8373                   then
8374                      Add_Predicate (Prag);
8375                   end if;
8376                end;
8377             end if;
8378 
8379             Next_Rep_Item (Ritem);
8380          end loop;
8381       end Add_Predicates;
8382 
8383       ----------------
8384       -- Process_RE --
8385       ----------------
8386 
8387       function Process_RE (N : Node_Id) return Traverse_Result is
8388       begin
8389          if Nkind (N) = N_Raise_Expression then
8390             Set_Convert_To_Return_False (N);
8391             return Skip;
8392          else
8393             return OK;
8394          end if;
8395       end Process_RE;
8396 
8397       -------------
8398       -- Test_RE --
8399       -------------
8400 
8401       function Test_RE (N : Node_Id) return Traverse_Result is
8402       begin
8403          if Nkind (N) = N_Raise_Expression then
8404             Raise_Expression_Present := True;
8405             return Abandon;
8406          else
8407             return OK;
8408          end if;
8409       end Test_RE;
8410 
8411       --  Local variables
8412 
8413       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
8414 
8415    --  Start of processing for Build_Predicate_Functions
8416 
8417    begin
8418       --  Return if already built or if type does not have predicates
8419 
8420       SId := Predicate_Function (Typ);
8421       if not Has_Predicates (Typ)
8422         or else (Present (SId) and then Has_Completion (SId))
8423       then
8424          return;
8425       end if;
8426 
8427       --  The related type may be subject to pragma Ghost. Set the mode now to
8428       --  ensure that the predicate functions are properly marked as Ghost.
8429 
8430       Set_Ghost_Mode_From_Entity (Typ);
8431 
8432       --  Prepare to construct predicate expression
8433 
8434       Expr := Empty;
8435 
8436       if Present (SId) then
8437          FDecl := Unit_Declaration_Node (SId);
8438 
8439       else
8440          FDecl := Build_Predicate_Function_Declaration (Typ);
8441          SId   := Defining_Entity (FDecl);
8442       end if;
8443 
8444       --  Recover name of formal parameter of function that replaces references
8445       --  to the type in predicate expressions.
8446 
8447       Object_Entity :=
8448          Defining_Identifier
8449            (First (Parameter_Specifications (Specification (FDecl))));
8450 
8451       Object_Name     := Chars (Object_Entity);
8452       Object_Entity_M := Make_Defining_Identifier (Loc, Chars => Object_Name);
8453 
8454       --  Add predicates for ancestor if present. These must come before the
8455       --  ones for the current type, as required by AI12-0071-1.
8456 
8457       declare
8458          Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
8459       begin
8460          if Present (Atyp) then
8461             Add_Call (Atyp);
8462          end if;
8463       end;
8464 
8465       --  Add Predicates for the current type
8466 
8467       Add_Predicates;
8468 
8469       --  Case where predicates are present
8470 
8471       if Present (Expr) then
8472 
8473          --  Test for raise expression present
8474 
8475          Test_REs (Expr);
8476 
8477          --  If raise expression is present, capture a copy of Expr for use
8478          --  in building the predicateM function version later on. For this
8479          --  copy we replace references to Object_Entity by Object_Entity_M.
8480 
8481          if Raise_Expression_Present then
8482             declare
8483                Map   : constant Elist_Id := New_Elmt_List;
8484                New_V : Entity_Id := Empty;
8485 
8486                --  The unanalyzed expression will be copied and appear in
8487                --  both functions. Normally expressions do not declare new
8488                --  entities, but quantified expressions do, so we need to
8489                --  create new entities for their bound variables, to prevent
8490                --  multiple definitions in gigi.
8491 
8492                function Reset_Loop_Variable (N : Node_Id)
8493                  return Traverse_Result;
8494 
8495                procedure Collect_Loop_Variables is
8496                  new Traverse_Proc (Reset_Loop_Variable);
8497 
8498                ------------------------
8499                -- Reset_Loop_Variable --
8500                ------------------------
8501 
8502                function Reset_Loop_Variable (N : Node_Id)
8503                  return Traverse_Result
8504                is
8505                begin
8506                   if Nkind (N) = N_Iterator_Specification then
8507                      New_V := Make_Defining_Identifier
8508                        (Sloc (N), Chars (Defining_Identifier (N)));
8509 
8510                      Set_Defining_Identifier (N, New_V);
8511                   end if;
8512 
8513                   return OK;
8514                end Reset_Loop_Variable;
8515 
8516             begin
8517                Append_Elmt (Object_Entity, Map);
8518                Append_Elmt (Object_Entity_M, Map);
8519                Expr_M := New_Copy_Tree (Expr, Map => Map);
8520                Collect_Loop_Variables (Expr_M);
8521             end;
8522          end if;
8523 
8524          --  Build the main predicate function
8525 
8526          declare
8527             SIdB : constant Entity_Id :=
8528               Make_Defining_Identifier (Loc,
8529                 Chars => New_External_Name (Chars (Typ), "Predicate"));
8530             --  The entity for the function body
8531 
8532             Spec  : Node_Id;
8533             FBody : Node_Id;
8534 
8535          begin
8536 
8537             --  The predicate function is shared between views of a type
8538 
8539             if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
8540                Set_Predicate_Function (Full_View (Typ), SId);
8541             end if;
8542 
8543             --  Mark the predicate function explicitly as Ghost because it does
8544             --  not come from source.
8545 
8546             if Ghost_Mode > None then
8547                Set_Is_Ghost_Entity (SId);
8548             end if;
8549 
8550             --  Build function body
8551 
8552             Spec :=
8553               Make_Function_Specification (Loc,
8554                 Defining_Unit_Name       => SIdB,
8555                 Parameter_Specifications => New_List (
8556                   Make_Parameter_Specification (Loc,
8557                     Defining_Identifier =>
8558                       Make_Defining_Identifier (Loc, Object_Name),
8559                     Parameter_Type =>
8560                       New_Occurrence_Of (Typ, Loc))),
8561                 Result_Definition        =>
8562                   New_Occurrence_Of (Standard_Boolean, Loc));
8563 
8564             FBody :=
8565               Make_Subprogram_Body (Loc,
8566                 Specification              => Spec,
8567                 Declarations               => Empty_List,
8568                 Handled_Statement_Sequence =>
8569                   Make_Handled_Sequence_Of_Statements (Loc,
8570                     Statements => New_List (
8571                       Make_Simple_Return_Statement (Loc,
8572                         Expression => Expr))));
8573 
8574             --  If declaration has not been analyzed yet, Insert declaration
8575             --  before freeze node.  Insert body itself after freeze node.
8576 
8577             if not Analyzed (FDecl) then
8578                Insert_Before_And_Analyze (N, FDecl);
8579             end if;
8580 
8581             Insert_After_And_Analyze (N, FBody);
8582 
8583             --  Static predicate functions are always side-effect free, and
8584             --  in most cases dynamic predicate functions are as well. Mark
8585             --  them as such whenever possible, so redundant predicate checks
8586             --  can be optimized. If there is a variable reference within the
8587             --  expression, the function is not pure.
8588 
8589             if Expander_Active then
8590                Set_Is_Pure (SId,
8591                  Side_Effect_Free (Expr, Variable_Ref => True));
8592                Set_Is_Inlined (SId);
8593             end if;
8594          end;
8595 
8596          --  Test for raise expressions present and if so build M version
8597 
8598          if Raise_Expression_Present then
8599             declare
8600                SId : constant Entity_Id :=
8601                  Make_Defining_Identifier (Loc,
8602                    Chars => New_External_Name (Chars (Typ), "PredicateM"));
8603                --  The entity for the function spec
8604 
8605                SIdB : constant Entity_Id :=
8606                  Make_Defining_Identifier (Loc,
8607                    Chars => New_External_Name (Chars (Typ), "PredicateM"));
8608                --  The entity for the function body
8609 
8610                Spec  : Node_Id;
8611                FBody : Node_Id;
8612                FDecl : Node_Id;
8613                BTemp : Entity_Id;
8614 
8615             begin
8616                --  Mark any raise expressions for special expansion
8617 
8618                Process_REs (Expr_M);
8619 
8620                --  Build function declaration
8621 
8622                Set_Ekind (SId, E_Function);
8623                Set_Is_Predicate_Function_M (SId);
8624                Set_Predicate_Function_M (Typ, SId);
8625 
8626                --  The predicate function is shared between views of a type
8627 
8628                if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
8629                   Set_Predicate_Function_M (Full_View (Typ), SId);
8630                end if;
8631 
8632                --  Mark the predicate function explicitly as Ghost because it
8633                --  does not come from source.
8634 
8635                if Ghost_Mode > None then
8636                   Set_Is_Ghost_Entity (SId);
8637                end if;
8638 
8639                Spec :=
8640                  Make_Function_Specification (Loc,
8641                    Defining_Unit_Name       => SId,
8642                    Parameter_Specifications => New_List (
8643                      Make_Parameter_Specification (Loc,
8644                        Defining_Identifier => Object_Entity_M,
8645                        Parameter_Type      => New_Occurrence_Of (Typ, Loc))),
8646                    Result_Definition        =>
8647                      New_Occurrence_Of (Standard_Boolean, Loc));
8648 
8649                FDecl :=
8650                  Make_Subprogram_Declaration (Loc,
8651                    Specification => Spec);
8652 
8653                --  Build function body
8654 
8655                Spec :=
8656                  Make_Function_Specification (Loc,
8657                    Defining_Unit_Name       => SIdB,
8658                    Parameter_Specifications => New_List (
8659                      Make_Parameter_Specification (Loc,
8660                        Defining_Identifier =>
8661                          Make_Defining_Identifier (Loc, Object_Name),
8662                        Parameter_Type =>
8663                          New_Occurrence_Of (Typ, Loc))),
8664                    Result_Definition        =>
8665                      New_Occurrence_Of (Standard_Boolean, Loc));
8666 
8667                --  Build the body, we declare the boolean expression before
8668                --  doing the return, because we are not really confident of
8669                --  what happens if a return appears within a return.
8670 
8671                BTemp :=
8672                  Make_Defining_Identifier (Loc,
8673                    Chars => New_Internal_Name ('B'));
8674 
8675                FBody :=
8676                  Make_Subprogram_Body (Loc,
8677                    Specification              => Spec,
8678 
8679                    Declarations               => New_List (
8680                      Make_Object_Declaration (Loc,
8681                        Defining_Identifier => BTemp,
8682                        Constant_Present    => True,
8683                          Object_Definition =>
8684                            New_Occurrence_Of (Standard_Boolean, Loc),
8685                          Expression        => Expr_M)),
8686 
8687                    Handled_Statement_Sequence =>
8688                      Make_Handled_Sequence_Of_Statements (Loc,
8689                        Statements => New_List (
8690                          Make_Simple_Return_Statement (Loc,
8691                            Expression => New_Occurrence_Of (BTemp, Loc)))));
8692 
8693                --  Insert declaration before freeze node and body after
8694 
8695                Insert_Before_And_Analyze (N, FDecl);
8696                Insert_After_And_Analyze  (N, FBody);
8697             end;
8698          end if;
8699 
8700          --  See if we have a static predicate. Note that the answer may be
8701          --  yes even if we have an explicit Dynamic_Predicate present.
8702 
8703          declare
8704             PS : Boolean;
8705             EN : Node_Id;
8706 
8707          begin
8708             if not Is_Scalar_Type (Typ) and then not Is_String_Type (Typ) then
8709                PS := False;
8710             else
8711                PS := Is_Predicate_Static (Expr, Object_Name);
8712             end if;
8713 
8714             --  Case where we have a predicate-static aspect
8715 
8716             if PS then
8717 
8718                --  We don't set Has_Static_Predicate_Aspect, since we can have
8719                --  any of the three cases (Predicate, Dynamic_Predicate, or
8720                --  Static_Predicate) generating a predicate with an expression
8721                --  that is predicate-static. We just indicate that we have a
8722                --  predicate that can be treated as static.
8723 
8724                Set_Has_Static_Predicate (Typ);
8725 
8726                --  For discrete subtype, build the static predicate list
8727 
8728                if Is_Discrete_Type (Typ) then
8729                   Build_Discrete_Static_Predicate (Typ, Expr, Object_Name);
8730 
8731                   --  If we don't get a static predicate list, it means that we
8732                   --  have a case where this is not possible, most typically in
8733                   --  the case where we inherit a dynamic predicate. We do not
8734                   --  consider this an error, we just leave the predicate as
8735                   --  dynamic. But if we do succeed in building the list, then
8736                   --  we mark the predicate as static.
8737 
8738                   if No (Static_Discrete_Predicate (Typ)) then
8739                      Set_Has_Static_Predicate (Typ, False);
8740                   end if;
8741 
8742                --  For real or string subtype, save predicate expression
8743 
8744                elsif Is_Real_Type (Typ) or else Is_String_Type (Typ) then
8745                   Set_Static_Real_Or_String_Predicate (Typ, Expr);
8746                end if;
8747 
8748             --  Case of dynamic predicate (expression is not predicate-static)
8749 
8750             else
8751                --  Again, we don't set Has_Dynamic_Predicate_Aspect, since that
8752                --  is only set if we have an explicit Dynamic_Predicate aspect
8753                --  given. Here we may simply have a Predicate aspect where the
8754                --  expression happens not to be predicate-static.
8755 
8756                --  Emit an error when the predicate is categorized as static
8757                --  but its expression is not predicate-static.
8758 
8759                --  First a little fiddling to get a nice location for the
8760                --  message. If the expression is of the form (A and then B),
8761                --  where A is an inherited predicate, then use the right
8762                --  operand for the Sloc. This avoids getting confused by a call
8763                --  to an inherited predicate with a less convenient source
8764                --  location.
8765 
8766                EN := Expr;
8767                while Nkind (EN) = N_And_Then
8768                  and then Nkind (Left_Opnd (EN)) = N_Function_Call
8769                  and then Is_Predicate_Function
8770                             (Entity (Name (Left_Opnd (EN))))
8771                loop
8772                   EN := Right_Opnd (EN);
8773                end loop;
8774 
8775                --  Now post appropriate message
8776 
8777                if Has_Static_Predicate_Aspect (Typ) then
8778                   if Is_Scalar_Type (Typ) or else Is_String_Type (Typ) then
8779                      Error_Msg_F
8780                        ("expression is not predicate-static (RM 3.2.4(16-22))",
8781                         EN);
8782                   else
8783                      Error_Msg_F
8784                        ("static predicate requires scalar or string type", EN);
8785                   end if;
8786                end if;
8787             end if;
8788          end;
8789       end if;
8790 
8791       Ghost_Mode := Save_Ghost_Mode;
8792    end Build_Predicate_Functions;
8793 
8794    ------------------------------------------
8795    -- Build_Predicate_Function_Declaration --
8796    ------------------------------------------
8797 
8798    function Build_Predicate_Function_Declaration
8799      (Typ : Entity_Id) return Node_Id
8800    is
8801       Loc : constant Source_Ptr := Sloc (Typ);
8802 
8803       Object_Entity : constant Entity_Id :=
8804                         Make_Defining_Identifier (Loc,
8805                           Chars => New_Internal_Name ('I'));
8806 
8807       --  The formal parameter of the function
8808 
8809       SId : constant Entity_Id :=
8810               Make_Defining_Identifier (Loc,
8811                 Chars => New_External_Name (Chars (Typ), "Predicate"));
8812 
8813       --  The entity for the function spec
8814 
8815       FDecl : Node_Id;
8816       Spec  : Node_Id;
8817 
8818    begin
8819       Spec :=
8820         Make_Function_Specification (Loc,
8821           Defining_Unit_Name       => SId,
8822           Parameter_Specifications => New_List (
8823             Make_Parameter_Specification (Loc,
8824               Defining_Identifier => Object_Entity,
8825               Parameter_Type      => New_Occurrence_Of (Typ, Loc))),
8826           Result_Definition        =>
8827             New_Occurrence_Of (Standard_Boolean, Loc));
8828 
8829       FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec);
8830 
8831       Set_Ekind (SId, E_Function);
8832       Set_Etype (SId, Standard_Boolean);
8833       Set_Is_Internal (SId);
8834       Set_Is_Predicate_Function (SId);
8835       Set_Predicate_Function (Typ, SId);
8836 
8837       if Comes_From_Source (Typ) then
8838          Insert_After (Parent (Typ), FDecl);
8839       else
8840          Insert_After (Parent (Base_Type (Typ)), FDecl);
8841       end if;
8842 
8843       Analyze (FDecl);
8844 
8845       return FDecl;
8846    end Build_Predicate_Function_Declaration;
8847 
8848    -----------------------------------------
8849    -- Check_Aspect_At_End_Of_Declarations --
8850    -----------------------------------------
8851 
8852    procedure Check_Aspect_At_End_Of_Declarations (ASN : Node_Id) is
8853       Ent   : constant Entity_Id := Entity     (ASN);
8854       Ident : constant Node_Id   := Identifier (ASN);
8855       A_Id  : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
8856 
8857       End_Decl_Expr : constant Node_Id := Entity (Ident);
8858       --  Expression to be analyzed at end of declarations
8859 
8860       Freeze_Expr : constant Node_Id := Expression (ASN);
8861       --  Expression from call to Check_Aspect_At_Freeze_Point
8862 
8863       T : constant Entity_Id := Etype (Freeze_Expr);
8864       --  Type required for preanalyze call
8865 
8866       Err : Boolean;
8867       --  Set False if error
8868 
8869       --  On entry to this procedure, Entity (Ident) contains a copy of the
8870       --  original expression from the aspect, saved for this purpose, and
8871       --  but Expression (Ident) is a preanalyzed copy of the expression,
8872       --  preanalyzed just after the freeze point.
8873 
8874       procedure Check_Overloaded_Name;
8875       --  For aspects whose expression is simply a name, this routine checks if
8876       --  the name is overloaded or not. If so, it verifies there is an
8877       --  interpretation that matches the entity obtained at the freeze point,
8878       --  otherwise the compiler complains.
8879 
8880       ---------------------------
8881       -- Check_Overloaded_Name --
8882       ---------------------------
8883 
8884       procedure Check_Overloaded_Name is
8885       begin
8886          if not Is_Overloaded (End_Decl_Expr) then
8887             Err := not Is_Entity_Name (End_Decl_Expr)
8888                      or else Entity (End_Decl_Expr) /= Entity (Freeze_Expr);
8889 
8890          else
8891             Err := True;
8892 
8893             declare
8894                Index : Interp_Index;
8895                It    : Interp;
8896 
8897             begin
8898                Get_First_Interp (End_Decl_Expr, Index, It);
8899                while Present (It.Typ) loop
8900                   if It.Nam = Entity (Freeze_Expr) then
8901                      Err := False;
8902                      exit;
8903                   end if;
8904 
8905                   Get_Next_Interp (Index, It);
8906                end loop;
8907             end;
8908          end if;
8909       end Check_Overloaded_Name;
8910 
8911    --  Start of processing for Check_Aspect_At_End_Of_Declarations
8912 
8913    begin
8914       --  In an instance we do not perform the consistency check between freeze
8915       --  point and end of declarations, because it was done already in the
8916       --  analysis of the generic. Furthermore, the delayed analysis of an
8917       --  aspect of the instance may produce spurious errors when the generic
8918       --  is a child unit that references entities in the parent (which might
8919       --  not be in scope at the freeze point of the instance).
8920 
8921       if In_Instance then
8922          return;
8923 
8924       --  Case of aspects Dimension, Dimension_System and Synchronization
8925 
8926       elsif A_Id = Aspect_Synchronization then
8927          return;
8928 
8929       --  Case of stream attributes, just have to compare entities. However,
8930       --  the expression is just a name (possibly overloaded), and there may
8931       --  be stream operations declared for unrelated types, so we just need
8932       --  to verify that one of these interpretations is the one available at
8933       --  at the freeze point.
8934 
8935       elsif A_Id = Aspect_Input  or else
8936             A_Id = Aspect_Output or else
8937             A_Id = Aspect_Read   or else
8938             A_Id = Aspect_Write
8939       then
8940          Analyze (End_Decl_Expr);
8941          Check_Overloaded_Name;
8942 
8943       elsif A_Id = Aspect_Variable_Indexing or else
8944             A_Id = Aspect_Constant_Indexing or else
8945             A_Id = Aspect_Default_Iterator  or else
8946             A_Id = Aspect_Iterator_Element
8947       then
8948          --  Make type unfrozen before analysis, to prevent spurious errors
8949          --  about late attributes.
8950 
8951          Set_Is_Frozen (Ent, False);
8952          Analyze (End_Decl_Expr);
8953          Set_Is_Frozen (Ent, True);
8954 
8955          --  If the end of declarations comes before any other freeze
8956          --  point, the Freeze_Expr is not analyzed: no check needed.
8957 
8958          if Analyzed (Freeze_Expr) and then not In_Instance then
8959             Check_Overloaded_Name;
8960          else
8961             Err := False;
8962          end if;
8963 
8964       --  All other cases
8965 
8966       else
8967          --  Indicate that the expression comes from an aspect specification,
8968          --  which is used in subsequent analysis even if expansion is off.
8969 
8970          Set_Parent (End_Decl_Expr, ASN);
8971 
8972          --  In a generic context the aspect expressions have not been
8973          --  preanalyzed, so do it now. There are no conformance checks
8974          --  to perform in this case.
8975 
8976          if No (T) then
8977             Check_Aspect_At_Freeze_Point (ASN);
8978             return;
8979 
8980          --  The default values attributes may be defined in the private part,
8981          --  and the analysis of the expression may take place when only the
8982          --  partial view is visible. The expression must be scalar, so use
8983          --  the full view to resolve.
8984 
8985          elsif (A_Id = Aspect_Default_Value
8986                   or else
8987                 A_Id = Aspect_Default_Component_Value)
8988             and then Is_Private_Type (T)
8989          then
8990             Preanalyze_Spec_Expression (End_Decl_Expr, Full_View (T));
8991 
8992          else
8993             Preanalyze_Spec_Expression (End_Decl_Expr, T);
8994          end if;
8995 
8996          Err := not Fully_Conformant_Expressions (End_Decl_Expr, Freeze_Expr);
8997       end if;
8998 
8999       --  Output error message if error. Force error on aspect specification
9000       --  even if there is an error on the expression itself.
9001 
9002       if Err then
9003          Error_Msg_NE
9004            ("!visibility of aspect for& changes after freeze point",
9005             ASN, Ent);
9006          Error_Msg_NE
9007            ("info: & is frozen here, aspects evaluated at this point??",
9008             Freeze_Node (Ent), Ent);
9009       end if;
9010    end Check_Aspect_At_End_Of_Declarations;
9011 
9012    ----------------------------------
9013    -- Check_Aspect_At_Freeze_Point --
9014    ----------------------------------
9015 
9016    procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id) is
9017       Ident : constant Node_Id := Identifier (ASN);
9018       --  Identifier (use Entity field to save expression)
9019 
9020       A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
9021 
9022       T : Entity_Id := Empty;
9023       --  Type required for preanalyze call
9024 
9025    begin
9026       --  On entry to this procedure, Entity (Ident) contains a copy of the
9027       --  original expression from the aspect, saved for this purpose.
9028 
9029       --  On exit from this procedure Entity (Ident) is unchanged, still
9030       --  containing that copy, but Expression (Ident) is a preanalyzed copy
9031       --  of the expression, preanalyzed just after the freeze point.
9032 
9033       --  Make a copy of the expression to be preanalyzed
9034 
9035       Set_Expression (ASN, New_Copy_Tree (Entity (Ident)));
9036 
9037       --  Find type for preanalyze call
9038 
9039       case A_Id is
9040 
9041          --  No_Aspect should be impossible
9042 
9043          when No_Aspect =>
9044             raise Program_Error;
9045 
9046          --  Aspects taking an optional boolean argument
9047 
9048          when Boolean_Aspects      |
9049               Library_Unit_Aspects =>
9050 
9051             T := Standard_Boolean;
9052 
9053          --  Aspects corresponding to attribute definition clauses
9054 
9055          when Aspect_Address =>
9056             T := RTE (RE_Address);
9057 
9058          when Aspect_Attach_Handler =>
9059             T := RTE (RE_Interrupt_ID);
9060 
9061          when Aspect_Bit_Order | Aspect_Scalar_Storage_Order =>
9062             T := RTE (RE_Bit_Order);
9063 
9064          when Aspect_Convention =>
9065             return;
9066 
9067          when Aspect_CPU =>
9068             T := RTE (RE_CPU_Range);
9069 
9070          --  Default_Component_Value is resolved with the component type
9071 
9072          when Aspect_Default_Component_Value =>
9073             T := Component_Type (Entity (ASN));
9074 
9075          when Aspect_Default_Storage_Pool =>
9076             T := Class_Wide_Type (RTE (RE_Root_Storage_Pool));
9077 
9078          --  Default_Value is resolved with the type entity in question
9079 
9080          when Aspect_Default_Value =>
9081             T := Entity (ASN);
9082 
9083          when Aspect_Dispatching_Domain =>
9084             T := RTE (RE_Dispatching_Domain);
9085 
9086          when Aspect_External_Tag =>
9087             T := Standard_String;
9088 
9089          when Aspect_External_Name =>
9090             T := Standard_String;
9091 
9092          when Aspect_Link_Name =>
9093             T := Standard_String;
9094 
9095          when Aspect_Priority | Aspect_Interrupt_Priority =>
9096             T := Standard_Integer;
9097 
9098          when Aspect_Relative_Deadline =>
9099             T := RTE (RE_Time_Span);
9100 
9101          when Aspect_Small =>
9102             T := Universal_Real;
9103 
9104          --  For a simple storage pool, we have to retrieve the type of the
9105          --  pool object associated with the aspect's corresponding attribute
9106          --  definition clause.
9107 
9108          when Aspect_Simple_Storage_Pool =>
9109             T := Etype (Expression (Aspect_Rep_Item (ASN)));
9110 
9111          when Aspect_Storage_Pool =>
9112             T := Class_Wide_Type (RTE (RE_Root_Storage_Pool));
9113 
9114          when Aspect_Alignment      |
9115               Aspect_Component_Size |
9116               Aspect_Machine_Radix  |
9117               Aspect_Object_Size    |
9118               Aspect_Size           |
9119               Aspect_Storage_Size   |
9120               Aspect_Stream_Size    |
9121               Aspect_Value_Size     =>
9122             T := Any_Integer;
9123 
9124          when Aspect_Linker_Section =>
9125             T := Standard_String;
9126 
9127          when Aspect_Synchronization =>
9128             return;
9129 
9130          --  Special case, the expression of these aspects is just an entity
9131          --  that does not need any resolution, so just analyze.
9132 
9133          when Aspect_Input      |
9134               Aspect_Output     |
9135               Aspect_Read       |
9136               Aspect_Suppress   |
9137               Aspect_Unsuppress |
9138               Aspect_Warnings   |
9139               Aspect_Write      =>
9140             Analyze (Expression (ASN));
9141             return;
9142 
9143          --  Same for Iterator aspects, where the expression is a function
9144          --  name. Legality rules are checked separately.
9145 
9146          when Aspect_Constant_Indexing |
9147               Aspect_Default_Iterator  |
9148               Aspect_Iterator_Element  |
9149               Aspect_Variable_Indexing =>
9150             Analyze (Expression (ASN));
9151             return;
9152 
9153          --  Ditto for Iterable, legality checks in Validate_Iterable_Aspect.
9154 
9155          when Aspect_Iterable =>
9156             T := Entity (ASN);
9157 
9158             declare
9159                Cursor : constant Entity_Id := Get_Cursor_Type (ASN, T);
9160                Assoc  : Node_Id;
9161                Expr   : Node_Id;
9162 
9163             begin
9164                if Cursor = Any_Type then
9165                   return;
9166                end if;
9167 
9168                Assoc := First (Component_Associations (Expression (ASN)));
9169                while Present (Assoc) loop
9170                   Expr := Expression (Assoc);
9171                   Analyze (Expr);
9172 
9173                   if not Error_Posted (Expr) then
9174                      Resolve_Iterable_Operation
9175                        (Expr, Cursor, T, Chars (First (Choices (Assoc))));
9176                   end if;
9177 
9178                   Next (Assoc);
9179                end loop;
9180             end;
9181 
9182             return;
9183 
9184          --  Invariant/Predicate take boolean expressions
9185 
9186          when Aspect_Dynamic_Predicate |
9187               Aspect_Invariant         |
9188               Aspect_Predicate         |
9189               Aspect_Static_Predicate  |
9190               Aspect_Type_Invariant    =>
9191             T := Standard_Boolean;
9192 
9193          when Aspect_Predicate_Failure =>
9194             T := Standard_String;
9195 
9196          --  Here is the list of aspects that don't require delay analysis
9197 
9198          when Aspect_Abstract_State             |
9199               Aspect_Annotate                   |
9200               Aspect_Async_Readers              |
9201               Aspect_Async_Writers              |
9202               Aspect_Constant_After_Elaboration |
9203               Aspect_Contract_Cases             |
9204               Aspect_Default_Initial_Condition  |
9205               Aspect_Depends                    |
9206               Aspect_Dimension                  |
9207               Aspect_Dimension_System           |
9208               Aspect_Effective_Reads            |
9209               Aspect_Effective_Writes           |
9210               Aspect_Extensions_Visible         |
9211               Aspect_Ghost                      |
9212               Aspect_Global                     |
9213               Aspect_Implicit_Dereference       |
9214               Aspect_Initial_Condition          |
9215               Aspect_Initializes                |
9216               Aspect_Obsolescent                |
9217               Aspect_Part_Of                    |
9218               Aspect_Post                       |
9219               Aspect_Postcondition              |
9220               Aspect_Pre                        |
9221               Aspect_Precondition               |
9222               Aspect_Refined_Depends            |
9223               Aspect_Refined_Global             |
9224               Aspect_Refined_Post               |
9225               Aspect_Refined_State              |
9226               Aspect_SPARK_Mode                 |
9227               Aspect_Test_Case                  |
9228               Aspect_Unimplemented              |
9229               Aspect_Volatile_Function          =>
9230             raise Program_Error;
9231 
9232       end case;
9233 
9234       --  Do the preanalyze call
9235 
9236       Preanalyze_Spec_Expression (Expression (ASN), T);
9237    end Check_Aspect_At_Freeze_Point;
9238 
9239    -----------------------------------
9240    -- Check_Constant_Address_Clause --
9241    -----------------------------------
9242 
9243    procedure Check_Constant_Address_Clause
9244      (Expr  : Node_Id;
9245       U_Ent : Entity_Id)
9246    is
9247       procedure Check_At_Constant_Address (Nod : Node_Id);
9248       --  Checks that the given node N represents a name whose 'Address is
9249       --  constant (in the same sense as OK_Constant_Address_Clause, i.e. the
9250       --  address value is the same at the point of declaration of U_Ent and at
9251       --  the time of elaboration of the address clause.
9252 
9253       procedure Check_Expr_Constants (Nod : Node_Id);
9254       --  Checks that Nod meets the requirements for a constant address clause
9255       --  in the sense of the enclosing procedure.
9256 
9257       procedure Check_List_Constants (Lst : List_Id);
9258       --  Check that all elements of list Lst meet the requirements for a
9259       --  constant address clause in the sense of the enclosing procedure.
9260 
9261       -------------------------------
9262       -- Check_At_Constant_Address --
9263       -------------------------------
9264 
9265       procedure Check_At_Constant_Address (Nod : Node_Id) is
9266       begin
9267          if Is_Entity_Name (Nod) then
9268             if Present (Address_Clause (Entity ((Nod)))) then
9269                Error_Msg_NE
9270                  ("invalid address clause for initialized object &!",
9271                            Nod, U_Ent);
9272                Error_Msg_NE
9273                  ("address for& cannot" &
9274                     " depend on another address clause! (RM 13.1(22))!",
9275                   Nod, U_Ent);
9276 
9277             elsif In_Same_Source_Unit (Entity (Nod), U_Ent)
9278               and then Sloc (U_Ent) < Sloc (Entity (Nod))
9279             then
9280                Error_Msg_NE
9281                  ("invalid address clause for initialized object &!",
9282                   Nod, U_Ent);
9283                Error_Msg_Node_2 := U_Ent;
9284                Error_Msg_NE
9285                  ("\& must be defined before & (RM 13.1(22))!",
9286                   Nod, Entity (Nod));
9287             end if;
9288 
9289          elsif Nkind (Nod) = N_Selected_Component then
9290             declare
9291                T : constant Entity_Id := Etype (Prefix (Nod));
9292 
9293             begin
9294                if (Is_Record_Type (T)
9295                     and then Has_Discriminants (T))
9296                  or else
9297                   (Is_Access_Type (T)
9298                     and then Is_Record_Type (Designated_Type (T))
9299                     and then Has_Discriminants (Designated_Type (T)))
9300                then
9301                   Error_Msg_NE
9302                     ("invalid address clause for initialized object &!",
9303                      Nod, U_Ent);
9304                   Error_Msg_N
9305                     ("\address cannot depend on component" &
9306                      " of discriminated record (RM 13.1(22))!",
9307                      Nod);
9308                else
9309                   Check_At_Constant_Address (Prefix (Nod));
9310                end if;
9311             end;
9312 
9313          elsif Nkind (Nod) = N_Indexed_Component then
9314             Check_At_Constant_Address (Prefix (Nod));
9315             Check_List_Constants (Expressions (Nod));
9316 
9317          else
9318             Check_Expr_Constants (Nod);
9319          end if;
9320       end Check_At_Constant_Address;
9321 
9322       --------------------------
9323       -- Check_Expr_Constants --
9324       --------------------------
9325 
9326       procedure Check_Expr_Constants (Nod : Node_Id) is
9327          Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent);
9328          Ent       : Entity_Id           := Empty;
9329 
9330       begin
9331          if Nkind (Nod) in N_Has_Etype
9332            and then Etype (Nod) = Any_Type
9333          then
9334             return;
9335          end if;
9336 
9337          case Nkind (Nod) is
9338             when N_Empty | N_Error =>
9339                return;
9340 
9341             when N_Identifier | N_Expanded_Name =>
9342                Ent := Entity (Nod);
9343 
9344                --  We need to look at the original node if it is different
9345                --  from the node, since we may have rewritten things and
9346                --  substituted an identifier representing the rewrite.
9347 
9348                if Original_Node (Nod) /= Nod then
9349                   Check_Expr_Constants (Original_Node (Nod));
9350 
9351                   --  If the node is an object declaration without initial
9352                   --  value, some code has been expanded, and the expression
9353                   --  is not constant, even if the constituents might be
9354                   --  acceptable, as in A'Address + offset.
9355 
9356                   if Ekind (Ent) = E_Variable
9357                     and then
9358                       Nkind (Declaration_Node (Ent)) = N_Object_Declaration
9359                     and then
9360                       No (Expression (Declaration_Node (Ent)))
9361                   then
9362                      Error_Msg_NE
9363                        ("invalid address clause for initialized object &!",
9364                         Nod, U_Ent);
9365 
9366                   --  If entity is constant, it may be the result of expanding
9367                   --  a check. We must verify that its declaration appears
9368                   --  before the object in question, else we also reject the
9369                   --  address clause.
9370 
9371                   elsif Ekind (Ent) = E_Constant
9372                     and then In_Same_Source_Unit (Ent, U_Ent)
9373                     and then Sloc (Ent) > Loc_U_Ent
9374                   then
9375                      Error_Msg_NE
9376                        ("invalid address clause for initialized object &!",
9377                         Nod, U_Ent);
9378                   end if;
9379 
9380                   return;
9381                end if;
9382 
9383                --  Otherwise look at the identifier and see if it is OK
9384 
9385                if Ekind_In (Ent, E_Named_Integer, E_Named_Real)
9386                  or else Is_Type (Ent)
9387                then
9388                   return;
9389 
9390                elsif Ekind_In (Ent, E_Constant, E_In_Parameter) then
9391 
9392                   --  This is the case where we must have Ent defined before
9393                   --  U_Ent. Clearly if they are in different units this
9394                   --  requirement is met since the unit containing Ent is
9395                   --  already processed.
9396 
9397                   if not In_Same_Source_Unit (Ent, U_Ent) then
9398                      return;
9399 
9400                   --  Otherwise location of Ent must be before the location
9401                   --  of U_Ent, that's what prior defined means.
9402 
9403                   elsif Sloc (Ent) < Loc_U_Ent then
9404                      return;
9405 
9406                   else
9407                      Error_Msg_NE
9408                        ("invalid address clause for initialized object &!",
9409                         Nod, U_Ent);
9410                      Error_Msg_Node_2 := U_Ent;
9411                      Error_Msg_NE
9412                        ("\& must be defined before & (RM 13.1(22))!",
9413                         Nod, Ent);
9414                   end if;
9415 
9416                elsif Nkind (Original_Node (Nod)) = N_Function_Call then
9417                   Check_Expr_Constants (Original_Node (Nod));
9418 
9419                else
9420                   Error_Msg_NE
9421                     ("invalid address clause for initialized object &!",
9422                      Nod, U_Ent);
9423 
9424                   if Comes_From_Source (Ent) then
9425                      Error_Msg_NE
9426                        ("\reference to variable& not allowed"
9427                           & " (RM 13.1(22))!", Nod, Ent);
9428                   else
9429                      Error_Msg_N
9430                        ("non-static expression not allowed"
9431                           & " (RM 13.1(22))!", Nod);
9432                   end if;
9433                end if;
9434 
9435             when N_Integer_Literal   =>
9436 
9437                --  If this is a rewritten unchecked conversion, in a system
9438                --  where Address is an integer type, always use the base type
9439                --  for a literal value. This is user-friendly and prevents
9440                --  order-of-elaboration issues with instances of unchecked
9441                --  conversion.
9442 
9443                if Nkind (Original_Node (Nod)) = N_Function_Call then
9444                   Set_Etype (Nod, Base_Type (Etype (Nod)));
9445                end if;
9446 
9447             when N_Real_Literal      |
9448                  N_String_Literal    |
9449                  N_Character_Literal =>
9450                return;
9451 
9452             when N_Range =>
9453                Check_Expr_Constants (Low_Bound (Nod));
9454                Check_Expr_Constants (High_Bound (Nod));
9455 
9456             when N_Explicit_Dereference =>
9457                Check_Expr_Constants (Prefix (Nod));
9458 
9459             when N_Indexed_Component =>
9460                Check_Expr_Constants (Prefix (Nod));
9461                Check_List_Constants (Expressions (Nod));
9462 
9463             when N_Slice =>
9464                Check_Expr_Constants (Prefix (Nod));
9465                Check_Expr_Constants (Discrete_Range (Nod));
9466 
9467             when N_Selected_Component =>
9468                Check_Expr_Constants (Prefix (Nod));
9469 
9470             when N_Attribute_Reference =>
9471                if Nam_In (Attribute_Name (Nod), Name_Address,
9472                                                 Name_Access,
9473                                                 Name_Unchecked_Access,
9474                                                 Name_Unrestricted_Access)
9475                then
9476                   Check_At_Constant_Address (Prefix (Nod));
9477 
9478                else
9479                   Check_Expr_Constants (Prefix (Nod));
9480                   Check_List_Constants (Expressions (Nod));
9481                end if;
9482 
9483             when N_Aggregate =>
9484                Check_List_Constants (Component_Associations (Nod));
9485                Check_List_Constants (Expressions (Nod));
9486 
9487             when N_Component_Association =>
9488                Check_Expr_Constants (Expression (Nod));
9489 
9490             when N_Extension_Aggregate =>
9491                Check_Expr_Constants (Ancestor_Part (Nod));
9492                Check_List_Constants (Component_Associations (Nod));
9493                Check_List_Constants (Expressions (Nod));
9494 
9495             when N_Null =>
9496                return;
9497 
9498             when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
9499                Check_Expr_Constants (Left_Opnd (Nod));
9500                Check_Expr_Constants (Right_Opnd (Nod));
9501 
9502             when N_Unary_Op =>
9503                Check_Expr_Constants (Right_Opnd (Nod));
9504 
9505             when N_Type_Conversion           |
9506                  N_Qualified_Expression      |
9507                  N_Allocator                 |
9508                  N_Unchecked_Type_Conversion =>
9509                Check_Expr_Constants (Expression (Nod));
9510 
9511             when N_Function_Call =>
9512                if not Is_Pure (Entity (Name (Nod))) then
9513                   Error_Msg_NE
9514                     ("invalid address clause for initialized object &!",
9515                      Nod, U_Ent);
9516 
9517                   Error_Msg_NE
9518                     ("\function & is not pure (RM 13.1(22))!",
9519                      Nod, Entity (Name (Nod)));
9520 
9521                else
9522                   Check_List_Constants (Parameter_Associations (Nod));
9523                end if;
9524 
9525             when N_Parameter_Association =>
9526                Check_Expr_Constants (Explicit_Actual_Parameter (Nod));
9527 
9528             when others =>
9529                Error_Msg_NE
9530                  ("invalid address clause for initialized object &!",
9531                   Nod, U_Ent);
9532                Error_Msg_NE
9533                  ("\must be constant defined before& (RM 13.1(22))!",
9534                   Nod, U_Ent);
9535          end case;
9536       end Check_Expr_Constants;
9537 
9538       --------------------------
9539       -- Check_List_Constants --
9540       --------------------------
9541 
9542       procedure Check_List_Constants (Lst : List_Id) is
9543          Nod1 : Node_Id;
9544 
9545       begin
9546          if Present (Lst) then
9547             Nod1 := First (Lst);
9548             while Present (Nod1) loop
9549                Check_Expr_Constants (Nod1);
9550                Next (Nod1);
9551             end loop;
9552          end if;
9553       end Check_List_Constants;
9554 
9555    --  Start of processing for Check_Constant_Address_Clause
9556 
9557    begin
9558       --  If rep_clauses are to be ignored, no need for legality checks. In
9559       --  particular, no need to pester user about rep clauses that violate the
9560       --  rule on constant addresses, given that these clauses will be removed
9561       --  by Freeze before they reach the back end. Similarly in CodePeer mode,
9562       --  we want to relax these checks.
9563 
9564       if not Ignore_Rep_Clauses and not CodePeer_Mode then
9565          Check_Expr_Constants (Expr);
9566       end if;
9567    end Check_Constant_Address_Clause;
9568 
9569    ---------------------------
9570    -- Check_Pool_Size_Clash --
9571    ---------------------------
9572 
9573    procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id) is
9574       Post : Node_Id;
9575 
9576    begin
9577       --  We need to find out which one came first. Note that in the case of
9578       --  aspects mixed with pragmas there are cases where the processing order
9579       --  is reversed, which is why we do the check here.
9580 
9581       if Sloc (SP) < Sloc (SS) then
9582          Error_Msg_Sloc := Sloc (SP);
9583          Post := SS;
9584          Error_Msg_NE ("Storage_Pool previously given for&#", Post, Ent);
9585 
9586       else
9587          Error_Msg_Sloc := Sloc (SS);
9588          Post := SP;
9589          Error_Msg_NE ("Storage_Size previously given for&#", Post, Ent);
9590       end if;
9591 
9592       Error_Msg_N
9593         ("\cannot have Storage_Size and Storage_Pool (RM 13.11(3))", Post);
9594    end Check_Pool_Size_Clash;
9595 
9596    ----------------------------------------
9597    -- Check_Record_Representation_Clause --
9598    ----------------------------------------
9599 
9600    procedure Check_Record_Representation_Clause (N : Node_Id) is
9601       Loc     : constant Source_Ptr := Sloc (N);
9602       Ident   : constant Node_Id    := Identifier (N);
9603       Rectype : Entity_Id;
9604       Fent    : Entity_Id;
9605       CC      : Node_Id;
9606       Fbit    : Uint;
9607       Lbit    : Uint;
9608       Hbit    : Uint := Uint_0;
9609       Comp    : Entity_Id;
9610       Pcomp   : Entity_Id;
9611 
9612       Max_Bit_So_Far : Uint;
9613       --  Records the maximum bit position so far. If all field positions
9614       --  are monotonically increasing, then we can skip the circuit for
9615       --  checking for overlap, since no overlap is possible.
9616 
9617       Tagged_Parent : Entity_Id := Empty;
9618       --  This is set in the case of a derived tagged type for which we have
9619       --  Is_Fully_Repped_Tagged_Type True (indicating that all components are
9620       --  positioned by record representation clauses). In this case we must
9621       --  check for overlap between components of this tagged type, and the
9622       --  components of its parent. Tagged_Parent will point to this parent
9623       --  type. For all other cases Tagged_Parent is left set to Empty.
9624 
9625       Parent_Last_Bit : Uint;
9626       --  Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the
9627       --  last bit position for any field in the parent type. We only need to
9628       --  check overlap for fields starting below this point.
9629 
9630       Overlap_Check_Required : Boolean;
9631       --  Used to keep track of whether or not an overlap check is required
9632 
9633       Overlap_Detected : Boolean := False;
9634       --  Set True if an overlap is detected
9635 
9636       Ccount : Natural := 0;
9637       --  Number of component clauses in record rep clause
9638 
9639       procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id);
9640       --  Given two entities for record components or discriminants, checks
9641       --  if they have overlapping component clauses and issues errors if so.
9642 
9643       procedure Find_Component;
9644       --  Finds component entity corresponding to current component clause (in
9645       --  CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin
9646       --  start/stop bits for the field. If there is no matching component or
9647       --  if the matching component does not have a component clause, then
9648       --  that's an error and Comp is set to Empty, but no error message is
9649       --  issued, since the message was already given. Comp is also set to
9650       --  Empty if the current "component clause" is in fact a pragma.
9651 
9652       -----------------------------
9653       -- Check_Component_Overlap --
9654       -----------------------------
9655 
9656       procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is
9657          CC1 : constant Node_Id := Component_Clause (C1_Ent);
9658          CC2 : constant Node_Id := Component_Clause (C2_Ent);
9659 
9660       begin
9661          if Present (CC1) and then Present (CC2) then
9662 
9663             --  Exclude odd case where we have two tag components in the same
9664             --  record, both at location zero. This seems a bit strange, but
9665             --  it seems to happen in some circumstances, perhaps on an error.
9666 
9667             if Nam_In (Chars (C1_Ent), Name_uTag, Name_uTag) then
9668                return;
9669             end if;
9670 
9671             --  Here we check if the two fields overlap
9672 
9673             declare
9674                S1 : constant Uint := Component_Bit_Offset (C1_Ent);
9675                S2 : constant Uint := Component_Bit_Offset (C2_Ent);
9676                E1 : constant Uint := S1 + Esize (C1_Ent);
9677                E2 : constant Uint := S2 + Esize (C2_Ent);
9678 
9679             begin
9680                if E2 <= S1 or else E1 <= S2 then
9681                   null;
9682                else
9683                   Error_Msg_Node_2 := Component_Name (CC2);
9684                   Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
9685                   Error_Msg_Node_1 := Component_Name (CC1);
9686                   Error_Msg_N
9687                     ("component& overlaps & #", Component_Name (CC1));
9688                   Overlap_Detected := True;
9689                end if;
9690             end;
9691          end if;
9692       end Check_Component_Overlap;
9693 
9694       --------------------
9695       -- Find_Component --
9696       --------------------
9697 
9698       procedure Find_Component is
9699 
9700          procedure Search_Component (R : Entity_Id);
9701          --  Search components of R for a match. If found, Comp is set
9702 
9703          ----------------------
9704          -- Search_Component --
9705          ----------------------
9706 
9707          procedure Search_Component (R : Entity_Id) is
9708          begin
9709             Comp := First_Component_Or_Discriminant (R);
9710             while Present (Comp) loop
9711 
9712                --  Ignore error of attribute name for component name (we
9713                --  already gave an error message for this, so no need to
9714                --  complain here)
9715 
9716                if Nkind (Component_Name (CC)) = N_Attribute_Reference then
9717                   null;
9718                else
9719                   exit when Chars (Comp) = Chars (Component_Name (CC));
9720                end if;
9721 
9722                Next_Component_Or_Discriminant (Comp);
9723             end loop;
9724          end Search_Component;
9725 
9726       --  Start of processing for Find_Component
9727 
9728       begin
9729          --  Return with Comp set to Empty if we have a pragma
9730 
9731          if Nkind (CC) = N_Pragma then
9732             Comp := Empty;
9733             return;
9734          end if;
9735 
9736          --  Search current record for matching component
9737 
9738          Search_Component (Rectype);
9739 
9740          --  If not found, maybe component of base type discriminant that is
9741          --  absent from statically constrained first subtype.
9742 
9743          if No (Comp) then
9744             Search_Component (Base_Type (Rectype));
9745          end if;
9746 
9747          --  If no component, or the component does not reference the component
9748          --  clause in question, then there was some previous error for which
9749          --  we already gave a message, so just return with Comp Empty.
9750 
9751          if No (Comp) or else Component_Clause (Comp) /= CC then
9752             Check_Error_Detected;
9753             Comp := Empty;
9754 
9755          --  Normal case where we have a component clause
9756 
9757          else
9758             Fbit := Component_Bit_Offset (Comp);
9759             Lbit := Fbit + Esize (Comp) - 1;
9760          end if;
9761       end Find_Component;
9762 
9763    --  Start of processing for Check_Record_Representation_Clause
9764 
9765    begin
9766       Find_Type (Ident);
9767       Rectype := Entity (Ident);
9768 
9769       if Rectype = Any_Type then
9770          return;
9771       else
9772          Rectype := Underlying_Type (Rectype);
9773       end if;
9774 
9775       --  See if we have a fully repped derived tagged type
9776 
9777       declare
9778          PS : constant Entity_Id := Parent_Subtype (Rectype);
9779 
9780       begin
9781          if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then
9782             Tagged_Parent := PS;
9783 
9784             --  Find maximum bit of any component of the parent type
9785 
9786             Parent_Last_Bit := UI_From_Int (System_Address_Size - 1);
9787             Pcomp := First_Entity (Tagged_Parent);
9788             while Present (Pcomp) loop
9789                if Ekind_In (Pcomp, E_Discriminant, E_Component) then
9790                   if Component_Bit_Offset (Pcomp) /= No_Uint
9791                     and then Known_Static_Esize (Pcomp)
9792                   then
9793                      Parent_Last_Bit :=
9794                        UI_Max
9795                          (Parent_Last_Bit,
9796                           Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1);
9797                   end if;
9798                else
9799 
9800                   --  Skip anonymous types generated for constrained array
9801                   --  or record components.
9802 
9803                   null;
9804                end if;
9805 
9806                Next_Entity (Pcomp);
9807             end loop;
9808          end if;
9809       end;
9810 
9811       --  All done if no component clauses
9812 
9813       CC := First (Component_Clauses (N));
9814 
9815       if No (CC) then
9816          return;
9817       end if;
9818 
9819       --  If a tag is present, then create a component clause that places it
9820       --  at the start of the record (otherwise gigi may place it after other
9821       --  fields that have rep clauses).
9822 
9823       Fent := First_Entity (Rectype);
9824 
9825       if Nkind (Fent) = N_Defining_Identifier
9826         and then Chars (Fent) = Name_uTag
9827       then
9828          Set_Component_Bit_Offset    (Fent, Uint_0);
9829          Set_Normalized_Position     (Fent, Uint_0);
9830          Set_Normalized_First_Bit    (Fent, Uint_0);
9831          Set_Normalized_Position_Max (Fent, Uint_0);
9832          Init_Esize                  (Fent, System_Address_Size);
9833 
9834          Set_Component_Clause (Fent,
9835            Make_Component_Clause (Loc,
9836              Component_Name => Make_Identifier (Loc, Name_uTag),
9837 
9838              Position  => Make_Integer_Literal (Loc, Uint_0),
9839              First_Bit => Make_Integer_Literal (Loc, Uint_0),
9840              Last_Bit  =>
9841                Make_Integer_Literal (Loc,
9842                  UI_From_Int (System_Address_Size))));
9843 
9844          Ccount := Ccount + 1;
9845       end if;
9846 
9847       Max_Bit_So_Far := Uint_Minus_1;
9848       Overlap_Check_Required := False;
9849 
9850       --  Process the component clauses
9851 
9852       while Present (CC) loop
9853          Find_Component;
9854 
9855          if Present (Comp) then
9856             Ccount := Ccount + 1;
9857 
9858             --  We need a full overlap check if record positions non-monotonic
9859 
9860             if Fbit <= Max_Bit_So_Far then
9861                Overlap_Check_Required := True;
9862             end if;
9863 
9864             Max_Bit_So_Far := Lbit;
9865 
9866             --  Check bit position out of range of specified size
9867 
9868             if Has_Size_Clause (Rectype)
9869               and then RM_Size (Rectype) <= Lbit
9870             then
9871                Error_Msg_N
9872                  ("bit number out of range of specified size",
9873                   Last_Bit (CC));
9874 
9875                --  Check for overlap with tag component
9876 
9877             else
9878                if Is_Tagged_Type (Rectype)
9879                  and then Fbit < System_Address_Size
9880                then
9881                   Error_Msg_NE
9882                     ("component overlaps tag field of&",
9883                      Component_Name (CC), Rectype);
9884                   Overlap_Detected := True;
9885                end if;
9886 
9887                if Hbit < Lbit then
9888                   Hbit := Lbit;
9889                end if;
9890             end if;
9891 
9892             --  Check parent overlap if component might overlap parent field
9893 
9894             if Present (Tagged_Parent) and then Fbit <= Parent_Last_Bit then
9895                Pcomp := First_Component_Or_Discriminant (Tagged_Parent);
9896                while Present (Pcomp) loop
9897                   if not Is_Tag (Pcomp)
9898                     and then Chars (Pcomp) /= Name_uParent
9899                   then
9900                      Check_Component_Overlap (Comp, Pcomp);
9901                   end if;
9902 
9903                   Next_Component_Or_Discriminant (Pcomp);
9904                end loop;
9905             end if;
9906          end if;
9907 
9908          Next (CC);
9909       end loop;
9910 
9911       --  Now that we have processed all the component clauses, check for
9912       --  overlap. We have to leave this till last, since the components can
9913       --  appear in any arbitrary order in the representation clause.
9914 
9915       --  We do not need this check if all specified ranges were monotonic,
9916       --  as recorded by Overlap_Check_Required being False at this stage.
9917 
9918       --  This first section checks if there are any overlapping entries at
9919       --  all. It does this by sorting all entries and then seeing if there are
9920       --  any overlaps. If there are none, then that is decisive, but if there
9921       --  are overlaps, they may still be OK (they may result from fields in
9922       --  different variants).
9923 
9924       if Overlap_Check_Required then
9925          Overlap_Check1 : declare
9926 
9927             OC_Fbit : array (0 .. Ccount) of Uint;
9928             --  First-bit values for component clauses, the value is the offset
9929             --  of the first bit of the field from start of record. The zero
9930             --  entry is for use in sorting.
9931 
9932             OC_Lbit : array (0 .. Ccount) of Uint;
9933             --  Last-bit values for component clauses, the value is the offset
9934             --  of the last bit of the field from start of record. The zero
9935             --  entry is for use in sorting.
9936 
9937             OC_Count : Natural := 0;
9938             --  Count of entries in OC_Fbit and OC_Lbit
9939 
9940             function OC_Lt (Op1, Op2 : Natural) return Boolean;
9941             --  Compare routine for Sort
9942 
9943             procedure OC_Move (From : Natural; To : Natural);
9944             --  Move routine for Sort
9945 
9946             package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt);
9947 
9948             -----------
9949             -- OC_Lt --
9950             -----------
9951 
9952             function OC_Lt (Op1, Op2 : Natural) return Boolean is
9953             begin
9954                return OC_Fbit (Op1) < OC_Fbit (Op2);
9955             end OC_Lt;
9956 
9957             -------------
9958             -- OC_Move --
9959             -------------
9960 
9961             procedure OC_Move (From : Natural; To : Natural) is
9962             begin
9963                OC_Fbit (To) := OC_Fbit (From);
9964                OC_Lbit (To) := OC_Lbit (From);
9965             end OC_Move;
9966 
9967             --  Start of processing for Overlap_Check
9968 
9969          begin
9970             CC := First (Component_Clauses (N));
9971             while Present (CC) loop
9972 
9973                --  Exclude component clause already marked in error
9974 
9975                if not Error_Posted (CC) then
9976                   Find_Component;
9977 
9978                   if Present (Comp) then
9979                      OC_Count := OC_Count + 1;
9980                      OC_Fbit (OC_Count) := Fbit;
9981                      OC_Lbit (OC_Count) := Lbit;
9982                   end if;
9983                end if;
9984 
9985                Next (CC);
9986             end loop;
9987 
9988             Sorting.Sort (OC_Count);
9989 
9990             Overlap_Check_Required := False;
9991             for J in 1 .. OC_Count - 1 loop
9992                if OC_Lbit (J) >= OC_Fbit (J + 1) then
9993                   Overlap_Check_Required := True;
9994                   exit;
9995                end if;
9996             end loop;
9997          end Overlap_Check1;
9998       end if;
9999 
10000       --  If Overlap_Check_Required is still True, then we have to do the full
10001       --  scale overlap check, since we have at least two fields that do
10002       --  overlap, and we need to know if that is OK since they are in
10003       --  different variant, or whether we have a definite problem.
10004 
10005       if Overlap_Check_Required then
10006          Overlap_Check2 : declare
10007             C1_Ent, C2_Ent : Entity_Id;
10008             --  Entities of components being checked for overlap
10009 
10010             Clist : Node_Id;
10011             --  Component_List node whose Component_Items are being checked
10012 
10013             Citem : Node_Id;
10014             --  Component declaration for component being checked
10015 
10016          begin
10017             C1_Ent := First_Entity (Base_Type (Rectype));
10018 
10019             --  Loop through all components in record. For each component check
10020             --  for overlap with any of the preceding elements on the component
10021             --  list containing the component and also, if the component is in
10022             --  a variant, check against components outside the case structure.
10023             --  This latter test is repeated recursively up the variant tree.
10024 
10025             Main_Component_Loop : while Present (C1_Ent) loop
10026                if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then
10027                   goto Continue_Main_Component_Loop;
10028                end if;
10029 
10030                --  Skip overlap check if entity has no declaration node. This
10031                --  happens with discriminants in constrained derived types.
10032                --  Possibly we are missing some checks as a result, but that
10033                --  does not seem terribly serious.
10034 
10035                if No (Declaration_Node (C1_Ent)) then
10036                   goto Continue_Main_Component_Loop;
10037                end if;
10038 
10039                Clist := Parent (List_Containing (Declaration_Node (C1_Ent)));
10040 
10041                --  Loop through component lists that need checking. Check the
10042                --  current component list and all lists in variants above us.
10043 
10044                Component_List_Loop : loop
10045 
10046                   --  If derived type definition, go to full declaration
10047                   --  If at outer level, check discriminants if there are any.
10048 
10049                   if Nkind (Clist) = N_Derived_Type_Definition then
10050                      Clist := Parent (Clist);
10051                   end if;
10052 
10053                   --  Outer level of record definition, check discriminants
10054 
10055                   if Nkind_In (Clist, N_Full_Type_Declaration,
10056                                       N_Private_Type_Declaration)
10057                   then
10058                      if Has_Discriminants (Defining_Identifier (Clist)) then
10059                         C2_Ent :=
10060                           First_Discriminant (Defining_Identifier (Clist));
10061                         while Present (C2_Ent) loop
10062                            exit when C1_Ent = C2_Ent;
10063                            Check_Component_Overlap (C1_Ent, C2_Ent);
10064                            Next_Discriminant (C2_Ent);
10065                         end loop;
10066                      end if;
10067 
10068                      --  Record extension case
10069 
10070                   elsif Nkind (Clist) = N_Derived_Type_Definition then
10071                      Clist := Empty;
10072 
10073                      --  Otherwise check one component list
10074 
10075                   else
10076                      Citem := First (Component_Items (Clist));
10077                      while Present (Citem) loop
10078                         if Nkind (Citem) = N_Component_Declaration then
10079                            C2_Ent := Defining_Identifier (Citem);
10080                            exit when C1_Ent = C2_Ent;
10081                            Check_Component_Overlap (C1_Ent, C2_Ent);
10082                         end if;
10083 
10084                         Next (Citem);
10085                      end loop;
10086                   end if;
10087 
10088                   --  Check for variants above us (the parent of the Clist can
10089                   --  be a variant, in which case its parent is a variant part,
10090                   --  and the parent of the variant part is a component list
10091                   --  whose components must all be checked against the current
10092                   --  component for overlap).
10093 
10094                   if Nkind (Parent (Clist)) = N_Variant then
10095                      Clist := Parent (Parent (Parent (Clist)));
10096 
10097                      --  Check for possible discriminant part in record, this
10098                      --  is treated essentially as another level in the
10099                      --  recursion. For this case the parent of the component
10100                      --  list is the record definition, and its parent is the
10101                      --  full type declaration containing the discriminant
10102                      --  specifications.
10103 
10104                   elsif Nkind (Parent (Clist)) = N_Record_Definition then
10105                      Clist := Parent (Parent ((Clist)));
10106 
10107                      --  If neither of these two cases, we are at the top of
10108                      --  the tree.
10109 
10110                   else
10111                      exit Component_List_Loop;
10112                   end if;
10113                end loop Component_List_Loop;
10114 
10115                <<Continue_Main_Component_Loop>>
10116                Next_Entity (C1_Ent);
10117 
10118             end loop Main_Component_Loop;
10119          end Overlap_Check2;
10120       end if;
10121 
10122       --  The following circuit deals with warning on record holes (gaps). We
10123       --  skip this check if overlap was detected, since it makes sense for the
10124       --  programmer to fix this illegality before worrying about warnings.
10125 
10126       if not Overlap_Detected and Warn_On_Record_Holes then
10127          Record_Hole_Check : declare
10128             Decl : constant Node_Id := Declaration_Node (Base_Type (Rectype));
10129             --  Full declaration of record type
10130 
10131             procedure Check_Component_List
10132               (CL   : Node_Id;
10133                Sbit : Uint;
10134                DS   : List_Id);
10135             --  Check component list CL for holes. The starting bit should be
10136             --  Sbit. which is zero for the main record component list and set
10137             --  appropriately for recursive calls for variants. DS is set to
10138             --  a list of discriminant specifications to be included in the
10139             --  consideration of components. It is No_List if none to consider.
10140 
10141             --------------------------
10142             -- Check_Component_List --
10143             --------------------------
10144 
10145             procedure Check_Component_List
10146               (CL   : Node_Id;
10147                Sbit : Uint;
10148                DS   : List_Id)
10149             is
10150                Compl : Integer;
10151 
10152             begin
10153                Compl := Integer (List_Length (Component_Items (CL)));
10154 
10155                if DS /= No_List then
10156                   Compl := Compl + Integer (List_Length (DS));
10157                end if;
10158 
10159                declare
10160                   Comps : array (Natural range 0 .. Compl) of Entity_Id;
10161                   --  Gather components (zero entry is for sort routine)
10162 
10163                   Ncomps : Natural := 0;
10164                   --  Number of entries stored in Comps (starting at Comps (1))
10165 
10166                   Citem : Node_Id;
10167                   --  One component item or discriminant specification
10168 
10169                   Nbit  : Uint;
10170                   --  Starting bit for next component
10171 
10172                   CEnt  : Entity_Id;
10173                   --  Component entity
10174 
10175                   Variant : Node_Id;
10176                   --  One variant
10177 
10178                   function Lt (Op1, Op2 : Natural) return Boolean;
10179                   --  Compare routine for Sort
10180 
10181                   procedure Move (From : Natural; To : Natural);
10182                   --  Move routine for Sort
10183 
10184                   package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
10185 
10186                   --------
10187                   -- Lt --
10188                   --------
10189 
10190                   function Lt (Op1, Op2 : Natural) return Boolean is
10191                   begin
10192                      return Component_Bit_Offset (Comps (Op1))
10193                        <
10194                        Component_Bit_Offset (Comps (Op2));
10195                   end Lt;
10196 
10197                   ----------
10198                   -- Move --
10199                   ----------
10200 
10201                   procedure Move (From : Natural; To : Natural) is
10202                   begin
10203                      Comps (To) := Comps (From);
10204                   end Move;
10205 
10206                begin
10207                   --  Gather discriminants into Comp
10208 
10209                   if DS /= No_List then
10210                      Citem := First (DS);
10211                      while Present (Citem) loop
10212                         if Nkind (Citem) = N_Discriminant_Specification then
10213                            declare
10214                               Ent : constant Entity_Id :=
10215                                       Defining_Identifier (Citem);
10216                            begin
10217                               if Ekind (Ent) = E_Discriminant then
10218                                  Ncomps := Ncomps + 1;
10219                                  Comps (Ncomps) := Ent;
10220                               end if;
10221                            end;
10222                         end if;
10223 
10224                         Next (Citem);
10225                      end loop;
10226                   end if;
10227 
10228                   --  Gather component entities into Comp
10229 
10230                   Citem := First (Component_Items (CL));
10231                   while Present (Citem) loop
10232                      if Nkind (Citem) = N_Component_Declaration then
10233                         Ncomps := Ncomps + 1;
10234                         Comps (Ncomps) := Defining_Identifier (Citem);
10235                      end if;
10236 
10237                      Next (Citem);
10238                   end loop;
10239 
10240                   --  Now sort the component entities based on the first bit.
10241                   --  Note we already know there are no overlapping components.
10242 
10243                   Sorting.Sort (Ncomps);
10244 
10245                   --  Loop through entries checking for holes
10246 
10247                   Nbit := Sbit;
10248                   for J in 1 .. Ncomps loop
10249                      CEnt := Comps (J);
10250                      Error_Msg_Uint_1 := Component_Bit_Offset (CEnt) - Nbit;
10251 
10252                      if Error_Msg_Uint_1 > 0 then
10253                         Error_Msg_NE
10254                           ("?H?^-bit gap before component&",
10255                            Component_Name (Component_Clause (CEnt)), CEnt);
10256                      end if;
10257 
10258                      Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt);
10259                   end loop;
10260 
10261                   --  Process variant parts recursively if present
10262 
10263                   if Present (Variant_Part (CL)) then
10264                      Variant := First (Variants (Variant_Part (CL)));
10265                      while Present (Variant) loop
10266                         Check_Component_List
10267                           (Component_List (Variant), Nbit, No_List);
10268                         Next (Variant);
10269                      end loop;
10270                   end if;
10271                end;
10272             end Check_Component_List;
10273 
10274          --  Start of processing for Record_Hole_Check
10275 
10276          begin
10277             declare
10278                Sbit : Uint;
10279 
10280             begin
10281                if Is_Tagged_Type (Rectype) then
10282                   Sbit := UI_From_Int (System_Address_Size);
10283                else
10284                   Sbit := Uint_0;
10285                end if;
10286 
10287                if Nkind (Decl) = N_Full_Type_Declaration
10288                  and then Nkind (Type_Definition (Decl)) = N_Record_Definition
10289                then
10290                   Check_Component_List
10291                     (Component_List (Type_Definition (Decl)),
10292                      Sbit,
10293                      Discriminant_Specifications (Decl));
10294                end if;
10295             end;
10296          end Record_Hole_Check;
10297       end if;
10298 
10299       --  For records that have component clauses for all components, and whose
10300       --  size is less than or equal to 32, we need to know the size in the
10301       --  front end to activate possible packed array processing where the
10302       --  component type is a record.
10303 
10304       --  At this stage Hbit + 1 represents the first unused bit from all the
10305       --  component clauses processed, so if the component clauses are
10306       --  complete, then this is the length of the record.
10307 
10308       --  For records longer than System.Storage_Unit, and for those where not
10309       --  all components have component clauses, the back end determines the
10310       --  length (it may for example be appropriate to round up the size
10311       --  to some convenient boundary, based on alignment considerations, etc).
10312 
10313       if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then
10314 
10315          --  Nothing to do if at least one component has no component clause
10316 
10317          Comp := First_Component_Or_Discriminant (Rectype);
10318          while Present (Comp) loop
10319             exit when No (Component_Clause (Comp));
10320             Next_Component_Or_Discriminant (Comp);
10321          end loop;
10322 
10323          --  If we fall out of loop, all components have component clauses
10324          --  and so we can set the size to the maximum value.
10325 
10326          if No (Comp) then
10327             Set_RM_Size (Rectype, Hbit + 1);
10328          end if;
10329       end if;
10330    end Check_Record_Representation_Clause;
10331 
10332    ----------------
10333    -- Check_Size --
10334    ----------------
10335 
10336    procedure Check_Size
10337      (N      : Node_Id;
10338       T      : Entity_Id;
10339       Siz    : Uint;
10340       Biased : out Boolean)
10341    is
10342       procedure Size_Too_Small_Error (Min_Siz : Uint);
10343       --  Emit an error concerning illegal size Siz. Min_Siz denotes the
10344       --  minimum size.
10345 
10346       --------------------------
10347       -- Size_Too_Small_Error --
10348       --------------------------
10349 
10350       procedure Size_Too_Small_Error (Min_Siz : Uint) is
10351       begin
10352          --  This error is suppressed in ASIS mode to allow for different ASIS
10353          --  back ends or ASIS-based tools to query the illegal clause.
10354 
10355          if not ASIS_Mode then
10356             Error_Msg_Uint_1 := Min_Siz;
10357             Error_Msg_NE ("size for& too small, minimum allowed is ^", N, T);
10358          end if;
10359       end Size_Too_Small_Error;
10360 
10361       --  Local variables
10362 
10363       UT : constant Entity_Id := Underlying_Type (T);
10364       M  : Uint;
10365 
10366    --  Start of processing for Check_Size
10367 
10368    begin
10369       Biased := False;
10370 
10371       --  Reject patently improper size values
10372 
10373       if Is_Elementary_Type (T)
10374         and then Siz > UI_From_Int (Int'Last)
10375       then
10376          Error_Msg_N ("Size value too large for elementary type", N);
10377 
10378          if Nkind (Original_Node (N)) = N_Op_Expon then
10379             Error_Msg_N
10380               ("\maybe '* was meant, rather than '*'*", Original_Node (N));
10381          end if;
10382       end if;
10383 
10384       --  Dismiss generic types
10385 
10386       if Is_Generic_Type (T)
10387            or else
10388          Is_Generic_Type (UT)
10389            or else
10390          Is_Generic_Type (Root_Type (UT))
10391       then
10392          return;
10393 
10394       --  Guard against previous errors
10395 
10396       elsif No (UT) or else UT = Any_Type then
10397          Check_Error_Detected;
10398          return;
10399 
10400       --  Check case of bit packed array
10401 
10402       elsif Is_Array_Type (UT)
10403         and then Known_Static_Component_Size (UT)
10404         and then Is_Bit_Packed_Array (UT)
10405       then
10406          declare
10407             Asiz : Uint;
10408             Indx : Node_Id;
10409             Ityp : Entity_Id;
10410 
10411          begin
10412             Asiz := Component_Size (UT);
10413             Indx := First_Index (UT);
10414             loop
10415                Ityp := Etype (Indx);
10416 
10417                --  If non-static bound, then we are not in the business of
10418                --  trying to check the length, and indeed an error will be
10419                --  issued elsewhere, since sizes of non-static array types
10420                --  cannot be set implicitly or explicitly.
10421 
10422                if not Is_OK_Static_Subtype (Ityp) then
10423                   return;
10424                end if;
10425 
10426                --  Otherwise accumulate next dimension
10427 
10428                Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) -
10429                                Expr_Value (Type_Low_Bound  (Ityp)) +
10430                                Uint_1);
10431 
10432                Next_Index (Indx);
10433                exit when No (Indx);
10434             end loop;
10435 
10436             if Asiz <= Siz then
10437                return;
10438 
10439             else
10440                Size_Too_Small_Error (Asiz);
10441                Set_Esize   (T, Asiz);
10442                Set_RM_Size (T, Asiz);
10443             end if;
10444          end;
10445 
10446       --  All other composite types are ignored
10447 
10448       elsif Is_Composite_Type (UT) then
10449          return;
10450 
10451       --  For fixed-point types, don't check minimum if type is not frozen,
10452       --  since we don't know all the characteristics of the type that can
10453       --  affect the size (e.g. a specified small) till freeze time.
10454 
10455       elsif Is_Fixed_Point_Type (UT) and then not Is_Frozen (UT) then
10456          null;
10457 
10458       --  Cases for which a minimum check is required
10459 
10460       else
10461          --  Ignore if specified size is correct for the type
10462 
10463          if Known_Esize (UT) and then Siz = Esize (UT) then
10464             return;
10465          end if;
10466 
10467          --  Otherwise get minimum size
10468 
10469          M := UI_From_Int (Minimum_Size (UT));
10470 
10471          if Siz < M then
10472 
10473             --  Size is less than minimum size, but one possibility remains
10474             --  that we can manage with the new size if we bias the type.
10475 
10476             M := UI_From_Int (Minimum_Size (UT, Biased => True));
10477 
10478             if Siz < M then
10479                Size_Too_Small_Error (M);
10480                Set_Esize   (T, M);
10481                Set_RM_Size (T, M);
10482             else
10483                Biased := True;
10484             end if;
10485          end if;
10486       end if;
10487    end Check_Size;
10488 
10489    --------------------------
10490    -- Freeze_Entity_Checks --
10491    --------------------------
10492 
10493    procedure Freeze_Entity_Checks (N : Node_Id) is
10494       procedure Hide_Non_Overridden_Subprograms (Typ : Entity_Id);
10495       --  Inspect the primitive operations of type Typ and hide all pairs of
10496       --  implicitly declared non-overridden non-fully conformant homographs
10497       --  (Ada RM 8.3 12.3/2).
10498 
10499       -------------------------------------
10500       -- Hide_Non_Overridden_Subprograms --
10501       -------------------------------------
10502 
10503       procedure Hide_Non_Overridden_Subprograms (Typ : Entity_Id) is
10504          procedure Hide_Matching_Homographs
10505            (Subp_Id    : Entity_Id;
10506             Start_Elmt : Elmt_Id);
10507          --  Inspect a list of primitive operations starting with Start_Elmt
10508          --  and find matching implicitly declared non-overridden non-fully
10509          --  conformant homographs of Subp_Id. If found, all matches along
10510          --  with Subp_Id are hidden from all visibility.
10511 
10512          function Is_Non_Overridden_Or_Null_Procedure
10513            (Subp_Id : Entity_Id) return Boolean;
10514          --  Determine whether subprogram Subp_Id is implicitly declared non-
10515          --  overridden subprogram or an implicitly declared null procedure.
10516 
10517          ------------------------------
10518          -- Hide_Matching_Homographs --
10519          ------------------------------
10520 
10521          procedure Hide_Matching_Homographs
10522            (Subp_Id    : Entity_Id;
10523             Start_Elmt : Elmt_Id)
10524          is
10525             Prim      : Entity_Id;
10526             Prim_Elmt : Elmt_Id;
10527 
10528          begin
10529             Prim_Elmt := Start_Elmt;
10530             while Present (Prim_Elmt) loop
10531                Prim := Node (Prim_Elmt);
10532 
10533                --  The current primitive is implicitly declared non-overridden
10534                --  non-fully conformant homograph of Subp_Id. Both subprograms
10535                --  must be hidden from visibility.
10536 
10537                if Chars (Prim) = Chars (Subp_Id)
10538                  and then Is_Non_Overridden_Or_Null_Procedure (Prim)
10539                  and then not Fully_Conformant (Prim, Subp_Id)
10540                then
10541                   Set_Is_Hidden_Non_Overridden_Subpgm (Prim);
10542                   Set_Is_Immediately_Visible          (Prim, False);
10543                   Set_Is_Potentially_Use_Visible      (Prim, False);
10544 
10545                   Set_Is_Hidden_Non_Overridden_Subpgm (Subp_Id);
10546                   Set_Is_Immediately_Visible          (Subp_Id, False);
10547                   Set_Is_Potentially_Use_Visible      (Subp_Id, False);
10548                end if;
10549 
10550                Next_Elmt (Prim_Elmt);
10551             end loop;
10552          end Hide_Matching_Homographs;
10553 
10554          -----------------------------------------
10555          -- Is_Non_Overridden_Or_Null_Procedure --
10556          -----------------------------------------
10557 
10558          function Is_Non_Overridden_Or_Null_Procedure
10559            (Subp_Id : Entity_Id) return Boolean
10560          is
10561             Alias_Id : Entity_Id;
10562 
10563          begin
10564             --  The subprogram is inherited (implicitly declared), it does not
10565             --  override and does not cover a primitive of an interface.
10566 
10567             if Ekind_In (Subp_Id, E_Function, E_Procedure)
10568               and then Present (Alias (Subp_Id))
10569               and then No (Interface_Alias (Subp_Id))
10570               and then No (Overridden_Operation (Subp_Id))
10571             then
10572                Alias_Id := Alias (Subp_Id);
10573 
10574                if Requires_Overriding (Alias_Id) then
10575                   return True;
10576 
10577                elsif Nkind (Parent (Alias_Id)) = N_Procedure_Specification
10578                  and then Null_Present (Parent (Alias_Id))
10579                then
10580                   return True;
10581                end if;
10582             end if;
10583 
10584             return False;
10585          end Is_Non_Overridden_Or_Null_Procedure;
10586 
10587          --  Local variables
10588 
10589          Prim_Ops  : constant Elist_Id := Direct_Primitive_Operations (Typ);
10590          Prim      : Entity_Id;
10591          Prim_Elmt : Elmt_Id;
10592 
10593       --  Start of processing for Hide_Non_Overridden_Subprograms
10594 
10595       begin
10596          --  Inspect the list of primitives looking for non-overridden
10597          --  subprograms.
10598 
10599          if Present (Prim_Ops) then
10600             Prim_Elmt := First_Elmt (Prim_Ops);
10601             while Present (Prim_Elmt) loop
10602                Prim := Node (Prim_Elmt);
10603                Next_Elmt (Prim_Elmt);
10604 
10605                if Is_Non_Overridden_Or_Null_Procedure (Prim) then
10606                   Hide_Matching_Homographs
10607                     (Subp_Id    => Prim,
10608                      Start_Elmt => Prim_Elmt);
10609                end if;
10610             end loop;
10611          end if;
10612       end Hide_Non_Overridden_Subprograms;
10613 
10614       --  Local variables
10615 
10616       E : constant Entity_Id := Entity (N);
10617 
10618       Non_Generic_Case : constant Boolean := Nkind (N) = N_Freeze_Entity;
10619       --  True in non-generic case. Some of the processing here is skipped
10620       --  for the generic case since it is not needed. Basically in the
10621       --  generic case, we only need to do stuff that might generate error
10622       --  messages or warnings.
10623 
10624    --  Start of processing for Freeze_Entity_Checks
10625 
10626    begin
10627       --  Remember that we are processing a freezing entity. Required to
10628       --  ensure correct decoration of internal entities associated with
10629       --  interfaces (see New_Overloaded_Entity).
10630 
10631       Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
10632 
10633       --  For tagged types covering interfaces add internal entities that link
10634       --  the primitives of the interfaces with the primitives that cover them.
10635       --  Note: These entities were originally generated only when generating
10636       --  code because their main purpose was to provide support to initialize
10637       --  the secondary dispatch tables. They are now generated also when
10638       --  compiling with no code generation to provide ASIS the relationship
10639       --  between interface primitives and tagged type primitives. They are
10640       --  also used to locate primitives covering interfaces when processing
10641       --  generics (see Derive_Subprograms).
10642 
10643       --  This is not needed in the generic case
10644 
10645       if Ada_Version >= Ada_2005
10646         and then Non_Generic_Case
10647         and then Ekind (E) = E_Record_Type
10648         and then Is_Tagged_Type (E)
10649         and then not Is_Interface (E)
10650         and then Has_Interfaces (E)
10651       then
10652          --  This would be a good common place to call the routine that checks
10653          --  overriding of interface primitives (and thus factorize calls to
10654          --  Check_Abstract_Overriding located at different contexts in the
10655          --  compiler). However, this is not possible because it causes
10656          --  spurious errors in case of late overriding.
10657 
10658          Add_Internal_Interface_Entities (E);
10659       end if;
10660 
10661       --  After all forms of overriding have been resolved, a tagged type may
10662       --  be left with a set of implicitly declared and possibly erroneous
10663       --  abstract subprograms, null procedures and subprograms that require
10664       --  overriding. If this set contains fully conformant homographs, then
10665       --  one is chosen arbitrarily (already done during resolution), otherwise
10666       --  all remaining non-fully conformant homographs are hidden from
10667       --  visibility (Ada RM 8.3 12.3/2).
10668 
10669       if Is_Tagged_Type (E) then
10670          Hide_Non_Overridden_Subprograms (E);
10671       end if;
10672 
10673       --  Check CPP types
10674 
10675       if Ekind (E) = E_Record_Type
10676         and then Is_CPP_Class (E)
10677         and then Is_Tagged_Type (E)
10678         and then Tagged_Type_Expansion
10679       then
10680          if CPP_Num_Prims (E) = 0 then
10681 
10682             --  If the CPP type has user defined components then it must import
10683             --  primitives from C++. This is required because if the C++ class
10684             --  has no primitives then the C++ compiler does not added the _tag
10685             --  component to the type.
10686 
10687             if First_Entity (E) /= Last_Entity (E) then
10688                Error_Msg_N
10689                  ("'C'P'P type must import at least one primitive from C++??",
10690                   E);
10691             end if;
10692          end if;
10693 
10694          --  Check that all its primitives are abstract or imported from C++.
10695          --  Check also availability of the C++ constructor.
10696 
10697          declare
10698             Has_Constructors : constant Boolean := Has_CPP_Constructors (E);
10699             Elmt             : Elmt_Id;
10700             Error_Reported   : Boolean := False;
10701             Prim             : Node_Id;
10702 
10703          begin
10704             Elmt := First_Elmt (Primitive_Operations (E));
10705             while Present (Elmt) loop
10706                Prim := Node (Elmt);
10707 
10708                if Comes_From_Source (Prim) then
10709                   if Is_Abstract_Subprogram (Prim) then
10710                      null;
10711 
10712                   elsif not Is_Imported (Prim)
10713                     or else Convention (Prim) /= Convention_CPP
10714                   then
10715                      Error_Msg_N
10716                        ("primitives of 'C'P'P types must be imported from C++ "
10717                         & "or abstract??", Prim);
10718 
10719                   elsif not Has_Constructors
10720                      and then not Error_Reported
10721                   then
10722                      Error_Msg_Name_1 := Chars (E);
10723                      Error_Msg_N
10724                        ("??'C'P'P constructor required for type %", Prim);
10725                      Error_Reported := True;
10726                   end if;
10727                end if;
10728 
10729                Next_Elmt (Elmt);
10730             end loop;
10731          end;
10732       end if;
10733 
10734       --  Check Ada derivation of CPP type
10735 
10736       if Expander_Active              -- why? losing errors in -gnatc mode???
10737         and then Present (Etype (E))  -- defend against errors
10738         and then Tagged_Type_Expansion
10739         and then Ekind (E) = E_Record_Type
10740         and then Etype (E) /= E
10741         and then Is_CPP_Class (Etype (E))
10742         and then CPP_Num_Prims (Etype (E)) > 0
10743         and then not Is_CPP_Class (E)
10744         and then not Has_CPP_Constructors (Etype (E))
10745       then
10746          --  If the parent has C++ primitives but it has no constructor then
10747          --  check that all the primitives are overridden in this derivation;
10748          --  otherwise the constructor of the parent is needed to build the
10749          --  dispatch table.
10750 
10751          declare
10752             Elmt : Elmt_Id;
10753             Prim : Node_Id;
10754 
10755          begin
10756             Elmt := First_Elmt (Primitive_Operations (E));
10757             while Present (Elmt) loop
10758                Prim := Node (Elmt);
10759 
10760                if not Is_Abstract_Subprogram (Prim)
10761                  and then No (Interface_Alias (Prim))
10762                  and then Find_Dispatching_Type (Ultimate_Alias (Prim)) /= E
10763                then
10764                   Error_Msg_Name_1 := Chars (Etype (E));
10765                   Error_Msg_N
10766                     ("'C'P'P constructor required for parent type %", E);
10767                   exit;
10768                end if;
10769 
10770                Next_Elmt (Elmt);
10771             end loop;
10772          end;
10773       end if;
10774 
10775       Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
10776 
10777       --  If we have a type with predicates, build predicate function. This is
10778       --  not needed in the generic case, nor within TSS subprograms and other
10779       --  predefined primitives.
10780 
10781       if Is_Type (E)
10782         and then Non_Generic_Case
10783         and then not Within_Internal_Subprogram
10784         and then Has_Predicates (E)
10785       then
10786          Build_Predicate_Functions (E, N);
10787       end if;
10788 
10789       --  If type has delayed aspects, this is where we do the preanalysis at
10790       --  the freeze point, as part of the consistent visibility check. Note
10791       --  that this must be done after calling Build_Predicate_Functions or
10792       --  Build_Invariant_Procedure since these subprograms fix occurrences of
10793       --  the subtype name in the saved expression so that they will not cause
10794       --  trouble in the preanalysis.
10795 
10796       --  This is also not needed in the generic case
10797 
10798       if Non_Generic_Case
10799         and then Has_Delayed_Aspects (E)
10800         and then Scope (E) = Current_Scope
10801       then
10802          --  Retrieve the visibility to the discriminants in order to properly
10803          --  analyze the aspects.
10804 
10805          Push_Scope_And_Install_Discriminants (E);
10806 
10807          declare
10808             Ritem : Node_Id;
10809 
10810          begin
10811             --  Look for aspect specification entries for this entity
10812 
10813             Ritem := First_Rep_Item (E);
10814             while Present (Ritem) loop
10815                if Nkind (Ritem) = N_Aspect_Specification
10816                  and then Entity (Ritem) = E
10817                  and then Is_Delayed_Aspect (Ritem)
10818                then
10819                   Check_Aspect_At_Freeze_Point (Ritem);
10820                end if;
10821 
10822                Next_Rep_Item (Ritem);
10823             end loop;
10824          end;
10825 
10826          Uninstall_Discriminants_And_Pop_Scope (E);
10827       end if;
10828 
10829       --  For a record type, deal with variant parts. This has to be delayed
10830       --  to this point, because of the issue of statically predicated
10831       --  subtypes, which we have to ensure are frozen before checking
10832       --  choices, since we need to have the static choice list set.
10833 
10834       if Is_Record_Type (E) then
10835          Check_Variant_Part : declare
10836             D  : constant Node_Id := Declaration_Node (E);
10837             T  : Node_Id;
10838             C  : Node_Id;
10839             VP : Node_Id;
10840 
10841             Others_Present : Boolean;
10842             pragma Warnings (Off, Others_Present);
10843             --  Indicates others present, not used in this case
10844 
10845             procedure Non_Static_Choice_Error (Choice : Node_Id);
10846             --  Error routine invoked by the generic instantiation below when
10847             --  the variant part has a non static choice.
10848 
10849             procedure Process_Declarations (Variant : Node_Id);
10850             --  Processes declarations associated with a variant. We analyzed
10851             --  the declarations earlier (in Sem_Ch3.Analyze_Variant_Part),
10852             --  but we still need the recursive call to Check_Choices for any
10853             --  nested variant to get its choices properly processed. This is
10854             --  also where we expand out the choices if expansion is active.
10855 
10856             package Variant_Choices_Processing is new
10857               Generic_Check_Choices
10858                 (Process_Empty_Choice      => No_OP,
10859                  Process_Non_Static_Choice => Non_Static_Choice_Error,
10860                  Process_Associated_Node   => Process_Declarations);
10861             use Variant_Choices_Processing;
10862 
10863             -----------------------------
10864             -- Non_Static_Choice_Error --
10865             -----------------------------
10866 
10867             procedure Non_Static_Choice_Error (Choice : Node_Id) is
10868             begin
10869                Flag_Non_Static_Expr
10870                  ("choice given in variant part is not static!", Choice);
10871             end Non_Static_Choice_Error;
10872 
10873             --------------------------
10874             -- Process_Declarations --
10875             --------------------------
10876 
10877             procedure Process_Declarations (Variant : Node_Id) is
10878                CL : constant Node_Id := Component_List (Variant);
10879                VP : Node_Id;
10880 
10881             begin
10882                --  Check for static predicate present in this variant
10883 
10884                if Has_SP_Choice (Variant) then
10885 
10886                   --  Here we expand. You might expect to find this call in
10887                   --  Expand_N_Variant_Part, but that is called when we first
10888                   --  see the variant part, and we cannot do this expansion
10889                   --  earlier than the freeze point, since for statically
10890                   --  predicated subtypes, the predicate is not known till
10891                   --  the freeze point.
10892 
10893                   --  Furthermore, we do this expansion even if the expander
10894                   --  is not active, because other semantic processing, e.g.
10895                   --  for aggregates, requires the expanded list of choices.
10896 
10897                   --  If the expander is not active, then we can't just clobber
10898                   --  the list since it would invalidate the ASIS -gnatct tree.
10899                   --  So we have to rewrite the variant part with a Rewrite
10900                   --  call that replaces it with a copy and clobber the copy.
10901 
10902                   if not Expander_Active then
10903                      declare
10904                         NewV : constant Node_Id := New_Copy (Variant);
10905                      begin
10906                         Set_Discrete_Choices
10907                           (NewV, New_Copy_List (Discrete_Choices (Variant)));
10908                         Rewrite (Variant, NewV);
10909                      end;
10910                   end if;
10911 
10912                   Expand_Static_Predicates_In_Choices (Variant);
10913                end if;
10914 
10915                --  We don't need to worry about the declarations in the variant
10916                --  (since they were analyzed by Analyze_Choices when we first
10917                --  encountered the variant), but we do need to take care of
10918                --  expansion of any nested variants.
10919 
10920                if not Null_Present (CL) then
10921                   VP := Variant_Part (CL);
10922 
10923                   if Present (VP) then
10924                      Check_Choices
10925                        (VP, Variants (VP), Etype (Name (VP)), Others_Present);
10926                   end if;
10927                end if;
10928             end Process_Declarations;
10929 
10930          --  Start of processing for Check_Variant_Part
10931 
10932          begin
10933             --  Find component list
10934 
10935             C := Empty;
10936 
10937             if Nkind (D) = N_Full_Type_Declaration then
10938                T := Type_Definition (D);
10939 
10940                if Nkind (T) = N_Record_Definition then
10941                   C := Component_List (T);
10942 
10943                elsif Nkind (T) = N_Derived_Type_Definition
10944                  and then Present (Record_Extension_Part (T))
10945                then
10946                   C := Component_List (Record_Extension_Part (T));
10947                end if;
10948             end if;
10949 
10950             --  Case of variant part present
10951 
10952             if Present (C) and then Present (Variant_Part (C)) then
10953                VP := Variant_Part (C);
10954 
10955                --  Check choices
10956 
10957                Check_Choices
10958                  (VP, Variants (VP), Etype (Name (VP)), Others_Present);
10959 
10960                --  If the last variant does not contain the Others choice,
10961                --  replace it with an N_Others_Choice node since Gigi always
10962                --  wants an Others. Note that we do not bother to call Analyze
10963                --  on the modified variant part, since its only effect would be
10964                --  to compute the Others_Discrete_Choices node laboriously, and
10965                --  of course we already know the list of choices corresponding
10966                --  to the others choice (it's the list we're replacing).
10967 
10968                --  We only want to do this if the expander is active, since
10969                --  we do not want to clobber the ASIS tree.
10970 
10971                if Expander_Active then
10972                   declare
10973                      Last_Var : constant Node_Id :=
10974                                      Last_Non_Pragma (Variants (VP));
10975 
10976                      Others_Node : Node_Id;
10977 
10978                   begin
10979                      if Nkind (First (Discrete_Choices (Last_Var))) /=
10980                                                             N_Others_Choice
10981                      then
10982                         Others_Node := Make_Others_Choice (Sloc (Last_Var));
10983                         Set_Others_Discrete_Choices
10984                           (Others_Node, Discrete_Choices (Last_Var));
10985                         Set_Discrete_Choices
10986                           (Last_Var, New_List (Others_Node));
10987                      end if;
10988                   end;
10989                end if;
10990             end if;
10991          end Check_Variant_Part;
10992       end if;
10993    end Freeze_Entity_Checks;
10994 
10995    -------------------------
10996    -- Get_Alignment_Value --
10997    -------------------------
10998 
10999    function Get_Alignment_Value (Expr : Node_Id) return Uint is
11000       Align : constant Uint := Static_Integer (Expr);
11001 
11002    begin
11003       if Align = No_Uint then
11004          return No_Uint;
11005 
11006       elsif Align <= 0 then
11007 
11008          --  This error is suppressed in ASIS mode to allow for different ASIS
11009          --  back ends or ASIS-based tools to query the illegal clause.
11010 
11011          if not ASIS_Mode then
11012             Error_Msg_N ("alignment value must be positive", Expr);
11013          end if;
11014 
11015          return No_Uint;
11016 
11017       else
11018          for J in Int range 0 .. 64 loop
11019             declare
11020                M : constant Uint := Uint_2 ** J;
11021 
11022             begin
11023                exit when M = Align;
11024 
11025                if M > Align then
11026 
11027                   --  This error is suppressed in ASIS mode to allow for
11028                   --  different ASIS back ends or ASIS-based tools to query the
11029                   --  illegal clause.
11030 
11031                   if not ASIS_Mode then
11032                      Error_Msg_N ("alignment value must be power of 2", Expr);
11033                   end if;
11034 
11035                   return No_Uint;
11036                end if;
11037             end;
11038          end loop;
11039 
11040          return Align;
11041       end if;
11042    end Get_Alignment_Value;
11043 
11044    -----------------------------
11045    -- Get_Interfacing_Aspects --
11046    -----------------------------
11047 
11048    procedure Get_Interfacing_Aspects
11049      (Iface_Asp : Node_Id;
11050       Conv_Asp  : out Node_Id;
11051       EN_Asp    : out Node_Id;
11052       Expo_Asp  : out Node_Id;
11053       Imp_Asp   : out Node_Id;
11054       LN_Asp    : out Node_Id;
11055       Do_Checks : Boolean := False)
11056    is
11057       procedure Save_Or_Duplication_Error
11058         (Asp : Node_Id;
11059          To  : in out Node_Id);
11060       --  Save the value of aspect Asp in node To. If To already has a value,
11061       --  then this is considered a duplicate use of aspect. Emit an error if
11062       --  flag Do_Checks is set.
11063 
11064       -------------------------------
11065       -- Save_Or_Duplication_Error --
11066       -------------------------------
11067 
11068       procedure Save_Or_Duplication_Error
11069         (Asp : Node_Id;
11070          To  : in out Node_Id)
11071       is
11072       begin
11073          --  Detect an extra aspect and issue an error
11074 
11075          if Present (To) then
11076             if Do_Checks then
11077                Error_Msg_Name_1 := Chars (Identifier (Asp));
11078                Error_Msg_Sloc   := Sloc (To);
11079                Error_Msg_N ("aspect % previously given #", Asp);
11080             end if;
11081 
11082          --  Otherwise capture the aspect
11083 
11084          else
11085             To := Asp;
11086          end if;
11087       end Save_Or_Duplication_Error;
11088 
11089       --  Local variables
11090 
11091       Asp    : Node_Id;
11092       Asp_Id : Aspect_Id;
11093 
11094       --  The following variables capture each individual aspect
11095 
11096       Conv : Node_Id := Empty;
11097       EN   : Node_Id := Empty;
11098       Expo : Node_Id := Empty;
11099       Imp  : Node_Id := Empty;
11100       LN   : Node_Id := Empty;
11101 
11102    --  Start of processing for Get_Interfacing_Aspects
11103 
11104    begin
11105       --  The input interfacing aspect should reside in an aspect specification
11106       --  list.
11107 
11108       pragma Assert (Is_List_Member (Iface_Asp));
11109 
11110       --  Examine the aspect specifications of the related entity. Find and
11111       --  capture all interfacing aspects. Detect duplicates and emit errors
11112       --  if applicable.
11113 
11114       Asp := First (List_Containing (Iface_Asp));
11115       while Present (Asp) loop
11116          Asp_Id := Get_Aspect_Id (Asp);
11117 
11118          if Asp_Id = Aspect_Convention then
11119             Save_Or_Duplication_Error (Asp, Conv);
11120 
11121          elsif Asp_Id = Aspect_External_Name then
11122             Save_Or_Duplication_Error (Asp, EN);
11123 
11124          elsif Asp_Id = Aspect_Export then
11125             Save_Or_Duplication_Error (Asp, Expo);
11126 
11127          elsif Asp_Id = Aspect_Import then
11128             Save_Or_Duplication_Error (Asp, Imp);
11129 
11130          elsif Asp_Id = Aspect_Link_Name then
11131             Save_Or_Duplication_Error (Asp, LN);
11132          end if;
11133 
11134          Next (Asp);
11135       end loop;
11136 
11137       Conv_Asp := Conv;
11138       EN_Asp   := EN;
11139       Expo_Asp := Expo;
11140       Imp_Asp  := Imp;
11141       LN_Asp   := LN;
11142    end Get_Interfacing_Aspects;
11143 
11144    -------------------------------------
11145    -- Inherit_Aspects_At_Freeze_Point --
11146    -------------------------------------
11147 
11148    procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is
11149       function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11150         (Rep_Item : Node_Id) return Boolean;
11151       --  This routine checks if Rep_Item is either a pragma or an aspect
11152       --  specification node whose correponding pragma (if any) is present in
11153       --  the Rep Item chain of the entity it has been specified to.
11154 
11155       --------------------------------------------------
11156       -- Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item --
11157       --------------------------------------------------
11158 
11159       function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11160         (Rep_Item : Node_Id) return Boolean
11161       is
11162       begin
11163          return
11164            Nkind (Rep_Item) = N_Pragma
11165              or else Present_In_Rep_Item
11166                        (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item));
11167       end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item;
11168 
11169    --  Start of processing for Inherit_Aspects_At_Freeze_Point
11170 
11171    begin
11172       --  A representation item is either subtype-specific (Size and Alignment
11173       --  clauses) or type-related (all others).  Subtype-specific aspects may
11174       --  differ for different subtypes of the same type (RM 13.1.8).
11175 
11176       --  A derived type inherits each type-related representation aspect of
11177       --  its parent type that was directly specified before the declaration of
11178       --  the derived type (RM 13.1.15).
11179 
11180       --  A derived subtype inherits each subtype-specific representation
11181       --  aspect of its parent subtype that was directly specified before the
11182       --  declaration of the derived type (RM 13.1.15).
11183 
11184       --  The general processing involves inheriting a representation aspect
11185       --  from a parent type whenever the first rep item (aspect specification,
11186       --  attribute definition clause, pragma) corresponding to the given
11187       --  representation aspect in the rep item chain of Typ, if any, isn't
11188       --  directly specified to Typ but to one of its parents.
11189 
11190       --  ??? Note that, for now, just a limited number of representation
11191       --  aspects have been inherited here so far. Many of them are
11192       --  still inherited in Sem_Ch3. This will be fixed soon. Here is
11193       --  a non- exhaustive list of aspects that likely also need to
11194       --  be moved to this routine: Alignment, Component_Alignment,
11195       --  Component_Size, Machine_Radix, Object_Size, Pack, Predicates,
11196       --  Preelaborable_Initialization, RM_Size and Small.
11197 
11198       --  In addition, Convention must be propagated from base type to subtype,
11199       --  because the subtype may have been declared on an incomplete view.
11200 
11201       if Nkind (Parent (Typ)) = N_Private_Extension_Declaration then
11202          return;
11203       end if;
11204 
11205       --  Ada_05/Ada_2005
11206 
11207       if not Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005, False)
11208         and then Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005)
11209         and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11210                    (Get_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005))
11211       then
11212          Set_Is_Ada_2005_Only (Typ);
11213       end if;
11214 
11215       --  Ada_12/Ada_2012
11216 
11217       if not Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012, False)
11218         and then Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012)
11219         and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11220                    (Get_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012))
11221       then
11222          Set_Is_Ada_2012_Only (Typ);
11223       end if;
11224 
11225       --  Atomic/Shared
11226 
11227       if not Has_Rep_Item (Typ, Name_Atomic, Name_Shared, False)
11228         and then Has_Rep_Pragma (Typ, Name_Atomic, Name_Shared)
11229         and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11230                    (Get_Rep_Item (Typ, Name_Atomic, Name_Shared))
11231       then
11232          Set_Is_Atomic (Typ);
11233          Set_Is_Volatile (Typ);
11234          Set_Treat_As_Volatile (Typ);
11235       end if;
11236 
11237       --  Convention
11238 
11239       if Is_Record_Type (Typ)
11240         and then Typ /= Base_Type (Typ) and then Is_Frozen (Base_Type (Typ))
11241       then
11242          Set_Convention (Typ, Convention (Base_Type (Typ)));
11243       end if;
11244 
11245       --  Default_Component_Value
11246 
11247       --  Verify that there is no rep_item declared for the type, and there
11248       --  is one coming from an ancestor.
11249 
11250       if Is_Array_Type (Typ)
11251         and then Is_Base_Type (Typ)
11252         and then not Has_Rep_Item (Typ, Name_Default_Component_Value, False)
11253         and then Has_Rep_Item (Typ, Name_Default_Component_Value)
11254       then
11255          Set_Default_Aspect_Component_Value (Typ,
11256            Default_Aspect_Component_Value
11257              (Entity (Get_Rep_Item (Typ, Name_Default_Component_Value))));
11258       end if;
11259 
11260       --  Default_Value
11261 
11262       if Is_Scalar_Type (Typ)
11263         and then Is_Base_Type (Typ)
11264         and then not Has_Rep_Item (Typ, Name_Default_Value, False)
11265         and then Has_Rep_Item (Typ, Name_Default_Value)
11266       then
11267          Set_Has_Default_Aspect (Typ);
11268          Set_Default_Aspect_Value (Typ,
11269            Default_Aspect_Value
11270              (Entity (Get_Rep_Item (Typ, Name_Default_Value))));
11271       end if;
11272 
11273       --  Discard_Names
11274 
11275       if not Has_Rep_Item (Typ, Name_Discard_Names, False)
11276         and then Has_Rep_Item (Typ, Name_Discard_Names)
11277         and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11278                    (Get_Rep_Item (Typ, Name_Discard_Names))
11279       then
11280          Set_Discard_Names (Typ);
11281       end if;
11282 
11283       --  Volatile
11284 
11285       if not Has_Rep_Item (Typ, Name_Volatile, False)
11286         and then Has_Rep_Item (Typ, Name_Volatile)
11287         and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11288                    (Get_Rep_Item (Typ, Name_Volatile))
11289       then
11290          Set_Is_Volatile (Typ);
11291          Set_Treat_As_Volatile (Typ);
11292       end if;
11293 
11294       --  Volatile_Full_Access
11295 
11296       if not Has_Rep_Item (Typ, Name_Volatile_Full_Access, False)
11297         and then Has_Rep_Pragma (Typ, Name_Volatile_Full_Access)
11298         and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11299                    (Get_Rep_Item (Typ, Name_Volatile_Full_Access))
11300       then
11301          Set_Is_Volatile_Full_Access (Typ);
11302          Set_Is_Volatile (Typ);
11303          Set_Treat_As_Volatile (Typ);
11304       end if;
11305 
11306       --  Inheritance for derived types only
11307 
11308       if Is_Derived_Type (Typ) then
11309          declare
11310             Bas_Typ     : constant Entity_Id := Base_Type (Typ);
11311             Imp_Bas_Typ : constant Entity_Id := Implementation_Base_Type (Typ);
11312 
11313          begin
11314             --  Atomic_Components
11315 
11316             if not Has_Rep_Item (Typ, Name_Atomic_Components, False)
11317               and then Has_Rep_Item (Typ, Name_Atomic_Components)
11318               and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11319                    (Get_Rep_Item (Typ, Name_Atomic_Components))
11320             then
11321                Set_Has_Atomic_Components (Imp_Bas_Typ);
11322             end if;
11323 
11324             --  Volatile_Components
11325 
11326             if not Has_Rep_Item (Typ, Name_Volatile_Components, False)
11327               and then Has_Rep_Item (Typ, Name_Volatile_Components)
11328               and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11329                    (Get_Rep_Item (Typ, Name_Volatile_Components))
11330             then
11331                Set_Has_Volatile_Components (Imp_Bas_Typ);
11332             end if;
11333 
11334             --  Finalize_Storage_Only
11335 
11336             if not Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only, False)
11337               and then Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only)
11338             then
11339                Set_Finalize_Storage_Only (Bas_Typ);
11340             end if;
11341 
11342             --  Universal_Aliasing
11343 
11344             if not Has_Rep_Item (Typ, Name_Universal_Aliasing, False)
11345               and then Has_Rep_Item (Typ, Name_Universal_Aliasing)
11346               and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11347                    (Get_Rep_Item (Typ, Name_Universal_Aliasing))
11348             then
11349                Set_Universal_Aliasing (Imp_Bas_Typ);
11350             end if;
11351 
11352             --  Bit_Order
11353 
11354             if Is_Record_Type (Typ) then
11355                if not Has_Rep_Item (Typ, Name_Bit_Order, False)
11356                  and then Has_Rep_Item (Typ, Name_Bit_Order)
11357                then
11358                   Set_Reverse_Bit_Order (Bas_Typ,
11359                     Reverse_Bit_Order (Entity (Name
11360                       (Get_Rep_Item (Typ, Name_Bit_Order)))));
11361                end if;
11362             end if;
11363 
11364             --  Scalar_Storage_Order
11365 
11366             --  Note: the aspect is specified on a first subtype, but recorded
11367             --  in a flag of the base type!
11368 
11369             if (Is_Record_Type (Typ) or else Is_Array_Type (Typ))
11370                  and then Typ = Bas_Typ
11371             then
11372                --  For a type extension, always inherit from parent; otherwise
11373                --  inherit if no default applies. Note: we do not check for
11374                --  an explicit rep item on the parent type when inheriting,
11375                --  because the parent SSO may itself have been set by default.
11376 
11377                if not Has_Rep_Item (First_Subtype (Typ),
11378                                     Name_Scalar_Storage_Order, False)
11379                  and then (Is_Tagged_Type (Bas_Typ)
11380                             or else not (SSO_Set_Low_By_Default  (Bas_Typ)
11381                                            or else
11382                                          SSO_Set_High_By_Default (Bas_Typ)))
11383                then
11384                   Set_Reverse_Storage_Order (Bas_Typ,
11385                     Reverse_Storage_Order
11386                       (Implementation_Base_Type (Etype (Bas_Typ))));
11387 
11388                   --  Clear default SSO indications, since the inherited aspect
11389                   --  which was set explicitly overrides the default.
11390 
11391                   Set_SSO_Set_Low_By_Default  (Bas_Typ, False);
11392                   Set_SSO_Set_High_By_Default (Bas_Typ, False);
11393                end if;
11394             end if;
11395          end;
11396       end if;
11397    end Inherit_Aspects_At_Freeze_Point;
11398 
11399    ----------------
11400    -- Initialize --
11401    ----------------
11402 
11403    procedure Initialize is
11404    begin
11405       Address_Clause_Checks.Init;
11406       Unchecked_Conversions.Init;
11407 
11408       if AAMP_On_Target then
11409          Independence_Checks.Init;
11410       end if;
11411    end Initialize;
11412 
11413    ---------------------------
11414    -- Install_Discriminants --
11415    ---------------------------
11416 
11417    procedure Install_Discriminants (E : Entity_Id) is
11418       Disc : Entity_Id;
11419       Prev : Entity_Id;
11420    begin
11421       Disc := First_Discriminant (E);
11422       while Present (Disc) loop
11423          Prev := Current_Entity (Disc);
11424          Set_Current_Entity (Disc);
11425          Set_Is_Immediately_Visible (Disc);
11426          Set_Homonym (Disc, Prev);
11427          Next_Discriminant (Disc);
11428       end loop;
11429    end Install_Discriminants;
11430 
11431    -------------------------
11432    -- Is_Operational_Item --
11433    -------------------------
11434 
11435    function Is_Operational_Item (N : Node_Id) return Boolean is
11436    begin
11437       if Nkind (N) /= N_Attribute_Definition_Clause then
11438          return False;
11439 
11440       else
11441          declare
11442             Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
11443          begin
11444 
11445             --  List of operational items is given in AARM 13.1(8.mm/1).
11446             --  It is clearly incomplete, as it does not include iterator
11447             --  aspects, among others.
11448 
11449             return    Id = Attribute_Constant_Indexing
11450               or else Id = Attribute_Default_Iterator
11451               or else Id = Attribute_Implicit_Dereference
11452               or else Id = Attribute_Input
11453               or else Id = Attribute_Iterator_Element
11454               or else Id = Attribute_Iterable
11455               or else Id = Attribute_Output
11456               or else Id = Attribute_Read
11457               or else Id = Attribute_Variable_Indexing
11458               or else Id = Attribute_Write
11459               or else Id = Attribute_External_Tag;
11460          end;
11461       end if;
11462    end Is_Operational_Item;
11463 
11464    -------------------------
11465    -- Is_Predicate_Static --
11466    -------------------------
11467 
11468    --  Note: the basic legality of the expression has already been checked, so
11469    --  we don't need to worry about cases or ranges on strings for example.
11470 
11471    function Is_Predicate_Static
11472      (Expr : Node_Id;
11473       Nam  : Name_Id) return Boolean
11474    is
11475       function All_Static_Case_Alternatives (L : List_Id) return Boolean;
11476       --  Given a list of case expression alternatives, returns True if all
11477       --  the alternatives are static (have all static choices, and a static
11478       --  expression).
11479 
11480       function All_Static_Choices (L : List_Id) return Boolean;
11481       --  Returns true if all elements of the list are OK static choices
11482       --  as defined below for Is_Static_Choice. Used for case expression
11483       --  alternatives and for the right operand of a membership test. An
11484       --  others_choice is static if the corresponding expression is static.
11485       --  The staticness of the bounds is checked separately.
11486 
11487       function Is_Static_Choice (N : Node_Id) return Boolean;
11488       --  Returns True if N represents a static choice (static subtype, or
11489       --  static subtype indication, or static expression, or static range).
11490       --
11491       --  Note that this is a bit more inclusive than we actually need
11492       --  (in particular membership tests do not allow the use of subtype
11493       --  indications). But that doesn't matter, we have already checked
11494       --  that the construct is legal to get this far.
11495 
11496       function Is_Type_Ref (N : Node_Id) return Boolean;
11497       pragma Inline (Is_Type_Ref);
11498       --  Returns True if N is a reference to the type for the predicate in the
11499       --  expression (i.e. if it is an identifier whose Chars field matches the
11500       --  Nam given in the call). N must not be parenthesized, if the type name
11501       --  appears in parens, this routine will return False.
11502 
11503       ----------------------------------
11504       -- All_Static_Case_Alternatives --
11505       ----------------------------------
11506 
11507       function All_Static_Case_Alternatives (L : List_Id) return Boolean is
11508          N : Node_Id;
11509 
11510       begin
11511          N := First (L);
11512          while Present (N) loop
11513             if not (All_Static_Choices (Discrete_Choices (N))
11514                      and then Is_OK_Static_Expression (Expression (N)))
11515             then
11516                return False;
11517             end if;
11518 
11519             Next (N);
11520          end loop;
11521 
11522          return True;
11523       end All_Static_Case_Alternatives;
11524 
11525       ------------------------
11526       -- All_Static_Choices --
11527       ------------------------
11528 
11529       function All_Static_Choices (L : List_Id) return Boolean is
11530          N : Node_Id;
11531 
11532       begin
11533          N := First (L);
11534          while Present (N) loop
11535             if not Is_Static_Choice (N) then
11536                return False;
11537             end if;
11538 
11539             Next (N);
11540          end loop;
11541 
11542          return True;
11543       end All_Static_Choices;
11544 
11545       ----------------------
11546       -- Is_Static_Choice --
11547       ----------------------
11548 
11549       function Is_Static_Choice (N : Node_Id) return Boolean is
11550       begin
11551          return Nkind (N) = N_Others_Choice
11552            or else Is_OK_Static_Expression (N)
11553            or else (Is_Entity_Name (N) and then Is_Type (Entity (N))
11554                      and then Is_OK_Static_Subtype (Entity (N)))
11555            or else (Nkind (N) = N_Subtype_Indication
11556                      and then Is_OK_Static_Subtype (Entity (N)))
11557            or else (Nkind (N) = N_Range and then Is_OK_Static_Range (N));
11558       end Is_Static_Choice;
11559 
11560       -----------------
11561       -- Is_Type_Ref --
11562       -----------------
11563 
11564       function Is_Type_Ref (N : Node_Id) return Boolean is
11565       begin
11566          return Nkind (N) = N_Identifier
11567            and then Chars (N) = Nam
11568            and then Paren_Count (N) = 0;
11569       end Is_Type_Ref;
11570 
11571    --  Start of processing for Is_Predicate_Static
11572 
11573    begin
11574       --  Predicate_Static means one of the following holds. Numbers are the
11575       --  corresponding paragraph numbers in (RM 3.2.4(16-22)).
11576 
11577       --  16: A static expression
11578 
11579       if Is_OK_Static_Expression (Expr) then
11580          return True;
11581 
11582       --  17: A membership test whose simple_expression is the current
11583       --  instance, and whose membership_choice_list meets the requirements
11584       --  for a static membership test.
11585 
11586       elsif Nkind (Expr) in N_Membership_Test
11587         and then ((Present (Right_Opnd (Expr))
11588                     and then Is_Static_Choice (Right_Opnd (Expr)))
11589                   or else
11590                     (Present (Alternatives (Expr))
11591                       and then All_Static_Choices (Alternatives (Expr))))
11592       then
11593          return True;
11594 
11595       --  18. A case_expression whose selecting_expression is the current
11596       --  instance, and whose dependent expressions are static expressions.
11597 
11598       elsif Nkind (Expr) = N_Case_Expression
11599         and then Is_Type_Ref (Expression (Expr))
11600         and then All_Static_Case_Alternatives (Alternatives (Expr))
11601       then
11602          return True;
11603 
11604       --  19. A call to a predefined equality or ordering operator, where one
11605       --  operand is the current instance, and the other is a static
11606       --  expression.
11607 
11608       --  Note: the RM is clearly wrong here in not excluding string types.
11609       --  Without this exclusion, we would allow expressions like X > "ABC"
11610       --  to be considered as predicate-static, which is clearly not intended,
11611       --  since the idea is for predicate-static to be a subset of normal
11612       --  static expressions (and "DEF" > "ABC" is not a static expression).
11613 
11614       --  However, we do allow internally generated (not from source) equality
11615       --  and inequality operations to be valid on strings (this helps deal
11616       --  with cases where we transform A in "ABC" to A = "ABC).
11617 
11618       elsif Nkind (Expr) in N_Op_Compare
11619         and then ((not Is_String_Type (Etype (Left_Opnd (Expr))))
11620                     or else (Nkind_In (Expr, N_Op_Eq, N_Op_Ne)
11621                               and then not Comes_From_Source (Expr)))
11622         and then ((Is_Type_Ref (Left_Opnd (Expr))
11623                     and then Is_OK_Static_Expression (Right_Opnd (Expr)))
11624                   or else
11625                     (Is_Type_Ref (Right_Opnd (Expr))
11626                       and then Is_OK_Static_Expression (Left_Opnd (Expr))))
11627       then
11628          return True;
11629 
11630       --  20. A call to a predefined boolean logical operator, where each
11631       --  operand is predicate-static.
11632 
11633       elsif (Nkind_In (Expr, N_Op_And, N_Op_Or, N_Op_Xor)
11634               and then Is_Predicate_Static (Left_Opnd (Expr), Nam)
11635               and then Is_Predicate_Static (Right_Opnd (Expr), Nam))
11636         or else
11637             (Nkind (Expr) = N_Op_Not
11638               and then Is_Predicate_Static (Right_Opnd (Expr), Nam))
11639       then
11640          return True;
11641 
11642       --  21. A short-circuit control form where both operands are
11643       --  predicate-static.
11644 
11645       elsif Nkind (Expr) in N_Short_Circuit
11646         and then Is_Predicate_Static (Left_Opnd (Expr), Nam)
11647         and then Is_Predicate_Static (Right_Opnd (Expr), Nam)
11648       then
11649          return True;
11650 
11651       --  22. A parenthesized predicate-static expression. This does not
11652       --  require any special test, since we just ignore paren levels in
11653       --  all the cases above.
11654 
11655       --  One more test that is an implementation artifact caused by the fact
11656       --  that we are analyzing not the original expression, but the generated
11657       --  expression in the body of the predicate function. This can include
11658       --  references to inherited predicates, so that the expression we are
11659       --  processing looks like:
11660 
11661       --    xxPredicate (typ (Inns)) and then expression
11662 
11663       --  Where the call is to a Predicate function for an inherited predicate.
11664       --  We simply ignore such a call, which could be to either a dynamic or
11665       --  a static predicate. Note that if the parent predicate is dynamic then
11666       --  eventually this type will be marked as dynamic, but you are allowed
11667       --  to specify a static predicate for a subtype which is inheriting a
11668       --  dynamic predicate, so the static predicate validation here ignores
11669       --  the inherited predicate even if it is dynamic.
11670       --  In all cases, a static predicate can only apply to a scalar type.
11671 
11672       elsif Nkind (Expr) = N_Function_Call
11673         and then Is_Predicate_Function (Entity (Name (Expr)))
11674         and then Is_Scalar_Type (Etype (First_Entity (Entity (Name (Expr)))))
11675       then
11676          return True;
11677 
11678       --  That's an exhaustive list of tests, all other cases are not
11679       --  predicate-static, so we return False.
11680 
11681       else
11682          return False;
11683       end if;
11684    end Is_Predicate_Static;
11685 
11686    ---------------------
11687    -- Kill_Rep_Clause --
11688    ---------------------
11689 
11690    procedure Kill_Rep_Clause (N : Node_Id) is
11691    begin
11692       pragma Assert (Ignore_Rep_Clauses);
11693 
11694       --  Note: we use Replace rather than Rewrite, because we don't want
11695       --  ASIS to be able to use Original_Node to dig out the (undecorated)
11696       --  rep clause that is being replaced.
11697 
11698       Replace (N, Make_Null_Statement (Sloc (N)));
11699 
11700       --  The null statement must be marked as not coming from source. This is
11701       --  so that ASIS ignores it, and also the back end does not expect bogus
11702       --  "from source" null statements in weird places (e.g. in declarative
11703       --  regions where such null statements are not allowed).
11704 
11705       Set_Comes_From_Source (N, False);
11706    end Kill_Rep_Clause;
11707 
11708    ------------------
11709    -- Minimum_Size --
11710    ------------------
11711 
11712    function Minimum_Size
11713      (T      : Entity_Id;
11714       Biased : Boolean := False) return Nat
11715    is
11716       Lo     : Uint    := No_Uint;
11717       Hi     : Uint    := No_Uint;
11718       LoR    : Ureal   := No_Ureal;
11719       HiR    : Ureal   := No_Ureal;
11720       LoSet  : Boolean := False;
11721       HiSet  : Boolean := False;
11722       B      : Uint;
11723       S      : Nat;
11724       Ancest : Entity_Id;
11725       R_Typ  : constant Entity_Id := Root_Type (T);
11726 
11727    begin
11728       --  If bad type, return 0
11729 
11730       if T = Any_Type then
11731          return 0;
11732 
11733       --  For generic types, just return zero. There cannot be any legitimate
11734       --  need to know such a size, but this routine may be called with a
11735       --  generic type as part of normal processing.
11736 
11737       elsif Is_Generic_Type (R_Typ) or else R_Typ = Any_Type then
11738          return 0;
11739 
11740          --  Access types (cannot have size smaller than System.Address)
11741 
11742       elsif Is_Access_Type (T) then
11743          return System_Address_Size;
11744 
11745       --  Floating-point types
11746 
11747       elsif Is_Floating_Point_Type (T) then
11748          return UI_To_Int (Esize (R_Typ));
11749 
11750       --  Discrete types
11751 
11752       elsif Is_Discrete_Type (T) then
11753 
11754          --  The following loop is looking for the nearest compile time known
11755          --  bounds following the ancestor subtype chain. The idea is to find
11756          --  the most restrictive known bounds information.
11757 
11758          Ancest := T;
11759          loop
11760             if Ancest = Any_Type or else Etype (Ancest) = Any_Type then
11761                return 0;
11762             end if;
11763 
11764             if not LoSet then
11765                if Compile_Time_Known_Value (Type_Low_Bound (Ancest)) then
11766                   Lo := Expr_Rep_Value (Type_Low_Bound (Ancest));
11767                   LoSet := True;
11768                   exit when HiSet;
11769                end if;
11770             end if;
11771 
11772             if not HiSet then
11773                if Compile_Time_Known_Value (Type_High_Bound (Ancest)) then
11774                   Hi := Expr_Rep_Value (Type_High_Bound (Ancest));
11775                   HiSet := True;
11776                   exit when LoSet;
11777                end if;
11778             end if;
11779 
11780             Ancest := Ancestor_Subtype (Ancest);
11781 
11782             if No (Ancest) then
11783                Ancest := Base_Type (T);
11784 
11785                if Is_Generic_Type (Ancest) then
11786                   return 0;
11787                end if;
11788             end if;
11789          end loop;
11790 
11791       --  Fixed-point types. We can't simply use Expr_Value to get the
11792       --  Corresponding_Integer_Value values of the bounds, since these do not
11793       --  get set till the type is frozen, and this routine can be called
11794       --  before the type is frozen. Similarly the test for bounds being static
11795       --  needs to include the case where we have unanalyzed real literals for
11796       --  the same reason.
11797 
11798       elsif Is_Fixed_Point_Type (T) then
11799 
11800          --  The following loop is looking for the nearest compile time known
11801          --  bounds following the ancestor subtype chain. The idea is to find
11802          --  the most restrictive known bounds information.
11803 
11804          Ancest := T;
11805          loop
11806             if Ancest = Any_Type or else Etype (Ancest) = Any_Type then
11807                return 0;
11808             end if;
11809 
11810             --  Note: In the following two tests for LoSet and HiSet, it may
11811             --  seem redundant to test for N_Real_Literal here since normally
11812             --  one would assume that the test for the value being known at
11813             --  compile time includes this case. However, there is a glitch.
11814             --  If the real literal comes from folding a non-static expression,
11815             --  then we don't consider any non- static expression to be known
11816             --  at compile time if we are in configurable run time mode (needed
11817             --  in some cases to give a clearer definition of what is and what
11818             --  is not accepted). So the test is indeed needed. Without it, we
11819             --  would set neither Lo_Set nor Hi_Set and get an infinite loop.
11820 
11821             if not LoSet then
11822                if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal
11823                  or else Compile_Time_Known_Value (Type_Low_Bound (Ancest))
11824                then
11825                   LoR := Expr_Value_R (Type_Low_Bound (Ancest));
11826                   LoSet := True;
11827                   exit when HiSet;
11828                end if;
11829             end if;
11830 
11831             if not HiSet then
11832                if Nkind (Type_High_Bound (Ancest)) = N_Real_Literal
11833                  or else Compile_Time_Known_Value (Type_High_Bound (Ancest))
11834                then
11835                   HiR := Expr_Value_R (Type_High_Bound (Ancest));
11836                   HiSet := True;
11837                   exit when LoSet;
11838                end if;
11839             end if;
11840 
11841             Ancest := Ancestor_Subtype (Ancest);
11842 
11843             if No (Ancest) then
11844                Ancest := Base_Type (T);
11845 
11846                if Is_Generic_Type (Ancest) then
11847                   return 0;
11848                end if;
11849             end if;
11850          end loop;
11851 
11852          Lo := UR_To_Uint (LoR / Small_Value (T));
11853          Hi := UR_To_Uint (HiR / Small_Value (T));
11854 
11855       --  No other types allowed
11856 
11857       else
11858          raise Program_Error;
11859       end if;
11860 
11861       --  Fall through with Hi and Lo set. Deal with biased case
11862 
11863       if (Biased
11864            and then not Is_Fixed_Point_Type (T)
11865            and then not (Is_Enumeration_Type (T)
11866                           and then Has_Non_Standard_Rep (T)))
11867         or else Has_Biased_Representation (T)
11868       then
11869          Hi := Hi - Lo;
11870          Lo := Uint_0;
11871       end if;
11872 
11873       --  Null range case, size is always zero. We only do this in the discrete
11874       --  type case, since that's the odd case that came up. Probably we should
11875       --  also do this in the fixed-point case, but doing so causes peculiar
11876       --  gigi failures, and it is not worth worrying about this incredibly
11877       --  marginal case (explicit null-range fixed-point type declarations)???
11878 
11879       if Lo > Hi and then Is_Discrete_Type (T) then
11880          S := 0;
11881 
11882       --  Signed case. Note that we consider types like range 1 .. -1 to be
11883       --  signed for the purpose of computing the size, since the bounds have
11884       --  to be accommodated in the base type.
11885 
11886       elsif Lo < 0 or else Hi < 0 then
11887          S := 1;
11888          B := Uint_1;
11889 
11890          --  S = size, B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
11891          --  Note that we accommodate the case where the bounds cross. This
11892          --  can happen either because of the way the bounds are declared
11893          --  or because of the algorithm in Freeze_Fixed_Point_Type.
11894 
11895          while Lo < -B
11896            or else Hi < -B
11897            or else Lo >= B
11898            or else Hi >= B
11899          loop
11900             B := Uint_2 ** S;
11901             S := S + 1;
11902          end loop;
11903 
11904       --  Unsigned case
11905 
11906       else
11907          --  If both bounds are positive, make sure that both are represen-
11908          --  table in the case where the bounds are crossed. This can happen
11909          --  either because of the way the bounds are declared, or because of
11910          --  the algorithm in Freeze_Fixed_Point_Type.
11911 
11912          if Lo > Hi then
11913             Hi := Lo;
11914          end if;
11915 
11916          --  S = size, (can accommodate 0 .. (2**size - 1))
11917 
11918          S := 0;
11919          while Hi >= Uint_2 ** S loop
11920             S := S + 1;
11921          end loop;
11922       end if;
11923 
11924       return S;
11925    end Minimum_Size;
11926 
11927    ---------------------------
11928    -- New_Stream_Subprogram --
11929    ---------------------------
11930 
11931    procedure New_Stream_Subprogram
11932      (N     : Node_Id;
11933       Ent   : Entity_Id;
11934       Subp  : Entity_Id;
11935       Nam   : TSS_Name_Type)
11936    is
11937       Loc       : constant Source_Ptr := Sloc (N);
11938       Sname     : constant Name_Id    := Make_TSS_Name (Base_Type (Ent), Nam);
11939       Subp_Id   : Entity_Id;
11940       Subp_Decl : Node_Id;
11941       F         : Entity_Id;
11942       Etyp      : Entity_Id;
11943 
11944       Defer_Declaration : constant Boolean :=
11945                             Is_Tagged_Type (Ent) or else Is_Private_Type (Ent);
11946       --  For a tagged type, there is a declaration for each stream attribute
11947       --  at the freeze point, and we must generate only a completion of this
11948       --  declaration. We do the same for private types, because the full view
11949       --  might be tagged. Otherwise we generate a declaration at the point of
11950       --  the attribute definition clause. If the attribute definition comes
11951       --  from an aspect specification the declaration is part of the freeze
11952       --  actions of the type.
11953 
11954       function Build_Spec return Node_Id;
11955       --  Used for declaration and renaming declaration, so that this is
11956       --  treated as a renaming_as_body.
11957 
11958       ----------------
11959       -- Build_Spec --
11960       ----------------
11961 
11962       function Build_Spec return Node_Id is
11963          Out_P   : constant Boolean := (Nam = TSS_Stream_Read);
11964          Formals : List_Id;
11965          Spec    : Node_Id;
11966          T_Ref   : constant Node_Id := New_Occurrence_Of (Etyp, Loc);
11967 
11968       begin
11969          Subp_Id := Make_Defining_Identifier (Loc, Sname);
11970 
11971          --  S : access Root_Stream_Type'Class
11972 
11973          Formals := New_List (
11974                       Make_Parameter_Specification (Loc,
11975                         Defining_Identifier =>
11976                           Make_Defining_Identifier (Loc, Name_S),
11977                         Parameter_Type =>
11978                           Make_Access_Definition (Loc,
11979                             Subtype_Mark =>
11980                               New_Occurrence_Of (
11981                                 Designated_Type (Etype (F)), Loc))));
11982 
11983          if Nam = TSS_Stream_Input then
11984             Spec :=
11985               Make_Function_Specification (Loc,
11986                 Defining_Unit_Name       => Subp_Id,
11987                 Parameter_Specifications => Formals,
11988                 Result_Definition        => T_Ref);
11989          else
11990             --  V : [out] T
11991 
11992             Append_To (Formals,
11993               Make_Parameter_Specification (Loc,
11994                 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
11995                 Out_Present         => Out_P,
11996                 Parameter_Type      => T_Ref));
11997 
11998             Spec :=
11999               Make_Procedure_Specification (Loc,
12000                 Defining_Unit_Name       => Subp_Id,
12001                 Parameter_Specifications => Formals);
12002          end if;
12003 
12004          return Spec;
12005       end Build_Spec;
12006 
12007    --  Start of processing for New_Stream_Subprogram
12008 
12009    begin
12010       F := First_Formal (Subp);
12011 
12012       if Ekind (Subp) = E_Procedure then
12013          Etyp := Etype (Next_Formal (F));
12014       else
12015          Etyp := Etype (Subp);
12016       end if;
12017 
12018       --  Prepare subprogram declaration and insert it as an action on the
12019       --  clause node. The visibility for this entity is used to test for
12020       --  visibility of the attribute definition clause (in the sense of
12021       --  8.3(23) as amended by AI-195).
12022 
12023       if not Defer_Declaration then
12024          Subp_Decl :=
12025            Make_Subprogram_Declaration (Loc,
12026              Specification => Build_Spec);
12027 
12028       --  For a tagged type, there is always a visible declaration for each
12029       --  stream TSS (it is a predefined primitive operation), and the
12030       --  completion of this declaration occurs at the freeze point, which is
12031       --  not always visible at places where the attribute definition clause is
12032       --  visible. So, we create a dummy entity here for the purpose of
12033       --  tracking the visibility of the attribute definition clause itself.
12034 
12035       else
12036          Subp_Id :=
12037            Make_Defining_Identifier (Loc, New_External_Name (Sname, 'V'));
12038          Subp_Decl :=
12039            Make_Object_Declaration (Loc,
12040              Defining_Identifier => Subp_Id,
12041              Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc));
12042       end if;
12043 
12044       if not Defer_Declaration
12045         and then From_Aspect_Specification (N)
12046         and then Has_Delayed_Freeze (Ent)
12047       then
12048          Append_Freeze_Action (Ent, Subp_Decl);
12049 
12050       else
12051          Insert_Action (N, Subp_Decl);
12052          Set_Entity (N, Subp_Id);
12053       end if;
12054 
12055       Subp_Decl :=
12056         Make_Subprogram_Renaming_Declaration (Loc,
12057           Specification => Build_Spec,
12058           Name          => New_Occurrence_Of (Subp, Loc));
12059 
12060       if Defer_Declaration then
12061          Set_TSS (Base_Type (Ent), Subp_Id);
12062 
12063       else
12064          if From_Aspect_Specification (N) then
12065             Append_Freeze_Action (Ent, Subp_Decl);
12066          else
12067             Insert_Action (N, Subp_Decl);
12068          end if;
12069 
12070          Copy_TSS (Subp_Id, Base_Type (Ent));
12071       end if;
12072    end New_Stream_Subprogram;
12073 
12074    ------------------------------------------
12075    -- Push_Scope_And_Install_Discriminants --
12076    ------------------------------------------
12077 
12078    procedure Push_Scope_And_Install_Discriminants (E : Entity_Id) is
12079    begin
12080       if Has_Discriminants (E) then
12081          Push_Scope (E);
12082 
12083          --  Make the discriminants visible for type declarations and protected
12084          --  type declarations, not for subtype declarations (RM 13.1.1 (12/3))
12085 
12086          if Nkind (Parent (E)) /= N_Subtype_Declaration then
12087             Install_Discriminants (E);
12088          end if;
12089       end if;
12090    end Push_Scope_And_Install_Discriminants;
12091 
12092    ------------------------
12093    -- Rep_Item_Too_Early --
12094    ------------------------
12095 
12096    function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is
12097    begin
12098       --  Cannot apply non-operational rep items to generic types
12099 
12100       if Is_Operational_Item (N) then
12101          return False;
12102 
12103       elsif Is_Type (T)
12104         and then Is_Generic_Type (Root_Type (T))
12105         and then (Nkind (N) /= N_Pragma
12106                    or else Get_Pragma_Id (N) /= Pragma_Convention)
12107       then
12108          Error_Msg_N ("representation item not allowed for generic type", N);
12109          return True;
12110       end if;
12111 
12112       --  Otherwise check for incomplete type
12113 
12114       if Is_Incomplete_Or_Private_Type (T)
12115         and then No (Underlying_Type (T))
12116         and then
12117           (Nkind (N) /= N_Pragma
12118             or else Get_Pragma_Id (N) /= Pragma_Import)
12119       then
12120          Error_Msg_N
12121            ("representation item must be after full type declaration", N);
12122          return True;
12123 
12124       --  If the type has incomplete components, a representation clause is
12125       --  illegal but stream attributes and Convention pragmas are correct.
12126 
12127       elsif Has_Private_Component (T) then
12128          if Nkind (N) = N_Pragma then
12129             return False;
12130 
12131          else
12132             Error_Msg_N
12133               ("representation item must appear after type is fully defined",
12134                 N);
12135             return True;
12136          end if;
12137       else
12138          return False;
12139       end if;
12140    end Rep_Item_Too_Early;
12141 
12142    -----------------------
12143    -- Rep_Item_Too_Late --
12144    -----------------------
12145 
12146    function Rep_Item_Too_Late
12147      (T     : Entity_Id;
12148       N     : Node_Id;
12149       FOnly : Boolean := False) return Boolean
12150    is
12151       S           : Entity_Id;
12152       Parent_Type : Entity_Id;
12153 
12154       procedure No_Type_Rep_Item;
12155       --  Output message indicating that no type-related aspects can be
12156       --  specified due to some property of the parent type.
12157 
12158       procedure Too_Late;
12159       --  Output message for an aspect being specified too late
12160 
12161       --  Note that neither of the above errors is considered a serious one,
12162       --  since the effect is simply that we ignore the representation clause
12163       --  in these cases.
12164       --  Is this really true? In any case if we make this change we must
12165       --  document the requirement in the spec of Rep_Item_Too_Late that
12166       --  if True is returned, then the rep item must be completely ignored???
12167 
12168       ----------------------
12169       -- No_Type_Rep_Item --
12170       ----------------------
12171 
12172       procedure No_Type_Rep_Item is
12173       begin
12174          Error_Msg_N ("|type-related representation item not permitted!", N);
12175       end No_Type_Rep_Item;
12176 
12177       --------------
12178       -- Too_Late --
12179       --------------
12180 
12181       procedure Too_Late is
12182       begin
12183          --  Other compilers seem more relaxed about rep items appearing too
12184          --  late. Since analysis tools typically don't care about rep items
12185          --  anyway, no reason to be too strict about this.
12186 
12187          if not Relaxed_RM_Semantics then
12188             Error_Msg_N ("|representation item appears too late!", N);
12189          end if;
12190       end Too_Late;
12191 
12192    --  Start of processing for Rep_Item_Too_Late
12193 
12194    begin
12195       --  First make sure entity is not frozen (RM 13.1(9))
12196 
12197       if Is_Frozen (T)
12198 
12199         --  Exclude imported types, which may be frozen if they appear in a
12200         --  representation clause for a local type.
12201 
12202         and then not From_Limited_With (T)
12203 
12204         --  Exclude generated entities (not coming from source). The common
12205         --  case is when we generate a renaming which prematurely freezes the
12206         --  renamed internal entity, but we still want to be able to set copies
12207         --  of attribute values such as Size/Alignment.
12208 
12209         and then Comes_From_Source (T)
12210       then
12211          --  A self-referential aspect is illegal if it forces freezing the
12212          --  entity before the corresponding pragma has been analyzed.
12213 
12214          if Nkind_In (N, N_Attribute_Definition_Clause, N_Pragma)
12215            and then From_Aspect_Specification (N)
12216          then
12217             Error_Msg_NE
12218               ("aspect specification causes premature freezing of&", T, N);
12219             Set_Has_Delayed_Freeze (T, False);
12220             return True;
12221          end if;
12222 
12223          Too_Late;
12224          S := First_Subtype (T);
12225 
12226          if Present (Freeze_Node (S)) then
12227             if not Relaxed_RM_Semantics then
12228                Error_Msg_NE
12229                  ("??no more representation items for }", Freeze_Node (S), S);
12230             end if;
12231          end if;
12232 
12233          return True;
12234 
12235       --  Check for case of untagged derived type whose parent either has
12236       --  primitive operations, or is a by reference type (RM 13.1(10)). In
12237       --  this case we do not output a Too_Late message, since there is no
12238       --  earlier point where the rep item could be placed to make it legal.
12239 
12240       elsif Is_Type (T)
12241         and then not FOnly
12242         and then Is_Derived_Type (T)
12243         and then not Is_Tagged_Type (T)
12244       then
12245          Parent_Type := Etype (Base_Type (T));
12246 
12247          if Has_Primitive_Operations (Parent_Type) then
12248             No_Type_Rep_Item;
12249 
12250             if not Relaxed_RM_Semantics then
12251                Error_Msg_NE
12252                  ("\parent type & has primitive operations!", N, Parent_Type);
12253             end if;
12254 
12255             return True;
12256 
12257          elsif Is_By_Reference_Type (Parent_Type) then
12258             No_Type_Rep_Item;
12259 
12260             if not Relaxed_RM_Semantics then
12261                Error_Msg_NE
12262                  ("\parent type & is a by reference type!", N, Parent_Type);
12263             end if;
12264 
12265             return True;
12266          end if;
12267       end if;
12268 
12269       --  No error, but one more warning to consider. The RM (surprisingly)
12270       --  allows this pattern:
12271 
12272       --    type S is ...
12273       --    primitive operations for S
12274       --    type R is new S;
12275       --    rep clause for S
12276 
12277       --  Meaning that calls on the primitive operations of S for values of
12278       --  type R may require possibly expensive implicit conversion operations.
12279       --  This is not an error, but is worth a warning.
12280 
12281       if not Relaxed_RM_Semantics and then Is_Type (T) then
12282          declare
12283             DTL : constant Entity_Id := Derived_Type_Link (Base_Type (T));
12284 
12285          begin
12286             if Present (DTL)
12287               and then Has_Primitive_Operations (Base_Type (T))
12288 
12289               --  For now, do not generate this warning for the case of aspect
12290               --  specification using Ada 2012 syntax, since we get wrong
12291               --  messages we do not understand. The whole business of derived
12292               --  types and rep items seems a bit confused when aspects are
12293               --  used, since the aspects are not evaluated till freeze time.
12294 
12295               and then not From_Aspect_Specification (N)
12296             then
12297                Error_Msg_Sloc := Sloc (DTL);
12298                Error_Msg_N
12299                  ("representation item for& appears after derived type "
12300                   & "declaration#??", N);
12301                Error_Msg_NE
12302                  ("\may result in implicit conversions for primitive "
12303                   & "operations of&??", N, T);
12304                Error_Msg_NE
12305                  ("\to change representations when called with arguments "
12306                   & "of type&??", N, DTL);
12307             end if;
12308          end;
12309       end if;
12310 
12311       --  No error, link item into head of chain of rep items for the entity,
12312       --  but avoid chaining if we have an overloadable entity, and the pragma
12313       --  is one that can apply to multiple overloaded entities.
12314 
12315       if Is_Overloadable (T) and then Nkind (N) = N_Pragma then
12316          declare
12317             Pname : constant Name_Id := Pragma_Name (N);
12318          begin
12319             if Nam_In (Pname, Name_Convention, Name_Import,   Name_Export,
12320                               Name_External,   Name_Interface)
12321             then
12322                return False;
12323             end if;
12324          end;
12325       end if;
12326 
12327       Record_Rep_Item (T, N);
12328       return False;
12329    end Rep_Item_Too_Late;
12330 
12331    -------------------------------------
12332    -- Replace_Type_References_Generic --
12333    -------------------------------------
12334 
12335    procedure Replace_Type_References_Generic (N : Node_Id; T : Entity_Id) is
12336       TName : constant Name_Id := Chars (T);
12337 
12338       function Replace_Type_Ref (N : Node_Id) return Traverse_Result;
12339       --  Processes a single node in the traversal procedure below, checking
12340       --  if node N should be replaced, and if so, doing the replacement.
12341 
12342       function Visible_Component (Comp : Name_Id) return Entity_Id;
12343       --  Given an identifier in the expression, check whether there is a
12344       --  discriminant or component of the type that is directy visible, and
12345       --  rewrite it as the corresponding selected component of the formal of
12346       --  the subprogram. The entity is located by a sequential search, which
12347       --  seems acceptable given the typical size of component lists and check
12348       --  expressions. Possible optimization ???
12349 
12350       ----------------------
12351       -- Replace_Type_Ref --
12352       ----------------------
12353 
12354       function Replace_Type_Ref (N : Node_Id) return Traverse_Result is
12355          Loc : constant Source_Ptr := Sloc (N);
12356 
12357          procedure Add_Prefix (Ref : Node_Id; Comp : Entity_Id);
12358          --  Add the proper prefix to a reference to a component of the type
12359          --  when it is not already a selected component.
12360 
12361          ----------------
12362          -- Add_Prefix --
12363          ----------------
12364 
12365          procedure Add_Prefix (Ref : Node_Id; Comp : Entity_Id) is
12366          begin
12367             Rewrite (Ref,
12368               Make_Selected_Component (Loc,
12369                 Prefix        => New_Occurrence_Of (T, Loc),
12370                 Selector_Name => New_Occurrence_Of (Comp, Loc)));
12371             Replace_Type_Reference (Prefix (Ref));
12372          end Add_Prefix;
12373 
12374          --  Local variables
12375 
12376          Comp : Entity_Id;
12377          Pref : Node_Id;
12378          Scop : Entity_Id;
12379 
12380       --  Start of processing for Replace_Type_Ref
12381 
12382       begin
12383          if Nkind (N) = N_Identifier then
12384 
12385             --  If not the type name, check whether it is a reference to some
12386             --  other type, which must be frozen before the predicate function
12387             --  is analyzed, i.e. before the freeze node of the type to which
12388             --  the predicate applies.
12389 
12390             if Chars (N) /= TName then
12391                if Present (Current_Entity (N))
12392                  and then Is_Type (Current_Entity (N))
12393                then
12394                   Freeze_Before (Freeze_Node (T), Current_Entity (N));
12395                end if;
12396 
12397                --  The components of the type are directly visible and can
12398                --  be referenced without a prefix.
12399 
12400                if Nkind (Parent (N)) = N_Selected_Component then
12401                   null;
12402 
12403                --  In expression C (I), C may be a directly visible function
12404                --  or a visible component that has an array type. Disambiguate
12405                --  by examining the component type.
12406 
12407                elsif Nkind (Parent (N)) = N_Indexed_Component
12408                  and then N = Prefix (Parent (N))
12409                then
12410                   Comp := Visible_Component (Chars (N));
12411 
12412                   if Present (Comp) and then Is_Array_Type (Etype (Comp)) then
12413                      Add_Prefix (N, Comp);
12414                   end if;
12415 
12416                else
12417                   Comp := Visible_Component (Chars (N));
12418 
12419                   if Present (Comp) then
12420                      Add_Prefix (N, Comp);
12421                   end if;
12422                end if;
12423 
12424                return Skip;
12425 
12426             --  Otherwise do the replacement and we are done with this node
12427 
12428             else
12429                Replace_Type_Reference (N);
12430                return Skip;
12431             end if;
12432 
12433          --  Case of selected component (which is what a qualification looks
12434          --  like in the unanalyzed tree, which is what we have.
12435 
12436          elsif Nkind (N) = N_Selected_Component then
12437 
12438             --  If selector name is not our type, keeping going (we might still
12439             --  have an occurrence of the type in the prefix).
12440 
12441             if Nkind (Selector_Name (N)) /= N_Identifier
12442               or else Chars (Selector_Name (N)) /= TName
12443             then
12444                return OK;
12445 
12446             --  Selector name is our type, check qualification
12447 
12448             else
12449                --  Loop through scopes and prefixes, doing comparison
12450 
12451                Scop := Current_Scope;
12452                Pref := Prefix (N);
12453                loop
12454                   --  Continue if no more scopes or scope with no name
12455 
12456                   if No (Scop) or else Nkind (Scop) not in N_Has_Chars then
12457                      return OK;
12458                   end if;
12459 
12460                   --  Do replace if prefix is an identifier matching the scope
12461                   --  that we are currently looking at.
12462 
12463                   if Nkind (Pref) = N_Identifier
12464                     and then Chars (Pref) = Chars (Scop)
12465                   then
12466                      Replace_Type_Reference (N);
12467                      return Skip;
12468                   end if;
12469 
12470                   --  Go check scope above us if prefix is itself of the form
12471                   --  of a selected component, whose selector matches the scope
12472                   --  we are currently looking at.
12473 
12474                   if Nkind (Pref) = N_Selected_Component
12475                     and then Nkind (Selector_Name (Pref)) = N_Identifier
12476                     and then Chars (Selector_Name (Pref)) = Chars (Scop)
12477                   then
12478                      Scop := Scope (Scop);
12479                      Pref := Prefix (Pref);
12480 
12481                   --  For anything else, we don't have a match, so keep on
12482                   --  going, there are still some weird cases where we may
12483                   --  still have a replacement within the prefix.
12484 
12485                   else
12486                      return OK;
12487                   end if;
12488                end loop;
12489             end if;
12490 
12491          --  Continue for any other node kind
12492 
12493          else
12494             return OK;
12495          end if;
12496       end Replace_Type_Ref;
12497 
12498       procedure Replace_Type_Refs is new Traverse_Proc (Replace_Type_Ref);
12499 
12500       -----------------------
12501       -- Visible_Component --
12502       -----------------------
12503 
12504       function Visible_Component (Comp : Name_Id) return Entity_Id is
12505          E : Entity_Id;
12506 
12507       begin
12508          if Ekind (T) /= E_Record_Type then
12509             return Empty;
12510 
12511          else
12512             E := First_Entity (T);
12513             while Present (E) loop
12514                if Comes_From_Source (E) and then Chars (E) = Comp then
12515                   return E;
12516                end if;
12517 
12518                Next_Entity (E);
12519             end loop;
12520 
12521             return Empty;
12522          end if;
12523       end Visible_Component;
12524 
12525    --  Start of processing for Replace_Type_References_Generic
12526 
12527    begin
12528       Replace_Type_Refs (N);
12529    end Replace_Type_References_Generic;
12530 
12531    --------------------------------
12532    -- Resolve_Aspect_Expressions --
12533    --------------------------------
12534 
12535    procedure Resolve_Aspect_Expressions (E : Entity_Id) is
12536       ASN  : Node_Id;
12537       A_Id : Aspect_Id;
12538       Expr : Node_Id;
12539 
12540       function Resolve_Name (N : Node_Id) return Traverse_Result;
12541       --  Verify that all identifiers in the expression, with the exception
12542       --  of references to the current entity, denote visible entities. This
12543       --  is done only to detect visibility errors, as the expression will be
12544       --  properly analyzed/expanded during analysis of the predicate function
12545       --  body. We omit quantified expressions from this test, given that they
12546       --  introduce a local identifier that would require proper expansion to
12547       --  handle properly.
12548 
12549       ------------------
12550       -- Resolve_Name --
12551       ------------------
12552 
12553       function Resolve_Name (N : Node_Id) return Traverse_Result is
12554       begin
12555          if Nkind (N) = N_Selected_Component then
12556             if Nkind (Prefix (N)) = N_Identifier
12557               and then Chars (Prefix (N)) /= Chars (E)
12558             then
12559                Find_Selected_Component (N);
12560             end if;
12561 
12562             return Skip;
12563 
12564          elsif Nkind (N) = N_Identifier and then Chars (N) /= Chars (E) then
12565             Find_Direct_Name (N);
12566             Set_Entity (N, Empty);
12567 
12568          elsif Nkind (N) = N_Quantified_Expression then
12569             return Skip;
12570          end if;
12571 
12572          return OK;
12573       end Resolve_Name;
12574 
12575       procedure Resolve_Aspect_Expression is new Traverse_Proc (Resolve_Name);
12576 
12577    --  Start of processing for Resolve_Aspect_Expressions
12578 
12579    begin
12580       ASN := First_Rep_Item (E);
12581       while Present (ASN) loop
12582          if Nkind (ASN) = N_Aspect_Specification and then Entity (ASN) = E then
12583             A_Id := Get_Aspect_Id (ASN);
12584             Expr := Expression (ASN);
12585 
12586             case A_Id is
12587 
12588                --  For now we only deal with aspects that do not generate
12589                --  subprograms, or that may mention current instances of
12590                --  types. These will require special handling (???TBD).
12591 
12592                when Aspect_Predicate         |
12593                     Aspect_Predicate_Failure |
12594                     Aspect_Invariant         =>
12595                   null;
12596 
12597                when Aspect_Dynamic_Predicate |
12598                     Aspect_Static_Predicate  =>
12599 
12600                   --  Build predicate function specification and preanalyze
12601                   --  expression after type replacement.
12602 
12603                   if No (Predicate_Function (E)) then
12604                      declare
12605                         FDecl : constant Node_Id :=
12606                                   Build_Predicate_Function_Declaration (E);
12607                         pragma Unreferenced (FDecl);
12608                      begin
12609                         Resolve_Aspect_Expression (Expr);
12610                      end;
12611                   end if;
12612 
12613                when Pre_Post_Aspects =>
12614                   null;
12615 
12616                when Aspect_Iterable =>
12617                   if Nkind (Expr) = N_Aggregate then
12618                      declare
12619                         Assoc : Node_Id;
12620 
12621                      begin
12622                         Assoc := First (Component_Associations (Expr));
12623                         while Present (Assoc) loop
12624                            Find_Direct_Name (Expression (Assoc));
12625                            Next (Assoc);
12626                         end loop;
12627                      end;
12628                   end if;
12629 
12630                when others =>
12631                   if Present (Expr) then
12632                      case Aspect_Argument (A_Id) is
12633                         when Expression | Optional_Expression  =>
12634                            Analyze_And_Resolve (Expression (ASN));
12635 
12636                         when Name | Optional_Name =>
12637                            if Nkind (Expr) = N_Identifier then
12638                               Find_Direct_Name (Expr);
12639 
12640                            elsif Nkind (Expr) = N_Selected_Component then
12641                               Find_Selected_Component (Expr);
12642 
12643                            else
12644                               null;
12645                            end if;
12646                      end case;
12647                   end if;
12648             end case;
12649          end if;
12650 
12651          ASN := Next_Rep_Item (ASN);
12652       end loop;
12653    end Resolve_Aspect_Expressions;
12654 
12655    -------------------------
12656    -- Same_Representation --
12657    -------------------------
12658 
12659    function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is
12660       T1 : constant Entity_Id := Underlying_Type (Typ1);
12661       T2 : constant Entity_Id := Underlying_Type (Typ2);
12662 
12663    begin
12664       --  A quick check, if base types are the same, then we definitely have
12665       --  the same representation, because the subtype specific representation
12666       --  attributes (Size and Alignment) do not affect representation from
12667       --  the point of view of this test.
12668 
12669       if Base_Type (T1) = Base_Type (T2) then
12670          return True;
12671 
12672       elsif Is_Private_Type (Base_Type (T2))
12673         and then Base_Type (T1) = Full_View (Base_Type (T2))
12674       then
12675          return True;
12676       end if;
12677 
12678       --  Tagged types never have differing representations
12679 
12680       if Is_Tagged_Type (T1) then
12681          return True;
12682       end if;
12683 
12684       --  Representations are definitely different if conventions differ
12685 
12686       if Convention (T1) /= Convention (T2) then
12687          return False;
12688       end if;
12689 
12690       --  Representations are different if component alignments or scalar
12691       --  storage orders differ.
12692 
12693       if (Is_Record_Type (T1) or else Is_Array_Type (T1))
12694             and then
12695          (Is_Record_Type (T2) or else Is_Array_Type (T2))
12696         and then
12697          (Component_Alignment (T1) /= Component_Alignment (T2)
12698            or else Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
12699       then
12700          return False;
12701       end if;
12702 
12703       --  For arrays, the only real issue is component size. If we know the
12704       --  component size for both arrays, and it is the same, then that's
12705       --  good enough to know we don't have a change of representation.
12706 
12707       if Is_Array_Type (T1) then
12708          if Known_Component_Size (T1)
12709            and then Known_Component_Size (T2)
12710            and then Component_Size (T1) = Component_Size (T2)
12711          then
12712             return True;
12713          end if;
12714       end if;
12715 
12716       --  Types definitely have same representation if neither has non-standard
12717       --  representation since default representations are always consistent.
12718       --  If only one has non-standard representation, and the other does not,
12719       --  then we consider that they do not have the same representation. They
12720       --  might, but there is no way of telling early enough.
12721 
12722       if Has_Non_Standard_Rep (T1) then
12723          if not Has_Non_Standard_Rep (T2) then
12724             return False;
12725          end if;
12726       else
12727          return not Has_Non_Standard_Rep (T2);
12728       end if;
12729 
12730       --  Here the two types both have non-standard representation, and we need
12731       --  to determine if they have the same non-standard representation.
12732 
12733       --  For arrays, we simply need to test if the component sizes are the
12734       --  same. Pragma Pack is reflected in modified component sizes, so this
12735       --  check also deals with pragma Pack.
12736 
12737       if Is_Array_Type (T1) then
12738          return Component_Size (T1) = Component_Size (T2);
12739 
12740       --  Tagged types always have the same representation, because it is not
12741       --  possible to specify different representations for common fields.
12742 
12743       elsif Is_Tagged_Type (T1) then
12744          return True;
12745 
12746       --  Case of record types
12747 
12748       elsif Is_Record_Type (T1) then
12749 
12750          --  Packed status must conform
12751 
12752          if Is_Packed (T1) /= Is_Packed (T2) then
12753             return False;
12754 
12755          --  Otherwise we must check components. Typ2 maybe a constrained
12756          --  subtype with fewer components, so we compare the components
12757          --  of the base types.
12758 
12759          else
12760             Record_Case : declare
12761                CD1, CD2 : Entity_Id;
12762 
12763                function Same_Rep return Boolean;
12764                --  CD1 and CD2 are either components or discriminants. This
12765                --  function tests whether they have the same representation.
12766 
12767                --------------
12768                -- Same_Rep --
12769                --------------
12770 
12771                function Same_Rep return Boolean is
12772                begin
12773                   if No (Component_Clause (CD1)) then
12774                      return No (Component_Clause (CD2));
12775                   else
12776                      --  Note: at this point, component clauses have been
12777                      --  normalized to the default bit order, so that the
12778                      --  comparison of Component_Bit_Offsets is meaningful.
12779 
12780                      return
12781                         Present (Component_Clause (CD2))
12782                           and then
12783                         Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2)
12784                           and then
12785                         Esize (CD1) = Esize (CD2);
12786                   end if;
12787                end Same_Rep;
12788 
12789             --  Start of processing for Record_Case
12790 
12791             begin
12792                if Has_Discriminants (T1) then
12793 
12794                   --  The number of discriminants may be different if the
12795                   --  derived type has fewer (constrained by values). The
12796                   --  invisible discriminants retain the representation of
12797                   --  the original, so the discrepancy does not per se
12798                   --  indicate a different representation.
12799 
12800                   CD1 := First_Discriminant (T1);
12801                   CD2 := First_Discriminant (T2);
12802                   while Present (CD1) and then Present (CD2) loop
12803                      if not Same_Rep then
12804                         return False;
12805                      else
12806                         Next_Discriminant (CD1);
12807                         Next_Discriminant (CD2);
12808                      end if;
12809                   end loop;
12810                end if;
12811 
12812                CD1 := First_Component (Underlying_Type (Base_Type (T1)));
12813                CD2 := First_Component (Underlying_Type (Base_Type (T2)));
12814                while Present (CD1) loop
12815                   if not Same_Rep then
12816                      return False;
12817                   else
12818                      Next_Component (CD1);
12819                      Next_Component (CD2);
12820                   end if;
12821                end loop;
12822 
12823                return True;
12824             end Record_Case;
12825          end if;
12826 
12827       --  For enumeration types, we must check each literal to see if the
12828       --  representation is the same. Note that we do not permit enumeration
12829       --  representation clauses for Character and Wide_Character, so these
12830       --  cases were already dealt with.
12831 
12832       elsif Is_Enumeration_Type (T1) then
12833          Enumeration_Case : declare
12834             L1, L2 : Entity_Id;
12835 
12836          begin
12837             L1 := First_Literal (T1);
12838             L2 := First_Literal (T2);
12839             while Present (L1) loop
12840                if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then
12841                   return False;
12842                else
12843                   Next_Literal (L1);
12844                   Next_Literal (L2);
12845                end if;
12846             end loop;
12847 
12848             return True;
12849          end Enumeration_Case;
12850 
12851       --  Any other types have the same representation for these purposes
12852 
12853       else
12854          return True;
12855       end if;
12856    end Same_Representation;
12857 
12858    --------------------------------
12859    -- Resolve_Iterable_Operation --
12860    --------------------------------
12861 
12862    procedure Resolve_Iterable_Operation
12863      (N      : Node_Id;
12864       Cursor : Entity_Id;
12865       Typ    : Entity_Id;
12866       Nam    : Name_Id)
12867    is
12868       Ent : Entity_Id;
12869       F1  : Entity_Id;
12870       F2  : Entity_Id;
12871 
12872    begin
12873       if not Is_Overloaded (N) then
12874          if not Is_Entity_Name (N)
12875            or else Ekind (Entity (N)) /= E_Function
12876            or else Scope (Entity (N)) /= Scope (Typ)
12877            or else No (First_Formal (Entity (N)))
12878            or else Etype (First_Formal (Entity (N))) /= Typ
12879          then
12880             Error_Msg_N ("iterable primitive must be local function name "
12881                          & "whose first formal is an iterable type", N);
12882             return;
12883          end if;
12884 
12885          Ent := Entity (N);
12886          F1 := First_Formal (Ent);
12887          if Nam = Name_First then
12888 
12889             --  First (Container) => Cursor
12890 
12891             if Etype (Ent) /= Cursor then
12892                Error_Msg_N ("primitive for First must yield a curosr", N);
12893             end if;
12894 
12895          elsif Nam = Name_Next then
12896 
12897             --  Next (Container, Cursor) => Cursor
12898 
12899             F2 := Next_Formal (F1);
12900 
12901             if Etype (F2) /= Cursor
12902               or else Etype (Ent) /= Cursor
12903               or else Present (Next_Formal (F2))
12904             then
12905                Error_Msg_N ("no match for Next iterable primitive", N);
12906             end if;
12907 
12908          elsif Nam = Name_Has_Element then
12909 
12910             --  Has_Element (Container, Cursor) => Boolean
12911 
12912             F2 := Next_Formal (F1);
12913             if Etype (F2) /= Cursor
12914               or else Etype (Ent) /= Standard_Boolean
12915               or else Present (Next_Formal (F2))
12916             then
12917                Error_Msg_N ("no match for Has_Element iterable primitive", N);
12918             end if;
12919 
12920          elsif Nam = Name_Element then
12921             F2 := Next_Formal (F1);
12922 
12923             if No (F2)
12924               or else Etype (F2) /= Cursor
12925               or else Present (Next_Formal (F2))
12926             then
12927                Error_Msg_N ("no match for Element iterable primitive", N);
12928             end if;
12929             null;
12930 
12931          else
12932             raise Program_Error;
12933          end if;
12934 
12935       else
12936          --  Overloaded case: find subprogram with proper signature.
12937          --  Caller will report error if no match is found.
12938 
12939          declare
12940             I  : Interp_Index;
12941             It : Interp;
12942 
12943          begin
12944             Get_First_Interp (N, I, It);
12945             while Present (It.Typ) loop
12946                if Ekind (It.Nam) = E_Function
12947                   and then Scope (It.Nam) = Scope (Typ)
12948                   and then Etype (First_Formal (It.Nam)) = Typ
12949                then
12950                   F1 := First_Formal (It.Nam);
12951 
12952                   if Nam = Name_First then
12953                      if Etype (It.Nam) = Cursor
12954                        and then No (Next_Formal (F1))
12955                      then
12956                         Set_Entity (N, It.Nam);
12957                         exit;
12958                      end if;
12959 
12960                   elsif Nam = Name_Next then
12961                      F2 := Next_Formal (F1);
12962 
12963                      if Present (F2)
12964                        and then No (Next_Formal (F2))
12965                        and then Etype (F2) = Cursor
12966                        and then Etype (It.Nam) = Cursor
12967                      then
12968                         Set_Entity (N, It.Nam);
12969                         exit;
12970                      end if;
12971 
12972                   elsif Nam = Name_Has_Element then
12973                      F2 := Next_Formal (F1);
12974 
12975                      if Present (F2)
12976                        and then No (Next_Formal (F2))
12977                        and then Etype (F2) = Cursor
12978                        and then Etype (It.Nam) = Standard_Boolean
12979                      then
12980                         Set_Entity (N, It.Nam);
12981                         F2 := Next_Formal (F1);
12982                         exit;
12983                      end if;
12984 
12985                   elsif Nam = Name_Element then
12986                      F2 := Next_Formal (F1);
12987 
12988                      if Present (F2)
12989                        and then No (Next_Formal (F2))
12990                        and then Etype (F2) = Cursor
12991                      then
12992                         Set_Entity (N, It.Nam);
12993                         exit;
12994                      end if;
12995                   end if;
12996                end if;
12997 
12998                Get_Next_Interp (I, It);
12999             end loop;
13000          end;
13001       end if;
13002    end Resolve_Iterable_Operation;
13003 
13004    ----------------
13005    -- Set_Biased --
13006    ----------------
13007 
13008    procedure Set_Biased
13009      (E      : Entity_Id;
13010       N      : Node_Id;
13011       Msg    : String;
13012       Biased : Boolean := True)
13013    is
13014    begin
13015       if Biased then
13016          Set_Has_Biased_Representation (E);
13017 
13018          if Warn_On_Biased_Representation then
13019             Error_Msg_NE
13020               ("?B?" & Msg & " forces biased representation for&", N, E);
13021          end if;
13022       end if;
13023    end Set_Biased;
13024 
13025    --------------------
13026    -- Set_Enum_Esize --
13027    --------------------
13028 
13029    procedure Set_Enum_Esize (T : Entity_Id) is
13030       Lo : Uint;
13031       Hi : Uint;
13032       Sz : Nat;
13033 
13034    begin
13035       Init_Alignment (T);
13036 
13037       --  Find the minimum standard size (8,16,32,64) that fits
13038 
13039       Lo := Enumeration_Rep (Entity (Type_Low_Bound (T)));
13040       Hi := Enumeration_Rep (Entity (Type_High_Bound (T)));
13041 
13042       if Lo < 0 then
13043          if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then
13044             Sz := Standard_Character_Size;  -- May be > 8 on some targets
13045 
13046          elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then
13047             Sz := 16;
13048 
13049          elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then
13050             Sz := 32;
13051 
13052          else pragma Assert (Lo >= -Uint_2**63 and then Hi < Uint_2**63);
13053             Sz := 64;
13054          end if;
13055 
13056       else
13057          if Hi < Uint_2**08 then
13058             Sz := Standard_Character_Size;  -- May be > 8 on some targets
13059 
13060          elsif Hi < Uint_2**16 then
13061             Sz := 16;
13062 
13063          elsif Hi < Uint_2**32 then
13064             Sz := 32;
13065 
13066          else pragma Assert (Hi < Uint_2**63);
13067             Sz := 64;
13068          end if;
13069       end if;
13070 
13071       --  That minimum is the proper size unless we have a foreign convention
13072       --  and the size required is 32 or less, in which case we bump the size
13073       --  up to 32. This is required for C and C++ and seems reasonable for
13074       --  all other foreign conventions.
13075 
13076       if Has_Foreign_Convention (T)
13077         and then Esize (T) < Standard_Integer_Size
13078 
13079         --  Don't do this if Short_Enums on target
13080 
13081         and then not Target_Short_Enums
13082       then
13083          Init_Esize (T, Standard_Integer_Size);
13084       else
13085          Init_Esize (T, Sz);
13086       end if;
13087    end Set_Enum_Esize;
13088 
13089    -----------------------------
13090    -- Uninstall_Discriminants --
13091    -----------------------------
13092 
13093    procedure Uninstall_Discriminants (E : Entity_Id) is
13094       Disc  : Entity_Id;
13095       Prev  : Entity_Id;
13096       Outer : Entity_Id;
13097 
13098    begin
13099       --  Discriminants have been made visible for type declarations and
13100       --  protected type declarations, not for subtype declarations.
13101 
13102       if Nkind (Parent (E)) /= N_Subtype_Declaration then
13103          Disc := First_Discriminant (E);
13104          while Present (Disc) loop
13105             if Disc /= Current_Entity (Disc) then
13106                Prev := Current_Entity (Disc);
13107                while Present (Prev)
13108                  and then Present (Homonym (Prev))
13109                  and then Homonym (Prev) /= Disc
13110                loop
13111                   Prev := Homonym (Prev);
13112                end loop;
13113             else
13114                Prev := Empty;
13115             end if;
13116 
13117             Set_Is_Immediately_Visible (Disc, False);
13118 
13119             Outer := Homonym (Disc);
13120             while Present (Outer) and then Scope (Outer) = E loop
13121                Outer := Homonym (Outer);
13122             end loop;
13123 
13124             --  Reset homonym link of other entities, but do not modify link
13125             --  between entities in current scope, so that the back end can
13126             --  have a proper count of local overloadings.
13127 
13128             if No (Prev) then
13129                Set_Name_Entity_Id (Chars (Disc), Outer);
13130 
13131             elsif Scope (Prev) /= Scope (Disc) then
13132                Set_Homonym (Prev,  Outer);
13133             end if;
13134 
13135             Next_Discriminant (Disc);
13136          end loop;
13137       end if;
13138    end Uninstall_Discriminants;
13139 
13140    -------------------------------------------
13141    -- Uninstall_Discriminants_And_Pop_Scope --
13142    -------------------------------------------
13143 
13144    procedure Uninstall_Discriminants_And_Pop_Scope (E : Entity_Id) is
13145    begin
13146       if Has_Discriminants (E) then
13147          Uninstall_Discriminants (E);
13148          Pop_Scope;
13149       end if;
13150    end Uninstall_Discriminants_And_Pop_Scope;
13151 
13152    ------------------------------
13153    -- Validate_Address_Clauses --
13154    ------------------------------
13155 
13156    procedure Validate_Address_Clauses is
13157       function Offset_Value (Expr : Node_Id) return Uint;
13158       --  Given an Address attribute reference, return the value in bits of its
13159       --  offset from the first bit of the underlying entity, or 0 if it is not
13160       --  known at compile time.
13161 
13162       ------------------
13163       -- Offset_Value --
13164       ------------------
13165 
13166       function Offset_Value (Expr : Node_Id) return Uint is
13167          N   : Node_Id := Prefix (Expr);
13168          Off : Uint;
13169          Val : Uint := Uint_0;
13170 
13171       begin
13172          --  Climb the prefix chain and compute the cumulative offset
13173 
13174          loop
13175             if Is_Entity_Name (N) then
13176                return Val;
13177 
13178             elsif Nkind (N) = N_Selected_Component then
13179                Off := Component_Bit_Offset (Entity (Selector_Name (N)));
13180                if Off /= No_Uint and then Off >= Uint_0 then
13181                   Val := Val + Off;
13182                   N   := Prefix (N);
13183                else
13184                   return Uint_0;
13185                end if;
13186 
13187             elsif Nkind (N) = N_Indexed_Component then
13188                Off := Indexed_Component_Bit_Offset (N);
13189                if Off /= No_Uint then
13190                   Val := Val + Off;
13191                   N   := Prefix (N);
13192                else
13193                   return Uint_0;
13194                end if;
13195 
13196             else
13197                return Uint_0;
13198             end if;
13199          end loop;
13200       end Offset_Value;
13201 
13202    --  Start of processing for Validate_Address_Clauses
13203 
13204    begin
13205       for J in Address_Clause_Checks.First .. Address_Clause_Checks.Last loop
13206          declare
13207             ACCR : Address_Clause_Check_Record
13208                      renames Address_Clause_Checks.Table (J);
13209 
13210             Expr : Node_Id;
13211 
13212             X_Alignment : Uint;
13213             Y_Alignment : Uint;
13214 
13215             X_Size : Uint;
13216             Y_Size : Uint;
13217 
13218             X_Offs : Uint;
13219 
13220          begin
13221             --  Skip processing of this entry if warning already posted
13222 
13223             if not Address_Warning_Posted (ACCR.N) then
13224                Expr := Original_Node (Expression (ACCR.N));
13225 
13226                --  Get alignments, sizes and offset, if any
13227 
13228                X_Alignment := Alignment (ACCR.X);
13229                X_Size      := Esize (ACCR.X);
13230 
13231                if Present (ACCR.Y) then
13232                   Y_Alignment := Alignment (ACCR.Y);
13233                   Y_Size      := Esize (ACCR.Y);
13234                end if;
13235 
13236                if ACCR.Off
13237                  and then Nkind (Expr) = N_Attribute_Reference
13238                  and then Attribute_Name (Expr) = Name_Address
13239                then
13240                   X_Offs := Offset_Value (Expr);
13241                else
13242                   X_Offs := Uint_0;
13243                end if;
13244 
13245                --  Check for known value not multiple of alignment
13246 
13247                if No (ACCR.Y) then
13248                   if not Alignment_Checks_Suppressed (ACCR.X)
13249                     and then X_Alignment /= 0
13250                     and then ACCR.A mod X_Alignment /= 0
13251                   then
13252                      Error_Msg_NE
13253                        ("??specified address for& is inconsistent with "
13254                         & "alignment", ACCR.N, ACCR.X);
13255                      Error_Msg_N
13256                        ("\??program execution may be erroneous (RM 13.3(27))",
13257                         ACCR.N);
13258 
13259                      Error_Msg_Uint_1 := X_Alignment;
13260                      Error_Msg_NE ("\??alignment of & is ^", ACCR.N, ACCR.X);
13261                   end if;
13262 
13263                --  Check for large object overlaying smaller one
13264 
13265                elsif Y_Size > Uint_0
13266                  and then X_Size > Uint_0
13267                  and then X_Offs + X_Size > Y_Size
13268                then
13269                   Error_Msg_NE ("??& overlays smaller object", ACCR.N, ACCR.X);
13270                   Error_Msg_N
13271                     ("\??program execution may be erroneous", ACCR.N);
13272 
13273                   Error_Msg_Uint_1 := X_Size;
13274                   Error_Msg_NE ("\??size of & is ^", ACCR.N, ACCR.X);
13275 
13276                   Error_Msg_Uint_1 := Y_Size;
13277                   Error_Msg_NE ("\??size of & is ^", ACCR.N, ACCR.Y);
13278 
13279                   if Y_Size >= X_Size then
13280                      Error_Msg_Uint_1 := X_Offs;
13281                      Error_Msg_NE ("\??but offset of & is ^", ACCR.N, ACCR.X);
13282                   end if;
13283 
13284                --  Check for inadequate alignment, both of the base object
13285                --  and of the offset, if any. We only do this check if the
13286                --  run-time Alignment_Check is active. No point in warning
13287                --  if this check has been suppressed (or is suppressed by
13288                --  default in the non-strict alignment machine case).
13289 
13290                --  Note: we do not check the alignment if we gave a size
13291                --  warning, since it would likely be redundant.
13292 
13293                elsif not Alignment_Checks_Suppressed (ACCR.X)
13294                  and then Y_Alignment /= Uint_0
13295                  and then
13296                    (Y_Alignment < X_Alignment
13297                      or else
13298                        (ACCR.Off
13299                          and then Nkind (Expr) = N_Attribute_Reference
13300                          and then Attribute_Name (Expr) = Name_Address
13301                          and then Has_Compatible_Alignment
13302                                     (ACCR.X, Prefix (Expr), True) /=
13303                                       Known_Compatible))
13304                then
13305                   Error_Msg_NE
13306                     ("??specified address for& may be inconsistent with "
13307                      & "alignment", ACCR.N, ACCR.X);
13308                   Error_Msg_N
13309                     ("\??program execution may be erroneous (RM 13.3(27))",
13310                      ACCR.N);
13311 
13312                   Error_Msg_Uint_1 := X_Alignment;
13313                   Error_Msg_NE ("\??alignment of & is ^", ACCR.N, ACCR.X);
13314 
13315                   Error_Msg_Uint_1 := Y_Alignment;
13316                   Error_Msg_NE ("\??alignment of & is ^", ACCR.N, ACCR.Y);
13317 
13318                   if Y_Alignment >= X_Alignment then
13319                      Error_Msg_N
13320                        ("\??but offset is not multiple of alignment", ACCR.N);
13321                   end if;
13322                end if;
13323             end if;
13324          end;
13325       end loop;
13326    end Validate_Address_Clauses;
13327 
13328    ---------------------------
13329    -- Validate_Independence --
13330    ---------------------------
13331 
13332    procedure Validate_Independence is
13333       SU   : constant Uint := UI_From_Int (System_Storage_Unit);
13334       N    : Node_Id;
13335       E    : Entity_Id;
13336       IC   : Boolean;
13337       Comp : Entity_Id;
13338       Addr : Node_Id;
13339       P    : Node_Id;
13340 
13341       procedure Check_Array_Type (Atyp : Entity_Id);
13342       --  Checks if the array type Atyp has independent components, and
13343       --  if not, outputs an appropriate set of error messages.
13344 
13345       procedure No_Independence;
13346       --  Output message that independence cannot be guaranteed
13347 
13348       function OK_Component (C : Entity_Id) return Boolean;
13349       --  Checks one component to see if it is independently accessible, and
13350       --  if so yields True, otherwise yields False if independent access
13351       --  cannot be guaranteed. This is a conservative routine, it only
13352       --  returns True if it knows for sure, it returns False if it knows
13353       --  there is a problem, or it cannot be sure there is no problem.
13354 
13355       procedure Reason_Bad_Component (C : Entity_Id);
13356       --  Outputs continuation message if a reason can be determined for
13357       --  the component C being bad.
13358 
13359       ----------------------
13360       -- Check_Array_Type --
13361       ----------------------
13362 
13363       procedure Check_Array_Type (Atyp : Entity_Id) is
13364          Ctyp : constant Entity_Id := Component_Type (Atyp);
13365 
13366       begin
13367          --  OK if no alignment clause, no pack, and no component size
13368 
13369          if not Has_Component_Size_Clause (Atyp)
13370            and then not Has_Alignment_Clause (Atyp)
13371            and then not Is_Packed (Atyp)
13372          then
13373             return;
13374          end if;
13375 
13376          --  Case of component size is greater than or equal to 64 and the
13377          --  alignment of the array is at least as large as the alignment
13378          --  of the component. We are definitely OK in this situation.
13379 
13380          if Known_Component_Size (Atyp)
13381            and then Component_Size (Atyp) >= 64
13382            and then Known_Alignment (Atyp)
13383            and then Known_Alignment (Ctyp)
13384            and then Alignment (Atyp) >= Alignment (Ctyp)
13385          then
13386             return;
13387          end if;
13388 
13389          --  Check actual component size
13390 
13391          if not Known_Component_Size (Atyp)
13392            or else not (Addressable (Component_Size (Atyp))
13393                          and then Component_Size (Atyp) < 64)
13394            or else Component_Size (Atyp) mod Esize (Ctyp) /= 0
13395          then
13396             No_Independence;
13397 
13398             --  Bad component size, check reason
13399 
13400             if Has_Component_Size_Clause (Atyp) then
13401                P := Get_Attribute_Definition_Clause
13402                       (Atyp, Attribute_Component_Size);
13403 
13404                if Present (P) then
13405                   Error_Msg_Sloc := Sloc (P);
13406                   Error_Msg_N ("\because of Component_Size clause#", N);
13407                   return;
13408                end if;
13409             end if;
13410 
13411             if Is_Packed (Atyp) then
13412                P := Get_Rep_Pragma (Atyp, Name_Pack);
13413 
13414                if Present (P) then
13415                   Error_Msg_Sloc := Sloc (P);
13416                   Error_Msg_N ("\because of pragma Pack#", N);
13417                   return;
13418                end if;
13419             end if;
13420 
13421             --  No reason found, just return
13422 
13423             return;
13424          end if;
13425 
13426          --  Array type is OK independence-wise
13427 
13428          return;
13429       end Check_Array_Type;
13430 
13431       ---------------------
13432       -- No_Independence --
13433       ---------------------
13434 
13435       procedure No_Independence is
13436       begin
13437          if Pragma_Name (N) = Name_Independent then
13438             Error_Msg_NE ("independence cannot be guaranteed for&", N, E);
13439          else
13440             Error_Msg_NE
13441               ("independent components cannot be guaranteed for&", N, E);
13442          end if;
13443       end No_Independence;
13444 
13445       ------------------
13446       -- OK_Component --
13447       ------------------
13448 
13449       function OK_Component (C : Entity_Id) return Boolean is
13450          Rec  : constant Entity_Id := Scope (C);
13451          Ctyp : constant Entity_Id := Etype (C);
13452 
13453       begin
13454          --  OK if no component clause, no Pack, and no alignment clause
13455 
13456          if No (Component_Clause (C))
13457            and then not Is_Packed (Rec)
13458            and then not Has_Alignment_Clause (Rec)
13459          then
13460             return True;
13461          end if;
13462 
13463          --  Here we look at the actual component layout. A component is
13464          --  addressable if its size is a multiple of the Esize of the
13465          --  component type, and its starting position in the record has
13466          --  appropriate alignment, and the record itself has appropriate
13467          --  alignment to guarantee the component alignment.
13468 
13469          --  Make sure sizes are static, always assume the worst for any
13470          --  cases where we cannot check static values.
13471 
13472          if not (Known_Static_Esize (C)
13473                   and then
13474                  Known_Static_Esize (Ctyp))
13475          then
13476             return False;
13477          end if;
13478 
13479          --  Size of component must be addressable or greater than 64 bits
13480          --  and a multiple of bytes.
13481 
13482          if not Addressable (Esize (C)) and then Esize (C) < Uint_64 then
13483             return False;
13484          end if;
13485 
13486          --  Check size is proper multiple
13487 
13488          if Esize (C) mod Esize (Ctyp) /= 0 then
13489             return False;
13490          end if;
13491 
13492          --  Check alignment of component is OK
13493 
13494          if not Known_Component_Bit_Offset (C)
13495            or else Component_Bit_Offset (C) < Uint_0
13496            or else Component_Bit_Offset (C) mod Esize (Ctyp) /= 0
13497          then
13498             return False;
13499          end if;
13500 
13501          --  Check alignment of record type is OK
13502 
13503          if not Known_Alignment (Rec)
13504            or else (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0
13505          then
13506             return False;
13507          end if;
13508 
13509          --  All tests passed, component is addressable
13510 
13511          return True;
13512       end OK_Component;
13513 
13514       --------------------------
13515       -- Reason_Bad_Component --
13516       --------------------------
13517 
13518       procedure Reason_Bad_Component (C : Entity_Id) is
13519          Rec  : constant Entity_Id := Scope (C);
13520          Ctyp : constant Entity_Id := Etype (C);
13521 
13522       begin
13523          --  If component clause present assume that's the problem
13524 
13525          if Present (Component_Clause (C)) then
13526             Error_Msg_Sloc := Sloc (Component_Clause (C));
13527             Error_Msg_N ("\because of Component_Clause#", N);
13528             return;
13529          end if;
13530 
13531          --  If pragma Pack clause present, assume that's the problem
13532 
13533          if Is_Packed (Rec) then
13534             P := Get_Rep_Pragma (Rec, Name_Pack);
13535 
13536             if Present (P) then
13537                Error_Msg_Sloc := Sloc (P);
13538                Error_Msg_N ("\because of pragma Pack#", N);
13539                return;
13540             end if;
13541          end if;
13542 
13543          --  See if record has bad alignment clause
13544 
13545          if Has_Alignment_Clause (Rec)
13546            and then Known_Alignment (Rec)
13547            and then (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0
13548          then
13549             P := Get_Attribute_Definition_Clause (Rec, Attribute_Alignment);
13550 
13551             if Present (P) then
13552                Error_Msg_Sloc := Sloc (P);
13553                Error_Msg_N ("\because of Alignment clause#", N);
13554             end if;
13555          end if;
13556 
13557          --  Couldn't find a reason, so return without a message
13558 
13559          return;
13560       end Reason_Bad_Component;
13561 
13562    --  Start of processing for Validate_Independence
13563 
13564    begin
13565       for J in Independence_Checks.First .. Independence_Checks.Last loop
13566          N  := Independence_Checks.Table (J).N;
13567          E  := Independence_Checks.Table (J).E;
13568          IC := Pragma_Name (N) = Name_Independent_Components;
13569 
13570          --  Deal with component case
13571 
13572          if Ekind (E) = E_Discriminant or else Ekind (E) = E_Component then
13573             if not OK_Component (E) then
13574                No_Independence;
13575                Reason_Bad_Component (E);
13576                goto Continue;
13577             end if;
13578          end if;
13579 
13580          --  Deal with record with Independent_Components
13581 
13582          if IC and then Is_Record_Type (E) then
13583             Comp := First_Component_Or_Discriminant (E);
13584             while Present (Comp) loop
13585                if not OK_Component (Comp) then
13586                   No_Independence;
13587                   Reason_Bad_Component (Comp);
13588                   goto Continue;
13589                end if;
13590 
13591                Next_Component_Or_Discriminant (Comp);
13592             end loop;
13593          end if;
13594 
13595          --  Deal with address clause case
13596 
13597          if Is_Object (E) then
13598             Addr := Address_Clause (E);
13599 
13600             if Present (Addr) then
13601                No_Independence;
13602                Error_Msg_Sloc := Sloc (Addr);
13603                Error_Msg_N ("\because of Address clause#", N);
13604                goto Continue;
13605             end if;
13606          end if;
13607 
13608          --  Deal with independent components for array type
13609 
13610          if IC and then Is_Array_Type (E) then
13611             Check_Array_Type (E);
13612          end if;
13613 
13614          --  Deal with independent components for array object
13615 
13616          if IC and then Is_Object (E) and then Is_Array_Type (Etype (E)) then
13617             Check_Array_Type (Etype (E));
13618          end if;
13619 
13620       <<Continue>> null;
13621       end loop;
13622    end Validate_Independence;
13623 
13624    ------------------------------
13625    -- Validate_Iterable_Aspect --
13626    ------------------------------
13627 
13628    procedure Validate_Iterable_Aspect (Typ : Entity_Id; ASN : Node_Id) is
13629       Assoc : Node_Id;
13630       Expr  : Node_Id;
13631 
13632       Prim   : Node_Id;
13633       Cursor : constant Entity_Id := Get_Cursor_Type (ASN, Typ);
13634 
13635       First_Id       : Entity_Id;
13636       Next_Id        : Entity_Id;
13637       Has_Element_Id : Entity_Id;
13638       Element_Id     : Entity_Id;
13639 
13640    begin
13641       --  If previous error aspect is unusable
13642 
13643       if Cursor = Any_Type then
13644          return;
13645       end if;
13646 
13647       First_Id       := Empty;
13648       Next_Id        := Empty;
13649       Has_Element_Id := Empty;
13650       Element_Id     := Empty;
13651 
13652       --  Each expression must resolve to a function with the proper signature
13653 
13654       Assoc := First (Component_Associations (Expression (ASN)));
13655       while Present (Assoc) loop
13656          Expr := Expression (Assoc);
13657          Analyze (Expr);
13658 
13659          Prim := First (Choices (Assoc));
13660 
13661          if Nkind (Prim) /= N_Identifier or else Present (Next (Prim)) then
13662             Error_Msg_N ("illegal name in association", Prim);
13663 
13664          elsif Chars (Prim) = Name_First then
13665             Resolve_Iterable_Operation (Expr, Cursor, Typ, Name_First);
13666             First_Id := Entity (Expr);
13667 
13668          elsif Chars (Prim) = Name_Next then
13669             Resolve_Iterable_Operation (Expr, Cursor, Typ, Name_Next);
13670             Next_Id := Entity (Expr);
13671 
13672          elsif Chars (Prim) = Name_Has_Element then
13673             Resolve_Iterable_Operation (Expr, Cursor, Typ, Name_Has_Element);
13674             Has_Element_Id := Entity (Expr);
13675 
13676          elsif Chars (Prim) = Name_Element then
13677             Resolve_Iterable_Operation (Expr, Cursor, Typ, Name_Element);
13678             Element_Id := Entity (Expr);
13679 
13680          else
13681             Error_Msg_N ("invalid name for iterable function", Prim);
13682          end if;
13683 
13684          Next (Assoc);
13685       end loop;
13686 
13687       if No (First_Id) then
13688          Error_Msg_N ("match for First primitive not found", ASN);
13689 
13690       elsif No (Next_Id) then
13691          Error_Msg_N ("match for Next primitive not found", ASN);
13692 
13693       elsif No (Has_Element_Id) then
13694          Error_Msg_N ("match for Has_Element primitive not found", ASN);
13695 
13696       elsif No (Element_Id) then
13697          null;  --  Optional.
13698       end if;
13699    end Validate_Iterable_Aspect;
13700 
13701    -----------------------------------
13702    -- Validate_Unchecked_Conversion --
13703    -----------------------------------
13704 
13705    procedure Validate_Unchecked_Conversion
13706      (N        : Node_Id;
13707       Act_Unit : Entity_Id)
13708    is
13709       Source : Entity_Id;
13710       Target : Entity_Id;
13711       Vnode  : Node_Id;
13712 
13713    begin
13714       --  Obtain source and target types. Note that we call Ancestor_Subtype
13715       --  here because the processing for generic instantiation always makes
13716       --  subtypes, and we want the original frozen actual types.
13717 
13718       --  If we are dealing with private types, then do the check on their
13719       --  fully declared counterparts if the full declarations have been
13720       --  encountered (they don't have to be visible, but they must exist).
13721 
13722       Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit)));
13723 
13724       if Is_Private_Type (Source)
13725         and then Present (Underlying_Type (Source))
13726       then
13727          Source := Underlying_Type (Source);
13728       end if;
13729 
13730       Target := Ancestor_Subtype (Etype (Act_Unit));
13731 
13732       --  If either type is generic, the instantiation happens within a generic
13733       --  unit, and there is nothing to check. The proper check will happen
13734       --  when the enclosing generic is instantiated.
13735 
13736       if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then
13737          return;
13738       end if;
13739 
13740       if Is_Private_Type (Target)
13741         and then Present (Underlying_Type (Target))
13742       then
13743          Target := Underlying_Type (Target);
13744       end if;
13745 
13746       --  Source may be unconstrained array, but not target, except in relaxed
13747       --  semantics mode.
13748 
13749       if Is_Array_Type (Target)
13750         and then not Is_Constrained (Target)
13751         and then not Relaxed_RM_Semantics
13752       then
13753          Error_Msg_N
13754            ("unchecked conversion to unconstrained array not allowed", N);
13755          return;
13756       end if;
13757 
13758       --  Warn if conversion between two different convention pointers
13759 
13760       if Is_Access_Type (Target)
13761         and then Is_Access_Type (Source)
13762         and then Convention (Target) /= Convention (Source)
13763         and then Warn_On_Unchecked_Conversion
13764       then
13765          --  Give warnings for subprogram pointers only on most targets
13766 
13767          if Is_Access_Subprogram_Type (Target)
13768            or else Is_Access_Subprogram_Type (Source)
13769          then
13770             Error_Msg_N
13771               ("?z?conversion between pointers with different conventions!",
13772                N);
13773          end if;
13774       end if;
13775 
13776       --  Warn if one of the operands is Ada.Calendar.Time. Do not emit a
13777       --  warning when compiling GNAT-related sources.
13778 
13779       if Warn_On_Unchecked_Conversion
13780         and then not In_Predefined_Unit (N)
13781         and then RTU_Loaded (Ada_Calendar)
13782         and then (Chars (Source) = Name_Time
13783                     or else
13784                   Chars (Target) = Name_Time)
13785       then
13786          --  If Ada.Calendar is loaded and the name of one of the operands is
13787          --  Time, there is a good chance that this is Ada.Calendar.Time.
13788 
13789          declare
13790             Calendar_Time : constant Entity_Id := Full_View (RTE (RO_CA_Time));
13791          begin
13792             pragma Assert (Present (Calendar_Time));
13793 
13794             if Source = Calendar_Time or else Target = Calendar_Time then
13795                Error_Msg_N
13796                  ("?z?representation of 'Time values may change between "
13797                   & "'G'N'A'T versions", N);
13798             end if;
13799          end;
13800       end if;
13801 
13802       --  Make entry in unchecked conversion table for later processing by
13803       --  Validate_Unchecked_Conversions, which will check sizes and alignments
13804       --  (using values set by the back end where possible). This is only done
13805       --  if the appropriate warning is active.
13806 
13807       if Warn_On_Unchecked_Conversion then
13808          Unchecked_Conversions.Append
13809            (New_Val => UC_Entry'(Eloc     => Sloc (N),
13810                                  Source   => Source,
13811                                  Target   => Target,
13812                                  Act_Unit => Act_Unit));
13813 
13814          --  If both sizes are known statically now, then back-end annotation
13815          --  is not required to do a proper check but if either size is not
13816          --  known statically, then we need the annotation.
13817 
13818          if Known_Static_RM_Size (Source)
13819               and then
13820             Known_Static_RM_Size (Target)
13821          then
13822             null;
13823          else
13824             Back_Annotate_Rep_Info := True;
13825          end if;
13826       end if;
13827 
13828       --  If unchecked conversion to access type, and access type is declared
13829       --  in the same unit as the unchecked conversion, then set the flag
13830       --  No_Strict_Aliasing (no strict aliasing is implicit here)
13831 
13832       if Is_Access_Type (Target) and then
13833         In_Same_Source_Unit (Target, N)
13834       then
13835          Set_No_Strict_Aliasing (Implementation_Base_Type (Target));
13836       end if;
13837 
13838       --  Generate N_Validate_Unchecked_Conversion node for back end in case
13839       --  the back end needs to perform special validation checks.
13840 
13841       --  Shouldn't this be in Exp_Ch13, since the check only gets done if we
13842       --  have full expansion and the back end is called ???
13843 
13844       Vnode :=
13845         Make_Validate_Unchecked_Conversion (Sloc (N));
13846       Set_Source_Type (Vnode, Source);
13847       Set_Target_Type (Vnode, Target);
13848 
13849       --  If the unchecked conversion node is in a list, just insert before it.
13850       --  If not we have some strange case, not worth bothering about.
13851 
13852       if Is_List_Member (N) then
13853          Insert_After (N, Vnode);
13854       end if;
13855    end Validate_Unchecked_Conversion;
13856 
13857    ------------------------------------
13858    -- Validate_Unchecked_Conversions --
13859    ------------------------------------
13860 
13861    procedure Validate_Unchecked_Conversions is
13862    begin
13863       for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop
13864          declare
13865             T : UC_Entry renames Unchecked_Conversions.Table (N);
13866 
13867             Act_Unit : constant Entity_Id  := T.Act_Unit;
13868             Eloc     : constant Source_Ptr := T.Eloc;
13869             Source   : constant Entity_Id  := T.Source;
13870             Target   : constant Entity_Id  := T.Target;
13871 
13872             Source_Siz : Uint;
13873             Target_Siz : Uint;
13874 
13875          begin
13876             --  Skip if function marked as warnings off
13877 
13878             if Warnings_Off (Act_Unit) then
13879                goto Continue;
13880             end if;
13881 
13882             --  This validation check, which warns if we have unequal sizes for
13883             --  unchecked conversion, and thus potentially implementation
13884             --  dependent semantics, is one of the few occasions on which we
13885             --  use the official RM size instead of Esize. See description in
13886             --  Einfo "Handling of Type'Size Values" for details.
13887 
13888             if Serious_Errors_Detected = 0
13889               and then Known_Static_RM_Size (Source)
13890               and then Known_Static_RM_Size (Target)
13891 
13892               --  Don't do the check if warnings off for either type, note the
13893               --  deliberate use of OR here instead of OR ELSE to get the flag
13894               --  Warnings_Off_Used set for both types if appropriate.
13895 
13896               and then not (Has_Warnings_Off (Source)
13897                               or
13898                             Has_Warnings_Off (Target))
13899             then
13900                Source_Siz := RM_Size (Source);
13901                Target_Siz := RM_Size (Target);
13902 
13903                if Source_Siz /= Target_Siz then
13904                   Error_Msg
13905                     ("?z?types for unchecked conversion have different sizes!",
13906                      Eloc);
13907 
13908                   if All_Errors_Mode then
13909                      Error_Msg_Name_1 := Chars (Source);
13910                      Error_Msg_Uint_1 := Source_Siz;
13911                      Error_Msg_Name_2 := Chars (Target);
13912                      Error_Msg_Uint_2 := Target_Siz;
13913                      Error_Msg ("\size of % is ^, size of % is ^?z?", Eloc);
13914 
13915                      Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz);
13916 
13917                      if Is_Discrete_Type (Source)
13918                           and then
13919                         Is_Discrete_Type (Target)
13920                      then
13921                         if Source_Siz > Target_Siz then
13922                            Error_Msg
13923                              ("\?z?^ high order bits of source will "
13924                               & "be ignored!", Eloc);
13925 
13926                         elsif Is_Unsigned_Type (Source) then
13927                            Error_Msg
13928                              ("\?z?source will be extended with ^ high order "
13929                               & "zero bits!", Eloc);
13930 
13931                         else
13932                            Error_Msg
13933                              ("\?z?source will be extended with ^ high order "
13934                               & "sign bits!", Eloc);
13935                         end if;
13936 
13937                      elsif Source_Siz < Target_Siz then
13938                         if Is_Discrete_Type (Target) then
13939                            if Bytes_Big_Endian then
13940                               Error_Msg
13941                                 ("\?z?target value will include ^ undefined "
13942                                  & "low order bits!", Eloc);
13943                            else
13944                               Error_Msg
13945                                 ("\?z?target value will include ^ undefined "
13946                                  & "high order bits!", Eloc);
13947                            end if;
13948 
13949                         else
13950                            Error_Msg
13951                              ("\?z?^ trailing bits of target value will be "
13952                               & "undefined!", Eloc);
13953                         end if;
13954 
13955                      else pragma Assert (Source_Siz > Target_Siz);
13956                         if Is_Discrete_Type (Source) then
13957                            if Bytes_Big_Endian then
13958                               Error_Msg
13959                                 ("\?z?^ low order bits of source will be "
13960                                  & "ignored!", Eloc);
13961                            else
13962                               Error_Msg
13963                                 ("\?z?^ high order bits of source will be "
13964                                  & "ignored!", Eloc);
13965                            end if;
13966 
13967                         else
13968                            Error_Msg
13969                              ("\?z?^ trailing bits of source will be "
13970                               & "ignored!", Eloc);
13971                         end if;
13972                      end if;
13973                   end if;
13974                end if;
13975             end if;
13976 
13977             --  If both types are access types, we need to check the alignment.
13978             --  If the alignment of both is specified, we can do it here.
13979 
13980             if Serious_Errors_Detected = 0
13981               and then Is_Access_Type (Source)
13982               and then Is_Access_Type (Target)
13983               and then Target_Strict_Alignment
13984               and then Present (Designated_Type (Source))
13985               and then Present (Designated_Type (Target))
13986             then
13987                declare
13988                   D_Source : constant Entity_Id := Designated_Type (Source);
13989                   D_Target : constant Entity_Id := Designated_Type (Target);
13990 
13991                begin
13992                   if Known_Alignment (D_Source)
13993                        and then
13994                      Known_Alignment (D_Target)
13995                   then
13996                      declare
13997                         Source_Align : constant Uint := Alignment (D_Source);
13998                         Target_Align : constant Uint := Alignment (D_Target);
13999 
14000                      begin
14001                         if Source_Align < Target_Align
14002                           and then not Is_Tagged_Type (D_Source)
14003 
14004                           --  Suppress warning if warnings suppressed on either
14005                           --  type or either designated type. Note the use of
14006                           --  OR here instead of OR ELSE. That is intentional,
14007                           --  we would like to set flag Warnings_Off_Used in
14008                           --  all types for which warnings are suppressed.
14009 
14010                           and then not (Has_Warnings_Off (D_Source)
14011                                           or
14012                                         Has_Warnings_Off (D_Target)
14013                                           or
14014                                         Has_Warnings_Off (Source)
14015                                           or
14016                                         Has_Warnings_Off (Target))
14017                         then
14018                            Error_Msg_Uint_1 := Target_Align;
14019                            Error_Msg_Uint_2 := Source_Align;
14020                            Error_Msg_Node_1 := D_Target;
14021                            Error_Msg_Node_2 := D_Source;
14022                            Error_Msg
14023                              ("?z?alignment of & (^) is stricter than "
14024                               & "alignment of & (^)!", Eloc);
14025                            Error_Msg
14026                              ("\?z?resulting access value may have invalid "
14027                               & "alignment!", Eloc);
14028                         end if;
14029                      end;
14030                   end if;
14031                end;
14032             end if;
14033          end;
14034 
14035       <<Continue>>
14036          null;
14037       end loop;
14038    end Validate_Unchecked_Conversions;
14039 
14040 end Sem_Ch13;