gcc/ada/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-2013, 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 Lib;      use Lib;
  37 with Lib.Xref; use Lib.Xref;
  38 with Namet;    use Namet;
  39 with Nlists;   use Nlists;
  40 with Nmake;    use Nmake;
  41 with Opt;      use Opt;
  42 with Restrict; use Restrict;
  43 with Rident;   use Rident;
  44 with Rtsfind;  use Rtsfind;
  45 with Sem;      use Sem;
  46 with Sem_Aux;  use Sem_Aux;
  47 with Sem_Ch3;  use Sem_Ch3;
  48 with Sem_Ch6;  use Sem_Ch6;
  49 with Sem_Ch8;  use Sem_Ch8;
  50 with Sem_Ch9;  use Sem_Ch9;
  51 with Sem_Dim;  use Sem_Dim;
  52 with Sem_Disp; use Sem_Disp;
  53 with Sem_Eval; use Sem_Eval;
  54 with Sem_Prag; use Sem_Prag;
  55 with Sem_Res;  use Sem_Res;
  56 with Sem_Type; use Sem_Type;
  57 with Sem_Util; use Sem_Util;
  58 with Sem_Warn; use Sem_Warn;
  59 with Sinput;   use Sinput;
  60 with Snames;   use Snames;
  61 with Stand;    use Stand;
  62 with Sinfo;    use Sinfo;
  63 with Stringt;  use Stringt;
  64 with Targparm; use Targparm;
  65 with Ttypes;   use Ttypes;
  66 with Tbuild;   use Tbuild;
  67 with Urealp;   use Urealp;
  68 with Warnsw;   use Warnsw;
  69
  70 with GNAT.Heap_Sort_G;
  71
  72 package body Sem_Ch13 is
  73
  74    SSU : constant Pos := System_Storage_Unit;
  75    --  Convenient short hand for commonly used constant
  76
  77    -----------------------
  78    -- Local Subprograms --
  79    -----------------------
  80
  81    procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint);
  82    --  This routine is called after setting one of the sizes of type entity
  83    --  Typ to Size. The purpose is to deal with the situation of a derived
  84    --  type whose inherited alignment is no longer appropriate for the new
  85    --  size value. In this case, we reset the Alignment to unknown.
  86
  87    procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id);
  88    --  If Typ has predicates (indicated by Has_Predicates being set for Typ,
  89    --  then either there are pragma Predicate entries on the rep chain for the
  90    --  type (note that Predicate aspects are converted to pragma Predicate), or
  91    --  there are inherited aspects from a parent type, or ancestor subtypes.
  92    --  This procedure builds the spec and body for the Predicate function that
  93    --  tests these predicates. N is the freeze node for the type. The spec of
  94    --  the function is inserted before the freeze node, and the body of the
  95    --  function is inserted after the freeze node. If the predicate expression
  96    --  has at least one Raise_Expression, then this procedure also builds the
  97    --  M version of the predicate function for use in membership tests.
  98
  99    procedure Build_Static_Predicate
 100      (Typ  : Entity_Id;
 101       Expr : Node_Id;
 102       Nam  : Name_Id);
 103    --  Given a predicated type Typ, where Typ is a discrete static subtype,
 104    --  whose predicate expression is Expr, tests if Expr is a static predicate,
 105    --  and if so, builds the predicate range list. Nam is the name of the one
 106    --  argument to the predicate function. Occurrences of the type name in the
 107    --  predicate expression have been replaced by identifier references to this
 108    --  name, which is unique, so any identifier with Chars matching Nam must be
 109    --  a reference to the type. If the predicate is non-static, this procedure
 110    --  returns doing nothing. If the predicate is static, then the predicate
 111    --  list is stored in Static_Predicate (Typ), and the Expr is rewritten as
 112    --  a canonicalized membership operation.
 113
 114    function Get_Alignment_Value (Expr : Node_Id) return Uint;
 115    --  Given the expression for an alignment value, returns the corresponding
 116    --  Uint value. If the value is inappropriate, then error messages are
 117    --  posted as required, and a value of No_Uint is returned.
 118
 119    function Is_Operational_Item (N : Node_Id) return Boolean;
 120    --  A specification for a stream attribute is allowed before the full type
 121    --  is declared, as explained in AI-00137 and the corrigendum. Attributes
 122    --  that do not specify a representation characteristic are operational
 123    --  attributes.
 124
 125    procedure New_Stream_Subprogram
 126      (N    : Node_Id;
 127       Ent  : Entity_Id;
 128       Subp : Entity_Id;
 129       Nam  : TSS_Name_Type);
 130    --  Create a subprogram renaming of a given stream attribute to the
 131    --  designated subprogram and then in the tagged case, provide this as a
 132    --  primitive operation, or in the non-tagged case make an appropriate TSS
 133    --  entry. This is more properly an expansion activity than just semantics,
 134    --  but the presence of user-defined stream functions for limited types is a
 135    --  legality check, which is why this takes place here rather than in
 136    --  exp_ch13, where it was previously. Nam indicates the name of the TSS
 137    --  function to be generated.
 138    --
 139    --  To avoid elaboration anomalies with freeze nodes, for untagged types
 140    --  we generate both a subprogram declaration and a subprogram renaming
 141    --  declaration, so that the attribute specification is handled as a
 142    --  renaming_as_body. For tagged types, the specification is one of the
 143    --  primitive specs.
 144
 145    generic
 146       with procedure Replace_Type_Reference (N : Node_Id);
 147    procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id);
 148    --  This is used to scan an expression for a predicate or invariant aspect
 149    --  replacing occurrences of the name TName (the name of the subtype to
 150    --  which the aspect applies) with appropriate references to the parameter
 151    --  of the predicate function or invariant procedure. The procedure passed
 152    --  as a generic parameter does the actual replacement of node N, which is
 153    --  either a simple direct reference to TName, or a selected component that
 154    --  represents an appropriately qualified occurrence of TName.
 155
 156    procedure Set_Biased
 157      (E      : Entity_Id;
 158       N      : Node_Id;
 159       Msg    : String;
 160       Biased : Boolean := True);
 161    --  If Biased is True, sets Has_Biased_Representation flag for E, and
 162    --  outputs a warning message at node N if Warn_On_Biased_Representation is
 163    --  is True. This warning inserts the string Msg to describe the construct
 164    --  causing biasing.
 165
 166    ----------------------------------------------
 167    -- Table for Validate_Unchecked_Conversions --
 168    ----------------------------------------------
 169
 170    --  The following table collects unchecked conversions for validation.
 171    --  Entries are made by Validate_Unchecked_Conversion and then the call
 172    --  to Validate_Unchecked_Conversions does the actual error checking and
 173    --  posting of warnings. The reason for this delayed processing is to take
 174    --  advantage of back-annotations of size and alignment values performed by
 175    --  the back end.
 176
 177    --  Note: the reason we store a Source_Ptr value instead of a Node_Id is
 178    --  that by the time Validate_Unchecked_Conversions is called, Sprint will
 179    --  already have modified all Sloc values if the -gnatD option is set.
 180
 181    type UC_Entry is record
 182       Eloc   : Source_Ptr; -- node used for posting warnings
 183       Source : Entity_Id;  -- source type for unchecked conversion
 184       Target : Entity_Id;  -- target type for unchecked conversion
 185    end record;
 186
 187    package Unchecked_Conversions is new Table.Table (
 188      Table_Component_Type => UC_Entry,
 189      Table_Index_Type     => Int,
 190      Table_Low_Bound      => 1,
 191      Table_Initial        => 50,
 192      Table_Increment      => 200,
 193      Table_Name           => "Unchecked_Conversions");
 194
 195    ----------------------------------------
 196    -- Table for Validate_Address_Clauses --
 197    ----------------------------------------
 198
 199    --  If an address clause has the form
 200
 201    --    for X'Address use Expr
 202
 203    --  where Expr is of the form Y'Address or recursively is a reference to a
 204    --  constant of either of these forms, and X and Y are entities of objects,
 205    --  then if Y has a smaller alignment than X, that merits a warning about
 206    --  possible bad alignment. The following table collects address clauses of
 207    --  this kind. We put these in a table so that they can be checked after the
 208    --  back end has completed annotation of the alignments of objects, since we
 209    --  can catch more cases that way.
 210
 211    type Address_Clause_Check_Record is record
 212       N : Node_Id;
 213       --  The address clause
 214
 215       X : Entity_Id;
 216       --  The entity of the object overlaying Y
 217
 218       Y : Entity_Id;
 219       --  The entity of the object being overlaid
 220
 221       Off : Boolean;
 222       --  Whether the address is offset within Y
 223    end record;
 224
 225    package Address_Clause_Checks is new Table.Table (
 226      Table_Component_Type => Address_Clause_Check_Record,
 227      Table_Index_Type     => Int,
 228      Table_Low_Bound      => 1,
 229      Table_Initial        => 20,
 230      Table_Increment      => 200,
 231      Table_Name           => "Address_Clause_Checks");
 232
 233    -----------------------------------------
 234    -- Adjust_Record_For_Reverse_Bit_Order --
 235    -----------------------------------------
 236
 237    procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is
 238       Comp : Node_Id;
 239       CC   : Node_Id;
 240
 241    begin
 242       --  Processing depends on version of Ada
 243
 244       --  For Ada 95, we just renumber bits within a storage unit. We do the
 245       --  same for Ada 83 mode, since we recognize the Bit_Order attribute in
 246       --  Ada 83, and are free to add this extension.
 247
 248       if Ada_Version < Ada_2005 then
 249          Comp := First_Component_Or_Discriminant (R);
 250          while Present (Comp) loop
 251             CC := Component_Clause (Comp);
 252
 253             --  If component clause is present, then deal with the non-default
 254             --  bit order case for Ada 95 mode.
 255
 256             --  We only do this processing for the base type, and in fact that
 257             --  is important, since otherwise if there are record subtypes, we
 258             --  could reverse the bits once for each subtype, which is wrong.
 259
 260             if Present (CC) and then Ekind (R) = E_Record_Type then
 261                declare
 262                   CFB : constant Uint    := Component_Bit_Offset (Comp);
 263                   CSZ : constant Uint    := Esize (Comp);
 264                   CLC : constant Node_Id := Component_Clause (Comp);
 265                   Pos : constant Node_Id := Position (CLC);
 266                   FB  : constant Node_Id := First_Bit (CLC);
 267
 268                   Storage_Unit_Offset : constant Uint :=
 269                                           CFB / System_Storage_Unit;
 270
 271                   Start_Bit : constant Uint :=
 272                                 CFB mod System_Storage_Unit;
 273
 274                begin
 275                   --  Cases where field goes over storage unit boundary
 276
 277                   if Start_Bit + CSZ > System_Storage_Unit then
 278
 279                      --  Allow multi-byte field but generate warning
 280
 281                      if Start_Bit mod System_Storage_Unit = 0
 282                        and then CSZ mod System_Storage_Unit = 0
 283                      then
 284                         Error_Msg_N
 285                           ("multi-byte field specified with non-standard"
 286                            & " Bit_Order??", CLC);
 287
 288                         if Bytes_Big_Endian then
 289                            Error_Msg_N
 290                              ("bytes are not reversed "
 291                               & "(component is big-endian)??", CLC);
 292                         else
 293                            Error_Msg_N
 294                              ("bytes are not reversed "
 295                               & "(component is little-endian)??", CLC);
 296                         end if;
 297
 298                         --  Do not allow non-contiguous field
 299
 300                      else
 301                         Error_Msg_N
 302                           ("attempt to specify non-contiguous field "
 303                            & "not permitted", CLC);
 304                         Error_Msg_N
 305                           ("\caused by non-standard Bit_Order "
 306                            & "specified", CLC);
 307                         Error_Msg_N
 308                           ("\consider possibility of using "
 309                            & "Ada 2005 mode here", CLC);
 310                      end if;
 311
 312                   --  Case where field fits in one storage unit
 313
 314                   else
 315                      --  Give warning if suspicious component clause
 316
 317                      if Intval (FB) >= System_Storage_Unit
 318                        and then Warn_On_Reverse_Bit_Order
 319                      then
 320                         Error_Msg_N
 321                           ("Bit_Order clause does not affect " &
 322                            "byte ordering?V?", Pos);
 323                         Error_Msg_Uint_1 :=
 324                           Intval (Pos) + Intval (FB) /
 325                           System_Storage_Unit;
 326                         Error_Msg_N
 327                           ("position normalized to ^ before bit " &
 328                            "order interpreted?V?", Pos);
 329                      end if;
 330
 331                      --  Here is where we fix up the Component_Bit_Offset value
 332                      --  to account for the reverse bit order. Some examples of
 333                      --  what needs to be done are:
 334
 335                      --    First_Bit .. Last_Bit     Component_Bit_Offset
 336                      --      old          new          old       new
 337
 338                      --     0 .. 0       7 .. 7         0         7
 339                      --     0 .. 1       6 .. 7         0         6
 340                      --     0 .. 2       5 .. 7         0         5
 341                      --     0 .. 7       0 .. 7         0         4
 342
 343                      --     1 .. 1       6 .. 6         1         6
 344                      --     1 .. 4       3 .. 6         1         3
 345                      --     4 .. 7       0 .. 3         4         0
 346
 347                      --  The rule is that the first bit is is obtained by
 348                      --  subtracting the old ending bit from storage_unit - 1.
 349
 350                      Set_Component_Bit_Offset
 351                        (Comp,
 352                         (Storage_Unit_Offset * System_Storage_Unit) +
 353                           (System_Storage_Unit - 1) -
 354                           (Start_Bit + CSZ - 1));
 355
 356                      Set_Normalized_First_Bit
 357                        (Comp,
 358                         Component_Bit_Offset (Comp) mod
 359                           System_Storage_Unit);
 360                   end if;
 361                end;
 362             end if;
 363
 364             Next_Component_Or_Discriminant (Comp);
 365          end loop;
 366
 367       --  For Ada 2005, we do machine scalar processing, as fully described In
 368       --  AI-133. This involves gathering all components which start at the
 369       --  same byte offset and processing them together. Same approach is still
 370       --  valid in later versions including Ada 2012.
 371
 372       else
 373          declare
 374             Max_Machine_Scalar_Size : constant Uint :=
 375                                         UI_From_Int
 376                                           (Standard_Long_Long_Integer_Size);
 377             --  We use this as the maximum machine scalar size
 378
 379             Num_CC : Natural;
 380             SSU    : constant Uint := UI_From_Int (System_Storage_Unit);
 381
 382          begin
 383             --  This first loop through components does two things. First it
 384             --  deals with the case of components with component clauses whose
 385             --  length is greater than the maximum machine scalar size (either
 386             --  accepting them or rejecting as needed). Second, it counts the
 387             --  number of components with component clauses whose length does
 388             --  not exceed this maximum for later processing.
 389
 390             Num_CC := 0;
 391             Comp   := First_Component_Or_Discriminant (R);
 392             while Present (Comp) loop
 393                CC := Component_Clause (Comp);
 394
 395                if Present (CC) then
 396                   declare
 397                      Fbit : constant Uint := Static_Integer (First_Bit (CC));
 398                      Lbit : constant Uint := Static_Integer (Last_Bit (CC));
 399
 400                   begin
 401                      --  Case of component with last bit >= max machine scalar
 402
 403                      if Lbit >= Max_Machine_Scalar_Size then
 404
 405                         --  This is allowed only if first bit is zero, and
 406                         --  last bit + 1 is a multiple of storage unit size.
 407
 408                         if Fbit = 0 and then (Lbit + 1) mod SSU = 0 then
 409
 410                            --  This is the case to give a warning if enabled
 411
 412                            if Warn_On_Reverse_Bit_Order then
 413                               Error_Msg_N
 414                                 ("multi-byte field specified with "
 415                                  & "  non-standard Bit_Order?V?", CC);
 416
 417                               if Bytes_Big_Endian then
 418                                  Error_Msg_N
 419                                    ("\bytes are not reversed "
 420                                     & "(component is big-endian)?V?", CC);
 421                               else
 422                                  Error_Msg_N
 423                                    ("\bytes are not reversed "
 424                                     & "(component is little-endian)?V?", CC);
 425                               end if;
 426                            end if;
 427
 428                         --  Give error message for RM 13.5.1(10) violation
 429
 430                         else
 431                            Error_Msg_FE
 432                              ("machine scalar rules not followed for&",
 433                               First_Bit (CC), Comp);
 434
 435                            Error_Msg_Uint_1 := Lbit;
 436                            Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
 437                            Error_Msg_F
 438                              ("\last bit (^) exceeds maximum machine "
 439                               & "scalar size (^)",
 440                               First_Bit (CC));
 441
 442                            if (Lbit + 1) mod SSU /= 0 then
 443                               Error_Msg_Uint_1 := SSU;
 444                               Error_Msg_F
 445                                 ("\and is not a multiple of Storage_Unit (^) "
 446                                  & "(RM 13.4.1(10))",
 447                                  First_Bit (CC));
 448
 449                            else
 450                               Error_Msg_Uint_1 := Fbit;
 451                               Error_Msg_F
 452                                 ("\and first bit (^) is non-zero "
 453                                  & "(RM 13.4.1(10))",
 454                                  First_Bit (CC));
 455                            end if;
 456                         end if;
 457
 458                      --  OK case of machine scalar related component clause,
 459                      --  For now, just count them.
 460
 461                      else
 462                         Num_CC := Num_CC + 1;
 463                      end if;
 464                   end;
 465                end if;
 466
 467                Next_Component_Or_Discriminant (Comp);
 468             end loop;
 469
 470             --  We need to sort the component clauses on the basis of the
 471             --  Position values in the clause, so we can group clauses with
 472             --  the same Position. together to determine the relevant machine
 473             --  scalar size.
 474
 475             Sort_CC : declare
 476                Comps : array (0 .. Num_CC) of Entity_Id;
 477                --  Array to collect component and discriminant entities. The
 478                --  data starts at index 1, the 0'th entry is for the sort
 479                --  routine.
 480
 481                function CP_Lt (Op1, Op2 : Natural) return Boolean;
 482                --  Compare routine for Sort
 483
 484                procedure CP_Move (From : Natural; To : Natural);
 485                --  Move routine for Sort
 486
 487                package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
 488
 489                Start : Natural;
 490                Stop  : Natural;
 491                --  Start and stop positions in the component list of the set of
 492                --  components with the same starting position (that constitute
 493                --  components in a single machine scalar).
 494
 495                MaxL  : Uint;
 496                --  Maximum last bit value of any component in this set
 497
 498                MSS   : Uint;
 499                --  Corresponding machine scalar size
 500
 501                -----------
 502                -- CP_Lt --
 503                -----------
 504
 505                function CP_Lt (Op1, Op2 : Natural) return Boolean is
 506                begin
 507                   return Position (Component_Clause (Comps (Op1))) <
 508                     Position (Component_Clause (Comps (Op2)));
 509                end CP_Lt;
 510
 511                -------------
 512                -- CP_Move --
 513                -------------
 514
 515                procedure CP_Move (From : Natural; To : Natural) is
 516                begin
 517                   Comps (To) := Comps (From);
 518                end CP_Move;
 519
 520                --  Start of processing for Sort_CC
 521
 522             begin
 523                --  Collect the machine scalar relevant component clauses
 524
 525                Num_CC := 0;
 526                Comp   := First_Component_Or_Discriminant (R);
 527                while Present (Comp) loop
 528                   declare
 529                      CC   : constant Node_Id := Component_Clause (Comp);
 530
 531                   begin
 532                      --  Collect only component clauses whose last bit is less
 533                      --  than machine scalar size. Any component clause whose
 534                      --  last bit exceeds this value does not take part in
 535                      --  machine scalar layout considerations. The test for
 536                      --  Error_Posted makes sure we exclude component clauses
 537                      --  for which we already posted an error.
 538
 539                      if Present (CC)
 540                        and then not Error_Posted (Last_Bit (CC))
 541                        and then Static_Integer (Last_Bit (CC)) <
 542                                                     Max_Machine_Scalar_Size
 543                      then
 544                         Num_CC := Num_CC + 1;
 545                         Comps (Num_CC) := Comp;
 546                      end if;
 547                   end;
 548
 549                   Next_Component_Or_Discriminant (Comp);
 550                end loop;
 551
 552                --  Sort by ascending position number
 553
 554                Sorting.Sort (Num_CC);
 555
 556                --  We now have all the components whose size does not exceed
 557                --  the max machine scalar value, sorted by starting position.
 558                --  In this loop we gather groups of clauses starting at the
 559                --  same position, to process them in accordance with AI-133.
 560
 561                Stop := 0;
 562                while Stop < Num_CC loop
 563                   Start := Stop + 1;
 564                   Stop  := Start;
 565                   MaxL  :=
 566                     Static_Integer
 567                       (Last_Bit (Component_Clause (Comps (Start))));
 568                   while Stop < Num_CC loop
 569                      if Static_Integer
 570                           (Position (Component_Clause (Comps (Stop + 1)))) =
 571                         Static_Integer
 572                           (Position (Component_Clause (Comps (Stop))))
 573                      then
 574                         Stop := Stop + 1;
 575                         MaxL :=
 576                           UI_Max
 577                             (MaxL,
 578                              Static_Integer
 579                                (Last_Bit
 580                                   (Component_Clause (Comps (Stop)))));
 581                      else
 582                         exit;
 583                      end if;
 584                   end loop;
 585
 586                   --  Now we have a group of component clauses from Start to
 587                   --  Stop whose positions are identical, and MaxL is the
 588                   --  maximum last bit value of any of these components.
 589
 590                   --  We need to determine the corresponding machine scalar
 591                   --  size. This loop assumes that machine scalar sizes are
 592                   --  even, and that each possible machine scalar has twice
 593                   --  as many bits as the next smaller one.
 594
 595                   MSS := Max_Machine_Scalar_Size;
 596                   while MSS mod 2 = 0
 597                     and then (MSS / 2) >= SSU
 598                     and then (MSS / 2) > MaxL
 599                   loop
 600                      MSS := MSS / 2;
 601                   end loop;
 602
 603                   --  Here is where we fix up the Component_Bit_Offset value
 604                   --  to account for the reverse bit order. Some examples of
 605                   --  what needs to be done for the case of a machine scalar
 606                   --  size of 8 are:
 607
 608                   --    First_Bit .. Last_Bit     Component_Bit_Offset
 609                   --      old          new          old       new
 610
 611                   --     0 .. 0       7 .. 7         0         7
 612                   --     0 .. 1       6 .. 7         0         6
 613                   --     0 .. 2       5 .. 7         0         5
 614                   --     0 .. 7       0 .. 7         0         4
 615
 616                   --     1 .. 1       6 .. 6         1         6
 617                   --     1 .. 4       3 .. 6         1         3
 618                   --     4 .. 7       0 .. 3         4         0
 619
 620                   --  The rule is that the first bit is obtained by subtracting
 621                   --  the old ending bit from machine scalar size - 1.
 622
 623                   for C in Start .. Stop loop
 624                      declare
 625                         Comp : constant Entity_Id := Comps (C);
 626                         CC   : constant Node_Id   := Component_Clause (Comp);
 627
 628                         LB   : constant Uint := Static_Integer (Last_Bit (CC));
 629                         NFB  : constant Uint := MSS - Uint_1 - LB;
 630                         NLB  : constant Uint := NFB + Esize (Comp) - 1;
 631                         Pos  : constant Uint := Static_Integer (Position (CC));
 632
 633                      begin
 634                         if Warn_On_Reverse_Bit_Order then
 635                            Error_Msg_Uint_1 := MSS;
 636                            Error_Msg_N
 637                              ("info: reverse bit order in machine " &
 638                               "scalar of length^?V?", First_Bit (CC));
 639                            Error_Msg_Uint_1 := NFB;
 640                            Error_Msg_Uint_2 := NLB;
 641
 642                            if Bytes_Big_Endian then
 643                               Error_Msg_NE
 644                                 ("\info: big-endian range for "
 645                                  & "component & is ^ .. ^?V?",
 646                                  First_Bit (CC), Comp);
 647                            else
 648                               Error_Msg_NE
 649                                 ("\info: little-endian range "
 650                                  & "for component & is ^ .. ^?V?",
 651                                  First_Bit (CC), Comp);
 652                            end if;
 653                         end if;
 654
 655                         Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
 656                         Set_Normalized_First_Bit (Comp, NFB mod SSU);
 657                      end;
 658                   end loop;
 659                end loop;
 660             end Sort_CC;
 661          end;
 662       end if;
 663    end Adjust_Record_For_Reverse_Bit_Order;
 664
 665    -------------------------------------
 666    -- Alignment_Check_For_Size_Change --
 667    -------------------------------------
 668
 669    procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint) is
 670    begin
 671       --  If the alignment is known, and not set by a rep clause, and is
 672       --  inconsistent with the size being set, then reset it to unknown,
 673       --  we assume in this case that the size overrides the inherited
 674       --  alignment, and that the alignment must be recomputed.
 675
 676       if Known_Alignment (Typ)
 677         and then not Has_Alignment_Clause (Typ)
 678         and then Size mod (Alignment (Typ) * SSU) /= 0
 679       then
 680          Init_Alignment (Typ);
 681       end if;
 682    end Alignment_Check_For_Size_Change;
 683
 684    -------------------------------------
 685    -- Analyze_Aspects_At_Freeze_Point --
 686    -------------------------------------
 687
 688    procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id) is
 689       ASN   : Node_Id;
 690       A_Id  : Aspect_Id;
 691       Ritem : Node_Id;
 692
 693       procedure Analyze_Aspect_Default_Value (ASN : Node_Id);
 694       --  This routine analyzes an Aspect_Default_[Component_]Value denoted by
 695       --  the aspect specification node ASN.
 696
 697       procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id);
 698       --  Given an aspect specification node ASN whose expression is an
 699       --  optional Boolean, this routines creates the corresponding pragma
 700       --  at the freezing point.
 701
 702       ----------------------------------
 703       -- Analyze_Aspect_Default_Value --
 704       ----------------------------------
 705
 706       procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is
 707          Ent  : constant Entity_Id := Entity (ASN);
 708          Expr : constant Node_Id   := Expression (ASN);
 709          Id   : constant Node_Id   := Identifier (ASN);
 710
 711       begin
 712          Error_Msg_Name_1 := Chars (Id);
 713
 714          if not Is_Type (Ent) then
 715             Error_Msg_N ("aspect% can only apply to a type", Id);
 716             return;
 717
 718          elsif not Is_First_Subtype (Ent) then
 719             Error_Msg_N ("aspect% cannot apply to subtype", Id);
 720             return;
 721
 722          elsif A_Id = Aspect_Default_Value
 723            and then not Is_Scalar_Type (Ent)
 724          then
 725             Error_Msg_N ("aspect% can only be applied to scalar type", Id);
 726             return;
 727
 728          elsif A_Id = Aspect_Default_Component_Value then
 729             if not Is_Array_Type (Ent) then
 730                Error_Msg_N ("aspect% can only be applied to array type", Id);
 731                return;
 732
 733             elsif not Is_Scalar_Type (Component_Type (Ent)) then
 734                Error_Msg_N ("aspect% requires scalar components", Id);
 735                return;
 736             end if;
 737          end if;
 738
 739          Set_Has_Default_Aspect (Base_Type (Ent));
 740
 741          if Is_Scalar_Type (Ent) then
 742             Set_Default_Aspect_Value (Ent, Expr);
 743
 744             --  Place default value of base type as well, because that is
 745             --  the semantics of the aspect. It is convenient to link the
 746             --  aspect to both the (possibly anonymous) base type and to
 747             --  the given first subtype.
 748
 749             Set_Default_Aspect_Value (Base_Type (Ent), Expr);
 750
 751          else
 752             Set_Default_Aspect_Component_Value (Ent, Expr);
 753          end if;
 754       end Analyze_Aspect_Default_Value;
 755
 756       -------------------------------------
 757       -- Make_Pragma_From_Boolean_Aspect --
 758       -------------------------------------
 759
 760       procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id) is
 761          Ident  : constant Node_Id    := Identifier (ASN);
 762          A_Name : constant Name_Id    := Chars (Ident);
 763          A_Id   : constant Aspect_Id  := Get_Aspect_Id (A_Name);
 764          Ent    : constant Entity_Id  := Entity (ASN);
 765          Expr   : constant Node_Id    := Expression (ASN);
 766          Loc    : constant Source_Ptr := Sloc (ASN);
 767
 768          Prag : Node_Id;
 769
 770          procedure Check_False_Aspect_For_Derived_Type;
 771          --  This procedure checks for the case of a false aspect for a derived
 772          --  type, which improperly tries to cancel an aspect inherited from
 773          --  the parent.
 774
 775          -----------------------------------------
 776          -- Check_False_Aspect_For_Derived_Type --
 777          -----------------------------------------
 778
 779          procedure Check_False_Aspect_For_Derived_Type is
 780             Par : Node_Id;
 781
 782          begin
 783             --  We are only checking derived types
 784
 785             if not Is_Derived_Type (E) then
 786                return;
 787             end if;
 788
 789             Par := Nearest_Ancestor (E);
 790
 791             case A_Id is
 792                when Aspect_Atomic | Aspect_Shared =>
 793                   if not Is_Atomic (Par) then
 794                      return;
 795                   end if;
 796
 797                when Aspect_Atomic_Components =>
 798                   if not Has_Atomic_Components (Par) then
 799                      return;
 800                   end if;
 801
 802                when Aspect_Discard_Names =>
 803                   if not Discard_Names (Par) then
 804                      return;
 805                   end if;
 806
 807                when Aspect_Pack =>
 808                   if not Is_Packed (Par) then
 809                      return;
 810                   end if;
 811
 812                when Aspect_Unchecked_Union =>
 813                   if not Is_Unchecked_Union (Par) then
 814                      return;
 815                   end if;
 816
 817                when Aspect_Volatile =>
 818                   if not Is_Volatile (Par) then
 819                      return;
 820                   end if;
 821
 822                when Aspect_Volatile_Components =>
 823                   if not Has_Volatile_Components (Par) then
 824                      return;
 825                   end if;
 826
 827                when others =>
 828                   return;
 829             end case;
 830
 831             --  Fall through means we are canceling an inherited aspect
 832
 833             Error_Msg_Name_1 := A_Name;
 834             Error_Msg_NE ("derived type& inherits aspect%, cannot cancel",
 835                           Expr,
 836                           E);
 837
 838          end Check_False_Aspect_For_Derived_Type;
 839
 840       --  Start of processing for Make_Pragma_From_Boolean_Aspect
 841
 842       begin
 843          if Is_False (Static_Boolean (Expr)) then
 844             Check_False_Aspect_For_Derived_Type;
 845
 846          else
 847             Prag :=
 848               Make_Pragma (Loc,
 849                 Pragma_Argument_Associations => New_List (
 850                   Make_Pragma_Argument_Association (Sloc (Ident),
 851                     Expression => New_Occurrence_Of (Ent, Sloc (Ident)))),
 852
 853                 Pragma_Identifier            =>
 854                   Make_Identifier (Sloc (Ident), Chars (Ident)));
 855
 856             Set_From_Aspect_Specification (Prag, True);
 857             Set_Corresponding_Aspect (Prag, ASN);
 858             Set_Aspect_Rep_Item (ASN, Prag);
 859             Set_Is_Delayed_Aspect (Prag);
 860             Set_Parent (Prag, ASN);
 861          end if;
 862       end Make_Pragma_From_Boolean_Aspect;
 863
 864    --  Start of processing for Analyze_Aspects_At_Freeze_Point
 865
 866    begin
 867       --  Must be visible in current scope
 868
 869       if not Scope_Within_Or_Same (Current_Scope, Scope (E)) then
 870          return;
 871       end if;
 872
 873       --  Look for aspect specification entries for this entity
 874
 875       ASN := First_Rep_Item (E);
 876       while Present (ASN) loop
 877          if Nkind (ASN) = N_Aspect_Specification
 878            and then Entity (ASN) = E
 879            and then Is_Delayed_Aspect (ASN)
 880          then
 881             A_Id := Get_Aspect_Id (ASN);
 882
 883             case A_Id is
 884
 885                --  For aspects whose expression is an optional Boolean, make
 886                --  the corresponding pragma at the freezing point.
 887
 888                when Boolean_Aspects      |
 889                     Library_Unit_Aspects =>
 890                   Make_Pragma_From_Boolean_Aspect (ASN);
 891
 892                --  Special handling for aspects that don't correspond to
 893                --  pragmas/attributes.
 894
 895                when Aspect_Default_Value           |
 896                     Aspect_Default_Component_Value =>
 897                   Analyze_Aspect_Default_Value (ASN);
 898
 899                --  Ditto for iterator aspects, because the corresponding
 900                --  attributes may not have been analyzed yet.
 901
 902                when Aspect_Constant_Indexing |
 903                     Aspect_Variable_Indexing |
 904                     Aspect_Default_Iterator  |
 905                     Aspect_Iterator_Element  =>
 906                   Analyze (Expression (ASN));
 907
 908                when others =>
 909                   null;
 910             end case;
 911
 912             Ritem := Aspect_Rep_Item (ASN);
 913
 914             if Present (Ritem) then
 915                Analyze (Ritem);
 916             end if;
 917          end if;
 918
 919          Next_Rep_Item (ASN);
 920       end loop;
 921    end Analyze_Aspects_At_Freeze_Point;
 922
 923    -----------------------------------
 924    -- Analyze_Aspect_Specifications --
 925    -----------------------------------
 926
 927    procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is
 928       procedure Decorate_Delayed_Aspect_And_Pragma
 929         (Asp  : Node_Id;
 930          Prag : Node_Id);
 931       --  Establish the linkages between a delayed aspect and its corresponding
 932       --  pragma. Set all delay-related flags on both constructs.
 933
 934       procedure Insert_Delayed_Pragma (Prag : Node_Id);
 935       --  Insert a postcondition-like pragma into the tree depending on the
 936       --  context. Prag must denote one of the following: Pre, Post, Depends,
 937       --  Global or Contract_Cases.
 938
 939       ----------------------------------------
 940       -- Decorate_Delayed_Aspect_And_Pragma --
 941       ----------------------------------------
 942
 943       procedure Decorate_Delayed_Aspect_And_Pragma
 944         (Asp  : Node_Id;
 945          Prag : Node_Id)
 946       is
 947       begin
 948          Set_Aspect_Rep_Item           (Asp, Prag);
 949          Set_Corresponding_Aspect      (Prag, Asp);
 950          Set_From_Aspect_Specification (Prag);
 951          Set_Is_Delayed_Aspect         (Prag);
 952          Set_Is_Delayed_Aspect         (Asp);
 953          Set_Parent                    (Prag, Asp);
 954       end Decorate_Delayed_Aspect_And_Pragma;
 955
 956       ---------------------------
 957       -- Insert_Delayed_Pragma --
 958       ---------------------------
 959
 960       procedure Insert_Delayed_Pragma (Prag : Node_Id) is
 961          Aux : Node_Id;
 962
 963       begin
 964          --  When the context is a library unit, the pragma is added to the
 965          --  Pragmas_After list.
 966
 967          if Nkind (Parent (N)) = N_Compilation_Unit then
 968             Aux := Aux_Decls_Node (Parent (N));
 969
 970             if No (Pragmas_After (Aux)) then
 971                Set_Pragmas_After (Aux, New_List);
 972             end if;
 973
 974             Prepend (Prag, Pragmas_After (Aux));
 975
 976          --  Pragmas associated with subprogram bodies are inserted in the
 977          --  declarative part.
 978
 979          elsif Nkind (N) = N_Subprogram_Body then
 980             if No (Declarations (N)) then
 981                Set_Declarations (N, New_List);
 982             end if;
 983
 984             Append (Prag, Declarations (N));
 985
 986          --  Default
 987
 988          else
 989             Insert_After (N, Prag);
 990
 991             --  Analyze the pragma before analyzing the proper body of a stub.
 992             --  This ensures that the pragma will appear on the proper contract
 993             --  list (see N_Contract).
 994
 995             if Nkind (N) = N_Subprogram_Body_Stub then
 996                Analyze (Prag);
 997             end if;
 998          end if;
 999       end Insert_Delayed_Pragma;
1000
1001       --  Local variables
1002
1003       Aspect : Node_Id;
1004       Aitem  : Node_Id;
1005       Ent    : Node_Id;
1006
1007       L : constant List_Id := Aspect_Specifications (N);
1008
1009       Ins_Node : Node_Id := N;
1010       --  Insert pragmas/attribute definition clause after this node when no
1011       --  delayed analysis is required.
1012
1013       --  Start of processing for Analyze_Aspect_Specifications
1014
1015       --  The general processing involves building an attribute definition
1016       --  clause or a pragma node that corresponds to the aspect. Then in order
1017       --  to delay the evaluation of this aspect to the freeze point, we attach
1018       --  the corresponding pragma/attribute definition clause to the aspect
1019       --  specification node, which is then placed in the Rep Item chain. In
1020       --  this case we mark the entity by setting the flag Has_Delayed_Aspects
1021       --  and we evaluate the rep item at the freeze point. When the aspect
1022       --  doesn't have a corresponding pragma/attribute definition clause, then
1023       --  its analysis is simply delayed at the freeze point.
1024
1025       --  Some special cases don't require delay analysis, thus the aspect is
1026       --  analyzed right now.
1027
1028       --  Note that there is a special handling for Pre, Post, Test_Case,
1029       --  Contract_Cases aspects. In these cases, we do not have to worry
1030       --  about delay issues, since the pragmas themselves deal with delay
1031       --  of visibility for the expression analysis. Thus, we just insert
1032       --  the pragma after the node N.
1033
1034    begin
1035       pragma Assert (Present (L));
1036
1037       --  Loop through aspects
1038
1039       Aspect := First (L);
1040       Aspect_Loop : while Present (Aspect) loop
1041          Analyze_One_Aspect : declare
1042             Expr : constant Node_Id    := Expression (Aspect);
1043             Id   : constant Node_Id    := Identifier (Aspect);
1044             Loc  : constant Source_Ptr := Sloc (Aspect);
1045             Nam  : constant Name_Id    := Chars (Id);
1046             A_Id : constant Aspect_Id  := Get_Aspect_Id (Nam);
1047             Anod : Node_Id;
1048
1049             Delay_Required : Boolean := True;
1050             --  Set False if delay is not required
1051
1052             Eloc : Source_Ptr := No_Location;
1053             --  Source location of expression, modified when we split PPC's. It
1054             --  is set below when Expr is present.
1055
1056             procedure Analyze_Aspect_External_Or_Link_Name;
1057             --  Perform analysis of the External_Name or Link_Name aspects
1058
1059             procedure Analyze_Aspect_Implicit_Dereference;
1060             --  Perform analysis of the Implicit_Dereference aspects
1061
1062             procedure Make_Aitem_Pragma
1063               (Pragma_Argument_Associations : List_Id;
1064                Pragma_Name                  : Name_Id);
1065             --  This is a wrapper for Make_Pragma used for converting aspects
1066             --  to pragmas. It takes care of Sloc (set from Loc) and building
1067             --  the pragma identifier from the given name. In addition the
1068             --  flags Class_Present and Split_PPC are set from the aspect
1069             --  node, as well as Is_Ignored. This routine also sets the
1070             --  From_Aspect_Specification in the resulting pragma node to
1071             --  True, and sets Corresponding_Aspect to point to the aspect.
1072             --  The resulting pragma is assigned to Aitem.
1073
1074             ------------------------------------------
1075             -- Analyze_Aspect_External_Or_Link_Name --
1076             ------------------------------------------
1077
1078             procedure Analyze_Aspect_External_Or_Link_Name is
1079             begin
1080                --  Verify that there is an Import/Export aspect defined for the
1081                --  entity. The processing of that aspect in turn checks that
1082                --  there is a Convention aspect declared. The pragma is
1083                --  constructed when processing the Convention aspect.
1084
1085                declare
1086                   A : Node_Id;
1087
1088                begin
1089                   A := First (L);
1090                   while Present (A) loop
1091                      exit when Nam_In (Chars (Identifier (A)), Name_Export,
1092                                                                Name_Import);
1093                      Next (A);
1094                   end loop;
1095
1096                   if No (A) then
1097                      Error_Msg_N
1098                        ("missing Import/Export for Link/External name",
1099                          Aspect);
1100                   end if;
1101                end;
1102             end Analyze_Aspect_External_Or_Link_Name;
1103
1104             -----------------------------------------
1105             -- Analyze_Aspect_Implicit_Dereference --
1106             -----------------------------------------
1107
1108             procedure Analyze_Aspect_Implicit_Dereference is
1109             begin
1110                if not Is_Type (E) or else not Has_Discriminants (E) then
1111                   Error_Msg_N
1112                     ("aspect must apply to a type with discriminants", N);
1113
1114                else
1115                   declare
1116                      Disc : Entity_Id;
1117
1118                   begin
1119                      Disc := First_Discriminant (E);
1120                      while Present (Disc) loop
1121                         if Chars (Expr) = Chars (Disc)
1122                           and then Ekind (Etype (Disc)) =
1123                                      E_Anonymous_Access_Type
1124                         then
1125                            Set_Has_Implicit_Dereference (E);
1126                            Set_Has_Implicit_Dereference (Disc);
1127                            return;
1128                         end if;
1129
1130                         Next_Discriminant (Disc);
1131                      end loop;
1132
1133                      --  Error if no proper access discriminant.
1134
1135                      Error_Msg_NE
1136                       ("not an access discriminant of&", Expr, E);
1137                   end;
1138                end if;
1139             end Analyze_Aspect_Implicit_Dereference;
1140
1141             -----------------------
1142             -- Make_Aitem_Pragma --
1143             -----------------------
1144
1145             procedure Make_Aitem_Pragma
1146               (Pragma_Argument_Associations : List_Id;
1147                Pragma_Name                  : Name_Id)
1148             is
1149             begin
1150                --  We should never get here if aspect was disabled
1151
1152                pragma Assert (not Is_Disabled (Aspect));
1153
1154                --  Build the pragma
1155
1156                Aitem :=
1157                  Make_Pragma (Loc,
1158                    Pragma_Argument_Associations =>
1159                      Pragma_Argument_Associations,
1160                    Pragma_Identifier =>
1161                      Make_Identifier (Sloc (Id), Pragma_Name),
1162                    Class_Present     => Class_Present (Aspect),
1163                    Split_PPC         => Split_PPC (Aspect));
1164
1165                --  Set additional semantic fields
1166
1167                if Is_Ignored (Aspect) then
1168                   Set_Is_Ignored (Aitem);
1169                end if;
1170
1171                Set_Corresponding_Aspect (Aitem, Aspect);
1172                Set_From_Aspect_Specification (Aitem, True);
1173             end Make_Aitem_Pragma;
1174
1175          --  Start of processing for Analyze_One_Aspect
1176
1177          begin
1178             --  Skip aspect if already analyzed (not clear if this is needed)
1179
1180             if Analyzed (Aspect) then
1181                goto Continue;
1182             end if;
1183
1184             --  Skip looking at aspect if it is totally disabled. Just mark
1185             --  it as such for later reference in the tree. This also sets
1186             --  the Is_Ignored flag appropriately.
1187
1188             Check_Applicable_Policy (Aspect);
1189
1190             if Is_Disabled (Aspect) then
1191                goto Continue;
1192             end if;
1193
1194             --  Set the source location of expression, used in the case of
1195             --  a failed precondition/postcondition or invariant. Note that
1196             --  the source location of the expression is not usually the best
1197             --  choice here. For example, it gets located on the last AND
1198             --  keyword in a chain of boolean expressiond AND'ed together.
1199             --  It is best to put the message on the first character of the
1200             --  assertion, which is the effect of the First_Node call here.
1201
1202             if Present (Expr) then
1203                Eloc := Sloc (First_Node (Expr));
1204             end if;
1205
1206             --  Check restriction No_Implementation_Aspect_Specifications
1207
1208             if Implementation_Defined_Aspect (A_Id) then
1209                Check_Restriction
1210                  (No_Implementation_Aspect_Specifications, Aspect);
1211             end if;
1212
1213             --  Check restriction No_Specification_Of_Aspect
1214
1215             Check_Restriction_No_Specification_Of_Aspect (Aspect);
1216
1217             --  Analyze this aspect (actual analysis is delayed till later)
1218
1219             Set_Analyzed (Aspect);
1220             Set_Entity (Aspect, E);
1221             Ent := New_Occurrence_Of (E, Sloc (Id));
1222
1223             --  Check for duplicate aspect. Note that the Comes_From_Source
1224             --  test allows duplicate Pre/Post's that we generate internally
1225             --  to escape being flagged here.
1226
1227             if No_Duplicates_Allowed (A_Id) then
1228                Anod := First (L);
1229                while Anod /= Aspect loop
1230                   if Comes_From_Source (Aspect)
1231                     and then Same_Aspect (A_Id, Get_Aspect_Id (Anod))
1232                   then
1233                      Error_Msg_Name_1 := Nam;
1234                      Error_Msg_Sloc := Sloc (Anod);
1235
1236                      --  Case of same aspect specified twice
1237
1238                      if Class_Present (Anod) = Class_Present (Aspect) then
1239                         if not Class_Present (Anod) then
1240                            Error_Msg_NE
1241                              ("aspect% for & previously given#",
1242                               Id, E);
1243                         else
1244                            Error_Msg_NE
1245                              ("aspect `%''Class` for & previously given#",
1246                               Id, E);
1247                         end if;
1248                      end if;
1249                   end if;
1250
1251                   Next (Anod);
1252                end loop;
1253             end if;
1254
1255             --  Check some general restrictions on language defined aspects
1256
1257             if not Implementation_Defined_Aspect (A_Id) then
1258                Error_Msg_Name_1 := Nam;
1259
1260                --  Not allowed for renaming declarations
1261
1262                if Nkind (N) in N_Renaming_Declaration then
1263                   Error_Msg_N
1264                     ("aspect % not allowed for renaming declaration",
1265                      Aspect);
1266                end if;
1267
1268                --  Not allowed for formal type declarations
1269
1270                if Nkind (N) = N_Formal_Type_Declaration then
1271                   Error_Msg_N
1272                     ("aspect % not allowed for formal type declaration",
1273                      Aspect);
1274                end if;
1275             end if;
1276
1277             --  Copy expression for later processing by the procedures
1278             --  Check_Aspect_At_[Freeze_Point | End_Of_Declarations]
1279
1280             Set_Entity (Id, New_Copy_Tree (Expr));
1281
1282             --  Processing based on specific aspect
1283
1284             case A_Id is
1285
1286                --  No_Aspect should be impossible
1287
1288                when No_Aspect =>
1289                   raise Program_Error;
1290
1291                --  Case 1: Aspects corresponding to attribute definition
1292                --  clauses.
1293
1294                when Aspect_Address              |
1295                     Aspect_Alignment            |
1296                     Aspect_Bit_Order            |
1297                     Aspect_Component_Size       |
1298                     Aspect_Constant_Indexing    |
1299                     Aspect_Default_Iterator     |
1300                     Aspect_Dispatching_Domain   |
1301                     Aspect_External_Tag         |
1302                     Aspect_Input                |
1303                     Aspect_Iterator_Element     |
1304                     Aspect_Machine_Radix        |
1305                     Aspect_Object_Size          |
1306                     Aspect_Output               |
1307                     Aspect_Read                 |
1308                     Aspect_Scalar_Storage_Order |
1309                     Aspect_Size                 |
1310                     Aspect_Small                |
1311                     Aspect_Simple_Storage_Pool  |
1312                     Aspect_Storage_Pool         |
1313                     Aspect_Storage_Size         |
1314                     Aspect_Stream_Size          |
1315                     Aspect_Value_Size           |
1316                     Aspect_Variable_Indexing    |
1317                     Aspect_Write                =>
1318
1319                   --  Indexing aspects apply only to tagged type
1320
1321                   if (A_Id = Aspect_Constant_Indexing
1322                        or else A_Id = Aspect_Variable_Indexing)
1323                     and then not (Is_Type (E)
1324                                    and then Is_Tagged_Type (E))
1325                   then
1326                      Error_Msg_N ("indexing applies to a tagged type", N);
1327                      goto Continue;
1328                   end if;
1329
1330                   --  Construct the attribute definition clause
1331
1332                   Aitem :=
1333                     Make_Attribute_Definition_Clause (Loc,
1334                       Name       => Ent,
1335                       Chars      => Chars (Id),
1336                       Expression => Relocate_Node (Expr));
1337
1338                   --  If the address is specified, then we treat the entity as
1339                   --  referenced, to avoid spurious warnings. This is analogous
1340                   --  to what is done with an attribute definition clause, but
1341                   --  here we don't want to generate a reference because this
1342                   --  is the point of definition of the entity.
1343
1344                   if A_Id = Aspect_Address then
1345                      Set_Referenced (E);
1346                   end if;
1347
1348                --  Case 2: Aspects corresponding to pragmas
1349
1350                --  Case 2a: Aspects corresponding to pragmas with two
1351                --  arguments, where the first argument is a local name
1352                --  referring to the entity, and the second argument is the
1353                --  aspect definition expression.
1354
1355                --  Suppress/Unsuppress
1356
1357                when Aspect_Suppress   |
1358                     Aspect_Unsuppress =>
1359
1360                   Make_Aitem_Pragma
1361                     (Pragma_Argument_Associations => New_List (
1362                        Make_Pragma_Argument_Association (Loc,
1363                          Expression => New_Occurrence_Of (E, Loc)),
1364                        Make_Pragma_Argument_Association (Sloc (Expr),
1365                          Expression => Relocate_Node (Expr))),
1366                      Pragma_Name                  => Chars (Id));
1367
1368                --  Synchronization
1369
1370                --  Corresponds to pragma Implemented, construct the pragma
1371
1372                when Aspect_Synchronization =>
1373
1374                   Make_Aitem_Pragma
1375                     (Pragma_Argument_Associations => New_List (
1376                        Make_Pragma_Argument_Association (Loc,
1377                          Expression => New_Occurrence_Of (E, Loc)),
1378                        Make_Pragma_Argument_Association (Sloc (Expr),
1379                          Expression => Relocate_Node (Expr))),
1380                      Pragma_Name                  => Name_Implemented);
1381
1382                   --  No delay is required since the only values are: By_Entry
1383                   --  | By_Protected_Procedure | By_Any | Optional which don't
1384                   --  get analyzed anyway.
1385
1386                   Delay_Required := False;
1387
1388                --  Attach Handler
1389
1390                when Aspect_Attach_Handler =>
1391                   Make_Aitem_Pragma
1392                     (Pragma_Argument_Associations => New_List (
1393                        Make_Pragma_Argument_Association (Sloc (Ent),
1394                          Expression => Ent),
1395                        Make_Pragma_Argument_Association (Sloc (Expr),
1396                          Expression => Relocate_Node (Expr))),
1397                      Pragma_Name                  => Name_Attach_Handler);
1398
1399                --  Dynamic_Predicate, Predicate, Static_Predicate
1400
1401                when Aspect_Dynamic_Predicate |
1402                     Aspect_Predicate         |
1403                     Aspect_Static_Predicate  =>
1404
1405                   --  Construct the pragma (always a pragma Predicate, with
1406                   --  flags recording whether it is static/dynamic). We also
1407                   --  set flags recording this in the type itself.
1408
1409                   Make_Aitem_Pragma
1410                     (Pragma_Argument_Associations => New_List (
1411                        Make_Pragma_Argument_Association (Sloc (Ent),
1412                          Expression => Ent),
1413                        Make_Pragma_Argument_Association (Sloc (Expr),
1414                          Expression => Relocate_Node (Expr))),
1415                      Pragma_Name                  => Name_Predicate);
1416
1417                   --  Mark type has predicates, and remember what kind of
1418                   --  aspect lead to this predicate (we need this to access
1419                   --  the right set of check policies later on).
1420
1421                   Set_Has_Predicates (E);
1422
1423                   if A_Id = Aspect_Dynamic_Predicate then
1424                      Set_Has_Dynamic_Predicate_Aspect (E);
1425                   elsif A_Id = Aspect_Static_Predicate then
1426                      Set_Has_Static_Predicate_Aspect (E);
1427                   end if;
1428
1429                   --  If the type is private, indicate that its completion
1430                   --  has a freeze node, because that is the one that will be
1431                   --  visible at freeze time.
1432
1433                   if Is_Private_Type (E) and then Present (Full_View (E)) then
1434                      Set_Has_Predicates (Full_View (E));
1435
1436                      if A_Id = Aspect_Dynamic_Predicate then
1437                         Set_Has_Dynamic_Predicate_Aspect (Full_View (E));
1438                      elsif A_Id = Aspect_Static_Predicate then
1439                         Set_Has_Static_Predicate_Aspect (Full_View (E));
1440                      end if;
1441
1442                      Set_Has_Delayed_Aspects (Full_View (E));
1443                      Ensure_Freeze_Node (Full_View (E));
1444                   end if;
1445
1446                --  Case 2b: Aspects corresponding to pragmas with two
1447                --  arguments, where the second argument is a local name
1448                --  referring to the entity, and the first argument is the
1449                --  aspect definition expression.
1450
1451                --  Convention
1452
1453                when Aspect_Convention  =>
1454
1455                   --  The aspect may be part of the specification of an import
1456                   --  or export pragma. Scan the aspect list to gather the
1457                   --  other components, if any. The name of the generated
1458                   --  pragma is one of Convention/Import/Export.
1459
1460                   declare
1461                      P_Name   : Name_Id;
1462                      A_Name   : Name_Id;
1463                      A        : Node_Id;
1464                      Arg_List : List_Id;
1465                      Found    : Boolean;
1466                      L_Assoc  : Node_Id;
1467                      E_Assoc  : Node_Id;
1468
1469                   begin
1470                      P_Name   := Chars (Id);
1471                      Found    := False;
1472                      Arg_List := New_List;
1473                      L_Assoc  := Empty;
1474                      E_Assoc  := Empty;
1475
1476                      A := First (L);
1477                      while Present (A) loop
1478                         A_Name := Chars (Identifier (A));
1479
1480                         if Nam_In (A_Name, Name_Import, Name_Export) then
1481                            if Found then
1482                               Error_Msg_N ("conflicting", A);
1483                            else
1484                               Found := True;
1485                            end if;
1486
1487                            P_Name := A_Name;
1488
1489                         elsif A_Name = Name_Link_Name then
1490                            L_Assoc :=
1491                              Make_Pragma_Argument_Association (Loc,
1492                                Chars      => A_Name,
1493                                Expression => Relocate_Node (Expression (A)));
1494
1495                         elsif A_Name = Name_External_Name then
1496                            E_Assoc :=
1497                              Make_Pragma_Argument_Association (Loc,
1498                                Chars      => A_Name,
1499                                Expression => Relocate_Node (Expression (A)));
1500                         end if;
1501
1502                         Next (A);
1503                      end loop;
1504
1505                      Arg_List := New_List (
1506                        Make_Pragma_Argument_Association (Sloc (Expr),
1507                          Expression => Relocate_Node (Expr)),
1508                        Make_Pragma_Argument_Association (Sloc (Ent),
1509                          Expression => Ent));
1510
1511                      if Present (L_Assoc) then
1512                         Append_To (Arg_List, L_Assoc);
1513                      end if;
1514
1515                      if Present (E_Assoc) then
1516                         Append_To (Arg_List, E_Assoc);
1517                      end if;
1518
1519                      Make_Aitem_Pragma
1520                        (Pragma_Argument_Associations => Arg_List,
1521                         Pragma_Name                  => P_Name);
1522
1523                      --  Convention is a static name, and must be associated
1524                      --  with the entity at once.
1525
1526                      Delay_Required := False;
1527                   end;
1528
1529                --  CPU, Interrupt_Priority, Priority
1530
1531                --  These three aspects can be specified for a subprogram body,
1532                --  in which case we generate pragmas for them and insert them
1533                --  ahead of local declarations, rather than after the body.
1534
1535                when Aspect_CPU                |
1536                     Aspect_Interrupt_Priority |
1537                     Aspect_Priority           =>
1538
1539                   if Nkind (N) = N_Subprogram_Body then
1540                      Make_Aitem_Pragma
1541                        (Pragma_Argument_Associations => New_List (
1542                           Make_Pragma_Argument_Association (Sloc (Expr),
1543                             Expression => Relocate_Node (Expr))),
1544                         Pragma_Name                  => Chars (Id));
1545
1546                   else
1547                      Aitem :=
1548                        Make_Attribute_Definition_Clause (Loc,
1549                          Name       => Ent,
1550                          Chars      => Chars (Id),
1551                          Expression => Relocate_Node (Expr));
1552                   end if;
1553
1554                --  Warnings
1555
1556                when Aspect_Warnings =>
1557
1558                   Make_Aitem_Pragma
1559                     (Pragma_Argument_Associations => New_List (
1560                        Make_Pragma_Argument_Association (Sloc (Expr),
1561                          Expression => Relocate_Node (Expr)),
1562                        Make_Pragma_Argument_Association (Loc,
1563                          Expression => New_Occurrence_Of (E, Loc))),
1564                      Pragma_Name                  => Chars (Id));
1565
1566                   --  We don't have to play the delay game here, since the only
1567                   --  values are ON/OFF which don't get analyzed anyway.
1568
1569                   Delay_Required := False;
1570
1571                --  Case 2c: Aspects corresponding to pragmas with three
1572                --  arguments.
1573
1574                --  Invariant aspects have a first argument that references the
1575                --  entity, a second argument that is the expression and a third
1576                --  argument that is an appropriate message.
1577
1578                --  Invariant, Type_Invariant
1579
1580                when Aspect_Invariant      |
1581                     Aspect_Type_Invariant =>
1582
1583                   --  Analysis of the pragma will verify placement legality:
1584                   --  an invariant must apply to a private type, or appear in
1585                   --  the private part of a spec and apply to a completion.
1586
1587                   Make_Aitem_Pragma
1588                     (Pragma_Argument_Associations => New_List (
1589                        Make_Pragma_Argument_Association (Sloc (Ent),
1590                          Expression => Ent),
1591                        Make_Pragma_Argument_Association (Sloc (Expr),
1592                          Expression => Relocate_Node (Expr))),
1593                      Pragma_Name                  => Name_Invariant);
1594
1595                   --  Add message unless exception messages are suppressed
1596
1597                   if not Opt.Exception_Locations_Suppressed then
1598                      Append_To (Pragma_Argument_Associations (Aitem),
1599                        Make_Pragma_Argument_Association (Eloc,
1600                          Chars      => Name_Message,
1601                          Expression =>
1602                            Make_String_Literal (Eloc,
1603                              Strval => "failed invariant from "
1604                                        & Build_Location_String (Eloc))));
1605                   end if;
1606
1607                   --  For Invariant case, insert immediately after the entity
1608                   --  declaration. We do not have to worry about delay issues
1609                   --  since the pragma processing takes care of this.
1610
1611                   Delay_Required := False;
1612
1613                --  Case 2d : Aspects that correspond to a pragma with one
1614                --  argument.
1615
1616                --  Abstract_State
1617
1618                when Aspect_Abstract_State =>
1619                   Make_Aitem_Pragma
1620                     (Pragma_Argument_Associations => New_List (
1621                        Make_Pragma_Argument_Association (Loc,
1622                          Expression => Relocate_Node (Expr))),
1623                      Pragma_Name                  => Name_Abstract_State);
1624                   Delay_Required := False;
1625
1626                --  Depends
1627
1628                --  Aspect Depends must be delayed because it mentions names
1629                --  of inputs and output that are classified by aspect Global.
1630                --  The aspect and pragma are treated the same way as a post
1631                --  condition.
1632
1633                when Aspect_Depends =>
1634                   Make_Aitem_Pragma
1635                     (Pragma_Argument_Associations => New_List (
1636                        Make_Pragma_Argument_Association (Loc,
1637                          Expression => Relocate_Node (Expr))),
1638                      Pragma_Name                  => Name_Depends);
1639
1640                   Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem);
1641                   Insert_Delayed_Pragma (Aitem);
1642                   goto Continue;
1643
1644                --  Global
1645
1646                --  Aspect Global must be delayed because it can mention names
1647                --  and benefit from the forward visibility rules applicable to
1648                --  aspects of subprograms. The aspect and pragma are treated
1649                --  the same way as a post condition.
1650
1651                when Aspect_Global =>
1652                   Make_Aitem_Pragma
1653                     (Pragma_Argument_Associations => New_List (
1654                        Make_Pragma_Argument_Association (Loc,
1655                          Expression => Relocate_Node (Expr))),
1656                      Pragma_Name                  => Name_Global);
1657
1658                   Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem);
1659                   Insert_Delayed_Pragma (Aitem);
1660                   goto Continue;
1661
1662                --  SPARK_Mode
1663
1664                when Aspect_SPARK_Mode =>
1665                   Make_Aitem_Pragma
1666                     (Pragma_Argument_Associations => New_List (
1667                        Make_Pragma_Argument_Association (Loc,
1668                          Expression => Relocate_Node (Expr))),
1669                      Pragma_Name                  => Name_SPARK_Mode);
1670                   Delay_Required := False;
1671
1672                --  Relative_Deadline
1673
1674                when Aspect_Relative_Deadline =>
1675                   Make_Aitem_Pragma
1676                     (Pragma_Argument_Associations => New_List (
1677                        Make_Pragma_Argument_Association (Loc,
1678                          Expression => Relocate_Node (Expr))),
1679                       Pragma_Name                 => Name_Relative_Deadline);
1680
1681                   --  If the aspect applies to a task, the corresponding pragma
1682                   --  must appear within its declarations, not after.
1683
1684                   if Nkind (N) = N_Task_Type_Declaration then
1685                      declare
1686                         Def : Node_Id;
1687                         V   : List_Id;
1688
1689                      begin
1690                         if No (Task_Definition (N)) then
1691                            Set_Task_Definition (N,
1692                              Make_Task_Definition (Loc,
1693                                 Visible_Declarations => New_List,
1694                                 End_Label => Empty));
1695                         end if;
1696
1697                         Def := Task_Definition (N);
1698                         V  := Visible_Declarations (Def);
1699                         if not Is_Empty_List (V) then
1700                            Insert_Before (First (V), Aitem);
1701
1702                         else
1703                            Set_Visible_Declarations (Def, New_List (Aitem));
1704                         end if;
1705
1706                         goto Continue;
1707                      end;
1708                   end if;
1709
1710                --  Case 3 : Aspects that don't correspond to pragma/attribute
1711                --  definition clause.
1712
1713                --  Case 3a: The aspects listed below don't correspond to
1714                --  pragmas/attributes but do require delayed analysis.
1715
1716                --  Default_Value, Default_Component_Value
1717
1718                when Aspect_Default_Value           |
1719                     Aspect_Default_Component_Value =>
1720                   Aitem := Empty;
1721
1722                --  Case 3b: The aspects listed below don't correspond to
1723                --  pragmas/attributes and don't need delayed analysis.
1724
1725                --  Implicit_Dereference
1726
1727                --  For Implicit_Dereference, External_Name and Link_Name, only
1728                --  the legality checks are done during the analysis, thus no
1729                --  delay is required.
1730
1731                when Aspect_Implicit_Dereference =>
1732                   Analyze_Aspect_Implicit_Dereference;
1733                   goto Continue;
1734
1735                --  External_Name, Link_Name
1736
1737                when Aspect_External_Name |
1738                     Aspect_Link_Name     =>
1739                   Analyze_Aspect_External_Or_Link_Name;
1740                   goto Continue;
1741
1742                --  Dimension
1743
1744                when Aspect_Dimension =>
1745                   Analyze_Aspect_Dimension (N, Id, Expr);
1746                   goto Continue;
1747
1748                --  Dimension_System
1749
1750                when Aspect_Dimension_System =>
1751                   Analyze_Aspect_Dimension_System (N, Id, Expr);
1752                   goto Continue;
1753
1754                --  Case 4: Special handling for aspects
1755
1756                --  Pre/Post/Test_Case/Contract_Cases whose corresponding
1757                --  pragmas take care of the delay.
1758
1759                --  Pre/Post
1760
1761                --  Aspects Pre/Post generate Precondition/Postcondition pragmas
1762                --  with a first argument that is the expression, and a second
1763                --  argument that is an informative message if the test fails.
1764                --  This is inserted right after the declaration, to get the
1765                --  required pragma placement. The processing for the pragmas
1766                --  takes care of the required delay.
1767
1768                when Pre_Post_Aspects => Pre_Post : declare
1769                   Pname : Name_Id;
1770
1771                begin
1772                   if A_Id = Aspect_Pre or else A_Id = Aspect_Precondition then
1773                      Pname := Name_Precondition;
1774                   else
1775                      Pname := Name_Postcondition;
1776                   end if;
1777
1778                   --  If the expressions is of the form A and then B, then
1779                   --  we generate separate Pre/Post aspects for the separate
1780                   --  clauses. Since we allow multiple pragmas, there is no
1781                   --  problem in allowing multiple Pre/Post aspects internally.
1782                   --  These should be treated in reverse order (B first and
1783                   --  A second) since they are later inserted just after N in
1784                   --  the order they are treated. This way, the pragma for A
1785                   --  ends up preceding the pragma for B, which may have an
1786                   --  importance for the error raised (either constraint error
1787                   --  or precondition error).
1788
1789                   --  We do not do this for Pre'Class, since we have to put
1790                   --  these conditions together in a complex OR expression
1791
1792                   --  We do not do this in ASIS mode, as ASIS relies on the
1793                   --  original node representing the complete expression, when
1794                   --  retrieving it through the source aspect table.
1795
1796                   if not ASIS_Mode
1797                     and then (Pname = Name_Postcondition
1798                                or else not Class_Present (Aspect))
1799                   then
1800                      while Nkind (Expr) = N_And_Then loop
1801                         Insert_After (Aspect,
1802                           Make_Aspect_Specification (Sloc (Left_Opnd (Expr)),
1803                             Identifier    => Identifier (Aspect),
1804                             Expression    => Relocate_Node (Left_Opnd (Expr)),
1805                             Class_Present => Class_Present (Aspect),
1806                             Split_PPC     => True));
1807                         Rewrite (Expr, Relocate_Node (Right_Opnd (Expr)));
1808                         Eloc := Sloc (Expr);
1809                      end loop;
1810                   end if;
1811
1812                   --  Build the precondition/postcondition pragma. We copy
1813                   --  the expression to avoid sharing between the original
1814                   --  aspect and the pragma node, because in ASIS_Mode both
1815                   --  will be independently analyzed.
1816
1817                   Make_Aitem_Pragma
1818                     (Pragma_Argument_Associations => New_List (
1819                        Make_Pragma_Argument_Association (Eloc,
1820                          Chars      => Name_Check,
1821                          Expression => New_Copy_Tree (Expr))),
1822                        Pragma_Name                => Pname);
1823
1824                   --  Add message unless exception messages are suppressed
1825
1826                   if not Opt.Exception_Locations_Suppressed then
1827                      Append_To (Pragma_Argument_Associations (Aitem),
1828                        Make_Pragma_Argument_Association (Eloc,
1829                          Chars     => Name_Message,
1830                          Expression =>
1831                            Make_String_Literal (Eloc,
1832                              Strval => "failed "
1833                                        & Get_Name_String (Pname)
1834                                        & " from "
1835                                        & Build_Location_String (Eloc))));
1836                   end if;
1837
1838                   Set_Is_Delayed_Aspect (Aspect);
1839
1840                   --  For Pre/Post cases, insert immediately after the entity
1841                   --  declaration, since that is the required pragma placement.
1842                   --  Note that for these aspects, we do not have to worry
1843                   --  about delay issues, since the pragmas themselves deal
1844                   --  with delay of visibility for the expression analysis.
1845
1846                   Insert_Delayed_Pragma (Aitem);
1847                   goto Continue;
1848                end Pre_Post;
1849
1850                --  Test_Case
1851
1852                when Aspect_Test_Case => Test_Case : declare
1853                   Args      : List_Id;
1854                   Comp_Expr : Node_Id;
1855                   Comp_Assn : Node_Id;
1856                   New_Expr  : Node_Id;
1857
1858                begin
1859                   Args := New_List;
1860
1861                   if Nkind (Parent (N)) = N_Compilation_Unit then
1862                      Error_Msg_Name_1 := Nam;
1863                      Error_Msg_N ("incorrect placement of aspect `%`", E);
1864                      goto Continue;
1865                   end if;
1866
1867                   if Nkind (Expr) /= N_Aggregate then
1868                      Error_Msg_Name_1 := Nam;
1869                      Error_Msg_NE
1870                        ("wrong syntax for aspect `%` for &", Id, E);
1871                      goto Continue;
1872                   end if;
1873
1874                   --  Make pragma expressions refer to the original aspect
1875                   --  expressions through the Original_Node link. This is
1876                   --  used in semantic analysis for ASIS mode, so that the
1877                   --  original expression also gets analyzed.
1878
1879                   Comp_Expr := First (Expressions (Expr));
1880                   while Present (Comp_Expr) loop
1881                      New_Expr := Relocate_Node (Comp_Expr);
1882                      Set_Original_Node (New_Expr, Comp_Expr);
1883                      Append_To (Args,
1884                        Make_Pragma_Argument_Association (Sloc (Comp_Expr),
1885                          Expression => New_Expr));
1886                      Next (Comp_Expr);
1887                   end loop;
1888
1889                   Comp_Assn := First (Component_Associations (Expr));
1890                   while Present (Comp_Assn) loop
1891                      if List_Length (Choices (Comp_Assn)) /= 1
1892                        or else
1893                          Nkind (First (Choices (Comp_Assn))) /= N_Identifier
1894                      then
1895                         Error_Msg_Name_1 := Nam;
1896                         Error_Msg_NE
1897                           ("wrong syntax for aspect `%` for &", Id, E);
1898                         goto Continue;
1899                      end if;
1900
1901                      New_Expr := Relocate_Node (Expression (Comp_Assn));
1902                      Set_Original_Node (New_Expr, Expression (Comp_Assn));
1903                      Append_To (Args,
1904                        Make_Pragma_Argument_Association (Sloc (Comp_Assn),
1905                        Chars      => Chars (First (Choices (Comp_Assn))),
1906                        Expression => New_Expr));
1907                      Next (Comp_Assn);
1908                   end loop;
1909
1910                   --  Build the test-case pragma
1911
1912                   Make_Aitem_Pragma
1913                     (Pragma_Argument_Associations => Args,
1914                      Pragma_Name                  => Nam);
1915
1916                   Delay_Required := False;
1917                end Test_Case;
1918
1919                --  Contract_Cases
1920
1921                when Aspect_Contract_Cases =>
1922                   Make_Aitem_Pragma
1923                     (Pragma_Argument_Associations => New_List (
1924                        Make_Pragma_Argument_Association (Loc,
1925                          Expression => Relocate_Node (Expr))),
1926                      Pragma_Name                  => Nam);
1927
1928                   Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem);
1929                   Insert_Delayed_Pragma (Aitem);
1930                   goto Continue;
1931
1932                --  Case 5: Special handling for aspects with an optional
1933                --  boolean argument.
1934
1935                --  In the general case, the corresponding pragma cannot be
1936                --  generated yet because the evaluation of the boolean needs
1937                --  to be delayed till the freeze point.
1938
1939                when Boolean_Aspects      |
1940                     Library_Unit_Aspects =>
1941
1942                   Set_Is_Boolean_Aspect (Aspect);
1943
1944                   --  Lock_Free aspect only apply to protected objects
1945
1946                   if A_Id = Aspect_Lock_Free then
1947                      if Ekind (E) /= E_Protected_Type then
1948                         Error_Msg_Name_1 := Nam;
1949                         Error_Msg_N
1950                           ("aspect % only applies to a protected object",
1951                            Aspect);
1952
1953                      else
1954                         --  Set the Uses_Lock_Free flag to True if there is no
1955                         --  expression or if the expression is True. ??? The
1956                         --  evaluation of this aspect should be delayed to the
1957                         --  freeze point.
1958
1959                         if No (Expr)
1960                           or else Is_True (Static_Boolean (Expr))
1961                         then
1962                            Set_Uses_Lock_Free (E);
1963                         end if;
1964
1965                         Record_Rep_Item (E, Aspect);
1966                      end if;
1967
1968                      goto Continue;
1969
1970                   elsif A_Id = Aspect_Import or else A_Id = Aspect_Export then
1971
1972                      --  Verify that there is an aspect Convention that will
1973                      --  incorporate the Import/Export aspect, and eventual
1974                      --  Link/External names.
1975
1976                      declare
1977                         A : Node_Id;
1978
1979                      begin
1980                         A := First (L);
1981                         while Present (A) loop
1982                            exit when Chars (Identifier (A)) = Name_Convention;
1983                            Next (A);
1984                         end loop;
1985
1986                         if No (A) then
1987                            Error_Msg_N
1988                              ("missing Convention aspect for Export/Import",
1989                                  Aspect);
1990                         end if;
1991                      end;
1992
1993                      goto Continue;
1994                   end if;
1995
1996                   --  This requires special handling in the case of a package
1997                   --  declaration, the pragma needs to be inserted in the list
1998                   --  of declarations for the associated package. There is no
1999                   --  issue of visibility delay for these aspects.
2000
2001                   if A_Id in Library_Unit_Aspects
2002                     and then
2003                       Nkind_In (N, N_Package_Declaration,
2004                                    N_Generic_Package_Declaration)
2005                     and then Nkind (Parent (N)) /= N_Compilation_Unit
2006                   then
2007                      Error_Msg_N
2008                         ("incorrect context for library unit aspect&", Id);
2009                      goto Continue;
2010                   end if;
2011
2012                   --  Special handling when the aspect has no expression. In
2013                   --  this case the value is considered to be True. Thus, we
2014                   --  simply insert the pragma, no delay is required.
2015
2016                   if No (Expr) then
2017                      Make_Aitem_Pragma
2018                        (Pragma_Argument_Associations => New_List (
2019                           Make_Pragma_Argument_Association (Sloc (Ent),
2020                             Expression => Ent)),
2021                         Pragma_Name                  => Chars (Id));
2022
2023                      Delay_Required := False;
2024
2025                   --  In general cases, the corresponding pragma/attribute
2026                   --  definition clause will be inserted later at the freezing
2027                   --  point.
2028
2029                   else
2030                      Aitem := Empty;
2031                   end if;
2032             end case;
2033
2034             --  Attach the corresponding pragma/attribute definition clause to
2035             --  the aspect specification node.
2036
2037             if Present (Aitem) then
2038                Set_From_Aspect_Specification (Aitem, True);
2039             end if;
2040
2041             --  Aspect Abstract_State introduces implicit declarations for all
2042             --  state abstraction entities it defines. To emulate this behavior
2043             --  insert the pragma at the start of the visible declarations of
2044             --  the related package.
2045
2046             if Nam = Name_Abstract_State
2047               and then Nkind (N) = N_Package_Declaration
2048             then
2049                if No (Visible_Declarations (Specification (N))) then
2050                   Set_Visible_Declarations (Specification (N), New_List);
2051                end if;
2052
2053                Prepend (Aitem, Visible_Declarations (Specification (N)));
2054                goto Continue;
2055
2056             --  In the context of a compilation unit, we directly put the
2057             --  pragma in the Pragmas_After list of the N_Compilation_Unit_Aux
2058             --  node (no delay is required here) except for aspects on a
2059             --  subprogram body (see below) and a generic package, for which
2060             --  we need to introduce the pragma before building the generic
2061             --  copy (see sem_ch12).
2062
2063             elsif Nkind (Parent (N)) = N_Compilation_Unit
2064               and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect))
2065             then
2066                declare
2067                   Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
2068
2069                begin
2070                   pragma Assert (Nkind (Aux) = N_Compilation_Unit_Aux);
2071
2072                   --  For a Boolean aspect, create the corresponding pragma if
2073                   --  no expression or if the value is True.
2074
2075                   if Is_Boolean_Aspect (Aspect) and then No (Aitem) then
2076                      if Is_True (Static_Boolean (Expr)) then
2077                         Make_Aitem_Pragma
2078                           (Pragma_Argument_Associations => New_List (
2079                              Make_Pragma_Argument_Association (Sloc (Ent),
2080                                Expression => Ent)),
2081                            Pragma_Name                  => Chars (Id));
2082
2083                         Set_From_Aspect_Specification (Aitem, True);
2084                         Set_Corresponding_Aspect (Aitem, Aspect);
2085
2086                      else
2087                         goto Continue;
2088                      end if;
2089                   end if;
2090
2091                   --  If the aspect is on a subprogram body (relevant aspects
2092                   --  are Inline and Priority), add the pragma in front of
2093                   --  the declarations.
2094
2095                   if Nkind (N) = N_Subprogram_Body then
2096                      if No (Declarations (N)) then
2097                         Set_Declarations (N, New_List);
2098                      end if;
2099
2100                      Prepend (Aitem, Declarations (N));
2101
2102                   elsif Nkind (N) = N_Generic_Package_Declaration then
2103                      if No (Visible_Declarations (Specification (N))) then
2104                         Set_Visible_Declarations (Specification (N), New_List);
2105                      end if;
2106
2107                      Prepend (Aitem,
2108                        Visible_Declarations (Specification (N)));
2109
2110                   else
2111                      if No (Pragmas_After (Aux)) then
2112                         Set_Pragmas_After (Aux, New_List);
2113                      end if;
2114
2115                      Append (Aitem, Pragmas_After (Aux));
2116                   end if;
2117
2118                   goto Continue;
2119                end;
2120             end if;
2121
2122             --  The evaluation of the aspect is delayed to the freezing point.
2123             --  The pragma or attribute clause if there is one is then attached
2124             --  to the aspect specification which is placed in the rep item
2125             --  list.
2126
2127             if Delay_Required then
2128                if Present (Aitem) then
2129                   Set_Is_Delayed_Aspect (Aitem);
2130                   Set_Aspect_Rep_Item (Aspect, Aitem);
2131                   Set_Parent (Aitem, Aspect);
2132                end if;
2133
2134                Set_Is_Delayed_Aspect (Aspect);
2135
2136                --  In the case of Default_Value, link the aspect to base type
2137                --  as well, even though it appears on a first subtype. This is
2138                --  mandated by the semantics of the aspect. Do not establish
2139                --  the link when processing the base type itself as this leads
2140                --  to a rep item circularity. Verify that we are dealing with
2141                --  a scalar type to prevent cascaded errors.
2142
2143                if A_Id = Aspect_Default_Value
2144                  and then Is_Scalar_Type (E)
2145                  and then Base_Type (E) /= E
2146                then
2147                   Set_Has_Delayed_Aspects (Base_Type (E));
2148                   Record_Rep_Item (Base_Type (E), Aspect);
2149                end if;
2150
2151                Set_Has_Delayed_Aspects (E);
2152                Record_Rep_Item (E, Aspect);
2153
2154             --  When delay is not required and the context is not a compilation
2155             --  unit, we simply insert the pragma/attribute definition clause
2156             --  in sequence.
2157
2158             else
2159                Insert_After (Ins_Node, Aitem);
2160                Ins_Node := Aitem;
2161             end if;
2162          end Analyze_One_Aspect;
2163
2164       <<Continue>>
2165          Next (Aspect);
2166       end loop Aspect_Loop;
2167
2168       if Has_Delayed_Aspects (E) then
2169          Ensure_Freeze_Node (E);
2170       end if;
2171    end Analyze_Aspect_Specifications;
2172
2173    -----------------------
2174    -- Analyze_At_Clause --
2175    -----------------------
2176
2177    --  An at clause is replaced by the corresponding Address attribute
2178    --  definition clause that is the preferred approach in Ada 95.
2179
2180    procedure Analyze_At_Clause (N : Node_Id) is
2181       CS : constant Boolean := Comes_From_Source (N);
2182
2183    begin
2184       --  This is an obsolescent feature
2185
2186       Check_Restriction (No_Obsolescent_Features, N);
2187
2188       if Warn_On_Obsolescent_Feature then
2189          Error_Msg_N
2190            ("?j?at clause is an obsolescent feature (RM J.7(2))", N);
2191          Error_Msg_N
2192            ("\?j?use address attribute definition clause instead", N);
2193       end if;
2194
2195       --  Rewrite as address clause
2196
2197       Rewrite (N,
2198         Make_Attribute_Definition_Clause (Sloc (N),
2199           Name       => Identifier (N),
2200           Chars      => Name_Address,
2201           Expression => Expression (N)));
2202
2203       --  We preserve Comes_From_Source, since logically the clause still comes
2204       --  from the source program even though it is changed in form.
2205
2206       Set_Comes_From_Source (N, CS);
2207
2208       --  Analyze rewritten clause
2209
2210       Analyze_Attribute_Definition_Clause (N);
2211    end Analyze_At_Clause;
2212
2213    -----------------------------------------
2214    -- Analyze_Attribute_Definition_Clause --
2215    -----------------------------------------
2216
2217    procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is
2218       Loc   : constant Source_Ptr   := Sloc (N);
2219       Nam   : constant Node_Id      := Name (N);
2220       Attr  : constant Name_Id      := Chars (N);
2221       Expr  : constant Node_Id      := Expression (N);
2222       Id    : constant Attribute_Id := Get_Attribute_Id (Attr);
2223
2224       Ent : Entity_Id;
2225       --  The entity of Nam after it is analyzed. In the case of an incomplete
2226       --  type, this is the underlying type.
2227
2228       U_Ent : Entity_Id;
2229       --  The underlying entity to which the attribute applies. Generally this
2230       --  is the Underlying_Type of Ent, except in the case where the clause
2231       --  applies to full view of incomplete type or private type in which case
2232       --  U_Ent is just a copy of Ent.
2233
2234       FOnly : Boolean := False;
2235       --  Reset to True for subtype specific attribute (Alignment, Size)
2236       --  and for stream attributes, i.e. those cases where in the call
2237       --  to Rep_Item_Too_Late, FOnly is set True so that only the freezing
2238       --  rules are checked. Note that the case of stream attributes is not
2239       --  clear from the RM, but see AI95-00137. Also, the RM seems to
2240       --  disallow Storage_Size for derived task types, but that is also
2241       --  clearly unintentional.
2242
2243       procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type);
2244       --  Common processing for 'Read, 'Write, 'Input and 'Output attribute
2245       --  definition clauses.
2246
2247       function Duplicate_Clause return Boolean;
2248       --  This routine checks if the aspect for U_Ent being given by attribute
2249       --  definition clause N is for an aspect that has already been specified,
2250       --  and if so gives an error message. If there is a duplicate, True is
2251       --  returned, otherwise if there is no error, False is returned.
2252
2253       procedure Check_Indexing_Functions;
2254       --  Check that the function in Constant_Indexing or Variable_Indexing
2255       --  attribute has the proper type structure. If the name is overloaded,
2256       --  check that some interpretation is legal.
2257
2258       procedure Check_Iterator_Functions;
2259       --  Check that there is a single function in Default_Iterator attribute
2260       --  has the proper type structure.
2261
2262       function Check_Primitive_Function (Subp : Entity_Id) return Boolean;
2263       --  Common legality check for the previous two
2264
2265       -----------------------------------
2266       -- Analyze_Stream_TSS_Definition --
2267       -----------------------------------
2268
2269       procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is
2270          Subp : Entity_Id := Empty;
2271          I    : Interp_Index;
2272          It   : Interp;
2273          Pnam : Entity_Id;
2274
2275          Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read);
2276          --  True for Read attribute, false for other attributes
2277
2278          function Has_Good_Profile (Subp : Entity_Id) return Boolean;
2279          --  Return true if the entity is a subprogram with an appropriate
2280          --  profile for the attribute being defined.
2281
2282          ----------------------
2283          -- Has_Good_Profile --
2284          ----------------------
2285
2286          function Has_Good_Profile (Subp : Entity_Id) return Boolean is
2287             F              : Entity_Id;
2288             Is_Function    : constant Boolean := (TSS_Nam = TSS_Stream_Input);
2289             Expected_Ekind : constant array (Boolean) of Entity_Kind :=
2290                                (False => E_Procedure, True => E_Function);
2291             Typ            : Entity_Id;
2292
2293          begin
2294             if Ekind (Subp) /= Expected_Ekind (Is_Function) then
2295                return False;
2296             end if;
2297
2298             F := First_Formal (Subp);
2299
2300             if No (F)
2301               or else Ekind (Etype (F)) /= E_Anonymous_Access_Type
2302               or else Designated_Type (Etype (F)) /=
2303                                Class_Wide_Type (RTE (RE_Root_Stream_Type))
2304             then
2305                return False;
2306             end if;
2307
2308             if not Is_Function then
2309                Next_Formal (F);
2310
2311                declare
2312                   Expected_Mode : constant array (Boolean) of Entity_Kind :=
2313                                     (False => E_In_Parameter,
2314                                      True  => E_Out_Parameter);
2315                begin
2316                   if Parameter_Mode (F) /= Expected_Mode (Is_Read) then
2317                      return False;
2318                   end if;
2319                end;
2320
2321                Typ := Etype (F);
2322
2323             else
2324                Typ := Etype (Subp);
2325             end if;
2326
2327             return Base_Type (Typ) = Base_Type (Ent)
2328               and then No (Next_Formal (F));
2329          end Has_Good_Profile;
2330
2331       --  Start of processing for Analyze_Stream_TSS_Definition
2332
2333       begin
2334          FOnly := True;
2335
2336          if not Is_Type (U_Ent) then
2337             Error_Msg_N ("local name must be a subtype", Nam);
2338             return;
2339          end if;
2340
2341          Pnam := TSS (Base_Type (U_Ent), TSS_Nam);
2342
2343          --  If Pnam is present, it can be either inherited from an ancestor
2344          --  type (in which case it is legal to redefine it for this type), or
2345          --  be a previous definition of the attribute for the same type (in
2346          --  which case it is illegal).
2347
2348          --  In the first case, it will have been analyzed already, and we
2349          --  can check that its profile does not match the expected profile
2350          --  for a stream attribute of U_Ent. In the second case, either Pnam
2351          --  has been analyzed (and has the expected profile), or it has not
2352          --  been analyzed yet (case of a type that has not been frozen yet
2353          --  and for which the stream attribute has been set using Set_TSS).
2354
2355          if Present (Pnam)
2356            and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam))
2357          then
2358             Error_Msg_Sloc := Sloc (Pnam);
2359             Error_Msg_Name_1 := Attr;
2360             Error_Msg_N ("% attribute already defined #", Nam);
2361             return;
2362          end if;
2363
2364          Analyze (Expr);
2365
2366          if Is_Entity_Name (Expr) then
2367             if not Is_Overloaded (Expr) then
2368                if Has_Good_Profile (Entity (Expr)) then
2369                   Subp := Entity (Expr);
2370                end if;
2371
2372             else
2373                Get_First_Interp (Expr, I, It);
2374                while Present (It.Nam) loop
2375                   if Has_Good_Profile (It.Nam) then
2376                      Subp := It.Nam;
2377                      exit;
2378                   end if;
2379
2380                   Get_Next_Interp (I, It);
2381                end loop;
2382             end if;
2383          end if;
2384
2385          if Present (Subp) then
2386             if Is_Abstract_Subprogram (Subp) then
2387                Error_Msg_N ("stream subprogram must not be abstract", Expr);
2388                return;
2389             end if;
2390
2391             Set_Entity (Expr, Subp);
2392             Set_Etype (Expr, Etype (Subp));
2393
2394             New_Stream_Subprogram (N, U_Ent, Subp, TSS_Nam);
2395
2396          else
2397             Error_Msg_Name_1 := Attr;
2398             Error_Msg_N ("incorrect expression for% attribute", Expr);
2399          end if;
2400       end Analyze_Stream_TSS_Definition;
2401
2402       ------------------------------
2403       -- Check_Indexing_Functions --
2404       ------------------------------
2405
2406       procedure Check_Indexing_Functions is
2407          Indexing_Found : Boolean;
2408
2409          procedure Check_One_Function (Subp : Entity_Id);
2410          --  Check one possible interpretation. Sets Indexing_Found True if an
2411          --  indexing function is found.
2412
2413          ------------------------
2414          -- Check_One_Function --
2415          ------------------------
2416
2417          procedure Check_One_Function (Subp : Entity_Id) is
2418             Default_Element : constant Node_Id :=
2419                                 Find_Value_Of_Aspect
2420                                   (Etype (First_Formal (Subp)),
2421                                    Aspect_Iterator_Element);
2422
2423          begin
2424             if not Check_Primitive_Function (Subp)
2425               and then not Is_Overloaded (Expr)
2426             then
2427                Error_Msg_NE
2428                  ("aspect Indexing requires a function that applies to type&",
2429                     Subp, Ent);
2430             end if;
2431
2432             --  An indexing function must return either the default element of
2433             --  the container, or a reference type. For variable indexing it
2434             --  must be the latter.
2435
2436             if Present (Default_Element) then
2437                Analyze (Default_Element);
2438
2439                if Is_Entity_Name (Default_Element)
2440                  and then Covers (Entity (Default_Element), Etype (Subp))
2441                then
2442                   Indexing_Found := True;
2443                   return;
2444                end if;
2445             end if;
2446
2447             --  For variable_indexing the return type must be a reference type
2448
2449             if Attr = Name_Variable_Indexing
2450               and then not Has_Implicit_Dereference (Etype (Subp))
2451             then
2452                Error_Msg_N
2453                  ("function for indexing must return a reference type", Subp);
2454
2455             else
2456                Indexing_Found := True;
2457             end if;
2458          end Check_One_Function;
2459
2460       --  Start of processing for Check_Indexing_Functions
2461
2462       begin
2463          if In_Instance then
2464             return;
2465          end if;
2466
2467          Analyze (Expr);
2468
2469          if not Is_Overloaded (Expr) then
2470             Check_One_Function (Entity (Expr));
2471
2472          else
2473             declare
2474                I  : Interp_Index;
2475                It : Interp;
2476
2477             begin
2478                Indexing_Found := False;
2479                Get_First_Interp (Expr, I, It);
2480                while Present (It.Nam) loop
2481
2482                   --  Note that analysis will have added the interpretation
2483                   --  that corresponds to the dereference. We only check the
2484                   --  subprogram itself.
2485
2486                   if Is_Overloadable (It.Nam) then
2487                      Check_One_Function (It.Nam);
2488                   end if;
2489
2490                   Get_Next_Interp (I, It);
2491                end loop;
2492
2493                if not Indexing_Found then
2494                   Error_Msg_NE
2495                     ("aspect Indexing requires a function that "
2496                      & "applies to type&", Expr, Ent);
2497                end if;
2498             end;
2499          end if;
2500       end Check_Indexing_Functions;
2501
2502       ------------------------------
2503       -- Check_Iterator_Functions --
2504       ------------------------------
2505
2506       procedure Check_Iterator_Functions is
2507          Default : Entity_Id;
2508
2509          function Valid_Default_Iterator (Subp : Entity_Id) return Boolean;
2510          --  Check one possible interpretation for validity
2511
2512          ----------------------------
2513          -- Valid_Default_Iterator --
2514          ----------------------------
2515
2516          function Valid_Default_Iterator (Subp : Entity_Id) return Boolean is
2517             Formal : Entity_Id;
2518
2519          begin
2520             if not Check_Primitive_Function (Subp) then
2521                return False;
2522             else
2523                Formal := First_Formal (Subp);
2524             end if;
2525
2526             --  False if any subsequent formal has no default expression
2527
2528             Formal := Next_Formal (Formal);
2529             while Present (Formal) loop
2530                if No (Expression (Parent (Formal))) then
2531                   return False;
2532                end if;
2533
2534                Next_Formal (Formal);
2535             end loop;
2536
2537             --  True if all subsequent formals have default expressions
2538
2539             return True;
2540          end Valid_Default_Iterator;
2541
2542       --  Start of processing for Check_Iterator_Functions
2543
2544       begin
2545          Analyze (Expr);
2546
2547          if not Is_Entity_Name (Expr) then
2548             Error_Msg_N ("aspect Iterator must be a function name", Expr);
2549          end if;
2550
2551          if not Is_Overloaded (Expr) then
2552             if not Check_Primitive_Function (Entity (Expr)) then
2553                Error_Msg_NE
2554                  ("aspect Indexing requires a function that applies to type&",
2555                    Entity (Expr), Ent);
2556             end if;
2557
2558             if not Valid_Default_Iterator (Entity (Expr)) then
2559                Error_Msg_N ("improper function for default iterator", Expr);
2560             end if;
2561
2562          else
2563             Default := Empty;
2564             declare
2565                I : Interp_Index;
2566                It : Interp;
2567
2568             begin
2569                Get_First_Interp (Expr, I, It);
2570                while Present (It.Nam) loop
2571                   if not Check_Primitive_Function (It.Nam)
2572                     or else not Valid_Default_Iterator (It.Nam)
2573                   then
2574                      Remove_Interp (I);
2575
2576                   elsif Present (Default) then
2577                      Error_Msg_N ("default iterator must be unique", Expr);
2578
2579                   else
2580                      Default := It.Nam;
2581                   end if;
2582
2583                   Get_Next_Interp (I, It);
2584                end loop;
2585             end;
2586
2587             if Present (Default) then
2588                Set_Entity (Expr, Default);
2589                Set_Is_Overloaded (Expr, False);
2590             end if;
2591          end if;
2592       end Check_Iterator_Functions;
2593
2594       -------------------------------
2595       -- Check_Primitive_Function  --
2596       -------------------------------
2597
2598       function Check_Primitive_Function (Subp : Entity_Id) return Boolean is
2599          Ctrl : Entity_Id;
2600
2601       begin
2602          if Ekind (Subp) /= E_Function then
2603             return False;
2604          end if;
2605
2606          if No (First_Formal (Subp)) then
2607             return False;
2608          else
2609             Ctrl := Etype (First_Formal (Subp));
2610          end if;
2611
2612          if Ctrl = Ent
2613            or else Ctrl = Class_Wide_Type (Ent)
2614            or else
2615              (Ekind (Ctrl) = E_Anonymous_Access_Type
2616                and then
2617                  (Designated_Type (Ctrl) = Ent
2618                    or else Designated_Type (Ctrl) = Class_Wide_Type (Ent)))
2619          then
2620             null;
2621
2622          else
2623             return False;
2624          end if;
2625
2626          return True;
2627       end Check_Primitive_Function;
2628
2629       ----------------------
2630       -- Duplicate_Clause --
2631       ----------------------
2632
2633       function Duplicate_Clause return Boolean is
2634          A : Node_Id;
2635
2636       begin
2637          --  Nothing to do if this attribute definition clause comes from
2638          --  an aspect specification, since we could not be duplicating an
2639          --  explicit clause, and we dealt with the case of duplicated aspects
2640          --  in Analyze_Aspect_Specifications.
2641
2642          if From_Aspect_Specification (N) then
2643             return False;
2644          end if;
2645
2646          --  Otherwise current clause may duplicate previous clause, or a
2647          --  previously given pragma or aspect specification for the same
2648          --  aspect.
2649
2650          A := Get_Rep_Item (U_Ent, Chars (N), Check_Parents => False);
2651
2652          if Present (A) then
2653             Error_Msg_Name_1 := Chars (N);
2654             Error_Msg_Sloc := Sloc (A);
2655
2656             Error_Msg_NE ("aspect% for & previously given#", N, U_Ent);
2657             return True;
2658          end if;
2659
2660          return False;
2661       end Duplicate_Clause;
2662
2663    --  Start of processing for Analyze_Attribute_Definition_Clause
2664
2665    begin
2666       --  The following code is a defense against recursion. Not clear that
2667       --  this can happen legitimately, but perhaps some error situations
2668       --  can cause it, and we did see this recursion during testing.
2669
2670       if Analyzed (N) then
2671          return;
2672       else
2673          Set_Analyzed (N, True);
2674       end if;
2675
2676       --  Ignore some selected attributes in CodePeer mode since they are not
2677       --  relevant in this context.
2678
2679       if CodePeer_Mode then
2680          case Id is
2681
2682             --  Ignore Component_Size in CodePeer mode, to avoid changing the
2683             --  internal representation of types by implicitly packing them.
2684
2685             when Attribute_Component_Size =>
2686                Rewrite (N, Make_Null_Statement (Sloc (N)));
2687                return;
2688
2689             when others =>
2690                null;
2691          end case;
2692       end if;
2693
2694       --  Process Ignore_Rep_Clauses option
2695
2696       if Ignore_Rep_Clauses then
2697          case Id is
2698
2699             --  The following should be ignored. They do not affect legality
2700             --  and may be target dependent. The basic idea of -gnatI is to
2701             --  ignore any rep clauses that may be target dependent but do not
2702             --  affect legality (except possibly to be rejected because they
2703             --  are incompatible with the compilation target).
2704
2705             when Attribute_Alignment      |
2706                  Attribute_Bit_Order      |
2707                  Attribute_Component_Size |
2708                  Attribute_Machine_Radix  |
2709                  Attribute_Object_Size    |
2710                  Attribute_Size           |
2711                  Attribute_Stream_Size    |
2712                  Attribute_Value_Size     =>
2713                Rewrite (N, Make_Null_Statement (Sloc (N)));
2714                return;
2715
2716             --  Perhaps 'Small should not be ignored by Ignore_Rep_Clauses ???
2717
2718             when Attribute_Small =>
2719                if Ignore_Rep_Clauses then
2720                   Rewrite (N, Make_Null_Statement (Sloc (N)));
2721                   return;
2722                end if;
2723
2724             --  The following should not be ignored, because in the first place
2725             --  they are reasonably portable, and should not cause problems in
2726             --  compiling code from another target, and also they do affect
2727             --  legality, e.g. failing to provide a stream attribute for a
2728             --  type may make a program illegal.
2729
2730             when Attribute_External_Tag        |
2731                  Attribute_Input               |
2732                  Attribute_Output              |
2733                  Attribute_Read                |
2734                  Attribute_Simple_Storage_Pool |
2735                  Attribute_Storage_Pool        |
2736                  Attribute_Storage_Size        |
2737                  Attribute_Write               =>
2738                null;
2739
2740             --  Other cases are errors ("attribute& cannot be set with
2741             --  definition clause"), which will be caught below.
2742
2743             when others =>
2744                null;
2745          end case;
2746       end if;
2747
2748       Analyze (Nam);
2749       Ent := Entity (Nam);
2750
2751       if Rep_Item_Too_Early (Ent, N) then
2752          return;
2753       end if;
2754
2755       --  Rep clause applies to full view of incomplete type or private type if
2756       --  we have one (if not, this is a premature use of the type). However,
2757       --  certain semantic checks need to be done on the specified entity (i.e.
2758       --  the private view), so we save it in Ent.
2759
2760       if Is_Private_Type (Ent)
2761         and then Is_Derived_Type (Ent)
2762         and then not Is_Tagged_Type (Ent)
2763         and then No (Full_View (Ent))
2764       then
2765          --  If this is a private type whose completion is a derivation from
2766          --  another private type, there is no full view, and the attribute
2767          --  belongs to the type itself, not its underlying parent.
2768
2769          U_Ent := Ent;
2770
2771       elsif Ekind (Ent) = E_Incomplete_Type then
2772
2773          --  The attribute applies to the full view, set the entity of the
2774          --  attribute definition accordingly.
2775
2776          Ent := Underlying_Type (Ent);
2777          U_Ent := Ent;
2778          Set_Entity (Nam, Ent);
2779
2780       else
2781          U_Ent := Underlying_Type (Ent);
2782       end if;
2783
2784       --  Avoid cascaded error
2785
2786       if Etype (Nam) = Any_Type then
2787          return;
2788
2789       --  Must be declared in current scope or in case of an aspect
2790       --  specification, must be visible in current scope.
2791
2792       elsif Scope (Ent) /= Current_Scope
2793         and then
2794           not (From_Aspect_Specification (N)
2795                 and then Scope_Within_Or_Same (Current_Scope, Scope (Ent)))
2796       then
2797          Error_Msg_N ("entity must be declared in this scope", Nam);
2798          return;
2799
2800       --  Must not be a source renaming (we do have some cases where the
2801       --  expander generates a renaming, and those cases are OK, in such
2802       --  cases any attribute applies to the renamed object as well).
2803
2804       elsif Is_Object (Ent)
2805         and then Present (Renamed_Object (Ent))
2806       then
2807          --  Case of renamed object from source, this is an error
2808
2809          if Comes_From_Source (Renamed_Object (Ent)) then
2810             Get_Name_String (Chars (N));
2811             Error_Msg_Strlen := Name_Len;
2812             Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
2813             Error_Msg_N
2814               ("~ clause not allowed for a renaming declaration "
2815                & "(RM 13.1(6))", Nam);
2816             return;
2817
2818          --  For the case of a compiler generated renaming, the attribute
2819          --  definition clause applies to the renamed object created by the
2820          --  expander. The easiest general way to handle this is to create a
2821          --  copy of the attribute definition clause for this object.
2822
2823          else
2824             Insert_Action (N,
2825               Make_Attribute_Definition_Clause (Loc,
2826                 Name       =>
2827                   New_Occurrence_Of (Entity (Renamed_Object (Ent)), Loc),
2828                 Chars      => Chars (N),
2829                 Expression => Duplicate_Subexpr (Expression (N))));
2830          end if;
2831
2832       --  If no underlying entity, use entity itself, applies to some
2833       --  previously detected error cases ???
2834
2835       elsif No (U_Ent) then
2836          U_Ent := Ent;
2837
2838       --  Cannot specify for a subtype (exception Object/Value_Size)
2839
2840       elsif Is_Type (U_Ent)
2841         and then not Is_First_Subtype (U_Ent)
2842         and then Id /= Attribute_Object_Size
2843         and then Id /= Attribute_Value_Size
2844         and then not From_At_Mod (N)
2845       then
2846          Error_Msg_N ("cannot specify attribute for subtype", Nam);
2847          return;
2848       end if;
2849
2850       Set_Entity (N, U_Ent);
2851       Check_Restriction_No_Use_Of_Attribute (N);
2852
2853       --  Switch on particular attribute
2854
2855       case Id is
2856
2857          -------------
2858          -- Address --
2859          -------------
2860
2861          --  Address attribute definition clause
2862
2863          when Attribute_Address => Address : begin
2864
2865             --  A little error check, catch for X'Address use X'Address;
2866
2867             if Nkind (Nam) = N_Identifier
2868               and then Nkind (Expr) = N_Attribute_Reference
2869               and then Attribute_Name (Expr) = Name_Address
2870               and then Nkind (Prefix (Expr)) = N_Identifier
2871               and then Chars (Nam) = Chars (Prefix (Expr))
2872             then
2873                Error_Msg_NE
2874                  ("address for & is self-referencing", Prefix (Expr), Ent);
2875                return;
2876             end if;
2877
2878             --  Not that special case, carry on with analysis of expression
2879
2880             Analyze_And_Resolve (Expr, RTE (RE_Address));
2881
2882             --  Even when ignoring rep clauses we need to indicate that the
2883             --  entity has an address clause and thus it is legal to declare
2884             --  it imported.
2885
2886             if Ignore_Rep_Clauses then
2887                if Ekind_In (U_Ent, E_Variable, E_Constant) then
2888                   Record_Rep_Item (U_Ent, N);
2889                end if;
2890
2891                return;
2892             end if;
2893
2894             if Duplicate_Clause then
2895                null;
2896
2897             --  Case of address clause for subprogram
2898
2899             elsif Is_Subprogram (U_Ent) then
2900                if Has_Homonym (U_Ent) then
2901                   Error_Msg_N
2902                     ("address clause cannot be given " &
2903                      "for overloaded subprogram",
2904                      Nam);
2905                   return;
2906                end if;
2907
2908                --  For subprograms, all address clauses are permitted, and we
2909                --  mark the subprogram as having a deferred freeze so that Gigi
2910                --  will not elaborate it too soon.
2911
2912                --  Above needs more comments, what is too soon about???
2913
2914                Set_Has_Delayed_Freeze (U_Ent);
2915
2916             --  Case of address clause for entry
2917
2918             elsif Ekind (U_Ent) = E_Entry then
2919                if Nkind (Parent (N)) = N_Task_Body then
2920                   Error_Msg_N
2921                     ("entry address must be specified in task spec", Nam);
2922                   return;
2923                end if;
2924
2925                --  For entries, we require a constant address
2926
2927                Check_Constant_Address_Clause (Expr, U_Ent);
2928
2929                --  Special checks for task types
2930
2931                if Is_Task_Type (Scope (U_Ent))
2932                  and then Comes_From_Source (Scope (U_Ent))
2933                then
2934                   Error_Msg_N
2935                     ("??entry address declared for entry in task type", N);
2936                   Error_Msg_N
2937                     ("\??only one task can be declared of this type", N);
2938                end if;
2939
2940                --  Entry address clauses are obsolescent
2941
2942                Check_Restriction (No_Obsolescent_Features, N);
2943
2944                if Warn_On_Obsolescent_Feature then
2945                   Error_Msg_N
2946                     ("?j?attaching interrupt to task entry is an " &
2947                      "obsolescent feature (RM J.7.1)", N);
2948                   Error_Msg_N
2949                     ("\?j?use interrupt procedure instead", N);
2950                end if;
2951
2952             --  Case of an address clause for a controlled object which we
2953             --  consider to be erroneous.
2954
2955             elsif Is_Controlled (Etype (U_Ent))
2956               or else Has_Controlled_Component (Etype (U_Ent))
2957             then
2958                Error_Msg_NE
2959                  ("??controlled object& must not be overlaid", Nam, U_Ent);
2960                Error_Msg_N
2961                  ("\??Program_Error will be raised at run time", Nam);
2962                Insert_Action (Declaration_Node (U_Ent),
2963                  Make_Raise_Program_Error (Loc,
2964                    Reason => PE_Overlaid_Controlled_Object));
2965                return;
2966
2967             --  Case of address clause for a (non-controlled) object
2968
2969             elsif
2970               Ekind (U_Ent) = E_Variable
2971                 or else
2972               Ekind (U_Ent) = E_Constant
2973             then
2974                declare
2975                   Expr  : constant Node_Id := Expression (N);
2976                   O_Ent : Entity_Id;
2977                   Off   : Boolean;
2978
2979                begin
2980                   --  Exported variables cannot have an address clause, because
2981                   --  this cancels the effect of the pragma Export.
2982
2983                   if Is_Exported (U_Ent) then
2984                      Error_Msg_N
2985                        ("cannot export object with address clause", Nam);
2986                      return;
2987                   end if;
2988
2989                   Find_Overlaid_Entity (N, O_Ent, Off);
2990
2991                   --  Overlaying controlled objects is erroneous
2992
2993                   if Present (O_Ent)
2994                     and then (Has_Controlled_Component (Etype (O_Ent))
2995                                 or else Is_Controlled (Etype (O_Ent)))
2996                   then
2997                      Error_Msg_N
2998                        ("??cannot overlay with controlled object", Expr);
2999                      Error_Msg_N
3000                        ("\??Program_Error will be raised at run time", Expr);
3001                      Insert_Action (Declaration_Node (U_Ent),
3002                        Make_Raise_Program_Error (Loc,
3003                          Reason => PE_Overlaid_Controlled_Object));
3004                      return;
3005
3006                   elsif Present (O_Ent)
3007                     and then Ekind (U_Ent) = E_Constant
3008                     and then not Is_Constant_Object (O_Ent)
3009                   then
3010                      Error_Msg_N ("??constant overlays a variable", Expr);
3011
3012                   --  Imported variables can have an address clause, but then
3013                   --  the import is pretty meaningless except to suppress
3014                   --  initializations, so we do not need such variables to
3015                   --  be statically allocated (and in fact it causes trouble
3016                   --  if the address clause is a local value).
3017
3018                   elsif Is_Imported (U_Ent) then
3019                      Set_Is_Statically_Allocated (U_Ent, False);
3020                   end if;
3021
3022                   --  We mark a possible modification of a variable with an
3023                   --  address clause, since it is likely aliasing is occurring.
3024
3025                   Note_Possible_Modification (Nam, Sure => False);
3026
3027                   --  Here we are checking for explicit overlap of one variable
3028                   --  by another, and if we find this then mark the overlapped
3029                   --  variable as also being volatile to prevent unwanted
3030                   --  optimizations. This is a significant pessimization so
3031                   --  avoid it when there is an offset, i.e. when the object
3032                   --  is composite; they cannot be optimized easily anyway.
3033
3034                   if Present (O_Ent)
3035                     and then Is_Object (O_Ent)
3036                     and then not Off
3037
3038                     --  The following test is an expedient solution to what
3039                     --  is really a problem in CodePeer. Suppressing the
3040                     --  Set_Treat_As_Volatile call here prevents later
3041                     --  generation (in some cases) of trees that CodePeer
3042                     --  should, but currently does not, handle correctly.
3043                     --  This test should probably be removed when CodePeer
3044                     --  is improved, just because we want the tree CodePeer
3045                     --  analyzes to match the tree for which we generate code
3046                     --  as closely as is practical. ???
3047
3048                     and then not CodePeer_Mode
3049                   then
3050                      --  ??? O_Ent might not be in current unit
3051
3052                      Set_Treat_As_Volatile (O_Ent);
3053                   end if;
3054
3055                   --  Legality checks on the address clause for initialized
3056                   --  objects is deferred until the freeze point, because
3057                   --  a subsequent pragma might indicate that the object
3058                   --  is imported and thus not initialized. Also, the address
3059                   --  clause might involve entities that have yet to be
3060                   --  elaborated.
3061
3062                   Set_Has_Delayed_Freeze (U_Ent);
3063
3064                   --  If an initialization call has been generated for this
3065                   --  object, it needs to be deferred to after the freeze node
3066                   --  we have just now added, otherwise GIGI will see a
3067                   --  reference to the variable (as actual to the IP call)
3068                   --  before its definition.
3069
3070                   declare
3071                      Init_Call : constant Node_Id :=
3072                                    Remove_Init_Call (U_Ent, N);
3073
3074                   begin
3075                      if Present (Init_Call) then
3076
3077                         --  If the init call is an expression with actions with
3078                         --  null expression, just extract the actions.
3079
3080                         if Nkind (Init_Call) = N_Expression_With_Actions
3081                           and then
3082                             Nkind (Expression (Init_Call)) = N_Null_Statement
3083                         then
3084                            Append_Freeze_Actions (U_Ent, Actions (Init_Call));
3085
3086                         --  General case: move Init_Call to freeze actions
3087
3088                         else
3089                            Append_Freeze_Action (U_Ent, Init_Call);
3090                         end if;
3091                      end if;
3092                   end;
3093
3094                   if Is_Exported (U_Ent) then
3095                      Error_Msg_N
3096                        ("& cannot be exported if an address clause is given",
3097                         Nam);
3098                      Error_Msg_N
3099                        ("\define and export a variable "
3100                         & "that holds its address instead", Nam);
3101                   end if;
3102
3103                   --  Entity has delayed freeze, so we will generate an
3104                   --  alignment check at the freeze point unless suppressed.
3105
3106                   if not Range_Checks_Suppressed (U_Ent)
3107                     and then not Alignment_Checks_Suppressed (U_Ent)
3108                   then
3109                      Set_Check_Address_Alignment (N);
3110                   end if;
3111
3112                   --  Kill the size check code, since we are not allocating
3113                   --  the variable, it is somewhere else.
3114
3115                   Kill_Size_Check_Code (U_Ent);
3116
3117                   --  If the address clause is of the form:
3118
3119                   --    for Y'Address use X'Address
3120
3121                   --  or
3122
3123                   --    Const : constant Address := X'Address;
3124                   --    ...
3125                   --    for Y'Address use Const;
3126
3127                   --  then we make an entry in the table for checking the size
3128                   --  and alignment of the overlaying variable. We defer this
3129                   --  check till after code generation to take full advantage
3130                   --  of the annotation done by the back end. This entry is
3131                   --  only made if the address clause comes from source.
3132
3133                   --  If the entity has a generic type, the check will be
3134                   --  performed in the instance if the actual type justifies
3135                   --  it, and we do not insert the clause in the table to
3136                   --  prevent spurious warnings.
3137
3138                   if Address_Clause_Overlay_Warnings
3139                     and then Comes_From_Source (N)
3140                     and then Present (O_Ent)
3141                     and then Is_Object (O_Ent)
3142                   then
3143                      if not Is_Generic_Type (Etype (U_Ent)) then
3144                         Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off));
3145                      end if;
3146
3147                      --  If variable overlays a constant view, and we are
3148                      --  warning on overlays, then mark the variable as
3149                      --  overlaying a constant (we will give warnings later
3150                      --  if this variable is assigned).
3151
3152                      if Is_Constant_Object (O_Ent)
3153                        and then Ekind (U_Ent) = E_Variable
3154                      then
3155                         Set_Overlays_Constant (U_Ent);
3156                      end if;
3157                   end if;
3158                end;
3159
3160             --  Not a valid entity for an address clause
3161
3162             else
3163                Error_Msg_N ("address cannot be given for &", Nam);
3164             end if;
3165          end Address;
3166
3167          ---------------
3168          -- Alignment --
3169          ---------------
3170
3171          --  Alignment attribute definition clause
3172
3173          when Attribute_Alignment => Alignment : declare
3174             Align     : constant Uint := Get_Alignment_Value (Expr);
3175             Max_Align : constant Uint := UI_From_Int (Maximum_Alignment);
3176
3177          begin
3178             FOnly := True;
3179
3180             if not Is_Type (U_Ent)
3181               and then Ekind (U_Ent) /= E_Variable
3182               and then Ekind (U_Ent) /= E_Constant
3183             then
3184                Error_Msg_N ("alignment cannot be given for &", Nam);
3185
3186             elsif Duplicate_Clause then
3187                null;
3188
3189             elsif Align /= No_Uint then
3190                Set_Has_Alignment_Clause (U_Ent);
3191
3192                --  Tagged type case, check for attempt to set alignment to a
3193                --  value greater than Max_Align, and reset if so.
3194
3195                if Is_Tagged_Type (U_Ent) and then Align > Max_Align then
3196                   Error_Msg_N
3197                     ("alignment for & set to Maximum_Aligment??", Nam);
3198                      Set_Alignment (U_Ent, Max_Align);
3199
3200                --  All other cases
3201
3202                else
3203                   Set_Alignment (U_Ent, Align);
3204                end if;
3205
3206                --  For an array type, U_Ent is the first subtype. In that case,
3207                --  also set the alignment of the anonymous base type so that
3208                --  other subtypes (such as the itypes for aggregates of the
3209                --  type) also receive the expected alignment.
3210
3211                if Is_Array_Type (U_Ent) then
3212                   Set_Alignment (Base_Type (U_Ent), Align);
3213                end if;
3214             end if;
3215          end Alignment;
3216
3217          ---------------
3218          -- Bit_Order --
3219          ---------------
3220
3221          --  Bit_Order attribute definition clause
3222
3223          when Attribute_Bit_Order => Bit_Order : declare
3224          begin
3225             if not Is_Record_Type (U_Ent) then
3226                Error_Msg_N
3227                  ("Bit_Order can only be defined for record type", Nam);
3228
3229             elsif Duplicate_Clause then
3230                null;
3231
3232             else
3233                Analyze_And_Resolve (Expr, RTE (RE_Bit_Order));
3234
3235                if Etype (Expr) = Any_Type then
3236                   return;
3237
3238                elsif not Is_Static_Expression (Expr) then
3239                   Flag_Non_Static_Expr
3240                     ("Bit_Order requires static expression!", Expr);
3241
3242                else
3243                   if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
3244                      Set_Reverse_Bit_Order (U_Ent, True);
3245                   end if;
3246                end if;
3247             end if;
3248          end Bit_Order;
3249
3250          --------------------
3251          -- Component_Size --
3252          --------------------
3253
3254          --  Component_Size attribute definition clause
3255
3256          when Attribute_Component_Size => Component_Size_Case : declare
3257             Csize    : constant Uint := Static_Integer (Expr);
3258             Ctyp     : Entity_Id;
3259             Btype    : Entity_Id;
3260             Biased   : Boolean;
3261             New_Ctyp : Entity_Id;
3262             Decl     : Node_Id;
3263
3264          begin
3265             if not Is_Array_Type (U_Ent) then
3266                Error_Msg_N ("component size requires array type", Nam);
3267                return;
3268             end if;
3269
3270             Btype := Base_Type (U_Ent);
3271             Ctyp := Component_Type (Btype);
3272
3273             if Duplicate_Clause then
3274                null;
3275
3276             elsif Rep_Item_Too_Early (Btype, N) then
3277                null;
3278
3279             elsif Csize /= No_Uint then
3280                Check_Size (Expr, Ctyp, Csize, Biased);
3281
3282                --  For the biased case, build a declaration for a subtype that
3283                --  will be used to represent the biased subtype that reflects
3284                --  the biased representation of components. We need the subtype
3285                --  to get proper conversions on referencing elements of the
3286                --  array. Note: component size clauses are ignored in VM mode.
3287
3288                if VM_Target = No_VM then
3289                   if Biased then
3290                      New_Ctyp :=
3291                        Make_Defining_Identifier (Loc,
3292                          Chars =>
3293                            New_External_Name (Chars (U_Ent), 'C', 0, 'T'));
3294
3295                      Decl :=
3296                        Make_Subtype_Declaration (Loc,
3297                          Defining_Identifier => New_Ctyp,
3298                          Subtype_Indication  =>
3299                            New_Occurrence_Of (Component_Type (Btype), Loc));
3300
3301                      Set_Parent (Decl, N);
3302                      Analyze (Decl, Suppress => All_Checks);
3303
3304                      Set_Has_Delayed_Freeze        (New_Ctyp, False);
3305                      Set_Esize                     (New_Ctyp, Csize);
3306                      Set_RM_Size                   (New_Ctyp, Csize);
3307                      Init_Alignment                (New_Ctyp);
3308                      Set_Is_Itype                  (New_Ctyp, True);
3309                      Set_Associated_Node_For_Itype (New_Ctyp, U_Ent);
3310
3311                      Set_Component_Type (Btype, New_Ctyp);
3312                      Set_Biased (New_Ctyp, N, "component size clause");
3313                   end if;
3314
3315                   Set_Component_Size (Btype, Csize);
3316
3317                --  For VM case, we ignore component size clauses
3318
3319                else
3320                   --  Give a warning unless we are in GNAT mode, in which case
3321                   --  the warning is suppressed since it is not useful.
3322
3323                   if not GNAT_Mode then
3324                      Error_Msg_N
3325                        ("component size ignored in this configuration??", N);
3326                   end if;
3327                end if;
3328
3329                --  Deal with warning on overridden size
3330
3331                if Warn_On_Overridden_Size
3332                  and then Has_Size_Clause (Ctyp)
3333                  and then RM_Size (Ctyp) /= Csize
3334                then
3335                   Error_Msg_NE
3336                     ("component size overrides size clause for&?S?", N, Ctyp);
3337                end if;
3338
3339                Set_Has_Component_Size_Clause (Btype, True);
3340                Set_Has_Non_Standard_Rep (Btype, True);
3341             end if;
3342          end Component_Size_Case;
3343
3344          -----------------------
3345          -- Constant_Indexing --
3346          -----------------------
3347
3348          when Attribute_Constant_Indexing =>
3349             Check_Indexing_Functions;
3350
3351          ---------
3352          -- CPU --
3353          ---------
3354
3355          when Attribute_CPU => CPU :
3356          begin
3357             --  CPU attribute definition clause not allowed except from aspect
3358             --  specification.
3359
3360             if From_Aspect_Specification (N) then
3361                if not Is_Task_Type (U_Ent) then
3362                   Error_Msg_N ("CPU can only be defined for task", Nam);
3363
3364                elsif Duplicate_Clause then
3365                   null;
3366
3367                else
3368                   --  The expression must be analyzed in the special manner
3369                   --  described in "Handling of Default and Per-Object
3370                   --  Expressions" in sem.ads.
3371
3372                   --  The visibility to the discriminants must be restored
3373
3374                   Push_Scope_And_Install_Discriminants (U_Ent);
3375                   Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range));
3376                   Uninstall_Discriminants_And_Pop_Scope (U_Ent);
3377
3378                   if not Is_Static_Expression (Expr) then
3379                      Check_Restriction (Static_Priorities, Expr);
3380                   end if;
3381                end if;
3382
3383             else
3384                Error_Msg_N
3385                  ("attribute& cannot be set with definition clause", N);
3386             end if;
3387          end CPU;
3388
3389          ----------------------
3390          -- Default_Iterator --
3391          ----------------------
3392
3393          when Attribute_Default_Iterator =>  Default_Iterator : declare
3394             Func : Entity_Id;
3395
3396          begin
3397             if not Is_Tagged_Type (U_Ent) then
3398                Error_Msg_N
3399                  ("aspect Default_Iterator applies to  tagged type", Nam);
3400             end if;
3401
3402             Check_Iterator_Functions;
3403
3404             Analyze (Expr);
3405
3406             if not Is_Entity_Name (Expr)
3407               or else Ekind (Entity (Expr)) /= E_Function
3408             then
3409                Error_Msg_N ("aspect Iterator must be a function", Expr);
3410             else
3411                Func := Entity (Expr);
3412             end if;
3413
3414             if No (First_Formal (Func))
3415               or else Etype (First_Formal (Func)) /= U_Ent
3416             then
3417                Error_Msg_NE
3418                  ("Default Iterator must be a primitive of&", Func, U_Ent);
3419             end if;
3420          end Default_Iterator;
3421
3422          ------------------------
3423          -- Dispatching_Domain --
3424          ------------------------
3425
3426          when Attribute_Dispatching_Domain => Dispatching_Domain :
3427          begin
3428             --  Dispatching_Domain attribute definition clause not allowed
3429             --  except from aspect specification.
3430
3431             if From_Aspect_Specification (N) then
3432                if not Is_Task_Type (U_Ent) then
3433                   Error_Msg_N ("Dispatching_Domain can only be defined" &
3434                                "for task",
3435                                Nam);
3436
3437                elsif Duplicate_Clause then
3438                   null;
3439
3440                else
3441                   --  The expression must be analyzed in the special manner
3442                   --  described in "Handling of Default and Per-Object
3443                   --  Expressions" in sem.ads.
3444
3445                   --  The visibility to the discriminants must be restored
3446
3447                   Push_Scope_And_Install_Discriminants (U_Ent);
3448
3449                   Preanalyze_Spec_Expression
3450                     (Expr, RTE (RE_Dispatching_Domain));
3451
3452                   Uninstall_Discriminants_And_Pop_Scope (U_Ent);
3453                end if;
3454
3455             else
3456                Error_Msg_N
3457                  ("attribute& cannot be set with definition clause", N);
3458             end if;
3459          end Dispatching_Domain;
3460
3461          ------------------
3462          -- External_Tag --
3463          ------------------
3464
3465          when Attribute_External_Tag => External_Tag :
3466          begin
3467             if not Is_Tagged_Type (U_Ent) then
3468                Error_Msg_N ("should be a tagged type", Nam);
3469             end if;
3470
3471             if Duplicate_Clause then
3472                null;
3473
3474             else
3475                Analyze_And_Resolve (Expr, Standard_String);
3476
3477                if not Is_Static_Expression (Expr) then
3478                   Flag_Non_Static_Expr
3479                     ("static string required for tag name!", Nam);
3480                end if;
3481
3482                if VM_Target = No_VM then
3483                   Set_Has_External_Tag_Rep_Clause (U_Ent);
3484                else
3485                   Error_Msg_Name_1 := Attr;
3486                   Error_Msg_N
3487                     ("% attribute unsupported in this configuration", Nam);
3488                end if;
3489
3490                if not Is_Library_Level_Entity (U_Ent) then
3491                   Error_Msg_NE
3492                     ("??non-unique external tag supplied for &", N, U_Ent);
3493                   Error_Msg_N
3494                        ("\??same external tag applies to all "
3495                         & "subprogram calls", N);
3496                   Error_Msg_N
3497                     ("\??corresponding internal tag cannot be obtained", N);
3498                end if;
3499             end if;
3500          end External_Tag;
3501
3502          --------------------------
3503          -- Implicit_Dereference --
3504          --------------------------
3505
3506          when Attribute_Implicit_Dereference =>
3507
3508             --  Legality checks already performed at the point of the type
3509             --  declaration, aspect is not delayed.
3510
3511             null;
3512
3513          -----------
3514          -- Input --
3515          -----------
3516
3517          when Attribute_Input =>
3518             Analyze_Stream_TSS_Definition (TSS_Stream_Input);
3519             Set_Has_Specified_Stream_Input (Ent);
3520
3521          ------------------------
3522          -- Interrupt_Priority --
3523          ------------------------
3524
3525          when Attribute_Interrupt_Priority => Interrupt_Priority :
3526          begin
3527             --  Interrupt_Priority attribute definition clause not allowed
3528             --  except from aspect specification.
3529
3530             if From_Aspect_Specification (N) then
3531                if not (Is_Protected_Type (U_Ent)
3532                         or else Is_Task_Type (U_Ent))
3533                then
3534                   Error_Msg_N
3535                     ("Interrupt_Priority can only be defined for task" &
3536                      "and protected object",
3537                      Nam);
3538
3539                elsif Duplicate_Clause then
3540                   null;
3541
3542                else
3543                   --  The expression must be analyzed in the special manner
3544                   --  described in "Handling of Default and Per-Object
3545                   --  Expressions" in sem.ads.
3546
3547                   --  The visibility to the discriminants must be restored
3548
3549                   Push_Scope_And_Install_Discriminants (U_Ent);
3550
3551                   Preanalyze_Spec_Expression
3552                     (Expr, RTE (RE_Interrupt_Priority));
3553
3554                   Uninstall_Discriminants_And_Pop_Scope (U_Ent);
3555                end if;
3556
3557             else
3558                Error_Msg_N
3559                  ("attribute& cannot be set with definition clause", N);
3560             end if;
3561          end Interrupt_Priority;
3562
3563          ----------------------
3564          -- Iterator_Element --
3565          ----------------------
3566
3567          when Attribute_Iterator_Element =>
3568             Analyze (Expr);
3569
3570             if not Is_Entity_Name (Expr)
3571               or else not Is_Type (Entity (Expr))
3572             then
3573                Error_Msg_N ("aspect Iterator_Element must be a type", Expr);
3574             end if;
3575
3576          -------------------
3577          -- Machine_Radix --
3578          -------------------
3579
3580          --  Machine radix attribute definition clause
3581
3582          when Attribute_Machine_Radix => Machine_Radix : declare
3583             Radix : constant Uint := Static_Integer (Expr);
3584
3585          begin
3586             if not Is_Decimal_Fixed_Point_Type (U_Ent) then
3587                Error_Msg_N ("decimal fixed-point type expected for &", Nam);
3588
3589             elsif Duplicate_Clause then
3590                null;
3591
3592             elsif Radix /= No_Uint then
3593                Set_Has_Machine_Radix_Clause (U_Ent);
3594                Set_Has_Non_Standard_Rep (Base_Type (U_Ent));
3595
3596                if Radix = 2 then
3597                   null;
3598                elsif Radix = 10 then
3599                   Set_Machine_Radix_10 (U_Ent);
3600                else
3601                   Error_Msg_N ("machine radix value must be 2 or 10", Expr);
3602                end if;
3603             end if;
3604          end Machine_Radix;
3605
3606          -----------------
3607          -- Object_Size --
3608          -----------------
3609
3610          --  Object_Size attribute definition clause
3611
3612          when Attribute_Object_Size => Object_Size : declare
3613             Size : constant Uint := Static_Integer (Expr);
3614
3615             Biased : Boolean;
3616             pragma Warnings (Off, Biased);
3617
3618          begin
3619             if not Is_Type (U_Ent) then
3620                Error_Msg_N ("Object_Size cannot be given for &", Nam);
3621
3622             elsif Duplicate_Clause then
3623                null;
3624
3625             else
3626                Check_Size (Expr, U_Ent, Size, Biased);
3627
3628                if Size /= 8
3629                     and then
3630                   Size /= 16
3631                     and then
3632                   Size /= 32
3633                     and then
3634                   UI_Mod (Size, 64) /= 0
3635                then
3636                   Error_Msg_N
3637                     ("Object_Size must be 8, 16, 32, or multiple of 64",
3638                      Expr);
3639                end if;
3640
3641                Set_Esize (U_Ent, Size);
3642                Set_Has_Object_Size_Clause (U_Ent);
3643                Alignment_Check_For_Size_Change (U_Ent, Size);
3644             end if;
3645          end Object_Size;
3646
3647          ------------
3648          -- Output --
3649          ------------
3650
3651          when Attribute_Output =>
3652             Analyze_Stream_TSS_Definition (TSS_Stream_Output);
3653             Set_Has_Specified_Stream_Output (Ent);
3654
3655          --------------
3656          -- Priority --
3657          --------------
3658
3659          when Attribute_Priority => Priority :
3660          begin
3661             --  Priority attribute definition clause not allowed except from
3662             --  aspect specification.
3663
3664             if From_Aspect_Specification (N) then
3665                if not (Is_Protected_Type (U_Ent)
3666                         or else Is_Task_Type (U_Ent)
3667                         or else Ekind (U_Ent) = E_Procedure)
3668                then
3669                   Error_Msg_N
3670                     ("Priority can only be defined for task and protected " &
3671                      "object",
3672                      Nam);
3673
3674                elsif Duplicate_Clause then
3675                   null;
3676
3677                else
3678                   --  The expression must be analyzed in the special manner
3679                   --  described in "Handling of Default and Per-Object
3680                   --  Expressions" in sem.ads.
3681
3682                   --  The visibility to the discriminants must be restored
3683
3684                   Push_Scope_And_Install_Discriminants (U_Ent);
3685                   Preanalyze_Spec_Expression (Expr, Standard_Integer);
3686                   Uninstall_Discriminants_And_Pop_Scope (U_Ent);
3687
3688                   if not Is_Static_Expression (Expr) then
3689                      Check_Restriction (Static_Priorities, Expr);
3690                   end if;
3691                end if;
3692
3693             else
3694                Error_Msg_N
3695                  ("attribute& cannot be set with definition clause", N);
3696             end if;
3697          end Priority;
3698
3699          ----------
3700          -- Read --
3701          ----------
3702
3703          when Attribute_Read =>
3704             Analyze_Stream_TSS_Definition (TSS_Stream_Read);
3705             Set_Has_Specified_Stream_Read (Ent);
3706
3707          --------------------------
3708          -- Scalar_Storage_Order --
3709          --------------------------
3710
3711          --  Scalar_Storage_Order attribute definition clause
3712
3713          when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : declare
3714          begin
3715             if not (Is_Record_Type (U_Ent) or else Is_Array_Type (U_Ent)) then
3716                Error_Msg_N
3717                  ("Scalar_Storage_Order can only be defined for "
3718                   & "record or array type", Nam);
3719
3720             elsif Duplicate_Clause then
3721                null;
3722
3723             else
3724                Analyze_And_Resolve (Expr, RTE (RE_Bit_Order));
3725
3726                if Etype (Expr) = Any_Type then
3727                   return;
3728
3729                elsif not Is_Static_Expression (Expr) then
3730                   Flag_Non_Static_Expr
3731                     ("Scalar_Storage_Order requires static expression!", Expr);
3732
3733                elsif (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
3734
3735                   --  Here for the case of a non-default (i.e. non-confirming)
3736                   --  Scalar_Storage_Order attribute definition.
3737
3738                   if Support_Nondefault_SSO_On_Target then
3739                      Set_Reverse_Storage_Order (Base_Type (U_Ent), True);
3740                   else
3741                      Error_Msg_N
3742                        ("non-default Scalar_Storage_Order "
3743                         & "not supported on target", Expr);
3744                   end if;
3745                end if;
3746             end if;
3747          end Scalar_Storage_Order;
3748
3749          ----------
3750          -- Size --
3751          ----------
3752
3753          --  Size attribute definition clause
3754
3755          when Attribute_Size => Size : declare
3756             Size   : constant Uint := Static_Integer (Expr);
3757             Etyp   : Entity_Id;
3758             Biased : Boolean;
3759
3760          begin
3761             FOnly := True;
3762
3763             if Duplicate_Clause then
3764                null;
3765
3766             elsif not Is_Type (U_Ent)
3767               and then Ekind (U_Ent) /= E_Variable
3768               and then Ekind (U_Ent) /= E_Constant
3769             then
3770                Error_Msg_N ("size cannot be given for &", Nam);
3771
3772             elsif Is_Array_Type (U_Ent)
3773               and then not Is_Constrained (U_Ent)
3774             then
3775                Error_Msg_N
3776                  ("size cannot be given for unconstrained array", Nam);
3777
3778             elsif Size /= No_Uint then
3779                if VM_Target /= No_VM and then not GNAT_Mode then
3780
3781                   --  Size clause is not handled properly on VM targets.
3782                   --  Display a warning unless we are in GNAT mode, in which
3783                   --  case this is useless.
3784
3785                   Error_Msg_N
3786                     ("size clauses are ignored in this configuration??", N);
3787                end if;
3788
3789                if Is_Type (U_Ent) then
3790                   Etyp := U_Ent;
3791                else
3792                   Etyp := Etype (U_Ent);
3793                end if;
3794
3795                --  Check size, note that Gigi is in charge of checking that the
3796                --  size of an array or record type is OK. Also we do not check
3797                --  the size in the ordinary fixed-point case, since it is too
3798                --  early to do so (there may be subsequent small clause that
3799                --  affects the size). We can check the size if a small clause
3800                --  has already been given.
3801
3802                if not Is_Ordinary_Fixed_Point_Type (U_Ent)
3803                  or else Has_Small_Clause (U_Ent)
3804                then
3805                   Check_Size (Expr, Etyp, Size, Biased);
3806                   Set_Biased (U_Ent, N, "size clause", Biased);
3807                end if;
3808
3809                --  For types set RM_Size and Esize if possible
3810
3811                if Is_Type (U_Ent) then
3812                   Set_RM_Size (U_Ent, Size);
3813
3814                   --  For elementary types, increase Object_Size to power of 2,
3815                   --  but not less than a storage unit in any case (normally
3816                   --  this means it will be byte addressable).
3817
3818                   --  For all other types, nothing else to do, we leave Esize
3819                   --  (object size) unset, the back end will set it from the
3820                   --  size and alignment in an appropriate manner.
3821
3822                   --  In both cases, we check whether the alignment must be
3823                   --  reset in the wake of the size change.
3824
3825                   if Is_Elementary_Type (U_Ent) then
3826                      if Size <= System_Storage_Unit then
3827                         Init_Esize (U_Ent, System_Storage_Unit);
3828                      elsif Size <= 16 then
3829                         Init_Esize (U_Ent, 16);
3830                      elsif Size <= 32 then
3831                         Init_Esize (U_Ent, 32);
3832                      else
3833                         Set_Esize  (U_Ent, (Size + 63) / 64 * 64);
3834                      end if;
3835
3836                      Alignment_Check_For_Size_Change (U_Ent, Esize (U_Ent));
3837                   else
3838                      Alignment_Check_For_Size_Change (U_Ent, Size);
3839                   end if;
3840
3841                --  For objects, set Esize only
3842
3843                else
3844                   if Is_Elementary_Type (Etyp) then
3845                      if Size /= System_Storage_Unit
3846                           and then
3847                         Size /= System_Storage_Unit * 2
3848                           and then
3849                         Size /= System_Storage_Unit * 4
3850                            and then
3851                         Size /= System_Storage_Unit * 8
3852                      then
3853                         Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
3854                         Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
3855                         Error_Msg_N
3856                           ("size for primitive object must be a power of 2"
3857                             & " in the range ^-^", N);
3858                      end if;
3859                   end if;
3860
3861                   Set_Esize (U_Ent, Size);
3862                end if;
3863
3864                Set_Has_Size_Clause (U_Ent);
3865             end if;
3866          end Size;
3867
3868          -----------
3869          -- Small --
3870          -----------
3871
3872          --  Small attribute definition clause
3873
3874          when Attribute_Small => Small : declare
3875             Implicit_Base : constant Entity_Id := Base_Type (U_Ent);
3876             Small         : Ureal;
3877
3878          begin
3879             Analyze_And_Resolve (Expr, Any_Real);
3880
3881             if Etype (Expr) = Any_Type then
3882                return;
3883
3884             elsif not Is_Static_Expression (Expr) then
3885                Flag_Non_Static_Expr
3886                  ("small requires static expression!", Expr);
3887                return;
3888
3889             else
3890                Small := Expr_Value_R (Expr);
3891
3892                if Small <= Ureal_0 then
3893                   Error_Msg_N ("small value must be greater than zero", Expr);
3894                   return;
3895                end if;
3896
3897             end if;
3898
3899             if not Is_Ordinary_Fixed_Point_Type (U_Ent) then
3900                Error_Msg_N
3901                  ("small requires an ordinary fixed point type", Nam);
3902
3903             elsif Has_Small_Clause (U_Ent) then
3904                Error_Msg_N ("small already given for &", Nam);
3905
3906             elsif Small > Delta_Value (U_Ent) then
3907                Error_Msg_N
3908                  ("small value must not be greater than delta value", Nam);
3909
3910             else
3911                Set_Small_Value (U_Ent, Small);
3912                Set_Small_Value (Implicit_Base, Small);
3913                Set_Has_Small_Clause (U_Ent);
3914                Set_Has_Small_Clause (Implicit_Base);
3915                Set_Has_Non_Standard_Rep (Implicit_Base);
3916             end if;
3917          end Small;
3918
3919          ------------------
3920          -- Storage_Pool --
3921          ------------------
3922
3923          --  Storage_Pool attribute definition clause
3924
3925          when Attribute_Storage_Pool | Attribute_Simple_Storage_Pool => declare
3926             Pool : Entity_Id;
3927             T    : Entity_Id;
3928
3929          begin
3930             if Ekind (U_Ent) = E_Access_Subprogram_Type then
3931                Error_Msg_N
3932                  ("storage pool cannot be given for access-to-subprogram type",
3933                   Nam);
3934                return;
3935
3936             elsif not
3937               Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type)
3938             then
3939                Error_Msg_N
3940                  ("storage pool can only be given for access types", Nam);
3941                return;
3942
3943             elsif Is_Derived_Type (U_Ent) then
3944                Error_Msg_N
3945                  ("storage pool cannot be given for a derived access type",
3946                   Nam);
3947
3948             elsif Duplicate_Clause then
3949                return;
3950
3951             elsif Present (Associated_Storage_Pool (U_Ent)) then
3952                Error_Msg_N ("storage pool already given for &", Nam);
3953                return;
3954             end if;
3955
3956             if Id = Attribute_Storage_Pool then
3957                Analyze_And_Resolve
3958                  (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
3959
3960             --  In the Simple_Storage_Pool case, we allow a variable of any
3961             --  simple storage pool type, so we Resolve without imposing an
3962             --  expected type.
3963
3964             else
3965                Analyze_And_Resolve (Expr);
3966
3967                if not Present (Get_Rep_Pragma
3968                                  (Etype (Expr), Name_Simple_Storage_Pool_Type))
3969                then
3970                   Error_Msg_N
3971                     ("expression must be of a simple storage pool type", Expr);
3972                end if;
3973             end if;
3974
3975             if not Denotes_Variable (Expr) then
3976                Error_Msg_N ("storage pool must be a variable", Expr);
3977                return;
3978             end if;
3979
3980             if Nkind (Expr) = N_Type_Conversion then
3981                T := Etype (Expression (Expr));
3982             else
3983                T := Etype (Expr);
3984             end if;
3985
3986             --  The Stack_Bounded_Pool is used internally for implementing
3987             --  access types with a Storage_Size. Since it only work properly
3988             --  when used on one specific type, we need to check that it is not
3989             --  hijacked improperly:
3990
3991             --    type T is access Integer;
3992             --    for T'Storage_Size use n;
3993             --    type Q is access Float;
3994             --    for Q'Storage_Size use T'Storage_Size; -- incorrect
3995
3996             if RTE_Available (RE_Stack_Bounded_Pool)
3997               and then Base_Type (T) = RTE (RE_Stack_Bounded_Pool)
3998             then
3999                Error_Msg_N ("non-shareable internal Pool", Expr);
4000                return;
4001             end if;
4002
4003             --  If the argument is a name that is not an entity name, then
4004             --  we construct a renaming operation to define an entity of
4005             --  type storage pool.
4006
4007             if not Is_Entity_Name (Expr)
4008               and then Is_Object_Reference (Expr)
4009             then
4010                Pool := Make_Temporary (Loc, 'P', Expr);
4011
4012                declare
4013                   Rnode : constant Node_Id :=
4014                             Make_Object_Renaming_Declaration (Loc,
4015                               Defining_Identifier => Pool,
4016                               Subtype_Mark        =>
4017                                 New_Occurrence_Of (Etype (Expr), Loc),
4018                               Name                => Expr);
4019
4020                begin
4021                   Insert_Before (N, Rnode);
4022                   Analyze (Rnode);
4023                   Set_Associated_Storage_Pool (U_Ent, Pool);
4024                end;
4025
4026             elsif Is_Entity_Name (Expr) then
4027                Pool := Entity (Expr);
4028
4029                --  If pool is a renamed object, get original one. This can
4030                --  happen with an explicit renaming, and within instances.
4031
4032                while Present (Renamed_Object (Pool))
4033                  and then Is_Entity_Name (Renamed_Object (Pool))
4034                loop
4035                   Pool := Entity (Renamed_Object (Pool));
4036                end loop;
4037
4038                if Present (Renamed_Object (Pool))
4039                  and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion
4040                  and then Is_Entity_Name (Expression (Renamed_Object (Pool)))
4041                then
4042                   Pool := Entity (Expression (Renamed_Object (Pool)));
4043                end if;
4044
4045                Set_Associated_Storage_Pool (U_Ent, Pool);
4046
4047             elsif Nkind (Expr) = N_Type_Conversion
4048               and then Is_Entity_Name (Expression (Expr))
4049               and then Nkind (Original_Node (Expr)) = N_Attribute_Reference
4050             then
4051                Pool := Entity (Expression (Expr));
4052                Set_Associated_Storage_Pool (U_Ent, Pool);
4053
4054             else
4055                Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
4056                return;
4057             end if;
4058          end;
4059
4060          ------------------
4061          -- Storage_Size --
4062          ------------------
4063
4064          --  Storage_Size attribute definition clause
4065
4066          when Attribute_Storage_Size => Storage_Size : declare
4067             Btype : constant Entity_Id := Base_Type (U_Ent);
4068
4069          begin
4070             if Is_Task_Type (U_Ent) then
4071                Check_Restriction (No_Obsolescent_Features, N);
4072
4073                if Warn_On_Obsolescent_Feature then
4074                   Error_Msg_N
4075                     ("?j?storage size clause for task is an " &
4076                      "obsolescent feature (RM J.9)", N);
4077                   Error_Msg_N ("\?j?use Storage_Size pragma instead", N);
4078                end if;
4079
4080                FOnly := True;
4081             end if;
4082
4083             if not Is_Access_Type (U_Ent)
4084               and then Ekind (U_Ent) /= E_Task_Type
4085             then
4086                Error_Msg_N ("storage size cannot be given for &", Nam);
4087
4088             elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then
4089                Error_Msg_N
4090                  ("storage size cannot be given for a derived access type",
4091                   Nam);
4092
4093             elsif Duplicate_Clause then
4094                null;
4095
4096             else
4097                Analyze_And_Resolve (Expr, Any_Integer);
4098
4099                if Is_Access_Type (U_Ent) then
4100                   if Present (Associated_Storage_Pool (U_Ent)) then
4101                      Error_Msg_N ("storage pool already given for &", Nam);
4102                      return;
4103                   end if;
4104
4105                   if Is_OK_Static_Expression (Expr)
4106                     and then Expr_Value (Expr) = 0
4107                   then
4108                      Set_No_Pool_Assigned (Btype);
4109                   end if;
4110                end if;
4111
4112                Set_Has_Storage_Size_Clause (Btype);
4113             end if;
4114          end Storage_Size;
4115
4116          -----------------
4117          -- Stream_Size --
4118          -----------------
4119
4120          when Attribute_Stream_Size => Stream_Size : declare
4121             Size : constant Uint := Static_Integer (Expr);
4122
4123          begin
4124             if Ada_Version <= Ada_95 then
4125                Check_Restriction (No_Implementation_Attributes, N);
4126             end if;
4127
4128             if Duplicate_Clause then
4129                null;
4130
4131             elsif Is_Elementary_Type (U_Ent) then
4132                if Size /= System_Storage_Unit
4133                     and then
4134                   Size /= System_Storage_Unit * 2
4135                     and then
4136                   Size /= System_Storage_Unit * 4
4137                      and then
4138                   Size /= System_Storage_Unit * 8
4139                then
4140                   Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
4141                   Error_Msg_N
4142                     ("stream size for elementary type must be a"
4143                        & " power of 2 and at least ^", N);
4144
4145                elsif RM_Size (U_Ent) > Size then
4146                   Error_Msg_Uint_1 := RM_Size (U_Ent);
4147                   Error_Msg_N
4148                     ("stream size for elementary type must be a"
4149                        & " power of 2 and at least ^", N);
4150                end if;
4151
4152                Set_Has_Stream_Size_Clause (U_Ent);
4153
4154             else
4155                Error_Msg_N ("Stream_Size cannot be given for &", Nam);
4156             end if;
4157          end Stream_Size;
4158
4159          ----------------
4160          -- Value_Size --
4161          ----------------
4162
4163          --  Value_Size attribute definition clause
4164
4165          when Attribute_Value_Size => Value_Size : declare
4166             Size   : constant Uint := Static_Integer (Expr);
4167             Biased : Boolean;
4168
4169          begin
4170             if not Is_Type (U_Ent) then
4171                Error_Msg_N ("Value_Size cannot be given for &", Nam);
4172
4173             elsif Duplicate_Clause then
4174                null;
4175
4176             elsif Is_Array_Type (U_Ent)
4177               and then not Is_Constrained (U_Ent)
4178             then
4179                Error_Msg_N
4180                  ("Value_Size cannot be given for unconstrained array", Nam);
4181
4182             else
4183                if Is_Elementary_Type (U_Ent) then
4184                   Check_Size (Expr, U_Ent, Size, Biased);
4185                   Set_Biased (U_Ent, N, "value size clause", Biased);
4186                end if;
4187
4188                Set_RM_Size (U_Ent, Size);
4189             end if;
4190          end Value_Size;
4191
4192          -----------------------
4193          -- Variable_Indexing --
4194          -----------------------
4195
4196          when Attribute_Variable_Indexing =>
4197             Check_Indexing_Functions;
4198
4199          -----------
4200          -- Write --
4201          -----------
4202
4203          when Attribute_Write =>
4204             Analyze_Stream_TSS_Definition (TSS_Stream_Write);
4205             Set_Has_Specified_Stream_Write (Ent);
4206
4207          --  All other attributes cannot be set
4208
4209          when others =>
4210             Error_Msg_N
4211               ("attribute& cannot be set with definition clause", N);
4212       end case;
4213
4214       --  The test for the type being frozen must be performed after any
4215       --  expression the clause has been analyzed since the expression itself
4216       --  might cause freezing that makes the clause illegal.
4217
4218       if Rep_Item_Too_Late (U_Ent, N, FOnly) then
4219          return;
4220       end if;
4221    end Analyze_Attribute_Definition_Clause;
4222
4223    ----------------------------
4224    -- Analyze_Code_Statement --
4225    ----------------------------
4226
4227    procedure Analyze_Code_Statement (N : Node_Id) is
4228       HSS   : constant Node_Id   := Parent (N);
4229       SBody : constant Node_Id   := Parent (HSS);
4230       Subp  : constant Entity_Id := Current_Scope;
4231       Stmt  : Node_Id;
4232       Decl  : Node_Id;
4233       StmtO : Node_Id;
4234       DeclO : Node_Id;
4235
4236    begin
4237       --  Analyze and check we get right type, note that this implements the
4238       --  requirement (RM 13.8(1)) that Machine_Code be with'ed, since that
4239       --  is the only way that Asm_Insn could possibly be visible.
4240
4241       Analyze_And_Resolve (Expression (N));
4242
4243       if Etype (Expression (N)) = Any_Type then
4244          return;
4245       elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then
4246          Error_Msg_N ("incorrect type for code statement", N);
4247          return;
4248       end if;
4249
4250       Check_Code_Statement (N);
4251
4252       --  Make sure we appear in the handled statement sequence of a
4253       --  subprogram (RM 13.8(3)).
4254
4255       if Nkind (HSS) /= N_Handled_Sequence_Of_Statements
4256         or else Nkind (SBody) /= N_Subprogram_Body
4257       then
4258          Error_Msg_N
4259            ("code statement can only appear in body of subprogram", N);
4260          return;
4261       end if;
4262
4263       --  Do remaining checks (RM 13.8(3)) if not already done
4264
4265       if not Is_Machine_Code_Subprogram (Subp) then
4266          Set_Is_Machine_Code_Subprogram (Subp);
4267
4268          --  No exception handlers allowed
4269
4270          if Present (Exception_Handlers (HSS)) then
4271             Error_Msg_N
4272               ("exception handlers not permitted in machine code subprogram",
4273                First (Exception_Handlers (HSS)));
4274          end if;
4275
4276          --  No declarations other than use clauses and pragmas (we allow
4277          --  certain internally generated declarations as well).
4278
4279          Decl := First (Declarations (SBody));
4280          while Present (Decl) loop
4281             DeclO := Original_Node (Decl);
4282             if Comes_From_Source (DeclO)
4283               and not Nkind_In (DeclO, N_Pragma,
4284                                        N_Use_Package_Clause,
4285                                        N_Use_Type_Clause,
4286                                        N_Implicit_Label_Declaration)
4287             then
4288                Error_Msg_N
4289                  ("this declaration not allowed in machine code subprogram",
4290                   DeclO);
4291             end if;
4292
4293             Next (Decl);
4294          end loop;
4295
4296          --  No statements other than code statements, pragmas, and labels.
4297          --  Again we allow certain internally generated statements.
4298
4299          --  In Ada 2012, qualified expressions are names, and the code
4300          --  statement is initially parsed as a procedure call.
4301
4302          Stmt := First (Statements (HSS));
4303          while Present (Stmt) loop
4304             StmtO := Original_Node (Stmt);
4305
4306             --  A procedure call transformed into a code statement is OK.
4307
4308             if Ada_Version >= Ada_2012
4309               and then Nkind (StmtO) = N_Procedure_Call_Statement
4310               and then Nkind (Name (StmtO)) = N_Qualified_Expression
4311             then
4312                null;
4313
4314             elsif Comes_From_Source (StmtO)
4315               and then not Nkind_In (StmtO, N_Pragma,
4316                                             N_Label,
4317                                             N_Code_Statement)
4318             then
4319                Error_Msg_N
4320                  ("this statement is not allowed in machine code subprogram",
4321                   StmtO);
4322             end if;
4323
4324             Next (Stmt);
4325          end loop;
4326       end if;
4327    end Analyze_Code_Statement;
4328
4329    -----------------------------------------------
4330    -- Analyze_Enumeration_Representation_Clause --
4331    -----------------------------------------------
4332
4333    procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is
4334       Ident    : constant Node_Id    := Identifier (N);
4335       Aggr     : constant Node_Id    := Array_Aggregate (N);
4336       Enumtype : Entity_Id;
4337       Elit     : Entity_Id;
4338       Expr     : Node_Id;
4339       Assoc    : Node_Id;
4340       Choice   : Node_Id;
4341       Val      : Uint;
4342
4343       Err : Boolean := False;
4344       --  Set True to avoid cascade errors and crashes on incorrect source code
4345
4346       Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer));
4347       Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer));
4348       --  Allowed range of universal integer (= allowed range of enum lit vals)
4349
4350       Min : Uint;
4351       Max : Uint;
4352       --  Minimum and maximum values of entries
4353
4354       Max_Node : Node_Id;
4355       --  Pointer to node for literal providing max value
4356
4357    begin
4358       if Ignore_Rep_Clauses then
4359          return;
4360       end if;
4361
4362       --  Ignore enumeration rep clauses by default in CodePeer mode,
4363       --  unless -gnatd.I is specified, as a work around for potential false
4364       --  positive messages.
4365
4366       if CodePeer_Mode and not Debug_Flag_Dot_II then
4367          return;
4368       end if;
4369
4370       --  First some basic error checks
4371
4372       Find_Type (Ident);
4373       Enumtype := Entity (Ident);
4374
4375       if Enumtype = Any_Type
4376         or else Rep_Item_Too_Early (Enumtype, N)
4377       then
4378          return;
4379       else
4380          Enumtype := Underlying_Type (Enumtype);
4381       end if;
4382
4383       if not Is_Enumeration_Type (Enumtype) then
4384          Error_Msg_NE
4385            ("enumeration type required, found}",
4386             Ident, First_Subtype (Enumtype));
4387          return;
4388       end if;
4389
4390       --  Ignore rep clause on generic actual type. This will already have
4391       --  been flagged on the template as an error, and this is the safest
4392       --  way to ensure we don't get a junk cascaded message in the instance.
4393
4394       if Is_Generic_Actual_Type (Enumtype) then
4395          return;
4396
4397       --  Type must be in current scope
4398
4399       elsif Scope (Enumtype) /= Current_Scope then
4400          Error_Msg_N ("type must be declared in this scope", Ident);
4401          return;
4402
4403       --  Type must be a first subtype
4404
4405       elsif not Is_First_Subtype (Enumtype) then
4406          Error_Msg_N ("cannot give enumeration rep clause for subtype", N);
4407          return;
4408
4409       --  Ignore duplicate rep clause
4410
4411       elsif Has_Enumeration_Rep_Clause (Enumtype) then
4412          Error_Msg_N ("duplicate enumeration rep clause ignored", N);
4413          return;
4414
4415       --  Don't allow rep clause for standard [wide_[wide_]]character
4416
4417       elsif Is_Standard_Character_Type (Enumtype) then
4418          Error_Msg_N ("enumeration rep clause not allowed for this type", N);
4419          return;
4420
4421       --  Check that the expression is a proper aggregate (no parentheses)
4422
4423       elsif Paren_Count (Aggr) /= 0 then
4424          Error_Msg
4425            ("extra parentheses surrounding aggregate not allowed",
4426             First_Sloc (Aggr));
4427          return;
4428
4429       --  All tests passed, so set rep clause in place
4430
4431       else
4432          Set_Has_Enumeration_Rep_Clause (Enumtype);
4433          Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype));
4434       end if;
4435
4436       --  Now we process the aggregate. Note that we don't use the normal
4437       --  aggregate code for this purpose, because we don't want any of the
4438       --  normal expansion activities, and a number of special semantic
4439       --  rules apply (including the component type being any integer type)
4440
4441       Elit := First_Literal (Enumtype);
4442
4443       --  First the positional entries if any
4444
4445       if Present (Expressions (Aggr)) then
4446          Expr := First (Expressions (Aggr));
4447          while Present (Expr) loop
4448             if No (Elit) then
4449                Error_Msg_N ("too many entries in aggregate", Expr);
4450                return;
4451             end if;
4452
4453             Val := Static_Integer (Expr);
4454
4455             --  Err signals that we found some incorrect entries processing
4456             --  the list. The final checks for completeness and ordering are
4457             --  skipped in this case.
4458
4459             if Val = No_Uint then
4460                Err := True;
4461             elsif Val < Lo or else Hi < Val then
4462                Error_Msg_N ("value outside permitted range", Expr);
4463                Err := True;
4464             end if;
4465
4466             Set_Enumeration_Rep (Elit, Val);
4467             Set_Enumeration_Rep_Expr (Elit, Expr);
4468             Next (Expr);
4469             Next (Elit);
4470          end loop;
4471       end if;
4472
4473       --  Now process the named entries if present
4474
4475       if Present (Component_Associations (Aggr)) then
4476          Assoc := First (Component_Associations (Aggr));
4477          while Present (Assoc) loop
4478             Choice := First (Choices (Assoc));
4479
4480             if Present (Next (Choice)) then
4481                Error_Msg_N
4482                  ("multiple choice not allowed here", Next (Choice));
4483                Err := True;
4484             end if;
4485
4486             if Nkind (Choice) = N_Others_Choice then
4487                Error_Msg_N ("others choice not allowed here", Choice);
4488                Err := True;
4489
4490             elsif Nkind (Choice) = N_Range then
4491
4492                --  ??? should allow zero/one element range here
4493
4494                Error_Msg_N ("range not allowed here", Choice);
4495                Err := True;
4496
4497             else
4498                Analyze_And_Resolve (Choice, Enumtype);
4499
4500                if Error_Posted (Choice) then
4501                   Err := True;
4502                end if;
4503
4504                if not Err then
4505                   if Is_Entity_Name (Choice)
4506                     and then Is_Type (Entity (Choice))
4507                   then
4508                      Error_Msg_N ("subtype name not allowed here", Choice);
4509                      Err := True;
4510
4511                      --  ??? should allow static subtype with zero/one entry
4512
4513                   elsif Etype (Choice) = Base_Type (Enumtype) then
4514                      if not Is_Static_Expression (Choice) then
4515                         Flag_Non_Static_Expr
4516                           ("non-static expression used for choice!", Choice);
4517                         Err := True;
4518
4519                      else
4520                         Elit := Expr_Value_E (Choice);
4521
4522                         if Present (Enumeration_Rep_Expr (Elit)) then
4523                            Error_Msg_Sloc :=
4524                              Sloc (Enumeration_Rep_Expr (Elit));
4525                            Error_Msg_NE
4526                              ("representation for& previously given#",
4527                               Choice, Elit);
4528                            Err := True;
4529                         end if;
4530
4531                         Set_Enumeration_Rep_Expr (Elit, Expression (Assoc));
4532
4533                         Expr := Expression (Assoc);
4534                         Val := Static_Integer (Expr);
4535
4536                         if Val = No_Uint then
4537                            Err := True;
4538
4539                         elsif Val < Lo or else Hi < Val then
4540                            Error_Msg_N ("value outside permitted range", Expr);
4541                            Err := True;
4542                         end if;
4543
4544                         Set_Enumeration_Rep (Elit, Val);
4545                      end if;
4546                   end if;
4547                end if;
4548             end if;
4549
4550             Next (Assoc);
4551          end loop;
4552       end if;
4553
4554       --  Aggregate is fully processed. Now we check that a full set of
4555       --  representations was given, and that they are in range and in order.
4556       --  These checks are only done if no other errors occurred.
4557
4558       if not Err then
4559          Min  := No_Uint;
4560          Max  := No_Uint;
4561
4562          Elit := First_Literal (Enumtype);
4563          while Present (Elit) loop
4564             if No (Enumeration_Rep_Expr (Elit)) then
4565                Error_Msg_NE ("missing representation for&!", N, Elit);
4566
4567             else
4568                Val := Enumeration_Rep (Elit);
4569
4570                if Min = No_Uint then
4571                   Min := Val;
4572                end if;
4573
4574                if Val /= No_Uint then
4575                   if Max /= No_Uint and then Val <= Max then
4576                      Error_Msg_NE
4577                        ("enumeration value for& not ordered!",
4578                         Enumeration_Rep_Expr (Elit), Elit);
4579                   end if;
4580
4581                   Max_Node := Enumeration_Rep_Expr (Elit);
4582                   Max := Val;
4583                end if;
4584
4585                --  If there is at least one literal whose representation is not
4586                --  equal to the Pos value, then note that this enumeration type
4587                --  has a non-standard representation.
4588
4589                if Val /= Enumeration_Pos (Elit) then
4590                   Set_Has_Non_Standard_Rep (Base_Type (Enumtype));
4591                end if;
4592             end if;
4593
4594             Next (Elit);
4595          end loop;
4596
4597          --  Now set proper size information
4598
4599          declare
4600             Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype));
4601
4602          begin
4603             if Has_Size_Clause (Enumtype) then
4604
4605                --  All OK, if size is OK now
4606
4607                if RM_Size (Enumtype) >= Minsize then
4608                   null;
4609
4610                else
4611                   --  Try if we can get by with biasing
4612
4613                   Minsize :=
4614                     UI_From_Int (Minimum_Size (Enumtype, Biased => True));
4615
4616                   --  Error message if even biasing does not work
4617
4618                   if RM_Size (Enumtype) < Minsize then
4619                      Error_Msg_Uint_1 := RM_Size (Enumtype);
4620                      Error_Msg_Uint_2 := Max;
4621                      Error_Msg_N
4622                        ("previously given size (^) is too small "
4623                         & "for this value (^)", Max_Node);
4624
4625                   --  If biasing worked, indicate that we now have biased rep
4626
4627                   else
4628                      Set_Biased
4629                        (Enumtype, Size_Clause (Enumtype), "size clause");
4630                   end if;
4631                end if;
4632
4633             else
4634                Set_RM_Size    (Enumtype, Minsize);
4635                Set_Enum_Esize (Enumtype);
4636             end if;
4637
4638             Set_RM_Size   (Base_Type (Enumtype), RM_Size   (Enumtype));
4639             Set_Esize     (Base_Type (Enumtype), Esize     (Enumtype));
4640             Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype));
4641          end;
4642       end if;
4643
4644       --  We repeat the too late test in case it froze itself!
4645
4646       if Rep_Item_Too_Late (Enumtype, N) then
4647          null;
4648       end if;
4649    end Analyze_Enumeration_Representation_Clause;
4650
4651    ----------------------------
4652    -- Analyze_Free_Statement --
4653    ----------------------------
4654
4655    procedure Analyze_Free_Statement (N : Node_Id) is
4656    begin
4657       Analyze (Expression (N));
4658    end Analyze_Free_Statement;
4659
4660    ---------------------------
4661    -- Analyze_Freeze_Entity --
4662    ---------------------------
4663
4664    procedure Analyze_Freeze_Entity (N : Node_Id) is
4665       E : constant Entity_Id := Entity (N);
4666
4667    begin
4668       --  Remember that we are processing a freezing entity. Required to
4669       --  ensure correct decoration of internal entities associated with
4670       --  interfaces (see New_Overloaded_Entity).
4671
4672       Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
4673
4674       --  For tagged types covering interfaces add internal entities that link
4675       --  the primitives of the interfaces with the primitives that cover them.
4676       --  Note: These entities were originally generated only when generating
4677       --  code because their main purpose was to provide support to initialize
4678       --  the secondary dispatch tables. They are now generated also when
4679       --  compiling with no code generation to provide ASIS the relationship
4680       --  between interface primitives and tagged type primitives. They are
4681       --  also used to locate primitives covering interfaces when processing
4682       --  generics (see Derive_Subprograms).
4683
4684       if Ada_Version >= Ada_2005
4685         and then Ekind (E) = E_Record_Type
4686         and then Is_Tagged_Type (E)
4687         and then not Is_Interface (E)
4688         and then Has_Interfaces (E)
4689       then
4690          --  This would be a good common place to call the routine that checks
4691          --  overriding of interface primitives (and thus factorize calls to
4692          --  Check_Abstract_Overriding located at different contexts in the
4693          --  compiler). However, this is not possible because it causes
4694          --  spurious errors in case of late overriding.
4695
4696          Add_Internal_Interface_Entities (E);
4697       end if;
4698
4699       --  Check CPP types
4700
4701       if Ekind (E) = E_Record_Type
4702         and then Is_CPP_Class (E)
4703         and then Is_Tagged_Type (E)
4704         and then Tagged_Type_Expansion
4705         and then Expander_Active
4706       then
4707          if CPP_Num_Prims (E) = 0 then
4708
4709             --  If the CPP type has user defined components then it must import
4710             --  primitives from C++. This is required because if the C++ class
4711             --  has no primitives then the C++ compiler does not added the _tag
4712             --  component to the type.
4713
4714             pragma Assert (Chars (First_Entity (E)) = Name_uTag);
4715
4716             if First_Entity (E) /= Last_Entity (E) then
4717                Error_Msg_N
4718                  ("'C'P'P type must import at least one primitive from C++??",
4719                   E);
4720             end if;
4721          end if;
4722
4723          --  Check that all its primitives are abstract or imported from C++.
4724          --  Check also availability of the C++ constructor.
4725
4726          declare
4727             Has_Constructors : constant Boolean := Has_CPP_Constructors (E);
4728             Elmt             : Elmt_Id;
4729             Error_Reported   : Boolean := False;
4730             Prim             : Node_Id;
4731
4732          begin
4733             Elmt := First_Elmt (Primitive_Operations (E));
4734             while Present (Elmt) loop
4735                Prim := Node (Elmt);
4736
4737                if Comes_From_Source (Prim) then
4738                   if Is_Abstract_Subprogram (Prim) then
4739                      null;
4740
4741                   elsif not Is_Imported (Prim)
4742                     or else Convention (Prim) /= Convention_CPP
4743                   then
4744                      Error_Msg_N
4745                        ("primitives of 'C'P'P types must be imported from C++ "
4746                         & "or abstract??", Prim);
4747
4748                   elsif not Has_Constructors
4749                      and then not Error_Reported
4750                   then
4751                      Error_Msg_Name_1 := Chars (E);
4752                      Error_Msg_N
4753                        ("??'C'P'P constructor required for type %", Prim);
4754                      Error_Reported := True;
4755                   end if;
4756                end if;
4757
4758                Next_Elmt (Elmt);
4759             end loop;
4760          end;
4761       end if;
4762
4763       --  Check Ada derivation of CPP type
4764
4765       if Expander_Active
4766         and then Tagged_Type_Expansion
4767         and then Ekind (E) = E_Record_Type
4768         and then Etype (E) /= E
4769         and then Is_CPP_Class (Etype (E))
4770         and then CPP_Num_Prims (Etype (E)) > 0
4771         and then not Is_CPP_Class (E)
4772         and then not Has_CPP_Constructors (Etype (E))
4773       then
4774          --  If the parent has C++ primitives but it has no constructor then
4775          --  check that all the primitives are overridden in this derivation;
4776          --  otherwise the constructor of the parent is needed to build the
4777          --  dispatch table.
4778
4779          declare
4780             Elmt : Elmt_Id;
4781             Prim : Node_Id;
4782
4783          begin
4784             Elmt := First_Elmt (Primitive_Operations (E));
4785             while Present (Elmt) loop
4786                Prim := Node (Elmt);
4787
4788                if not Is_Abstract_Subprogram (Prim)
4789                  and then No (Interface_Alias (Prim))
4790                  and then Find_Dispatching_Type (Ultimate_Alias (Prim)) /= E
4791                then
4792                   Error_Msg_Name_1 := Chars (Etype (E));
4793                   Error_Msg_N
4794                     ("'C'P'P constructor required for parent type %", E);
4795                   exit;
4796                end if;
4797
4798                Next_Elmt (Elmt);
4799             end loop;
4800          end;
4801       end if;
4802
4803       Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
4804
4805       --  If we have a type with predicates, build predicate function
4806
4807       if Is_Type (E) and then Has_Predicates (E) then
4808          Build_Predicate_Functions (E, N);
4809       end if;
4810
4811       --  If type has delayed aspects, this is where we do the preanalysis at
4812       --  the freeze point, as part of the consistent visibility check. Note
4813       --  that this must be done after calling Build_Predicate_Functions or
4814       --  Build_Invariant_Procedure since these subprograms fix occurrences of
4815       --  the subtype name in the saved expression so that they will not cause
4816       --  trouble in the preanalysis.
4817
4818       if Has_Delayed_Aspects (E)
4819         and then Scope (E) = Current_Scope
4820       then
4821          --  Retrieve the visibility to the discriminants in order to properly
4822          --  analyze the aspects.
4823
4824          Push_Scope_And_Install_Discriminants (E);
4825
4826          declare
4827             Ritem : Node_Id;
4828
4829          begin
4830             --  Look for aspect specification entries for this entity
4831
4832             Ritem := First_Rep_Item (E);
4833             while Present (Ritem) loop
4834                if Nkind (Ritem) = N_Aspect_Specification
4835                  and then Entity (Ritem) = E
4836                  and then Is_Delayed_Aspect (Ritem)
4837                then
4838                   Check_Aspect_At_Freeze_Point (Ritem);
4839                end if;
4840
4841                Next_Rep_Item (Ritem);
4842             end loop;
4843          end;
4844
4845          Uninstall_Discriminants_And_Pop_Scope (E);
4846       end if;
4847    end Analyze_Freeze_Entity;
4848
4849    ------------------------------------------
4850    -- Analyze_Record_Representation_Clause --
4851    ------------------------------------------
4852
4853    --  Note: we check as much as we can here, but we can't do any checks
4854    --  based on the position values (e.g. overlap checks) until freeze time
4855    --  because especially in Ada 2005 (machine scalar mode), the processing
4856    --  for non-standard bit order can substantially change the positions.
4857    --  See procedure Check_Record_Representation_Clause (called from Freeze)
4858    --  for the remainder of this processing.
4859
4860    procedure Analyze_Record_Representation_Clause (N : Node_Id) is
4861       Ident   : constant Node_Id := Identifier (N);
4862       Biased  : Boolean;
4863       CC      : Node_Id;
4864       Comp    : Entity_Id;
4865       Fbit    : Uint;
4866       Hbit    : Uint := Uint_0;
4867       Lbit    : Uint;
4868       Ocomp   : Entity_Id;
4869       Posit   : Uint;
4870       Rectype : Entity_Id;
4871       Recdef  : Node_Id;
4872
4873       function Is_Inherited (Comp : Entity_Id) return Boolean;
4874       --  True if Comp is an inherited component in a record extension
4875
4876       ------------------
4877       -- Is_Inherited --
4878       ------------------
4879
4880       function Is_Inherited (Comp : Entity_Id) return Boolean is
4881          Comp_Base : Entity_Id;
4882
4883       begin
4884          if Ekind (Rectype) = E_Record_Subtype then
4885             Comp_Base := Original_Record_Component (Comp);
4886          else
4887             Comp_Base := Comp;
4888          end if;
4889
4890          return Comp_Base /= Original_Record_Component (Comp_Base);
4891       end Is_Inherited;
4892
4893       --  Local variables
4894
4895       Is_Record_Extension : Boolean;
4896       --  True if Rectype is a record extension
4897
4898       CR_Pragma : Node_Id := Empty;
4899       --  Points to N_Pragma node if Complete_Representation pragma present
4900
4901    --  Start of processing for Analyze_Record_Representation_Clause
4902
4903    begin
4904       if Ignore_Rep_Clauses then
4905          return;
4906       end if;
4907
4908       Find_Type (Ident);
4909       Rectype := Entity (Ident);
4910
4911       if Rectype = Any_Type or else Rep_Item_Too_Early (Rectype, N) then
4912          return;
4913       else
4914          Rectype := Underlying_Type (Rectype);
4915       end if;
4916
4917       --  First some basic error checks
4918
4919       if not Is_Record_Type (Rectype) then
4920          Error_Msg_NE
4921            ("record type required, found}", Ident, First_Subtype (Rectype));
4922          return;
4923
4924       elsif Scope (Rectype) /= Current_Scope then
4925          Error_Msg_N ("type must be declared in this scope", N);
4926          return;
4927
4928       elsif not Is_First_Subtype (Rectype) then
4929          Error_Msg_N ("cannot give record rep clause for subtype", N);
4930          return;
4931
4932       elsif Has_Record_Rep_Clause (Rectype) then
4933          Error_Msg_N ("duplicate record rep clause ignored", N);
4934          return;
4935
4936       elsif Rep_Item_Too_Late (Rectype, N) then
4937          return;
4938       end if;
4939
4940       --  We know we have a first subtype, now possibly go the the anonymous
4941       --  base type to determine whether Rectype is a record extension.
4942
4943       Recdef := Type_Definition (Declaration_Node (Base_Type (Rectype)));
4944       Is_Record_Extension :=
4945         Nkind (Recdef) = N_Derived_Type_Definition
4946           and then Present (Record_Extension_Part (Recdef));
4947
4948       if Present (Mod_Clause (N)) then
4949          declare
4950             Loc     : constant Source_Ptr := Sloc (N);
4951             M       : constant Node_Id := Mod_Clause (N);
4952             P       : constant List_Id := Pragmas_Before (M);
4953             AtM_Nod : Node_Id;
4954
4955             Mod_Val : Uint;
4956             pragma Warnings (Off, Mod_Val);
4957
4958          begin
4959             Check_Restriction (No_Obsolescent_Features, Mod_Clause (N));
4960
4961             if Warn_On_Obsolescent_Feature then
4962                Error_Msg_N
4963                  ("?j?mod clause is an obsolescent feature (RM J.8)", N);
4964                Error_Msg_N
4965                  ("\?j?use alignment attribute definition clause instead", N);
4966             end if;
4967
4968             if Present (P) then
4969                Analyze_List (P);
4970             end if;
4971
4972             --  In ASIS_Mode mode, expansion is disabled, but we must convert
4973             --  the Mod clause into an alignment clause anyway, so that the
4974             --  back-end can compute and back-annotate properly the size and
4975             --  alignment of types that may include this record.
4976
4977             --  This seems dubious, this destroys the source tree in a manner
4978             --  not detectable by ASIS ???
4979
4980             if Operating_Mode = Check_Semantics and then ASIS_Mode then
4981                AtM_Nod :=
4982                  Make_Attribute_Definition_Clause (Loc,
4983                    Name       => New_Reference_To (Base_Type (Rectype), Loc),
4984                    Chars      => Name_Alignment,
4985                    Expression => Relocate_Node (Expression (M)));
4986
4987                Set_From_At_Mod (AtM_Nod);
4988                Insert_After (N, AtM_Nod);
4989                Mod_Val := Get_Alignment_Value (Expression (AtM_Nod));
4990                Set_Mod_Clause (N, Empty);
4991
4992             else
4993                --  Get the alignment value to perform error checking
4994
4995                Mod_Val := Get_Alignment_Value (Expression (M));
4996             end if;
4997          end;
4998       end if;
4999
5000       --  For untagged types, clear any existing component clauses for the
5001       --  type. If the type is derived, this is what allows us to override
5002       --  a rep clause for the parent. For type extensions, the representation
5003       --  of the inherited components is inherited, so we want to keep previous
5004       --  component clauses for completeness.
5005
5006       if not Is_Tagged_Type (Rectype) then
5007          Comp := First_Component_Or_Discriminant (Rectype);
5008          while Present (Comp) loop
5009             Set_Component_Clause (Comp, Empty);
5010             Next_Component_Or_Discriminant (Comp);
5011          end loop;
5012       end if;
5013
5014       --  All done if no component clauses
5015
5016       CC := First (Component_Clauses (N));
5017
5018       if No (CC) then
5019          return;
5020       end if;
5021
5022       --  A representation like this applies to the base type
5023
5024       Set_Has_Record_Rep_Clause (Base_Type (Rectype));
5025       Set_Has_Non_Standard_Rep  (Base_Type (Rectype));
5026       Set_Has_Specified_Layout  (Base_Type (Rectype));
5027
5028       --  Process the component clauses
5029
5030       while Present (CC) loop
5031
5032          --  Pragma
5033
5034          if Nkind (CC) = N_Pragma then
5035             Analyze (CC);
5036
5037             --  The only pragma of interest is Complete_Representation
5038
5039             if Pragma_Name (CC) = Name_Complete_Representation then
5040                CR_Pragma := CC;
5041             end if;
5042
5043          --  Processing for real component clause
5044
5045          else
5046             Posit := Static_Integer (Position  (CC));
5047             Fbit  := Static_Integer (First_Bit (CC));
5048             Lbit  := Static_Integer (Last_Bit  (CC));
5049
5050             if Posit /= No_Uint
5051               and then Fbit /= No_Uint
5052               and then Lbit /= No_Uint
5053             then
5054                if Posit < 0 then
5055                   Error_Msg_N
5056                     ("position cannot be negative", Position (CC));
5057
5058                elsif Fbit < 0 then
5059                   Error_Msg_N
5060                     ("first bit cannot be negative", First_Bit (CC));
5061
5062                --  The Last_Bit specified in a component clause must not be
5063                --  less than the First_Bit minus one (RM-13.5.1(10)).
5064
5065                elsif Lbit < Fbit - 1 then
5066                   Error_Msg_N
5067                     ("last bit cannot be less than first bit minus one",
5068                      Last_Bit (CC));
5069
5070                --  Values look OK, so find the corresponding record component
5071                --  Even though the syntax allows an attribute reference for
5072                --  implementation-defined components, GNAT does not allow the
5073                --  tag to get an explicit position.
5074
5075                elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then
5076                   if Attribute_Name (Component_Name (CC)) = Name_Tag then
5077                      Error_Msg_N ("position of tag cannot be specified", CC);
5078                   else
5079                      Error_Msg_N ("illegal component name", CC);
5080                   end if;
5081
5082                else
5083                   Comp := First_Entity (Rectype);
5084                   while Present (Comp) loop
5085                      exit when Chars (Comp) = Chars (Component_Name (CC));
5086                      Next_Entity (Comp);
5087                   end loop;
5088
5089                   if No (Comp) then
5090
5091                      --  Maybe component of base type that is absent from
5092                      --  statically constrained first subtype.
5093
5094                      Comp := First_Entity (Base_Type (Rectype));
5095                      while Present (Comp) loop
5096                         exit when Chars (Comp) = Chars (Component_Name (CC));
5097                         Next_Entity (Comp);
5098                      end loop;
5099                   end if;
5100
5101                   if No (Comp) then
5102                      Error_Msg_N
5103                        ("component clause is for non-existent field", CC);
5104
5105                   --  Ada 2012 (AI05-0026): Any name that denotes a
5106                   --  discriminant of an object of an unchecked union type
5107                   --  shall not occur within a record_representation_clause.
5108
5109                   --  The general restriction of using record rep clauses on
5110                   --  Unchecked_Union types has now been lifted. Since it is
5111                   --  possible to introduce a record rep clause which mentions
5112                   --  the discriminant of an Unchecked_Union in non-Ada 2012
5113                   --  code, this check is applied to all versions of the
5114                   --  language.
5115
5116                   elsif Ekind (Comp) = E_Discriminant
5117                     and then Is_Unchecked_Union (Rectype)
5118                   then
5119                      Error_Msg_N
5120                        ("cannot reference discriminant of unchecked union",
5121                         Component_Name (CC));
5122
5123                   elsif Is_Record_Extension and then Is_Inherited (Comp) then
5124                      Error_Msg_NE
5125                        ("component clause not allowed for inherited "
5126                         & "component&", CC, Comp);
5127
5128                   elsif Present (Component_Clause (Comp)) then
5129
5130                      --  Diagnose duplicate rep clause, or check consistency
5131                      --  if this is an inherited component. In a double fault,
5132                      --  there may be a duplicate inconsistent clause for an
5133                      --  inherited component.
5134
5135                      if Scope (Original_Record_Component (Comp)) = Rectype
5136                        or else Parent (Component_Clause (Comp)) = N
5137                      then
5138                         Error_Msg_Sloc := Sloc (Component_Clause (Comp));
5139                         Error_Msg_N ("component clause previously given#", CC);
5140
5141                      else
5142                         declare
5143                            Rep1 : constant Node_Id := Component_Clause (Comp);
5144                         begin
5145                            if Intval (Position (Rep1)) /=
5146                                                    Intval (Position (CC))
5147                              or else Intval (First_Bit (Rep1)) /=
5148                                                    Intval (First_Bit (CC))
5149                              or else Intval (Last_Bit (Rep1)) /=
5150                                                    Intval (Last_Bit (CC))
5151                            then
5152                               Error_Msg_N
5153                                 ("component clause inconsistent "
5154                                  & "with representation of ancestor", CC);
5155
5156                            elsif Warn_On_Redundant_Constructs then
5157                               Error_Msg_N
5158                                 ("?r?redundant confirming component clause "
5159                                  & "for component!", CC);
5160                            end if;
5161                         end;
5162                      end if;
5163
5164                   --  Normal case where this is the first component clause we
5165                   --  have seen for this entity, so set it up properly.
5166
5167                   else
5168                      --  Make reference for field in record rep clause and set
5169                      --  appropriate entity field in the field identifier.
5170
5171                      Generate_Reference
5172                        (Comp, Component_Name (CC), Set_Ref => False);
5173                      Set_Entity (Component_Name (CC), Comp);
5174
5175                      --  Update Fbit and Lbit to the actual bit number
5176
5177                      Fbit := Fbit + UI_From_Int (SSU) * Posit;
5178                      Lbit := Lbit + UI_From_Int (SSU) * Posit;
5179
5180                      if Has_Size_Clause (Rectype)
5181                        and then RM_Size (Rectype) <= Lbit
5182                      then
5183                         Error_Msg_N
5184                           ("bit number out of range of specified size",
5185                            Last_Bit (CC));
5186                      else
5187                         Set_Component_Clause     (Comp, CC);
5188                         Set_Component_Bit_Offset (Comp, Fbit);
5189                         Set_Esize                (Comp, 1 + (Lbit - Fbit));
5190                         Set_Normalized_First_Bit (Comp, Fbit mod SSU);
5191                         Set_Normalized_Position  (Comp, Fbit / SSU);
5192
5193                         if Warn_On_Overridden_Size
5194                           and then Has_Size_Clause (Etype (Comp))
5195                           and then RM_Size (Etype (Comp)) /= Esize (Comp)
5196                         then
5197                            Error_Msg_NE
5198                              ("?S?component size overrides size clause for&",
5199                               Component_Name (CC), Etype (Comp));
5200                         end if;
5201
5202                         --  This information is also set in the corresponding
5203                         --  component of the base type, found by accessing the
5204                         --  Original_Record_Component link if it is present.
5205
5206                         Ocomp := Original_Record_Component (Comp);
5207
5208                         if Hbit < Lbit then
5209                            Hbit := Lbit;
5210                         end if;
5211
5212                         Check_Size
5213                           (Component_Name (CC),
5214                            Etype (Comp),
5215                            Esize (Comp),
5216                            Biased);
5217
5218                         Set_Biased
5219                           (Comp, First_Node (CC), "component clause", Biased);
5220
5221                         if Present (Ocomp) then
5222                            Set_Component_Clause     (Ocomp, CC);
5223                            Set_Component_Bit_Offset (Ocomp, Fbit);
5224                            Set_Normalized_First_Bit (Ocomp, Fbit mod SSU);
5225                            Set_Normalized_Position  (Ocomp, Fbit / SSU);
5226                            Set_Esize                (Ocomp, 1 + (Lbit - Fbit));
5227
5228                            Set_Normalized_Position_Max
5229                              (Ocomp, Normalized_Position (Ocomp));
5230
5231                            --  Note: we don't use Set_Biased here, because we
5232                            --  already gave a warning above if needed, and we
5233                            --  would get a duplicate for the same name here.
5234
5235                            Set_Has_Biased_Representation
5236                              (Ocomp, Has_Biased_Representation (Comp));
5237                         end if;
5238
5239                         if Esize (Comp) < 0 then
5240                            Error_Msg_N ("component size is negative", CC);
5241                         end if;
5242                      end if;
5243                   end if;
5244                end if;
5245             end if;
5246          end if;
5247
5248          Next (CC);
5249       end loop;
5250
5251       --  Check missing components if Complete_Representation pragma appeared
5252
5253       if Present (CR_Pragma) then
5254          Comp := First_Component_Or_Discriminant (Rectype);
5255          while Present (Comp) loop
5256             if No (Component_Clause (Comp)) then
5257                Error_Msg_NE
5258                  ("missing component clause for &", CR_Pragma, Comp);
5259             end if;
5260
5261             Next_Component_Or_Discriminant (Comp);
5262          end loop;
5263
5264       --  Give missing components warning if required
5265
5266       elsif Warn_On_Unrepped_Components then
5267          declare
5268             Num_Repped_Components   : Nat := 0;
5269             Num_Unrepped_Components : Nat := 0;
5270
5271          begin
5272             --  First count number of repped and unrepped components
5273
5274             Comp := First_Component_Or_Discriminant (Rectype);
5275             while Present (Comp) loop
5276                if Present (Component_Clause (Comp)) then
5277                   Num_Repped_Components := Num_Repped_Components + 1;
5278                else
5279                   Num_Unrepped_Components := Num_Unrepped_Components + 1;
5280                end if;
5281
5282                Next_Component_Or_Discriminant (Comp);
5283             end loop;
5284
5285             --  We are only interested in the case where there is at least one
5286             --  unrepped component, and at least half the components have rep
5287             --  clauses. We figure that if less than half have them, then the
5288             --  partial rep clause is really intentional. If the component
5289             --  type has no underlying type set at this point (as for a generic
5290             --  formal type), we don't know enough to give a warning on the
5291             --  component.
5292
5293             if Num_Unrepped_Components > 0
5294               and then Num_Unrepped_Components < Num_Repped_Components
5295             then
5296                Comp := First_Component_Or_Discriminant (Rectype);
5297                while Present (Comp) loop
5298                   if No (Component_Clause (Comp))
5299                     and then Comes_From_Source (Comp)
5300                     and then Present (Underlying_Type (Etype (Comp)))
5301                     and then (Is_Scalar_Type (Underlying_Type (Etype (Comp)))
5302                                or else Size_Known_At_Compile_Time
5303                                          (Underlying_Type (Etype (Comp))))
5304                     and then not Has_Warnings_Off (Rectype)
5305                   then
5306                      Error_Msg_Sloc := Sloc (Comp);
5307                      Error_Msg_NE
5308                        ("?C?no component clause given for & declared #",
5309                         N, Comp);
5310                   end if;
5311
5312                   Next_Component_Or_Discriminant (Comp);
5313                end loop;
5314             end if;
5315          end;
5316       end if;
5317    end Analyze_Record_Representation_Clause;
5318
5319    -------------------------------------------
5320    -- Build_Invariant_Procedure_Declaration --
5321    -------------------------------------------
5322
5323    function Build_Invariant_Procedure_Declaration
5324      (Typ : Entity_Id) return Node_Id
5325    is
5326       Loc           : constant Source_Ptr := Sloc (Typ);
5327       Object_Entity : constant Entity_Id :=
5328         Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
5329       Spec          : Node_Id;
5330       SId           : Entity_Id;
5331
5332    begin
5333       Set_Etype (Object_Entity, Typ);
5334
5335       --  Check for duplicate definiations.
5336
5337       if Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)) then
5338          return Empty;
5339       end if;
5340
5341       SId :=
5342         Make_Defining_Identifier (Loc,
5343           Chars => New_External_Name (Chars (Typ), "Invariant"));
5344       Set_Has_Invariants (Typ);
5345       Set_Ekind (SId, E_Procedure);
5346       Set_Is_Invariant_Procedure (SId);
5347       Set_Invariant_Procedure (Typ, SId);
5348
5349       Spec :=
5350         Make_Procedure_Specification (Loc,
5351           Defining_Unit_Name       => SId,
5352           Parameter_Specifications => New_List (
5353             Make_Parameter_Specification (Loc,
5354               Defining_Identifier => Object_Entity,
5355               Parameter_Type      => New_Occurrence_Of (Typ, Loc))));
5356
5357       return Make_Subprogram_Declaration (Loc, Specification => Spec);
5358    end Build_Invariant_Procedure_Declaration;
5359
5360    -------------------------------
5361    -- Build_Invariant_Procedure --
5362    -------------------------------
5363
5364    --  The procedure that is constructed here has the form
5365
5366    --  procedure typInvariant (Ixxx : typ) is
5367    --  begin
5368    --     pragma Check (Invariant, exp, "failed invariant from xxx");
5369    --     pragma Check (Invariant, exp, "failed invariant from xxx");
5370    --     ...
5371    --     pragma Check (Invariant, exp, "failed inherited invariant from xxx");
5372    --     ...
5373    --  end typInvariant;
5374
5375    procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is
5376       Loc   : constant Source_Ptr := Sloc (Typ);
5377       Stmts : List_Id;
5378       Spec  : Node_Id;
5379       SId   : Entity_Id;
5380       PDecl : Node_Id;
5381       PBody : Node_Id;
5382
5383       Visible_Decls : constant List_Id := Visible_Declarations (N);
5384       Private_Decls : constant List_Id := Private_Declarations (N);
5385
5386       procedure Add_Invariants (T : Entity_Id; Inherit : Boolean);
5387       --  Appends statements to Stmts for any invariants in the rep item chain
5388       --  of the given type. If Inherit is False, then we only process entries
5389       --  on the chain for the type Typ. If Inherit is True, then we ignore any
5390       --  Invariant aspects, but we process all Invariant'Class aspects, adding
5391       --  "inherited" to the exception message and generating an informational
5392       --  message about the inheritance of an invariant.
5393
5394       Object_Name : Name_Id;
5395       --  Name for argument of invariant procedure
5396
5397       Object_Entity : Node_Id;
5398       --  The entity of the formal for the procedure
5399
5400       --------------------
5401       -- Add_Invariants --
5402       --------------------
5403
5404       procedure Add_Invariants (T : Entity_Id; Inherit : Boolean) is
5405          Ritem : Node_Id;
5406          Arg1  : Node_Id;
5407          Arg2  : Node_Id;
5408          Arg3  : Node_Id;
5409          Exp   : Node_Id;
5410          Loc   : Source_Ptr;
5411          Assoc : List_Id;
5412          Str   : String_Id;
5413
5414          procedure Replace_Type_Reference (N : Node_Id);
5415          --  Replace a single occurrence N of the subtype name with a reference
5416          --  to the formal of the predicate function. N can be an identifier
5417          --  referencing the subtype, or a selected component, representing an
5418          --  appropriately qualified occurrence of the subtype name.
5419
5420          procedure Replace_Type_References is
5421            new Replace_Type_References_Generic (Replace_Type_Reference);
5422          --  Traverse an expression replacing all occurrences of the subtype
5423          --  name with appropriate references to the object that is the formal
5424          --  parameter of the predicate function. Note that we must ensure
5425          --  that the type and entity information is properly set in the
5426          --  replacement node, since we will do a Preanalyze call of this
5427          --  expression without proper visibility of the procedure argument.
5428
5429          ----------------------------
5430          -- Replace_Type_Reference --
5431          ----------------------------
5432
5433          --  Note: See comments in Add_Predicates.Replace_Type_Reference
5434          --  regarding handling of Sloc and Comes_From_Source.
5435
5436          procedure Replace_Type_Reference (N : Node_Id) is
5437          begin
5438             --  Invariant'Class, replace with T'Class (obj)
5439
5440             if Class_Present (Ritem) then
5441                Rewrite (N,
5442                  Make_Type_Conversion (Sloc (N),
5443                    Subtype_Mark =>
5444                      Make_Attribute_Reference (Sloc (N),
5445                        Prefix         => New_Occurrence_Of (T, Sloc (N)),
5446                        Attribute_Name => Name_Class),
5447                    Expression   => Make_Identifier (Sloc (N), Object_Name)));
5448
5449                Set_Entity (Expression (N), Object_Entity);
5450                Set_Etype  (Expression (N), Typ);
5451
5452             --  Invariant, replace with obj
5453
5454             else
5455                Rewrite (N, Make_Identifier (Sloc (N), Object_Name));
5456                Set_Entity (N, Object_Entity);
5457                Set_Etype  (N, Typ);
5458             end if;
5459
5460             Set_Comes_From_Source (N, True);
5461          end Replace_Type_Reference;
5462
5463       --  Start of processing for Add_Invariants
5464
5465       begin
5466          Ritem := First_Rep_Item (T);
5467          while Present (Ritem) loop
5468             if Nkind (Ritem) = N_Pragma
5469               and then Pragma_Name (Ritem) = Name_Invariant
5470             then
5471                Arg1 := First (Pragma_Argument_Associations (Ritem));
5472                Arg2 := Next (Arg1);
5473                Arg3 := Next (Arg2);
5474
5475                Arg1 := Get_Pragma_Arg (Arg1);
5476                Arg2 := Get_Pragma_Arg (Arg2);
5477
5478                --  For Inherit case, ignore Invariant, process only Class case
5479
5480                if Inherit then
5481                   if not Class_Present (Ritem) then
5482                      goto Continue;
5483                   end if;
5484
5485                --  For Inherit false, process only item for right type
5486
5487                else
5488                   if Entity (Arg1) /= Typ then
5489                      goto Continue;
5490                   end if;
5491                end if;
5492
5493                if No (Stmts) then
5494                   Stmts := Empty_List;
5495                end if;
5496
5497                Exp := New_Copy_Tree (Arg2);
5498
5499                --  Preserve sloc of original pragma Invariant
5500
5501                Loc := Sloc (Ritem);
5502
5503                --  We need to replace any occurrences of the name of the type
5504                --  with references to the object, converted to type'Class in
5505                --  the case of Invariant'Class aspects.
5506
5507                Replace_Type_References (Exp, Chars (T));
5508
5509                --  If this invariant comes from an aspect, find the aspect
5510                --  specification, and replace the saved expression because
5511                --  we need the subtype references replaced for the calls to
5512                --  Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point
5513                --  and Check_Aspect_At_End_Of_Declarations.
5514
5515                if From_Aspect_Specification (Ritem) then
5516                   declare
5517                      Aitem : Node_Id;
5518
5519                   begin
5520                      --  Loop to find corresponding aspect, note that this
5521                      --  must be present given the pragma is marked delayed.
5522
5523                      Aitem := Next_Rep_Item (Ritem);
5524                      while Present (Aitem) loop
5525                         if Nkind (Aitem) = N_Aspect_Specification
5526                           and then Aspect_Rep_Item (Aitem) = Ritem
5527                         then
5528                            Set_Entity
5529                              (Identifier (Aitem), New_Copy_Tree (Exp));
5530                            exit;
5531                         end if;
5532
5533                         Aitem := Next_Rep_Item (Aitem);
5534                      end loop;
5535                   end;
5536                end if;
5537
5538                --  Now we need to preanalyze the expression to properly capture
5539                --  the visibility in the visible part. The expression will not
5540                --  be analyzed for real until the body is analyzed, but that is
5541                --  at the end of the private part and has the wrong visibility.
5542
5543                Set_Parent (Exp, N);
5544                Preanalyze_Assert_Expression (Exp, Standard_Boolean);
5545
5546                --  Build first two arguments for Check pragma
5547
5548                Assoc := New_List (
5549                  Make_Pragma_Argument_Association (Loc,
5550                    Expression => Make_Identifier (Loc, Name_Invariant)),
5551                  Make_Pragma_Argument_Association (Loc,
5552                    Expression => Exp));
5553
5554                --  Add message if present in Invariant pragma
5555
5556                if Present (Arg3) then
5557                   Str := Strval (Get_Pragma_Arg (Arg3));
5558
5559                   --  If inherited case, and message starts "failed invariant",
5560                   --  change it to be "failed inherited invariant".
5561
5562                   if Inherit then
5563                      String_To_Name_Buffer (Str);
5564
5565                      if Name_Buffer (1 .. 16) = "failed invariant" then
5566                         Insert_Str_In_Name_Buffer ("inherited ", 8);
5567                         Str := String_From_Name_Buffer;
5568                      end if;
5569                   end if;
5570
5571                   Append_To (Assoc,
5572                     Make_Pragma_Argument_Association (Loc,
5573                       Expression => Make_String_Literal (Loc, Str)));
5574                end if;
5575
5576                --  Add Check pragma to list of statements
5577
5578                Append_To (Stmts,
5579                  Make_Pragma (Loc,
5580                    Pragma_Identifier            =>
5581                      Make_Identifier (Loc, Name_Check),
5582                    Pragma_Argument_Associations => Assoc));
5583
5584                --  If Inherited case and option enabled, output info msg. Note
5585                --  that we know this is a case of Invariant'Class.
5586
5587                if Inherit and Opt.List_Inherited_Aspects then
5588                   Error_Msg_Sloc := Sloc (Ritem);
5589                   Error_Msg_N
5590                     ("?L?info: & inherits `Invariant''Class` aspect from #",
5591                      Typ);
5592                end if;
5593             end if;
5594
5595          <<Continue>>
5596             Next_Rep_Item (Ritem);
5597          end loop;
5598       end Add_Invariants;
5599
5600    --  Start of processing for Build_Invariant_Procedure
5601
5602    begin
5603       Stmts := No_List;
5604       PDecl := Empty;
5605       PBody := Empty;
5606       SId   := Empty;
5607
5608       --  If the aspect specification exists for some view of the type, the
5609       --  declaration for the procedure has been created.
5610
5611       if Has_Invariants (Typ) then
5612          SId := Invariant_Procedure (Typ);
5613       end if;
5614
5615       if Present (SId) then
5616          PDecl := Unit_Declaration_Node (SId);
5617
5618       else
5619          PDecl := Build_Invariant_Procedure_Declaration (Typ);
5620       end if;
5621
5622       --  Recover formal of procedure, for use in the calls to invariant
5623       --  functions (including inherited ones).
5624
5625       Object_Entity :=
5626         Defining_Identifier
5627           (First (Parameter_Specifications (Specification (PDecl))));
5628       Object_Name := Chars (Object_Entity);
5629
5630       --  Add invariants for the current type
5631
5632       Add_Invariants (Typ, Inherit => False);
5633
5634       --  Add invariants for parent types
5635
5636       declare
5637          Current_Typ : Entity_Id;
5638          Parent_Typ  : Entity_Id;
5639
5640       begin
5641          Current_Typ := Typ;
5642          loop
5643             Parent_Typ := Etype (Current_Typ);
5644
5645             if Is_Private_Type (Parent_Typ)
5646               and then Present (Full_View (Base_Type (Parent_Typ)))
5647             then
5648                Parent_Typ := Full_View (Base_Type (Parent_Typ));
5649             end if;
5650
5651             exit when Parent_Typ = Current_Typ;
5652
5653             Current_Typ := Parent_Typ;
5654             Add_Invariants (Current_Typ, Inherit => True);
5655          end loop;
5656       end;
5657
5658       --  Build the procedure if we generated at least one Check pragma
5659
5660       if Stmts /= No_List then
5661          Spec  := Copy_Separate_Tree (Specification (PDecl));
5662
5663          PBody :=
5664            Make_Subprogram_Body (Loc,
5665              Specification              => Spec,
5666              Declarations               => Empty_List,
5667              Handled_Statement_Sequence =>
5668                Make_Handled_Sequence_Of_Statements (Loc,
5669                  Statements => Stmts));
5670
5671          --  Insert procedure declaration and spec at the appropriate points.
5672          --  If declaration is already analyzed, it was processed by the
5673          --  generated pragma.
5674
5675          if Present (Private_Decls) then
5676
5677             --  The spec goes at the end of visible declarations, but they have
5678             --  already been analyzed, so we need to explicitly do the analyze.
5679
5680             if not Analyzed (PDecl) then
5681                Append_To (Visible_Decls, PDecl);
5682                Analyze (PDecl);
5683             end if;
5684
5685             --  The body goes at the end of the private declarations, which we
5686             --  have not analyzed yet, so we do not need to perform an explicit
5687             --  analyze call. We skip this if there are no private declarations
5688             --  (this is an error that will be caught elsewhere);
5689
5690             Append_To (Private_Decls, PBody);
5691
5692             --  If the invariant appears on the full view of a type, the
5693             --  analysis of the private part is complete, and we must
5694             --  analyze the new body explicitly.
5695
5696             if In_Private_Part (Current_Scope) then
5697                Analyze (PBody);
5698             end if;
5699
5700          --  If there are no private declarations this may be an error that
5701          --  will be diagnosed elsewhere. However, if this is a non-private
5702          --  type that inherits invariants, it needs no completion and there
5703          --  may be no private part. In this case insert invariant procedure
5704          --  at end of current declarative list, and analyze at once, given
5705          --  that the type is about to be frozen.
5706
5707          elsif not Is_Private_Type (Typ) then
5708             Append_To (Visible_Decls, PDecl);
5709             Append_To (Visible_Decls, PBody);
5710             Analyze (PDecl);
5711             Analyze (PBody);
5712          end if;
5713       end if;
5714    end Build_Invariant_Procedure;
5715
5716    -------------------------------
5717    -- Build_Predicate_Functions --
5718    -------------------------------
5719
5720    --  The procedures that are constructed here have the form:
5721
5722    --    function typPredicate (Ixxx : typ) return Boolean is
5723    --    begin
5724    --       return
5725    --          exp1 and then exp2 and then ...
5726    --          and then typ1Predicate (typ1 (Ixxx))
5727    --          and then typ2Predicate (typ2 (Ixxx))
5728    --          and then ...;
5729    --    end typPredicate;
5730
5731    --  Here exp1, and exp2 are expressions from Predicate pragmas. Note that
5732    --  this is the point at which these expressions get analyzed, providing the
5733    --  required delay, and typ1, typ2, are entities from which predicates are
5734    --  inherited. Note that we do NOT generate Check pragmas, that's because we
5735    --  use this function even if checks are off, e.g. for membership tests.
5736
5737    --  If the expression has at least one Raise_Expression, then we also build
5738    --  the typPredicateM version of the function, in which any occurrence of a
5739    --  Raise_Expression is converted to "return False".
5740
5741    procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is
5742       Loc : constant Source_Ptr := Sloc (Typ);
5743
5744       Expr : Node_Id;
5745       --  This is the expression for the result of the function. It is
5746       --  is build by connecting the component predicates with AND THEN.
5747
5748       Expr_M : Node_Id;
5749       --  This is the corresponding return expression for the Predicate_M
5750       --  function. It differs in that raise expressions are marked for
5751       --  special expansion (see Process_REs).
5752
5753       Object_Name : constant Name_Id := New_Internal_Name ('I');
5754       --  Name for argument of Predicate procedure. Note that we use the same
5755       --  name for both predicate procedure. That way the reference within the
5756       --  predicate expression is the same in both functions.
5757
5758       Object_Entity : constant Entity_Id :=
5759                         Make_Defining_Identifier (Loc, Chars => Object_Name);
5760       --  Entity for argument of Predicate procedure
5761
5762       Object_Entity_M : constant Entity_Id :=
5763                          Make_Defining_Identifier (Loc, Chars => Object_Name);
5764       --  Entity for argument of Predicate_M procedure
5765
5766       Raise_Expression_Present : Boolean := False;
5767       --  Set True if Expr has at least one Raise_Expression
5768
5769       Static_Predic : Node_Id := Empty;
5770       --  Set to N_Pragma node for a static predicate if one is encountered
5771
5772       procedure Add_Call (T : Entity_Id);
5773       --  Includes a call to the predicate function for type T in Expr if T
5774       --  has predicates and Predicate_Function (T) is non-empty.
5775
5776       procedure Add_Predicates;
5777       --  Appends expressions for any Predicate pragmas in the rep item chain
5778       --  Typ to Expr. Note that we look only at items for this exact entity.
5779       --  Inheritance of predicates for the parent type is done by calling the
5780       --  Predicate_Function of the parent type, using Add_Call above.
5781
5782       function Test_RE (N : Node_Id) return Traverse_Result;
5783       --  Used in Test_REs, tests one node for being a raise expression, and if
5784       --  so sets Raise_Expression_Present True.
5785
5786       procedure Test_REs is new Traverse_Proc (Test_RE);
5787       --  Tests to see if Expr contains any raise expressions
5788
5789       function Process_RE (N : Node_Id) return Traverse_Result;
5790       --  Used in Process REs, tests if node N is a raise expression, and if
5791       --  so, marks it to be converted to return False.
5792
5793       procedure Process_REs is new Traverse_Proc (Process_RE);
5794       --  Marks any raise expressions in Expr_M to return False
5795
5796       --------------
5797       -- Add_Call --
5798       --------------
5799
5800       procedure Add_Call (T : Entity_Id) is
5801          Exp : Node_Id;
5802
5803       begin
5804          if Present (T) and then Present (Predicate_Function (T)) then
5805             Set_Has_Predicates (Typ);
5806
5807             --  Build the call to the predicate function of T
5808
5809             Exp :=
5810               Make_Predicate_Call
5811                 (T, Convert_To (T, Make_Identifier (Loc, Object_Name)));
5812
5813             --  Add call to evolving expression, using AND THEN if needed
5814
5815             if No (Expr) then
5816                Expr := Exp;
5817             else
5818                Expr :=
5819                  Make_And_Then (Loc,
5820                    Left_Opnd  => Relocate_Node (Expr),
5821                    Right_Opnd => Exp);
5822             end if;
5823
5824             --  Output info message on inheritance if required. Note we do not
5825             --  give this information for generic actual types, since it is
5826             --  unwelcome noise in that case in instantiations. We also
5827             --  generally suppress the message in instantiations, and also
5828             --  if it involves internal names.
5829
5830             if Opt.List_Inherited_Aspects
5831               and then not Is_Generic_Actual_Type (Typ)
5832               and then Instantiation_Depth (Sloc (Typ)) = 0
5833               and then not Is_Internal_Name (Chars (T))
5834               and then not Is_Internal_Name (Chars (Typ))
5835             then
5836                Error_Msg_Sloc := Sloc (Predicate_Function (T));
5837                Error_Msg_Node_2 := T;
5838                Error_Msg_N ("info: & inherits predicate from & #?L?", Typ);
5839             end if;
5840          end if;
5841       end Add_Call;
5842
5843       --------------------
5844       -- Add_Predicates --
5845       --------------------
5846
5847       procedure Add_Predicates is
5848          Ritem : Node_Id;
5849          Arg1  : Node_Id;
5850          Arg2  : Node_Id;
5851
5852          procedure Replace_Type_Reference (N : Node_Id);
5853          --  Replace a single occurrence N of the subtype name with a reference
5854          --  to the formal of the predicate function. N can be an identifier
5855          --  referencing the subtype, or a selected component, representing an
5856          --  appropriately qualified occurrence of the subtype name.
5857
5858          procedure Replace_Type_References is
5859            new Replace_Type_References_Generic (Replace_Type_Reference);
5860          --  Traverse an expression changing every occurrence of an identifier
5861          --  whose name matches the name of the subtype with a reference to
5862          --  the formal parameter of the predicate function.
5863
5864          ----------------------------
5865          -- Replace_Type_Reference --
5866          ----------------------------
5867
5868          procedure Replace_Type_Reference (N : Node_Id) is
5869          begin
5870             Rewrite (N, Make_Identifier (Sloc (N), Object_Name));
5871             --  Use the Sloc of the usage name, not the defining name
5872
5873             Set_Etype (N, Typ);
5874             Set_Entity (N, Object_Entity);
5875
5876             --  We want to treat the node as if it comes from source, so that
5877             --  ASIS will not ignore it
5878
5879             Set_Comes_From_Source (N, True);
5880          end Replace_Type_Reference;
5881
5882       --  Start of processing for Add_Predicates
5883
5884       begin
5885          Ritem := First_Rep_Item (Typ);
5886          while Present (Ritem) loop
5887             if Nkind (Ritem) = N_Pragma
5888               and then Pragma_Name (Ritem) = Name_Predicate
5889             then
5890                --  Save the static predicate of the type for diagnostics and
5891                --  error reporting purposes.
5892
5893                if Present (Corresponding_Aspect (Ritem))
5894                  and then Chars (Identifier (Corresponding_Aspect (Ritem))) =
5895                             Name_Static_Predicate
5896                then
5897                   Static_Predic := Ritem;
5898                end if;
5899
5900                --  Acquire arguments
5901
5902                Arg1 := First (Pragma_Argument_Associations (Ritem));
5903                Arg2 := Next (Arg1);
5904
5905                Arg1 := Get_Pragma_Arg (Arg1);
5906                Arg2 := Get_Pragma_Arg (Arg2);
5907
5908                --  See if this predicate pragma is for the current type or for
5909                --  its full view. A predicate on a private completion is placed
5910                --  on the partial view beause this is the visible entity that
5911                --  is frozen.
5912
5913                if Entity (Arg1) = Typ
5914                  or else Full_View (Entity (Arg1)) = Typ
5915                then
5916                   --  We have a match, this entry is for our subtype
5917
5918                   --  We need to replace any occurrences of the name of the
5919                   --  type with references to the object.
5920
5921                   Replace_Type_References (Arg2, Chars (Typ));
5922
5923                   --  If this predicate comes from an aspect, find the aspect
5924                   --  specification, and replace the saved expression because
5925                   --  we need the subtype references replaced for the calls to
5926                   --  Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point
5927                   --  and Check_Aspect_At_End_Of_Declarations.
5928
5929                   if From_Aspect_Specification (Ritem) then
5930                      declare
5931                         Aitem : Node_Id;
5932
5933                      begin
5934                         --  Loop to find corresponding aspect, note that this
5935                         --  must be present given the pragma is marked delayed.
5936
5937                         Aitem := Next_Rep_Item (Ritem);
5938                         loop
5939                            if Nkind (Aitem) = N_Aspect_Specification
5940                              and then Aspect_Rep_Item (Aitem) = Ritem
5941                            then
5942                               Set_Entity
5943                                 (Identifier (Aitem), New_Copy_Tree (Arg2));
5944                               exit;
5945                            end if;
5946
5947                            Aitem := Next_Rep_Item (Aitem);
5948                         end loop;
5949                      end;
5950                   end if;
5951
5952                   --  Now we can add the expression
5953
5954                   if No (Expr) then
5955                      Expr := Relocate_Node (Arg2);
5956
5957                   --  There already was a predicate, so add to it
5958
5959                   else
5960                      Expr :=
5961                        Make_And_Then (Loc,
5962                          Left_Opnd  => Relocate_Node (Expr),
5963                          Right_Opnd => Relocate_Node (Arg2));
5964                   end if;
5965                end if;
5966             end if;
5967
5968             Next_Rep_Item (Ritem);
5969          end loop;
5970       end Add_Predicates;
5971
5972       ----------------
5973       -- Process_RE --
5974       ----------------
5975
5976       function Process_RE (N : Node_Id) return Traverse_Result is
5977       begin
5978          if Nkind (N) = N_Raise_Expression then
5979             Set_Convert_To_Return_False (N);
5980             return Skip;
5981          else
5982             return OK;
5983          end if;
5984       end Process_RE;
5985
5986       -------------
5987       -- Test_RE --
5988       -------------
5989
5990       function Test_RE (N : Node_Id) return Traverse_Result is
5991       begin
5992          if Nkind (N) = N_Raise_Expression then
5993             Raise_Expression_Present := True;
5994             return Abandon;
5995          else
5996             return OK;
5997          end if;
5998       end Test_RE;
5999
6000    --  Start of processing for Build_Predicate_Functions
6001
6002    begin
6003       --  Return if already built or if type does not have predicates
6004
6005       if not Has_Predicates (Typ)
6006         or else Present (Predicate_Function (Typ))
6007       then
6008          return;
6009       end if;
6010
6011       --  Prepare to construct predicate expression
6012
6013       Expr := Empty;
6014
6015       --  Add Predicates for the current type
6016
6017       Add_Predicates;
6018
6019       --  Add predicates for ancestor if present
6020
6021       declare
6022          Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
6023       begin
6024          if Present (Atyp) then
6025             Add_Call (Atyp);
6026          end if;
6027       end;
6028
6029       --  Case where predicates are present
6030
6031       if Present (Expr) then
6032
6033          --  Test for raise expression present
6034
6035          Test_REs (Expr);
6036
6037          --  If raise expression is present, capture a copy of Expr for use
6038          --  in building the predicateM function version later on. For this
6039          --  copy we replace references to Object_Entity by Object_Entity_M.
6040
6041          if Raise_Expression_Present then
6042             declare
6043                Map : constant Elist_Id := New_Elmt_List;
6044             begin
6045                Append_Elmt (Object_Entity, Map);
6046                Append_Elmt (Object_Entity_M, Map);
6047                Expr_M := New_Copy_Tree (Expr, Map => Map);
6048             end;
6049          end if;
6050
6051          --  Build the main predicate function
6052
6053          declare
6054             SId : constant Entity_Id :=
6055                     Make_Defining_Identifier (Loc,
6056                       Chars => New_External_Name (Chars (Typ), "Predicate"));
6057             --  The entity for the the function spec
6058
6059             SIdB : constant Entity_Id :=
6060               Make_Defining_Identifier (Loc,
6061                 Chars => New_External_Name (Chars (Typ), "Predicate"));
6062             --  The entity for the function body
6063
6064             Spec  : Node_Id;
6065             FDecl : Node_Id;
6066             FBody : Node_Id;
6067
6068          begin
6069             --  Build function declaration
6070
6071             Set_Ekind (SId, E_Function);
6072             Set_Is_Predicate_Function (SId);
6073             Set_Predicate_Function (Typ, SId);
6074
6075             --  The predicate function is shared between views of a type
6076
6077             if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
6078                Set_Predicate_Function (Full_View (Typ), SId);
6079             end if;
6080
6081             Spec :=
6082               Make_Function_Specification (Loc,
6083                 Defining_Unit_Name       => SId,
6084                 Parameter_Specifications => New_List (
6085                   Make_Parameter_Specification (Loc,
6086                     Defining_Identifier => Object_Entity,
6087                     Parameter_Type      => New_Occurrence_Of (Typ, Loc))),
6088                 Result_Definition        =>
6089                   New_Occurrence_Of (Standard_Boolean, Loc));
6090
6091             FDecl :=
6092               Make_Subprogram_Declaration (Loc,
6093                 Specification => Spec);
6094
6095             --  Build function body
6096
6097             Spec :=
6098               Make_Function_Specification (Loc,
6099                 Defining_Unit_Name       => SIdB,
6100                 Parameter_Specifications => New_List (
6101                   Make_Parameter_Specification (Loc,
6102                     Defining_Identifier =>
6103                       Make_Defining_Identifier (Loc, Object_Name),
6104                     Parameter_Type =>
6105                       New_Occurrence_Of (Typ, Loc))),
6106                 Result_Definition        =>
6107                   New_Occurrence_Of (Standard_Boolean, Loc));
6108
6109             FBody :=
6110               Make_Subprogram_Body (Loc,
6111                 Specification              => Spec,
6112                 Declarations               => Empty_List,
6113                 Handled_Statement_Sequence =>
6114                   Make_Handled_Sequence_Of_Statements (Loc,
6115                     Statements => New_List (
6116                       Make_Simple_Return_Statement (Loc,
6117                         Expression => Expr))));
6118
6119             --  Insert declaration before freeze node and body after
6120
6121             Insert_Before_And_Analyze (N, FDecl);
6122             Insert_After_And_Analyze  (N, FBody);
6123          end;
6124
6125          --  Test for raise expressions present and if so build M version
6126
6127          if Raise_Expression_Present then
6128             declare
6129                SId : constant Entity_Id :=
6130                  Make_Defining_Identifier (Loc,
6131                    Chars => New_External_Name (Chars (Typ), "PredicateM"));
6132                --  The entity for the the function spec
6133
6134                SIdB : constant Entity_Id :=
6135                  Make_Defining_Identifier (Loc,
6136                    Chars => New_External_Name (Chars (Typ), "PredicateM"));
6137                --  The entity for the function body
6138
6139                Spec  : Node_Id;
6140                FDecl : Node_Id;
6141                FBody : Node_Id;
6142                BTemp : Entity_Id;
6143
6144             begin
6145                --  Mark any raise expressions for special expansion
6146
6147                Process_REs (Expr_M);
6148
6149                --  Build function declaration
6150
6151                Set_Ekind (SId, E_Function);
6152                Set_Is_Predicate_Function_M (SId);
6153                Set_Predicate_Function_M (Typ, SId);
6154
6155                --  The predicate function is shared between views of a type
6156
6157                if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
6158                   Set_Predicate_Function_M (Full_View (Typ), SId);
6159                end if;
6160
6161                Spec :=
6162                  Make_Function_Specification (Loc,
6163                    Defining_Unit_Name       => SId,
6164                    Parameter_Specifications => New_List (
6165                      Make_Parameter_Specification (Loc,
6166                        Defining_Identifier => Object_Entity_M,
6167                        Parameter_Type      => New_Occurrence_Of (Typ, Loc))),
6168                    Result_Definition        =>
6169                      New_Occurrence_Of (Standard_Boolean, Loc));
6170
6171                FDecl :=
6172                  Make_Subprogram_Declaration (Loc,
6173                    Specification => Spec);
6174
6175                --  Build function body
6176
6177                Spec :=
6178                  Make_Function_Specification (Loc,
6179                    Defining_Unit_Name       => SIdB,
6180                    Parameter_Specifications => New_List (
6181                      Make_Parameter_Specification (Loc,
6182                        Defining_Identifier =>
6183                          Make_Defining_Identifier (Loc, Object_Name),
6184                        Parameter_Type =>
6185                          New_Occurrence_Of (Typ, Loc))),
6186                    Result_Definition        =>
6187                      New_Occurrence_Of (Standard_Boolean, Loc));
6188
6189                --  Build the body, we declare the boolean expression before
6190                --  doing the return, because we are not really confident of
6191                --  what happens if a return appears within a return!
6192
6193                BTemp :=
6194                  Make_Defining_Identifier (Loc,
6195                    Chars => New_Internal_Name ('B'));
6196
6197                FBody :=
6198                  Make_Subprogram_Body (Loc,
6199                    Specification              => Spec,
6200
6201                    Declarations               => New_List (
6202                      Make_Object_Declaration (Loc,
6203                        Defining_Identifier => BTemp,
6204                        Constant_Present    => True,
6205                          Object_Definition =>
6206                            New_Reference_To (Standard_Boolean, Loc),
6207                          Expression        => Expr_M)),
6208
6209                    Handled_Statement_Sequence =>
6210                      Make_Handled_Sequence_Of_Statements (Loc,
6211                        Statements => New_List (
6212                          Make_Simple_Return_Statement (Loc,
6213                            Expression => New_Reference_To (BTemp, Loc)))));
6214
6215                --  Insert declaration before freeze node and body after
6216
6217                Insert_Before_And_Analyze (N, FDecl);
6218                Insert_After_And_Analyze  (N, FBody);
6219             end;
6220          end if;
6221
6222          if Is_Scalar_Type (Typ) then
6223
6224             --  Attempt to build a static predicate for a discrete or a real
6225             --  subtype. This action may fail because the actual expression may
6226             --  not be static. Note that the presence of an inherited or
6227             --  explicitly declared dynamic predicate is orthogonal to this
6228             --  check because we are only interested in the static predicate.
6229
6230             if Ekind_In (Typ, E_Decimal_Fixed_Point_Subtype,
6231                               E_Enumeration_Subtype,
6232                               E_Floating_Point_Subtype,
6233                               E_Modular_Integer_Subtype,
6234                               E_Ordinary_Fixed_Point_Subtype,
6235                               E_Signed_Integer_Subtype)
6236             then
6237                Build_Static_Predicate (Typ, Expr, Object_Name);
6238
6239                --  Emit an error when the predicate is categorized as static
6240                --  but its expression is dynamic.
6241
6242                if Present (Static_Predic)
6243                  and then No (Static_Predicate (Typ))
6244                then
6245                   Error_Msg_F
6246                     ("expression does not have required form for "
6247                      & "static predicate",
6248                      Next (First (Pragma_Argument_Associations
6249                                    (Static_Predic))));
6250                end if;
6251             end if;
6252
6253          --  If a static predicate applies on other types, that's an error:
6254          --  either the type is scalar but non-static, or it's not even a
6255          --  scalar type. We do not issue an error on generated types, as
6256          --  these may be duplicates of the same error on a source type.
6257
6258          elsif Present (Static_Predic) and then Comes_From_Source (Typ) then
6259             if Is_Scalar_Type (Typ) then
6260                Error_Msg_FE
6261                  ("static predicate not allowed for non-static type&",
6262                   Typ, Typ);
6263             else
6264                Error_Msg_FE
6265                  ("static predicate not allowed for non-scalar type&",
6266                   Typ, Typ);
6267             end if;
6268          end if;
6269       end if;
6270    end Build_Predicate_Functions;
6271
6272    ----------------------------
6273    -- Build_Static_Predicate --
6274    ----------------------------
6275
6276    procedure Build_Static_Predicate
6277      (Typ  : Entity_Id;
6278       Expr : Node_Id;
6279       Nam  : Name_Id)
6280    is
6281       Loc : constant Source_Ptr := Sloc (Expr);
6282
6283       Non_Static : exception;
6284       --  Raised if something non-static is found
6285
6286       Btyp : constant Entity_Id := Base_Type (Typ);
6287
6288       BLo : constant Uint := Expr_Value (Type_Low_Bound  (Btyp));
6289       BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp));
6290       --  Low bound and high bound value of base type of Typ
6291
6292       TLo : constant Uint := Expr_Value (Type_Low_Bound  (Typ));
6293       THi : constant Uint := Expr_Value (Type_High_Bound (Typ));
6294       --  Low bound and high bound values of static subtype Typ
6295
6296       type REnt is record
6297          Lo, Hi : Uint;
6298       end record;
6299       --  One entry in a Rlist value, a single REnt (range entry) value denotes
6300       --  one range from Lo to Hi. To represent a single value range Lo = Hi =
6301       --  value.
6302
6303       type RList is array (Nat range <>) of REnt;
6304       --  A list of ranges. The ranges are sorted in increasing order, and are
6305       --  disjoint (there is a gap of at least one value between each range in
6306       --  the table). A value is in the set of ranges in Rlist if it lies
6307       --  within one of these ranges.
6308
6309       False_Range : constant RList :=
6310                       RList'(1 .. 0 => REnt'(No_Uint, No_Uint));
6311       --  An empty set of ranges represents a range list that can never be
6312       --  satisfied, since there are no ranges in which the value could lie,
6313       --  so it does not lie in any of them. False_Range is a canonical value
6314       --  for this empty set, but general processing should test for an Rlist
6315       --  with length zero (see Is_False predicate), since other null ranges
6316       --  may appear which must be treated as False.
6317
6318       True_Range : constant RList := RList'(1 => REnt'(BLo, BHi));
6319       --  Range representing True, value must be in the base range
6320
6321       function "and" (Left : RList; Right : RList) return RList;
6322       --  And's together two range lists, returning a range list. This is a set
6323       --  intersection operation.
6324
6325       function "or" (Left : RList; Right : RList) return RList;
6326       --  Or's together two range lists, returning a range list. This is a set
6327       --  union operation.
6328
6329       function "not" (Right : RList) return RList;
6330       --  Returns complement of a given range list, i.e. a range list
6331       --  representing all the values in TLo .. THi that are not in the input
6332       --  operand Right.
6333
6334       function Build_Val (V : Uint) return Node_Id;
6335       --  Return an analyzed N_Identifier node referencing this value, suitable
6336       --  for use as an entry in the Static_Predicate list. This node is typed
6337       --  with the base type.
6338
6339       function Build_Range (Lo : Uint; Hi : Uint) return Node_Id;
6340       --  Return an analyzed N_Range node referencing this range, suitable for
6341       --  use as an entry in the Static_Predicate list. This node is typed with
6342       --  the base type.
6343
6344       function Get_RList (Exp : Node_Id) return RList;
6345       --  This is a recursive routine that converts the given expression into a
6346       --  list of ranges, suitable for use in building the static predicate.
6347
6348       function Is_False (R : RList) return Boolean;
6349       pragma Inline (Is_False);
6350       --  Returns True if the given range list is empty, and thus represents a
6351       --  False list of ranges that can never be satisfied.
6352
6353       function Is_True (R : RList) return Boolean;
6354       --  Returns True if R trivially represents the True predicate by having a
6355       --  single range from BLo to BHi.
6356
6357       function Is_Type_Ref (N : Node_Id) return Boolean;
6358       pragma Inline (Is_Type_Ref);
6359       --  Returns if True if N is a reference to the type for the predicate in
6360       --  the expression (i.e. if it is an identifier whose Chars field matches
6361       --  the Nam given in the call).
6362
6363       function Lo_Val (N : Node_Id) return Uint;
6364       --  Given static expression or static range from a Static_Predicate list,
6365       --  gets expression value or low bound of range.
6366
6367       function Hi_Val (N : Node_Id) return Uint;
6368       --  Given static expression or static range from a Static_Predicate list,
6369       --  gets expression value of high bound of range.
6370
6371       function Membership_Entry (N : Node_Id) return RList;
6372       --  Given a single membership entry (range, value, or subtype), returns
6373       --  the corresponding range list. Raises Static_Error if not static.
6374
6375       function Membership_Entries (N : Node_Id) return RList;
6376       --  Given an element on an alternatives list of a membership operation,
6377       --  returns the range list corresponding to this entry and all following
6378       --  entries (i.e. returns the "or" of this list of values).
6379
6380       function Stat_Pred (Typ : Entity_Id) return RList;
6381       --  Given a type, if it has a static predicate, then return the predicate
6382       --  as a range list, otherwise raise Non_Static.
6383
6384       -----------
6385       -- "and" --
6386       -----------
6387
6388       function "and" (Left : RList; Right : RList) return RList is
6389          FEnt : REnt;
6390          --  First range of result
6391
6392          SLeft : Nat := Left'First;
6393          --  Start of rest of left entries
6394
6395          SRight : Nat := Right'First;
6396          --  Start of rest of right entries
6397
6398       begin
6399          --  If either range is True, return the other
6400
6401          if Is_True (Left) then
6402             return Right;
6403          elsif Is_True (Right) then
6404             return Left;
6405          end if;
6406
6407          --  If either range is False, return False
6408
6409          if Is_False (Left) or else Is_False (Right) then
6410             return False_Range;
6411          end if;
6412
6413          --  Loop to remove entries at start that are disjoint, and thus just
6414          --  get discarded from the result entirely.
6415
6416          loop
6417             --  If no operands left in either operand, result is false
6418
6419             if SLeft > Left'Last or else SRight > Right'Last then
6420                return False_Range;
6421
6422             --  Discard first left operand entry if disjoint with right
6423
6424             elsif Left (SLeft).Hi < Right (SRight).Lo then
6425                SLeft := SLeft + 1;
6426
6427             --  Discard first right operand entry if disjoint with left
6428
6429             elsif Right (SRight).Hi < Left (SLeft).Lo then
6430                SRight := SRight + 1;
6431
6432             --  Otherwise we have an overlapping entry
6433
6434             else
6435                exit;
6436             end if;
6437          end loop;
6438
6439          --  Now we have two non-null operands, and first entries overlap. The
6440          --  first entry in the result will be the overlapping part of these
6441          --  two entries.
6442
6443          FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo),
6444                        Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi));
6445
6446          --  Now we can remove the entry that ended at a lower value, since its
6447          --  contribution is entirely contained in Fent.
6448
6449          if Left (SLeft).Hi <= Right (SRight).Hi then
6450             SLeft := SLeft + 1;
6451          else
6452             SRight := SRight + 1;
6453          end if;
6454
6455          --  Compute result by concatenating this first entry with the "and" of
6456          --  the remaining parts of the left and right operands. Note that if
6457          --  either of these is empty, "and" will yield empty, so that we will
6458          --  end up with just Fent, which is what we want in that case.
6459
6460          return
6461            FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
6462       end "and";
6463
6464       -----------
6465       -- "not" --
6466       -----------
6467
6468       function "not" (Right : RList) return RList is
6469       begin
6470          --  Return True if False range
6471
6472          if Is_False (Right) then
6473             return True_Range;
6474          end if;
6475
6476          --  Return False if True range
6477
6478          if Is_True (Right) then
6479             return False_Range;
6480          end if;
6481
6482          --  Here if not trivial case
6483
6484          declare
6485             Result : RList (1 .. Right'Length + 1);
6486             --  May need one more entry for gap at beginning and end
6487
6488             Count : Nat := 0;
6489             --  Number of entries stored in Result
6490
6491          begin
6492             --  Gap at start
6493
6494             if Right (Right'First).Lo > TLo then
6495                Count := Count + 1;
6496                Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1);
6497             end if;
6498
6499             --  Gaps between ranges
6500
6501             for J in Right'First .. Right'Last - 1 loop
6502                Count := Count + 1;
6503                Result (Count) :=
6504                  REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1);
6505             end loop;
6506
6507             --  Gap at end
6508
6509             if Right (Right'Last).Hi < THi then
6510                Count := Count + 1;
6511                Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi);
6512             end if;
6513
6514             return Result (1 .. Count);
6515          end;
6516       end "not";
6517
6518       ----------
6519       -- "or" --
6520       ----------
6521
6522       function "or" (Left : RList; Right : RList) return RList is
6523          FEnt : REnt;
6524          --  First range of result
6525
6526          SLeft : Nat := Left'First;
6527          --  Start of rest of left entries
6528
6529          SRight : Nat := Right'First;
6530          --  Start of rest of right entries
6531
6532       begin
6533          --  If either range is True, return True
6534
6535          if Is_True (Left) or else Is_True (Right) then
6536             return True_Range;
6537          end if;
6538
6539          --  If either range is False (empty), return the other
6540
6541          if Is_False (Left) then
6542             return Right;
6543          elsif Is_False (Right) then
6544             return Left;
6545          end if;
6546
6547          --  Initialize result first entry from left or right operand depending
6548          --  on which starts with the lower range.
6549
6550          if Left (SLeft).Lo < Right (SRight).Lo then
6551             FEnt := Left (SLeft);
6552             SLeft := SLeft + 1;
6553          else
6554             FEnt := Right (SRight);
6555             SRight := SRight + 1;
6556          end if;
6557
6558          --  This loop eats ranges from left and right operands that are
6559          --  contiguous with the first range we are gathering.
6560
6561          loop
6562             --  Eat first entry in left operand if contiguous or overlapped by
6563             --  gathered first operand of result.
6564
6565             if SLeft <= Left'Last
6566               and then Left (SLeft).Lo <= FEnt.Hi + 1
6567             then
6568                FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi);
6569                SLeft := SLeft + 1;
6570
6571             --  Eat first entry in right operand if contiguous or overlapped by
6572             --  gathered right operand of result.
6573
6574             elsif SRight <= Right'Last
6575               and then Right (SRight).Lo <= FEnt.Hi + 1
6576             then
6577                FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi);
6578                SRight := SRight + 1;
6579
6580             --  All done if no more entries to eat
6581
6582             else
6583                exit;
6584             end if;
6585          end loop;
6586
6587          --  Obtain result as the first entry we just computed, concatenated
6588          --  to the "or" of the remaining results (if one operand is empty,
6589          --  this will just concatenate with the other
6590
6591          return
6592            FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last));
6593       end "or";
6594
6595       -----------------
6596       -- Build_Range --
6597       -----------------
6598
6599       function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is
6600          Result : Node_Id;
6601
6602       begin
6603          Result :=
6604            Make_Range (Loc,
6605              Low_Bound  => Build_Val (Lo),
6606              High_Bound => Build_Val (Hi));
6607          Set_Etype (Result, Btyp);
6608          Set_Analyzed (Result);
6609
6610          return Result;
6611       end Build_Range;
6612
6613       ---------------
6614       -- Build_Val --
6615       ---------------
6616
6617       function Build_Val (V : Uint) return Node_Id is
6618          Result : Node_Id;
6619
6620       begin
6621          if Is_Enumeration_Type (Typ) then
6622             Result := Get_Enum_Lit_From_Pos (Typ, V, Loc);
6623          else
6624             Result := Make_Integer_Literal (Loc, V);
6625          end if;
6626
6627          Set_Etype (Result, Btyp);
6628          Set_Is_Static_Expression (Result);
6629          Set_Analyzed (Result);
6630          return Result;
6631       end Build_Val;
6632
6633       ---------------
6634       -- Get_RList --
6635       ---------------
6636
6637       function Get_RList (Exp : Node_Id) return RList is
6638          Op  : Node_Kind;
6639          Val : Uint;
6640
6641       begin
6642          --  Static expression can only be true or false
6643
6644          if Is_OK_Static_Expression (Exp) then
6645
6646             --  For False
6647
6648             if Expr_Value (Exp) = 0 then
6649                return False_Range;
6650             else
6651                return True_Range;
6652             end if;
6653          end if;
6654
6655          --  Otherwise test node type
6656
6657          Op := Nkind (Exp);
6658
6659          case Op is
6660
6661             --  And
6662
6663             when N_Op_And | N_And_Then =>
6664                return Get_RList (Left_Opnd (Exp))
6665                         and
6666                       Get_RList (Right_Opnd (Exp));
6667
6668             --  Or
6669
6670             when N_Op_Or | N_Or_Else =>
6671                return Get_RList (Left_Opnd (Exp))
6672                         or
6673                       Get_RList (Right_Opnd (Exp));
6674
6675             --  Not
6676
6677             when N_Op_Not =>
6678                return not Get_RList (Right_Opnd (Exp));
6679
6680             --  Comparisons of type with static value
6681
6682             when N_Op_Compare =>
6683
6684                --  Type is left operand
6685
6686                if Is_Type_Ref (Left_Opnd (Exp))
6687                  and then Is_OK_Static_Expression (Right_Opnd (Exp))
6688                then
6689                   Val := Expr_Value (Right_Opnd (Exp));
6690
6691                   --  Typ is right operand
6692
6693                elsif Is_Type_Ref (Right_Opnd (Exp))
6694                  and then Is_OK_Static_Expression (Left_Opnd (Exp))
6695                then
6696                   Val := Expr_Value (Left_Opnd (Exp));
6697
6698                   --  Invert sense of comparison
6699
6700                   case Op is
6701                      when N_Op_Gt => Op := N_Op_Lt;
6702                      when N_Op_Lt => Op := N_Op_Gt;
6703                      when N_Op_Ge => Op := N_Op_Le;
6704                      when N_Op_Le => Op := N_Op_Ge;
6705                      when others  => null;
6706                   end case;
6707
6708                   --  Other cases are non-static
6709
6710                else
6711                   raise Non_Static;
6712                end if;
6713
6714                --  Construct range according to comparison operation
6715
6716                case Op is
6717                   when N_Op_Eq =>
6718                      return RList'(1 => REnt'(Val, Val));
6719
6720                   when N_Op_Ge =>
6721                      return RList'(1 => REnt'(Val, BHi));
6722
6723                   when N_Op_Gt =>
6724                      return RList'(1 => REnt'(Val + 1, BHi));
6725
6726                   when N_Op_Le =>
6727                      return RList'(1 => REnt'(BLo, Val));
6728
6729                   when N_Op_Lt =>
6730                      return RList'(1 => REnt'(BLo, Val - 1));
6731
6732                   when N_Op_Ne =>
6733                      return RList'(REnt'(BLo, Val - 1),
6734                                    REnt'(Val + 1, BHi));
6735
6736                   when others  =>
6737                      raise Program_Error;
6738                end case;
6739
6740             --  Membership (IN)
6741
6742             when N_In =>
6743                if not Is_Type_Ref (Left_Opnd (Exp)) then
6744                   raise Non_Static;
6745                end if;
6746
6747                if Present (Right_Opnd (Exp)) then
6748                   return Membership_Entry (Right_Opnd (Exp));
6749                else
6750                   return Membership_Entries (First (Alternatives (Exp)));
6751                end if;
6752
6753             --  Negative membership (NOT IN)
6754
6755             when N_Not_In =>
6756                if not Is_Type_Ref (Left_Opnd (Exp)) then
6757                   raise Non_Static;
6758                end if;
6759
6760                if Present (Right_Opnd (Exp)) then
6761                   return not Membership_Entry (Right_Opnd (Exp));
6762                else
6763                   return not Membership_Entries (First (Alternatives (Exp)));
6764                end if;
6765
6766             --  Function call, may be call to static predicate
6767
6768             when N_Function_Call =>
6769                if Is_Entity_Name (Name (Exp)) then
6770                   declare
6771                      Ent : constant Entity_Id := Entity (Name (Exp));
6772                   begin
6773                      if Is_Predicate_Function (Ent)
6774                           or else
6775                         Is_Predicate_Function_M (Ent)
6776                      then
6777                         return Stat_Pred (Etype (First_Formal (Ent)));
6778                      end if;
6779                   end;
6780                end if;
6781
6782                --  Other function call cases are non-static
6783
6784                raise Non_Static;
6785
6786             --  Qualified expression, dig out the expression
6787
6788             when N_Qualified_Expression =>
6789                return Get_RList (Expression (Exp));
6790
6791             --  Xor operator
6792
6793             when N_Op_Xor =>
6794                return (Get_RList (Left_Opnd (Exp))
6795                         and not Get_RList (Right_Opnd (Exp)))
6796                  or   (Get_RList (Right_Opnd (Exp))
6797                         and not Get_RList (Left_Opnd (Exp)));
6798
6799             --  Any other node type is non-static
6800
6801             when others =>
6802                raise Non_Static;
6803          end case;
6804       end Get_RList;
6805
6806       ------------
6807       -- Hi_Val --
6808       ------------
6809
6810       function Hi_Val (N : Node_Id) return Uint is
6811       begin
6812          if Is_Static_Expression (N) then
6813             return Expr_Value (N);
6814          else
6815             pragma Assert (Nkind (N) = N_Range);
6816             return Expr_Value (High_Bound (N));
6817          end if;
6818       end Hi_Val;
6819
6820       --------------
6821       -- Is_False --
6822       --------------
6823
6824       function Is_False (R : RList) return Boolean is
6825       begin
6826          return R'Length = 0;
6827       end Is_False;
6828
6829       -------------
6830       -- Is_True --
6831       -------------
6832
6833       function Is_True (R : RList) return Boolean is
6834       begin
6835          return R'Length = 1
6836            and then R (R'First).Lo = BLo
6837            and then R (R'First).Hi = BHi;
6838       end Is_True;
6839
6840       -----------------
6841       -- Is_Type_Ref --
6842       -----------------
6843
6844       function Is_Type_Ref (N : Node_Id) return Boolean is
6845       begin
6846          return Nkind (N) = N_Identifier and then Chars (N) = Nam;
6847       end Is_Type_Ref;
6848
6849       ------------
6850       -- Lo_Val --
6851       ------------
6852
6853       function Lo_Val (N : Node_Id) return Uint is
6854       begin
6855          if Is_Static_Expression (N) then
6856             return Expr_Value (N);
6857          else
6858             pragma Assert (Nkind (N) = N_Range);
6859             return Expr_Value (Low_Bound (N));
6860          end if;
6861       end Lo_Val;
6862
6863       ------------------------
6864       -- Membership_Entries --
6865       ------------------------
6866
6867       function Membership_Entries (N : Node_Id) return RList is
6868       begin
6869          if No (Next (N)) then
6870             return Membership_Entry (N);
6871          else
6872             return Membership_Entry (N) or Membership_Entries (Next (N));
6873          end if;
6874       end Membership_Entries;
6875
6876       ----------------------
6877       -- Membership_Entry --
6878       ----------------------
6879
6880       function Membership_Entry (N : Node_Id) return RList is
6881          Val : Uint;
6882          SLo : Uint;
6883          SHi : Uint;
6884
6885       begin
6886          --  Range case
6887
6888          if Nkind (N) = N_Range then
6889             if not Is_Static_Expression (Low_Bound (N))
6890                  or else
6891                not Is_Static_Expression (High_Bound (N))
6892             then
6893                raise Non_Static;
6894             else
6895                SLo := Expr_Value (Low_Bound  (N));
6896                SHi := Expr_Value (High_Bound (N));
6897                return RList'(1 => REnt'(SLo, SHi));
6898             end if;
6899
6900          --  Static expression case
6901
6902          elsif Is_Static_Expression (N) then
6903             Val := Expr_Value (N);
6904             return RList'(1 => REnt'(Val, Val));
6905
6906          --  Identifier (other than static expression) case
6907
6908          else pragma Assert (Nkind (N) = N_Identifier);
6909
6910             --  Type case
6911
6912             if Is_Type (Entity (N)) then
6913
6914                --  If type has predicates, process them
6915
6916                if Has_Predicates (Entity (N)) then
6917                   return Stat_Pred (Entity (N));
6918
6919                --  For static subtype without predicates, get range
6920
6921                elsif Is_Static_Subtype (Entity (N)) then
6922                   SLo := Expr_Value (Type_Low_Bound  (Entity (N)));
6923                   SHi := Expr_Value (Type_High_Bound (Entity (N)));
6924                   return RList'(1 => REnt'(SLo, SHi));
6925
6926                --  Any other type makes us non-static
6927
6928                else
6929                   raise Non_Static;
6930                end if;
6931
6932             --  Any other kind of identifier in predicate (e.g. a non-static
6933             --  expression value) means this is not a static predicate.
6934
6935             else
6936                raise Non_Static;
6937             end if;
6938          end if;
6939       end Membership_Entry;
6940
6941       ---------------
6942       -- Stat_Pred --
6943       ---------------
6944
6945       function Stat_Pred (Typ : Entity_Id) return RList is
6946       begin
6947          --  Not static if type does not have static predicates
6948
6949          if not Has_Predicates (Typ) or else No (Static_Predicate (Typ)) then
6950             raise Non_Static;
6951          end if;
6952
6953          --  Otherwise we convert the predicate list to a range list
6954
6955          declare
6956             Result : RList (1 .. List_Length (Static_Predicate (Typ)));
6957             P      : Node_Id;
6958
6959          begin
6960             P := First (Static_Predicate (Typ));
6961             for J in Result'Range loop
6962                Result (J) := REnt'(Lo_Val (P), Hi_Val (P));
6963                Next (P);
6964             end loop;
6965
6966             return Result;
6967          end;
6968       end Stat_Pred;
6969
6970    --  Start of processing for Build_Static_Predicate
6971
6972    begin
6973       --  Now analyze the expression to see if it is a static predicate
6974
6975       declare
6976          Ranges : constant RList := Get_RList (Expr);
6977          --  Range list from expression if it is static
6978
6979          Plist : List_Id;
6980
6981       begin
6982          --  Convert range list into a form for the static predicate. In the
6983          --  Ranges array, we just have raw ranges, these must be converted
6984          --  to properly typed and analyzed static expressions or range nodes.
6985
6986          --  Note: here we limit ranges to the ranges of the subtype, so that
6987          --  a predicate is always false for values outside the subtype. That
6988          --  seems fine, such values are invalid anyway, and considering them
6989          --  to fail the predicate seems allowed and friendly, and furthermore
6990          --  simplifies processing for case statements and loops.
6991
6992          Plist := New_List;
6993
6994          for J in Ranges'Range loop
6995             declare
6996                Lo : Uint := Ranges (J).Lo;
6997                Hi : Uint := Ranges (J).Hi;
6998
6999             begin
7000                --  Ignore completely out of range entry
7001
7002                if Hi < TLo or else Lo > THi then
7003                   null;
7004
7005                   --  Otherwise process entry
7006
7007                else
7008                   --  Adjust out of range value to subtype range
7009
7010                   if Lo < TLo then
7011                      Lo := TLo;
7012                   end if;
7013
7014                   if Hi > THi then
7015                      Hi := THi;
7016                   end if;
7017
7018                   --  Convert range into required form
7019
7020                   Append_To (Plist, Build_Range (Lo, Hi));
7021                end if;
7022             end;
7023          end loop;
7024
7025          --  Processing was successful and all entries were static, so now we
7026          --  can store the result as the predicate list.
7027
7028          Set_Static_Predicate (Typ, Plist);
7029
7030          --  The processing for static predicates put the expression into
7031          --  canonical form as a series of ranges. It also eliminated
7032          --  duplicates and collapsed and combined ranges. We might as well
7033          --  replace the alternatives list of the right operand of the
7034          --  membership test with the static predicate list, which will
7035          --  usually be more efficient.
7036
7037          declare
7038             New_Alts : constant List_Id := New_List;
7039             Old_Node : Node_Id;
7040             New_Node : Node_Id;
7041
7042          begin
7043             Old_Node := First (Plist);
7044             while Present (Old_Node) loop
7045                New_Node := New_Copy (Old_Node);
7046
7047                if Nkind (New_Node) = N_Range then
7048                   Set_Low_Bound  (New_Node, New_Copy (Low_Bound  (Old_Node)));
7049                   Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node)));
7050                end if;
7051
7052                Append_To (New_Alts, New_Node);
7053                Next (Old_Node);
7054             end loop;
7055
7056             --  If empty list, replace by False
7057
7058             if Is_Empty_List (New_Alts) then
7059                Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc));
7060
7061             --  Else replace by set membership test
7062
7063             else
7064                Rewrite (Expr,
7065                  Make_In (Loc,
7066                    Left_Opnd    => Make_Identifier (Loc, Nam),
7067                    Right_Opnd   => Empty,
7068                    Alternatives => New_Alts));
7069
7070                --  Resolve new expression in function context
7071
7072                Install_Formals (Predicate_Function (Typ));
7073                Push_Scope (Predicate_Function (Typ));
7074                Analyze_And_Resolve (Expr, Standard_Boolean);
7075                Pop_Scope;
7076             end if;
7077          end;
7078       end;
7079
7080    --  If non-static, return doing nothing
7081
7082    exception
7083       when Non_Static =>
7084          return;
7085    end Build_Static_Predicate;
7086
7087    -----------------------------------------
7088    -- Check_Aspect_At_End_Of_Declarations --
7089    -----------------------------------------
7090
7091    procedure Check_Aspect_At_End_Of_Declarations (ASN : Node_Id) is
7092       Ent   : constant Entity_Id := Entity     (ASN);
7093       Ident : constant Node_Id   := Identifier (ASN);
7094       A_Id  : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
7095
7096       End_Decl_Expr : constant Node_Id := Entity (Ident);
7097       --  Expression to be analyzed at end of declarations
7098
7099       Freeze_Expr : constant Node_Id := Expression (ASN);
7100       --  Expression from call to Check_Aspect_At_Freeze_Point
7101
7102       T : constant Entity_Id := Etype (Freeze_Expr);
7103       --  Type required for preanalyze call
7104
7105       Err : Boolean;
7106       --  Set False if error
7107
7108       --  On entry to this procedure, Entity (Ident) contains a copy of the
7109       --  original expression from the aspect, saved for this purpose, and
7110       --  but Expression (Ident) is a preanalyzed copy of the expression,
7111       --  preanalyzed just after the freeze point.
7112
7113       procedure Check_Overloaded_Name;
7114       --  For aspects whose expression is simply a name, this routine checks if
7115       --  the name is overloaded or not. If so, it verifies there is an
7116       --  interpretation that matches the entity obtained at the freeze point,
7117       --  otherwise the compiler complains.
7118
7119       ---------------------------
7120       -- Check_Overloaded_Name --
7121       ---------------------------
7122
7123       procedure Check_Overloaded_Name is
7124       begin
7125          if not Is_Overloaded (End_Decl_Expr) then
7126             Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr);
7127
7128          else
7129             Err := True;
7130
7131             declare
7132                Index : Interp_Index;
7133                It    : Interp;
7134
7135             begin
7136                Get_First_Interp (End_Decl_Expr, Index, It);
7137                while Present (It.Typ) loop
7138                   if It.Nam = Entity (Freeze_Expr) then
7139                      Err := False;
7140                      exit;
7141                   end if;
7142
7143                   Get_Next_Interp (Index, It);
7144                end loop;
7145             end;
7146          end if;
7147       end Check_Overloaded_Name;
7148
7149    --  Start of processing for Check_Aspect_At_End_Of_Declarations
7150
7151    begin
7152       --  Case of aspects Dimension, Dimension_System and Synchronization
7153
7154       if A_Id = Aspect_Synchronization then
7155          return;
7156
7157       --  Case of stream attributes, just have to compare entities. However,
7158       --  the expression is just a name (possibly overloaded), and there may
7159       --  be stream operations declared for unrelated types, so we just need
7160       --  to verify that one of these interpretations is the one available at
7161       --  at the freeze point.
7162
7163       elsif A_Id = Aspect_Input  or else
7164          A_Id = Aspect_Output    or else
7165          A_Id = Aspect_Read      or else
7166          A_Id = Aspect_Write
7167       then
7168          Analyze (End_Decl_Expr);
7169          Check_Overloaded_Name;
7170
7171       elsif A_Id = Aspect_Variable_Indexing or else
7172             A_Id = Aspect_Constant_Indexing or else
7173             A_Id = Aspect_Default_Iterator  or else
7174             A_Id = Aspect_Iterator_Element
7175       then
7176          --  Make type unfrozen before analysis, to prevent spurious errors
7177          --  about late attributes.
7178
7179          Set_Is_Frozen (Ent, False);
7180          Analyze (End_Decl_Expr);
7181          Set_Is_Frozen (Ent, True);
7182
7183          --  If the end of declarations comes before any other freeze
7184          --  point, the Freeze_Expr is not analyzed: no check needed.
7185
7186          if Analyzed (Freeze_Expr) and then not In_Instance then
7187             Check_Overloaded_Name;
7188          else
7189             Err := False;
7190          end if;
7191
7192       --  All other cases
7193
7194       else
7195          --  In a generic context the aspect expressions have not been
7196          --  preanalyzed, so do it now. There are no conformance checks
7197          --  to perform in this case.
7198
7199          if No (T) then
7200             Check_Aspect_At_Freeze_Point (ASN);
7201             return;
7202
7203          --  The default values attributes may be defined in the private part,
7204          --  and the analysis of the expression may take place when only the
7205          --  partial view is visible. The expression must be scalar, so use
7206          --  the full view to resolve.
7207
7208          elsif (A_Id = Aspect_Default_Value
7209                   or else
7210                 A_Id = Aspect_Default_Component_Value)
7211             and then Is_Private_Type (T)
7212          then
7213             Preanalyze_Spec_Expression (End_Decl_Expr, Full_View (T));
7214          else
7215             Preanalyze_Spec_Expression (End_Decl_Expr, T);
7216          end if;
7217
7218          Err := not Fully_Conformant_Expressions (End_Decl_Expr, Freeze_Expr);
7219       end if;
7220
7221       --  Output error message if error
7222
7223       if Err then
7224          Error_Msg_NE
7225            ("visibility of aspect for& changes after freeze point",
7226             ASN, Ent);
7227          Error_Msg_NE
7228            ("info: & is frozen here, aspects evaluated at this point??",
7229             Freeze_Node (Ent), Ent);
7230       end if;
7231    end Check_Aspect_At_End_Of_Declarations;
7232
7233    ----------------------------------
7234    -- Check_Aspect_At_Freeze_Point --
7235    ----------------------------------
7236
7237    procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id) is
7238       Ident : constant Node_Id := Identifier (ASN);
7239       --  Identifier (use Entity field to save expression)
7240
7241       A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
7242
7243       T : Entity_Id := Empty;
7244       --  Type required for preanalyze call
7245
7246    begin
7247       --  On entry to this procedure, Entity (Ident) contains a copy of the
7248       --  original expression from the aspect, saved for this purpose.
7249
7250       --  On exit from this procedure Entity (Ident) is unchanged, still
7251       --  containing that copy, but Expression (Ident) is a preanalyzed copy
7252       --  of the expression, preanalyzed just after the freeze point.
7253
7254       --  Make a copy of the expression to be preanalyzed
7255
7256       Set_Expression (ASN, New_Copy_Tree (Entity (Ident)));
7257
7258       --  Find type for preanalyze call
7259
7260       case A_Id is
7261
7262          --  No_Aspect should be impossible
7263
7264          when No_Aspect =>
7265             raise Program_Error;
7266
7267          --  Aspects taking an optional boolean argument
7268
7269          when Boolean_Aspects      |
7270               Library_Unit_Aspects =>
7271             T := Standard_Boolean;
7272
7273          --  Aspects corresponding to attribute definition clauses
7274
7275          when Aspect_Address =>
7276             T := RTE (RE_Address);
7277
7278          when Aspect_Attach_Handler =>
7279             T := RTE (RE_Interrupt_ID);
7280
7281          when Aspect_Bit_Order | Aspect_Scalar_Storage_Order =>
7282             T := RTE (RE_Bit_Order);
7283
7284          when Aspect_Convention =>
7285             return;
7286
7287          when Aspect_CPU =>
7288             T := RTE (RE_CPU_Range);
7289
7290          --  Default_Component_Value is resolved with the component type
7291
7292          when Aspect_Default_Component_Value =>
7293             T := Component_Type (Entity (ASN));
7294
7295          --  Default_Value is resolved with the type entity in question
7296
7297          when Aspect_Default_Value =>
7298             T := Entity (ASN);
7299
7300          --  Depends is a delayed aspect because it mentiones names first
7301          --  introduced by aspect Global which is already delayed. There is
7302          --  no action to be taken with respect to the aspect itself as the
7303          --  analysis is done by the corresponding pragma.
7304
7305          when Aspect_Depends =>
7306             return;
7307
7308          when Aspect_Dispatching_Domain =>
7309             T := RTE (RE_Dispatching_Domain);
7310
7311          when Aspect_External_Tag =>
7312             T := Standard_String;
7313
7314          when Aspect_External_Name =>
7315             T := Standard_String;
7316
7317          --  Global is a delayed aspect because it may reference names that
7318          --  have not been declared yet. There is no action to be taken with
7319          --  respect to the aspect itself as the reference checking is done
7320          --  on the corresponding pragma.
7321
7322          when Aspect_Global =>
7323             return;
7324
7325          when Aspect_Link_Name =>
7326             T := Standard_String;
7327
7328          when Aspect_Priority | Aspect_Interrupt_Priority =>
7329             T := Standard_Integer;
7330
7331          when Aspect_Relative_Deadline =>
7332             T := RTE (RE_Time_Span);
7333
7334          when Aspect_Small =>
7335             T := Universal_Real;
7336
7337          --  For a simple storage pool, we have to retrieve the type of the
7338          --  pool object associated with the aspect's corresponding attribute
7339          --  definition clause.
7340
7341          when Aspect_Simple_Storage_Pool =>
7342             T := Etype (Expression (Aspect_Rep_Item (ASN)));
7343
7344          when Aspect_Storage_Pool =>
7345             T := Class_Wide_Type (RTE (RE_Root_Storage_Pool));
7346
7347          when Aspect_Alignment      |
7348               Aspect_Component_Size |
7349               Aspect_Machine_Radix  |
7350               Aspect_Object_Size    |
7351               Aspect_Size           |
7352               Aspect_Storage_Size   |
7353               Aspect_Stream_Size    |
7354               Aspect_Value_Size     =>
7355             T := Any_Integer;
7356
7357          when Aspect_Synchronization =>
7358             return;
7359
7360          --  Special case, the expression of these aspects is just an entity
7361          --  that does not need any resolution, so just analyze.
7362
7363          when Aspect_Input      |
7364               Aspect_Output     |
7365               Aspect_Read       |
7366               Aspect_Suppress   |
7367               Aspect_Unsuppress |
7368               Aspect_Warnings   |
7369               Aspect_Write      =>
7370             Analyze (Expression (ASN));
7371             return;
7372
7373          --  Same for Iterator aspects, where the expression is a function
7374          --  name. Legality rules are checked separately.
7375
7376          when Aspect_Constant_Indexing |
7377               Aspect_Default_Iterator  |
7378               Aspect_Iterator_Element  |
7379               Aspect_Variable_Indexing =>
7380             Analyze (Expression (ASN));
7381             return;
7382
7383          --  Invariant/Predicate take boolean expressions
7384
7385          when Aspect_Dynamic_Predicate |
7386               Aspect_Invariant         |
7387               Aspect_Predicate         |
7388               Aspect_Static_Predicate  |
7389               Aspect_Type_Invariant    =>
7390             T := Standard_Boolean;
7391
7392          --  Here is the list of aspects that don't require delay analysis
7393
7394          when Aspect_Abstract_State       |
7395               Aspect_Contract_Cases       |
7396               Aspect_Dimension            |
7397               Aspect_Dimension_System     |
7398               Aspect_Implicit_Dereference |
7399               Aspect_Post                 |
7400               Aspect_Postcondition        |
7401               Aspect_Pre                  |
7402               Aspect_Precondition         |
7403               Aspect_SPARK_Mode           |
7404               Aspect_Test_Case     =>
7405             raise Program_Error;
7406
7407       end case;
7408
7409       --  Do the preanalyze call
7410
7411       Preanalyze_Spec_Expression (Expression (ASN), T);
7412    end Check_Aspect_At_Freeze_Point;
7413
7414    -----------------------------------
7415    -- Check_Constant_Address_Clause --
7416    -----------------------------------
7417
7418    procedure Check_Constant_Address_Clause
7419      (Expr  : Node_Id;
7420       U_Ent : Entity_Id)
7421    is
7422       procedure Check_At_Constant_Address (Nod : Node_Id);
7423       --  Checks that the given node N represents a name whose 'Address is
7424       --  constant (in the same sense as OK_Constant_Address_Clause, i.e. the
7425       --  address value is the same at the point of declaration of U_Ent and at
7426       --  the time of elaboration of the address clause.
7427
7428       procedure Check_Expr_Constants (Nod : Node_Id);
7429       --  Checks that Nod meets the requirements for a constant address clause
7430       --  in the sense of the enclosing procedure.
7431
7432       procedure Check_List_Constants (Lst : List_Id);
7433       --  Check that all elements of list Lst meet the requirements for a
7434       --  constant address clause in the sense of the enclosing procedure.
7435
7436       -------------------------------
7437       -- Check_At_Constant_Address --
7438       -------------------------------
7439
7440       procedure Check_At_Constant_Address (Nod : Node_Id) is
7441       begin
7442          if Is_Entity_Name (Nod) then
7443             if Present (Address_Clause (Entity ((Nod)))) then
7444                Error_Msg_NE
7445                  ("invalid address clause for initialized object &!",
7446                            Nod, U_Ent);
7447                Error_Msg_NE
7448                  ("address for& cannot" &
7449                     " depend on another address clause! (RM 13.1(22))!",
7450                   Nod, U_Ent);
7451
7452             elsif In_Same_Source_Unit (Entity (Nod), U_Ent)
7453               and then Sloc (U_Ent) < Sloc (Entity (Nod))
7454             then
7455                Error_Msg_NE
7456                  ("invalid address clause for initialized object &!",
7457                   Nod, U_Ent);
7458                Error_Msg_Node_2 := U_Ent;
7459                Error_Msg_NE
7460                  ("\& must be defined before & (RM 13.1(22))!",
7461                   Nod, Entity (Nod));
7462             end if;
7463
7464          elsif Nkind (Nod) = N_Selected_Component then
7465             declare
7466                T : constant Entity_Id := Etype (Prefix (Nod));
7467
7468             begin
7469                if (Is_Record_Type (T)
7470                     and then Has_Discriminants (T))
7471                  or else
7472                   (Is_Access_Type (T)
7473                      and then Is_Record_Type (Designated_Type (T))
7474                      and then Has_Discriminants (Designated_Type (T)))
7475                then
7476                   Error_Msg_NE
7477                     ("invalid address clause for initialized object &!",
7478                      Nod, U_Ent);
7479                   Error_Msg_N
7480                     ("\address cannot depend on component" &
7481                      " of discriminated record (RM 13.1(22))!",
7482                      Nod);
7483                else
7484                   Check_At_Constant_Address (Prefix (Nod));
7485                end if;
7486             end;
7487
7488          elsif Nkind (Nod) = N_Indexed_Component then
7489             Check_At_Constant_Address (Prefix (Nod));
7490             Check_List_Constants (Expressions (Nod));
7491
7492          else
7493             Check_Expr_Constants (Nod);
7494          end if;
7495       end Check_At_Constant_Address;
7496
7497       --------------------------
7498       -- Check_Expr_Constants --
7499       --------------------------
7500
7501       procedure Check_Expr_Constants (Nod : Node_Id) is
7502          Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent);
7503          Ent       : Entity_Id           := Empty;
7504
7505       begin
7506          if Nkind (Nod) in N_Has_Etype
7507            and then Etype (Nod) = Any_Type
7508          then
7509             return;
7510          end if;
7511
7512          case Nkind (Nod) is
7513             when N_Empty | N_Error =>
7514                return;
7515
7516             when N_Identifier | N_Expanded_Name =>
7517                Ent := Entity (Nod);
7518
7519                --  We need to look at the original node if it is different
7520                --  from the node, since we may have rewritten things and
7521                --  substituted an identifier representing the rewrite.
7522
7523                if Original_Node (Nod) /= Nod then
7524                   Check_Expr_Constants (Original_Node (Nod));
7525
7526                   --  If the node is an object declaration without initial
7527                   --  value, some code has been expanded, and the expression
7528                   --  is not constant, even if the constituents might be
7529                   --  acceptable, as in A'Address + offset.
7530
7531                   if Ekind (Ent) = E_Variable
7532                     and then
7533                       Nkind (Declaration_Node (Ent)) = N_Object_Declaration
7534                     and then
7535                       No (Expression (Declaration_Node (Ent)))
7536                   then
7537                      Error_Msg_NE
7538                        ("invalid address clause for initialized object &!",
7539                         Nod, U_Ent);
7540
7541                   --  If entity is constant, it may be the result of expanding
7542                   --  a check. We must verify that its declaration appears
7543                   --  before the object in question, else we also reject the
7544                   --  address clause.
7545
7546                   elsif Ekind (Ent) = E_Constant
7547                     and then In_Same_Source_Unit (Ent, U_Ent)
7548                     and then Sloc (Ent) > Loc_U_Ent
7549                   then
7550                      Error_Msg_NE
7551                        ("invalid address clause for initialized object &!",
7552                         Nod, U_Ent);
7553                   end if;
7554
7555                   return;
7556                end if;
7557
7558                --  Otherwise look at the identifier and see if it is OK
7559
7560                if Ekind_In (Ent, E_Named_Integer, E_Named_Real)
7561                  or else Is_Type (Ent)
7562                then
7563                   return;
7564
7565                elsif
7566                   Ekind (Ent) = E_Constant
7567                     or else
7568                   Ekind (Ent) = E_In_Parameter
7569                then
7570                   --  This is the case where we must have Ent defined before
7571                   --  U_Ent. Clearly if they are in different units this
7572                   --  requirement is met since the unit containing Ent is
7573                   --  already processed.
7574
7575                   if not In_Same_Source_Unit (Ent, U_Ent) then
7576                      return;
7577
7578                   --  Otherwise location of Ent must be before the location
7579                   --  of U_Ent, that's what prior defined means.
7580
7581                   elsif Sloc (Ent) < Loc_U_Ent then
7582                      return;
7583
7584                   else
7585                      Error_Msg_NE
7586                        ("invalid address clause for initialized object &!",
7587                         Nod, U_Ent);
7588                      Error_Msg_Node_2 := U_Ent;
7589                      Error_Msg_NE
7590                        ("\& must be defined before & (RM 13.1(22))!",
7591                         Nod, Ent);
7592                   end if;
7593
7594                elsif Nkind (Original_Node (Nod)) = N_Function_Call then
7595                   Check_Expr_Constants (Original_Node (Nod));
7596
7597                else
7598                   Error_Msg_NE
7599                     ("invalid address clause for initialized object &!",
7600                      Nod, U_Ent);
7601
7602                   if Comes_From_Source (Ent) then
7603                      Error_Msg_NE
7604                        ("\reference to variable& not allowed"
7605                           & " (RM 13.1(22))!", Nod, Ent);
7606                   else
7607                      Error_Msg_N
7608                        ("non-static expression not allowed"
7609                           & " (RM 13.1(22))!", Nod);
7610                   end if;
7611                end if;
7612
7613             when N_Integer_Literal   =>
7614
7615                --  If this is a rewritten unchecked conversion, in a system
7616                --  where Address is an integer type, always use the base type
7617                --  for a literal value. This is user-friendly and prevents
7618                --  order-of-elaboration issues with instances of unchecked
7619                --  conversion.
7620
7621                if Nkind (Original_Node (Nod)) = N_Function_Call then
7622                   Set_Etype (Nod, Base_Type (Etype (Nod)));
7623                end if;
7624
7625             when N_Real_Literal      |
7626                  N_String_Literal    |
7627                  N_Character_Literal =>
7628                return;
7629
7630             when N_Range =>
7631                Check_Expr_Constants (Low_Bound (Nod));
7632                Check_Expr_Constants (High_Bound (Nod));
7633
7634             when N_Explicit_Dereference =>
7635                Check_Expr_Constants (Prefix (Nod));
7636
7637             when N_Indexed_Component =>
7638                Check_Expr_Constants (Prefix (Nod));
7639                Check_List_Constants (Expressions (Nod));
7640
7641             when N_Slice =>
7642                Check_Expr_Constants (Prefix (Nod));
7643                Check_Expr_Constants (Discrete_Range (Nod));
7644
7645             when N_Selected_Component =>
7646                Check_Expr_Constants (Prefix (Nod));
7647
7648             when N_Attribute_Reference =>
7649                if Nam_In (Attribute_Name (Nod), Name_Address,
7650                                                 Name_Access,
7651                                                 Name_Unchecked_Access,
7652                                                 Name_Unrestricted_Access)
7653                then
7654                   Check_At_Constant_Address (Prefix (Nod));
7655
7656                else
7657                   Check_Expr_Constants (Prefix (Nod));
7658                   Check_List_Constants (Expressions (Nod));
7659                end if;
7660
7661             when N_Aggregate =>
7662                Check_List_Constants (Component_Associations (Nod));
7663                Check_List_Constants (Expressions (Nod));
7664
7665             when N_Component_Association =>
7666                Check_Expr_Constants (Expression (Nod));
7667
7668             when N_Extension_Aggregate =>
7669                Check_Expr_Constants (Ancestor_Part (Nod));
7670                Check_List_Constants (Component_Associations (Nod));
7671                Check_List_Constants (Expressions (Nod));
7672
7673             when N_Null =>
7674                return;
7675
7676             when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
7677                Check_Expr_Constants (Left_Opnd (Nod));
7678                Check_Expr_Constants (Right_Opnd (Nod));
7679
7680             when N_Unary_Op =>
7681                Check_Expr_Constants (Right_Opnd (Nod));
7682
7683             when N_Type_Conversion           |
7684                  N_Qualified_Expression      |
7685                  N_Allocator                 |
7686                  N_Unchecked_Type_Conversion =>
7687                Check_Expr_Constants (Expression (Nod));
7688
7689             when N_Function_Call =>
7690                if not Is_Pure (Entity (Name (Nod))) then
7691                   Error_Msg_NE
7692                     ("invalid address clause for initialized object &!",
7693                      Nod, U_Ent);
7694
7695                   Error_Msg_NE
7696                     ("\function & is not pure (RM 13.1(22))!",
7697                      Nod, Entity (Name (Nod)));
7698
7699                else
7700                   Check_List_Constants (Parameter_Associations (Nod));
7701                end if;
7702
7703             when N_Parameter_Association =>
7704                Check_Expr_Constants (Explicit_Actual_Parameter (Nod));
7705
7706             when others =>
7707                Error_Msg_NE
7708                  ("invalid address clause for initialized object &!",
7709                   Nod, U_Ent);
7710                Error_Msg_NE
7711                  ("\must be constant defined before& (RM 13.1(22))!",
7712                   Nod, U_Ent);
7713          end case;
7714       end Check_Expr_Constants;
7715
7716       --------------------------
7717       -- Check_List_Constants --
7718       --------------------------
7719
7720       procedure Check_List_Constants (Lst : List_Id) is
7721          Nod1 : Node_Id;
7722
7723       begin
7724          if Present (Lst) then
7725             Nod1 := First (Lst);
7726             while Present (Nod1) loop
7727                Check_Expr_Constants (Nod1);
7728                Next (Nod1);
7729             end loop;
7730          end if;
7731       end Check_List_Constants;
7732
7733    --  Start of processing for Check_Constant_Address_Clause
7734
7735    begin
7736       --  If rep_clauses are to be ignored, no need for legality checks. In
7737       --  particular, no need to pester user about rep clauses that violate
7738       --  the rule on constant addresses, given that these clauses will be
7739       --  removed by Freeze before they reach the back end.
7740
7741       if not Ignore_Rep_Clauses then
7742          Check_Expr_Constants (Expr);
7743       end if;
7744    end Check_Constant_Address_Clause;
7745
7746    ----------------------------------------
7747    -- Check_Record_Representation_Clause --
7748    ----------------------------------------
7749
7750    procedure Check_Record_Representation_Clause (N : Node_Id) is
7751       Loc     : constant Source_Ptr := Sloc (N);
7752       Ident   : constant Node_Id    := Identifier (N);
7753       Rectype : Entity_Id;
7754       Fent    : Entity_Id;
7755       CC      : Node_Id;
7756       Fbit    : Uint;
7757       Lbit    : Uint;
7758       Hbit    : Uint := Uint_0;
7759       Comp    : Entity_Id;
7760       Pcomp   : Entity_Id;
7761
7762       Max_Bit_So_Far : Uint;
7763       --  Records the maximum bit position so far. If all field positions
7764       --  are monotonically increasing, then we can skip the circuit for
7765       --  checking for overlap, since no overlap is possible.
7766
7767       Tagged_Parent : Entity_Id := Empty;
7768       --  This is set in the case of a derived tagged type for which we have
7769       --  Is_Fully_Repped_Tagged_Type True (indicating that all components are
7770       --  positioned by record representation clauses). In this case we must
7771       --  check for overlap between components of this tagged type, and the
7772       --  components of its parent. Tagged_Parent will point to this parent
7773       --  type. For all other cases Tagged_Parent is left set to Empty.
7774
7775       Parent_Last_Bit : Uint;
7776       --  Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the
7777       --  last bit position for any field in the parent type. We only need to
7778       --  check overlap for fields starting below this point.
7779
7780       Overlap_Check_Required : Boolean;
7781       --  Used to keep track of whether or not an overlap check is required
7782
7783       Overlap_Detected : Boolean := False;
7784       --  Set True if an overlap is detected
7785
7786       Ccount : Natural := 0;
7787       --  Number of component clauses in record rep clause
7788
7789       procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id);
7790       --  Given two entities for record components or discriminants, checks
7791       --  if they have overlapping component clauses and issues errors if so.
7792
7793       procedure Find_Component;
7794       --  Finds component entity corresponding to current component clause (in
7795       --  CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin
7796       --  start/stop bits for the field. If there is no matching component or
7797       --  if the matching component does not have a component clause, then
7798       --  that's an error and Comp is set to Empty, but no error message is
7799       --  issued, since the message was already given. Comp is also set to
7800       --  Empty if the current "component clause" is in fact a pragma.
7801
7802       -----------------------------
7803       -- Check_Component_Overlap --
7804       -----------------------------
7805
7806       procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is
7807          CC1 : constant Node_Id := Component_Clause (C1_Ent);
7808          CC2 : constant Node_Id := Component_Clause (C2_Ent);
7809
7810       begin
7811          if Present (CC1) and then Present (CC2) then
7812
7813             --  Exclude odd case where we have two tag components in the same
7814             --  record, both at location zero. This seems a bit strange, but
7815             --  it seems to happen in some circumstances, perhaps on an error.
7816
7817             if Nam_In (Chars (C1_Ent), Name_uTag, Name_uTag) then
7818                return;
7819             end if;
7820
7821             --  Here we check if the two fields overlap
7822
7823             declare
7824                S1 : constant Uint := Component_Bit_Offset (C1_Ent);
7825                S2 : constant Uint := Component_Bit_Offset (C2_Ent);
7826                E1 : constant Uint := S1 + Esize (C1_Ent);
7827                E2 : constant Uint := S2 + Esize (C2_Ent);
7828
7829             begin
7830                if E2 <= S1 or else E1 <= S2 then
7831                   null;
7832                else
7833                   Error_Msg_Node_2 := Component_Name (CC2);
7834                   Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
7835                   Error_Msg_Node_1 := Component_Name (CC1);
7836                   Error_Msg_N
7837                     ("component& overlaps & #", Component_Name (CC1));
7838                   Overlap_Detected := True;
7839                end if;
7840             end;
7841          end if;
7842       end Check_Component_Overlap;
7843
7844       --------------------
7845       -- Find_Component --
7846       --------------------
7847
7848       procedure Find_Component is
7849
7850          procedure Search_Component (R : Entity_Id);
7851          --  Search components of R for a match. If found, Comp is set
7852
7853          ----------------------
7854          -- Search_Component --
7855          ----------------------
7856
7857          procedure Search_Component (R : Entity_Id) is
7858          begin
7859             Comp := First_Component_Or_Discriminant (R);
7860             while Present (Comp) loop
7861
7862                --  Ignore error of attribute name for component name (we
7863                --  already gave an error message for this, so no need to
7864                --  complain here)
7865
7866                if Nkind (Component_Name (CC)) = N_Attribute_Reference then
7867                   null;
7868                else
7869                   exit when Chars (Comp) = Chars (Component_Name (CC));
7870                end if;
7871
7872                Next_Component_Or_Discriminant (Comp);
7873             end loop;
7874          end Search_Component;
7875
7876       --  Start of processing for Find_Component
7877
7878       begin
7879          --  Return with Comp set to Empty if we have a pragma
7880
7881          if Nkind (CC) = N_Pragma then
7882             Comp := Empty;
7883             return;
7884          end if;
7885
7886          --  Search current record for matching component
7887
7888          Search_Component (Rectype);
7889
7890          --  If not found, maybe component of base type discriminant that is
7891          --  absent from statically constrained first subtype.
7892
7893          if No (Comp) then
7894             Search_Component (Base_Type (Rectype));
7895          end if;
7896
7897          --  If no component, or the component does not reference the component
7898          --  clause in question, then there was some previous error for which
7899          --  we already gave a message, so just return with Comp Empty.
7900
7901          if No (Comp) or else Component_Clause (Comp) /= CC then
7902             Check_Error_Detected;
7903             Comp := Empty;
7904
7905          --  Normal case where we have a component clause
7906
7907          else
7908             Fbit := Component_Bit_Offset (Comp);
7909             Lbit := Fbit + Esize (Comp) - 1;
7910          end if;
7911       end Find_Component;
7912
7913    --  Start of processing for Check_Record_Representation_Clause
7914
7915    begin
7916       Find_Type (Ident);
7917       Rectype := Entity (Ident);
7918
7919       if Rectype = Any_Type then
7920          return;
7921       else
7922          Rectype := Underlying_Type (Rectype);
7923       end if;
7924
7925       --  See if we have a fully repped derived tagged type
7926
7927       declare
7928          PS : constant Entity_Id := Parent_Subtype (Rectype);
7929
7930       begin
7931          if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then
7932             Tagged_Parent := PS;
7933
7934             --  Find maximum bit of any component of the parent type
7935
7936             Parent_Last_Bit := UI_From_Int (System_Address_Size - 1);
7937             Pcomp := First_Entity (Tagged_Parent);
7938             while Present (Pcomp) loop
7939                if Ekind_In (Pcomp, E_Discriminant, E_Component) then
7940                   if Component_Bit_Offset (Pcomp) /= No_Uint
7941                     and then Known_Static_Esize (Pcomp)
7942                   then
7943                      Parent_Last_Bit :=
7944                        UI_Max
7945                          (Parent_Last_Bit,
7946                           Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1);
7947                   end if;
7948
7949                   Next_Entity (Pcomp);
7950                end if;
7951             end loop;
7952          end if;
7953       end;
7954
7955       --  All done if no component clauses
7956
7957       CC := First (Component_Clauses (N));
7958
7959       if No (CC) then
7960          return;
7961       end if;
7962
7963       --  If a tag is present, then create a component clause that places it
7964       --  at the start of the record (otherwise gigi may place it after other
7965       --  fields that have rep clauses).
7966
7967       Fent := First_Entity (Rectype);
7968
7969       if Nkind (Fent) = N_Defining_Identifier
7970         and then Chars (Fent) = Name_uTag
7971       then
7972          Set_Component_Bit_Offset    (Fent, Uint_0);
7973          Set_Normalized_Position     (Fent, Uint_0);
7974          Set_Normalized_First_Bit    (Fent, Uint_0);
7975          Set_Normalized_Position_Max (Fent, Uint_0);
7976          Init_Esize                  (Fent, System_Address_Size);
7977
7978          Set_Component_Clause (Fent,
7979            Make_Component_Clause (Loc,
7980              Component_Name => Make_Identifier (Loc, Name_uTag),
7981
7982              Position  => Make_Integer_Literal (Loc, Uint_0),
7983              First_Bit => Make_Integer_Literal (Loc, Uint_0),
7984              Last_Bit  =>
7985                Make_Integer_Literal (Loc,
7986                  UI_From_Int (System_Address_Size))));
7987
7988          Ccount := Ccount + 1;
7989       end if;
7990
7991       Max_Bit_So_Far := Uint_Minus_1;
7992       Overlap_Check_Required := False;
7993
7994       --  Process the component clauses
7995
7996       while Present (CC) loop
7997          Find_Component;
7998
7999          if Present (Comp) then
8000             Ccount := Ccount + 1;
8001
8002             --  We need a full overlap check if record positions non-monotonic
8003
8004             if Fbit <= Max_Bit_So_Far then
8005                Overlap_Check_Required := True;
8006             end if;
8007
8008             Max_Bit_So_Far := Lbit;
8009
8010             --  Check bit position out of range of specified size
8011
8012             if Has_Size_Clause (Rectype)
8013               and then RM_Size (Rectype) <= Lbit
8014             then
8015                Error_Msg_N
8016                  ("bit number out of range of specified size",
8017                   Last_Bit (CC));
8018
8019                --  Check for overlap with tag component
8020
8021             else
8022                if Is_Tagged_Type (Rectype)
8023                  and then Fbit < System_Address_Size
8024                then
8025                   Error_Msg_NE
8026                     ("component overlaps tag field of&",
8027                      Component_Name (CC), Rectype);
8028                   Overlap_Detected := True;
8029                end if;
8030
8031                if Hbit < Lbit then
8032                   Hbit := Lbit;
8033                end if;
8034             end if;
8035
8036             --  Check parent overlap if component might overlap parent field
8037
8038             if Present (Tagged_Parent) and then Fbit <= Parent_Last_Bit then
8039                Pcomp := First_Component_Or_Discriminant (Tagged_Parent);
8040                while Present (Pcomp) loop
8041                   if not Is_Tag (Pcomp)
8042                     and then Chars (Pcomp) /= Name_uParent
8043                   then
8044                      Check_Component_Overlap (Comp, Pcomp);
8045                   end if;
8046
8047                   Next_Component_Or_Discriminant (Pcomp);
8048                end loop;
8049             end if;
8050          end if;
8051
8052          Next (CC);
8053       end loop;
8054
8055       --  Now that we have processed all the component clauses, check for
8056       --  overlap. We have to leave this till last, since the components can
8057       --  appear in any arbitrary order in the representation clause.
8058
8059       --  We do not need this check if all specified ranges were monotonic,
8060       --  as recorded by Overlap_Check_Required being False at this stage.
8061
8062       --  This first section checks if there are any overlapping entries at
8063       --  all. It does this by sorting all entries and then seeing if there are
8064       --  any overlaps. If there are none, then that is decisive, but if there
8065       --  are overlaps, they may still be OK (they may result from fields in
8066       --  different variants).
8067
8068       if Overlap_Check_Required then
8069          Overlap_Check1 : declare
8070
8071             OC_Fbit : array (0 .. Ccount) of Uint;
8072             --  First-bit values for component clauses, the value is the offset
8073             --  of the first bit of the field from start of record. The zero
8074             --  entry is for use in sorting.
8075
8076             OC_Lbit : array (0 .. Ccount) of Uint;
8077             --  Last-bit values for component clauses, the value is the offset
8078             --  of the last bit of the field from start of record. The zero
8079             --  entry is for use in sorting.
8080
8081             OC_Count : Natural := 0;
8082             --  Count of entries in OC_Fbit and OC_Lbit
8083
8084             function OC_Lt (Op1, Op2 : Natural) return Boolean;
8085             --  Compare routine for Sort
8086
8087             procedure OC_Move (From : Natural; To : Natural);
8088             --  Move routine for Sort
8089
8090             package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt);
8091
8092             -----------
8093             -- OC_Lt --
8094             -----------
8095
8096             function OC_Lt (Op1, Op2 : Natural) return Boolean is
8097             begin
8098                return OC_Fbit (Op1) < OC_Fbit (Op2);
8099             end OC_Lt;
8100
8101             -------------
8102             -- OC_Move --
8103             -------------
8104
8105             procedure OC_Move (From : Natural; To : Natural) is
8106             begin
8107                OC_Fbit (To) := OC_Fbit (From);
8108                OC_Lbit (To) := OC_Lbit (From);
8109             end OC_Move;
8110
8111             --  Start of processing for Overlap_Check
8112
8113          begin
8114             CC := First (Component_Clauses (N));
8115             while Present (CC) loop
8116
8117                --  Exclude component clause already marked in error
8118
8119                if not Error_Posted (CC) then
8120                   Find_Component;
8121
8122                   if Present (Comp) then
8123                      OC_Count := OC_Count + 1;
8124                      OC_Fbit (OC_Count) := Fbit;
8125                      OC_Lbit (OC_Count) := Lbit;
8126                   end if;
8127                end if;
8128
8129                Next (CC);
8130             end loop;
8131
8132             Sorting.Sort (OC_Count);
8133
8134             Overlap_Check_Required := False;
8135             for J in 1 .. OC_Count - 1 loop
8136                if OC_Lbit (J) >= OC_Fbit (J + 1) then
8137                   Overlap_Check_Required := True;
8138                   exit;
8139                end if;
8140             end loop;
8141          end Overlap_Check1;
8142       end if;
8143
8144       --  If Overlap_Check_Required is still True, then we have to do the full
8145       --  scale overlap check, since we have at least two fields that do
8146       --  overlap, and we need to know if that is OK since they are in
8147       --  different variant, or whether we have a definite problem.
8148
8149       if Overlap_Check_Required then
8150          Overlap_Check2 : declare
8151             C1_Ent, C2_Ent : Entity_Id;
8152             --  Entities of components being checked for overlap
8153
8154             Clist : Node_Id;
8155             --  Component_List node whose Component_Items are being checked
8156
8157             Citem : Node_Id;
8158             --  Component declaration for component being checked
8159
8160          begin
8161             C1_Ent := First_Entity (Base_Type (Rectype));
8162
8163             --  Loop through all components in record. For each component check
8164             --  for overlap with any of the preceding elements on the component
8165             --  list containing the component and also, if the component is in
8166             --  a variant, check against components outside the case structure.
8167             --  This latter test is repeated recursively up the variant tree.
8168
8169             Main_Component_Loop : while Present (C1_Ent) loop
8170                if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then
8171                   goto Continue_Main_Component_Loop;
8172                end if;
8173
8174                --  Skip overlap check if entity has no declaration node. This
8175                --  happens with discriminants in constrained derived types.
8176                --  Possibly we are missing some checks as a result, but that
8177                --  does not seem terribly serious.
8178
8179                if No (Declaration_Node (C1_Ent)) then
8180                   goto Continue_Main_Component_Loop;
8181                end if;
8182
8183                Clist := Parent (List_Containing (Declaration_Node (C1_Ent)));
8184
8185                --  Loop through component lists that need checking. Check the
8186                --  current component list and all lists in variants above us.
8187
8188                Component_List_Loop : loop
8189
8190                   --  If derived type definition, go to full declaration
8191                   --  If at outer level, check discriminants if there are any.
8192
8193                   if Nkind (Clist) = N_Derived_Type_Definition then
8194                      Clist := Parent (Clist);
8195                   end if;
8196
8197                   --  Outer level of record definition, check discriminants
8198
8199                   if Nkind_In (Clist, N_Full_Type_Declaration,
8200                                       N_Private_Type_Declaration)
8201                   then
8202                      if Has_Discriminants (Defining_Identifier (Clist)) then
8203                         C2_Ent :=
8204                           First_Discriminant (Defining_Identifier (Clist));
8205                         while Present (C2_Ent) loop
8206                            exit when C1_Ent = C2_Ent;
8207                            Check_Component_Overlap (C1_Ent, C2_Ent);
8208                            Next_Discriminant (C2_Ent);
8209                         end loop;
8210                      end if;
8211
8212                      --  Record extension case
8213
8214                   elsif Nkind (Clist) = N_Derived_Type_Definition then
8215                      Clist := Empty;
8216
8217                      --  Otherwise check one component list
8218
8219                   else
8220                      Citem := First (Component_Items (Clist));
8221                      while Present (Citem) loop
8222                         if Nkind (Citem) = N_Component_Declaration then
8223                            C2_Ent := Defining_Identifier (Citem);
8224                            exit when C1_Ent = C2_Ent;
8225                            Check_Component_Overlap (C1_Ent, C2_Ent);
8226                         end if;
8227
8228                         Next (Citem);
8229                      end loop;
8230                   end if;
8231
8232                   --  Check for variants above us (the parent of the Clist can
8233                   --  be a variant, in which case its parent is a variant part,
8234                   --  and the parent of the variant part is a component list
8235                   --  whose components must all be checked against the current
8236                   --  component for overlap).
8237
8238                   if Nkind (Parent (Clist)) = N_Variant then
8239                      Clist := Parent (Parent (Parent (Clist)));
8240
8241                      --  Check for possible discriminant part in record, this
8242                      --  is treated essentially as another level in the
8243                      --  recursion. For this case the parent of the component
8244                      --  list is the record definition, and its parent is the
8245                      --  full type declaration containing the discriminant
8246                      --  specifications.
8247
8248                   elsif Nkind (Parent (Clist)) = N_Record_Definition then
8249                      Clist := Parent (Parent ((Clist)));
8250
8251                      --  If neither of these two cases, we are at the top of
8252                      --  the tree.
8253
8254                   else
8255                      exit Component_List_Loop;
8256                   end if;
8257                end loop Component_List_Loop;
8258
8259                <<Continue_Main_Component_Loop>>
8260                Next_Entity (C1_Ent);
8261
8262             end loop Main_Component_Loop;
8263          end Overlap_Check2;
8264       end if;
8265
8266       --  The following circuit deals with warning on record holes (gaps). We
8267       --  skip this check if overlap was detected, since it makes sense for the
8268       --  programmer to fix this illegality before worrying about warnings.
8269
8270       if not Overlap_Detected and Warn_On_Record_Holes then
8271          Record_Hole_Check : declare
8272             Decl : constant Node_Id := Declaration_Node (Base_Type (Rectype));
8273             --  Full declaration of record type
8274
8275             procedure Check_Component_List
8276               (CL   : Node_Id;
8277                Sbit : Uint;
8278                DS   : List_Id);
8279             --  Check component list CL for holes. The starting bit should be
8280             --  Sbit. which is zero for the main record component list and set
8281             --  appropriately for recursive calls for variants. DS is set to
8282             --  a list of discriminant specifications to be included in the
8283             --  consideration of components. It is No_List if none to consider.
8284
8285             --------------------------
8286             -- Check_Component_List --
8287             --------------------------
8288
8289             procedure Check_Component_List
8290               (CL   : Node_Id;
8291                Sbit : Uint;
8292                DS   : List_Id)
8293             is
8294                Compl : Integer;
8295
8296             begin
8297                Compl := Integer (List_Length (Component_Items (CL)));
8298
8299                if DS /= No_List then
8300                   Compl := Compl + Integer (List_Length (DS));
8301                end if;
8302
8303                declare
8304                   Comps : array (Natural range 0 .. Compl) of Entity_Id;
8305                   --  Gather components (zero entry is for sort routine)
8306
8307                   Ncomps : Natural := 0;
8308                   --  Number of entries stored in Comps (starting at Comps (1))
8309
8310                   Citem : Node_Id;
8311                   --  One component item or discriminant specification
8312
8313                   Nbit  : Uint;
8314                   --  Starting bit for next component
8315
8316                   CEnt  : Entity_Id;
8317                   --  Component entity
8318
8319                   Variant : Node_Id;
8320                   --  One variant
8321
8322                   function Lt (Op1, Op2 : Natural) return Boolean;
8323                   --  Compare routine for Sort
8324
8325                   procedure Move (From : Natural; To : Natural);
8326                   --  Move routine for Sort
8327
8328                   package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
8329
8330                   --------
8331                   -- Lt --
8332                   --------
8333
8334                   function Lt (Op1, Op2 : Natural) return Boolean is
8335                   begin
8336                      return Component_Bit_Offset (Comps (Op1))
8337                        <
8338                        Component_Bit_Offset (Comps (Op2));
8339                   end Lt;
8340
8341                   ----------
8342                   -- Move --
8343                   ----------
8344
8345                   procedure Move (From : Natural; To : Natural) is
8346                   begin
8347                      Comps (To) := Comps (From);
8348                   end Move;
8349
8350                begin
8351                   --  Gather discriminants into Comp
8352
8353                   if DS /= No_List then
8354                      Citem := First (DS);
8355                      while Present (Citem) loop
8356                         if Nkind (Citem) = N_Discriminant_Specification then
8357                            declare
8358                               Ent : constant Entity_Id :=
8359                                       Defining_Identifier (Citem);
8360                            begin
8361                               if Ekind (Ent) = E_Discriminant then
8362                                  Ncomps := Ncomps + 1;
8363                                  Comps (Ncomps) := Ent;
8364                               end if;
8365                            end;
8366                         end if;
8367
8368                         Next (Citem);
8369                      end loop;
8370                   end if;
8371
8372                   --  Gather component entities into Comp
8373
8374                   Citem := First (Component_Items (CL));
8375                   while Present (Citem) loop
8376                      if Nkind (Citem) = N_Component_Declaration then
8377                         Ncomps := Ncomps + 1;
8378                         Comps (Ncomps) := Defining_Identifier (Citem);
8379                      end if;
8380
8381                      Next (Citem);
8382                   end loop;
8383
8384                   --  Now sort the component entities based on the first bit.
8385                   --  Note we already know there are no overlapping components.
8386
8387                   Sorting.Sort (Ncomps);
8388
8389                   --  Loop through entries checking for holes
8390
8391                   Nbit := Sbit;
8392                   for J in 1 .. Ncomps loop
8393                      CEnt := Comps (J);
8394                      Error_Msg_Uint_1 := Component_Bit_Offset (CEnt) - Nbit;
8395
8396                      if Error_Msg_Uint_1 > 0 then
8397                         Error_Msg_NE
8398                           ("?H?^-bit gap before component&",
8399                            Component_Name (Component_Clause (CEnt)), CEnt);
8400                      end if;
8401
8402                      Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt);
8403                   end loop;
8404
8405                   --  Process variant parts recursively if present
8406
8407                   if Present (Variant_Part (CL)) then
8408                      Variant := First (Variants (Variant_Part (CL)));
8409                      while Present (Variant) loop
8410                         Check_Component_List
8411                           (Component_List (Variant), Nbit, No_List);
8412                         Next (Variant);
8413                      end loop;
8414                   end if;
8415                end;
8416             end Check_Component_List;
8417
8418          --  Start of processing for Record_Hole_Check
8419
8420          begin
8421             declare
8422                Sbit : Uint;
8423
8424             begin
8425                if Is_Tagged_Type (Rectype) then
8426                   Sbit := UI_From_Int (System_Address_Size);
8427                else
8428                   Sbit := Uint_0;
8429                end if;
8430
8431                if Nkind (Decl) = N_Full_Type_Declaration
8432                  and then Nkind (Type_Definition (Decl)) = N_Record_Definition
8433                then
8434                   Check_Component_List
8435                     (Component_List (Type_Definition (Decl)),
8436                      Sbit,
8437                      Discriminant_Specifications (Decl));
8438                end if;
8439             end;
8440          end Record_Hole_Check;
8441       end if;
8442
8443       --  For records that have component clauses for all components, and whose
8444       --  size is less than or equal to 32, we need to know the size in the
8445       --  front end to activate possible packed array processing where the
8446       --  component type is a record.
8447
8448       --  At this stage Hbit + 1 represents the first unused bit from all the
8449       --  component clauses processed, so if the component clauses are
8450       --  complete, then this is the length of the record.
8451
8452       --  For records longer than System.Storage_Unit, and for those where not
8453       --  all components have component clauses, the back end determines the
8454       --  length (it may for example be appropriate to round up the size
8455       --  to some convenient boundary, based on alignment considerations, etc).
8456
8457       if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then
8458
8459          --  Nothing to do if at least one component has no component clause
8460
8461          Comp := First_Component_Or_Discriminant (Rectype);
8462          while Present (Comp) loop
8463             exit when No (Component_Clause (Comp));
8464             Next_Component_Or_Discriminant (Comp);
8465          end loop;
8466
8467          --  If we fall out of loop, all components have component clauses
8468          --  and so we can set the size to the maximum value.
8469
8470          if No (Comp) then
8471             Set_RM_Size (Rectype, Hbit + 1);
8472          end if;
8473       end if;
8474    end Check_Record_Representation_Clause;
8475
8476    ----------------
8477    -- Check_Size --
8478    ----------------
8479
8480    procedure Check_Size
8481      (N      : Node_Id;
8482       T      : Entity_Id;
8483       Siz    : Uint;
8484       Biased : out Boolean)
8485    is
8486       UT : constant Entity_Id := Underlying_Type (T);
8487       M  : Uint;
8488
8489    begin
8490       Biased := False;
8491
8492       --  Reject patently improper size values.
8493
8494       if Is_Elementary_Type (T)
8495         and then Siz > UI_From_Int (Int'Last)
8496       then
8497          Error_Msg_N ("Size value too large for elementary type", N);
8498
8499          if Nkind (Original_Node (N)) = N_Op_Expon then
8500             Error_Msg_N
8501               ("\maybe '* was meant, rather than '*'*", Original_Node (N));
8502          end if;
8503       end if;
8504
8505       --  Dismiss generic types
8506
8507       if Is_Generic_Type (T)
8508            or else
8509          Is_Generic_Type (UT)
8510            or else
8511          Is_Generic_Type (Root_Type (UT))
8512       then
8513          return;
8514
8515       --  Guard against previous errors
8516
8517       elsif No (UT) or else UT = Any_Type then
8518          Check_Error_Detected;
8519          return;
8520
8521       --  Check case of bit packed array
8522
8523       elsif Is_Array_Type (UT)
8524         and then Known_Static_Component_Size (UT)
8525         and then Is_Bit_Packed_Array (UT)
8526       then
8527          declare
8528             Asiz : Uint;
8529             Indx : Node_Id;
8530             Ityp : Entity_Id;
8531
8532          begin
8533             Asiz := Component_Size (UT);
8534             Indx := First_Index (UT);
8535             loop
8536                Ityp := Etype (Indx);
8537
8538                --  If non-static bound, then we are not in the business of
8539                --  trying to check the length, and indeed an error will be
8540                --  issued elsewhere, since sizes of non-static array types
8541                --  cannot be set implicitly or explicitly.
8542
8543                if not Is_Static_Subtype (Ityp) then
8544                   return;
8545                end if;
8546
8547                --  Otherwise accumulate next dimension
8548
8549                Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) -
8550                                Expr_Value (Type_Low_Bound  (Ityp)) +
8551                                Uint_1);
8552
8553                Next_Index (Indx);
8554                exit when No (Indx);
8555             end loop;
8556
8557             if Asiz <= Siz then
8558                return;
8559
8560             else
8561                Error_Msg_Uint_1 := Asiz;
8562                Error_Msg_NE
8563                  ("size for& too small, minimum allowed is ^", N, T);
8564                Set_Esize   (T, Asiz);
8565                Set_RM_Size (T, Asiz);
8566             end if;
8567          end;
8568
8569       --  All other composite types are ignored
8570
8571       elsif Is_Composite_Type (UT) then
8572          return;
8573
8574       --  For fixed-point types, don't check minimum if type is not frozen,
8575       --  since we don't know all the characteristics of the type that can
8576       --  affect the size (e.g. a specified small) till freeze time.
8577
8578       elsif Is_Fixed_Point_Type (UT)
8579         and then not Is_Frozen (UT)
8580       then
8581          null;
8582
8583       --  Cases for which a minimum check is required
8584
8585       else
8586          --  Ignore if specified size is correct for the type
8587
8588          if Known_Esize (UT) and then Siz = Esize (UT) then
8589             return;
8590          end if;
8591
8592          --  Otherwise get minimum size
8593
8594          M := UI_From_Int (Minimum_Size (UT));
8595
8596          if Siz < M then
8597
8598             --  Size is less than minimum size, but one possibility remains
8599             --  that we can manage with the new size if we bias the type.
8600
8601             M := UI_From_Int (Minimum_Size (UT, Biased => True));
8602
8603             if Siz < M then
8604                Error_Msg_Uint_1 := M;
8605                Error_Msg_NE
8606                  ("size for& too small, minimum allowed is ^", N, T);
8607                Set_Esize (T, M);
8608                Set_RM_Size (T, M);
8609             else
8610                Biased := True;
8611             end if;
8612          end if;
8613       end if;
8614    end Check_Size;
8615
8616    -------------------------
8617    -- Get_Alignment_Value --
8618    -------------------------
8619
8620    function Get_Alignment_Value (Expr : Node_Id) return Uint is
8621       Align : constant Uint := Static_Integer (Expr);
8622
8623    begin
8624       if Align = No_Uint then
8625          return No_Uint;
8626
8627       elsif Align <= 0 then
8628          Error_Msg_N ("alignment value must be positive", Expr);
8629          return No_Uint;
8630
8631       else
8632          for J in Int range 0 .. 64 loop
8633             declare
8634                M : constant Uint := Uint_2 ** J;
8635
8636             begin
8637                exit when M = Align;
8638
8639                if M > Align then
8640                   Error_Msg_N
8641                     ("alignment value must be power of 2", Expr);
8642                   return No_Uint;
8643                end if;
8644             end;
8645          end loop;
8646
8647          return Align;
8648       end if;
8649    end Get_Alignment_Value;
8650
8651    -------------------------------------
8652    -- Inherit_Aspects_At_Freeze_Point --
8653    -------------------------------------
8654
8655    procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is
8656       function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
8657         (Rep_Item : Node_Id) return Boolean;
8658       --  This routine checks if Rep_Item is either a pragma or an aspect
8659       --  specification node whose correponding pragma (if any) is present in
8660       --  the Rep Item chain of the entity it has been specified to.
8661
8662       --------------------------------------------------
8663       -- Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item --
8664       --------------------------------------------------
8665
8666       function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
8667         (Rep_Item : Node_Id) return Boolean
8668       is
8669       begin
8670          return Nkind (Rep_Item) = N_Pragma
8671            or else Present_In_Rep_Item
8672                      (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item));
8673       end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item;
8674
8675    --  Start of processing for Inherit_Aspects_At_Freeze_Point
8676
8677    begin
8678       --  A representation item is either subtype-specific (Size and Alignment
8679       --  clauses) or type-related (all others).  Subtype-specific aspects may
8680       --  differ for different subtypes of the same type (RM 13.1.8).
8681
8682       --  A derived type inherits each type-related representation aspect of
8683       --  its parent type that was directly specified before the declaration of
8684       --  the derived type (RM 13.1.15).
8685
8686       --  A derived subtype inherits each subtype-specific representation
8687       --  aspect of its parent subtype that was directly specified before the
8688       --  declaration of the derived type (RM 13.1.15).
8689
8690       --  The general processing involves inheriting a representation aspect
8691       --  from a parent type whenever the first rep item (aspect specification,
8692       --  attribute definition clause, pragma) corresponding to the given
8693       --  representation aspect in the rep item chain of Typ, if any, isn't
8694       --  directly specified to Typ but to one of its parents.
8695
8696       --  ??? Note that, for now, just a limited number of representation
8697       --  aspects have been inherited here so far. Many of them are
8698       --  still inherited in Sem_Ch3. This will be fixed soon. Here is
8699       --  a non- exhaustive list of aspects that likely also need to
8700       --  be moved to this routine: Alignment, Component_Alignment,
8701       --  Component_Size, Machine_Radix, Object_Size, Pack, Predicates,
8702       --  Preelaborable_Initialization, RM_Size and Small.
8703
8704       if Nkind (Parent (Typ)) = N_Private_Extension_Declaration then
8705          return;
8706       end if;
8707
8708       --  Ada_05/Ada_2005
8709
8710       if not Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005, False)
8711         and then Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005)
8712         and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
8713                    (Get_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005))
8714       then
8715          Set_Is_Ada_2005_Only (Typ);
8716       end if;
8717
8718       --  Ada_12/Ada_2012
8719
8720       if not Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012, False)
8721         and then Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012)
8722         and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
8723                    (Get_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012))
8724       then
8725          Set_Is_Ada_2012_Only (Typ);
8726       end if;
8727
8728       --  Atomic/Shared
8729
8730       if not Has_Rep_Item (Typ, Name_Atomic, Name_Shared, False)
8731         and then Has_Rep_Pragma (Typ, Name_Atomic, Name_Shared)
8732         and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
8733                    (Get_Rep_Item (Typ, Name_Atomic, Name_Shared))
8734       then
8735          Set_Is_Atomic (Typ);
8736          Set_Treat_As_Volatile (Typ);
8737          Set_Is_Volatile (Typ);
8738       end if;
8739
8740       --  Default_Component_Value
8741
8742       if Is_Array_Type (Typ)
8743         and then Has_Rep_Item (Typ, Name_Default_Component_Value, False)
8744         and then Has_Rep_Item (Typ, Name_Default_Component_Value)
8745       then
8746          Set_Default_Aspect_Component_Value (Typ,
8747            Default_Aspect_Component_Value
8748              (Entity (Get_Rep_Item (Typ, Name_Default_Component_Value))));
8749       end if;
8750
8751       --  Default_Value
8752
8753       if Is_Scalar_Type (Typ)
8754         and then Has_Rep_Item (Typ, Name_Default_Value, False)
8755         and then Has_Rep_Item (Typ, Name_Default_Value)
8756       then
8757          Set_Default_Aspect_Value (Typ,
8758            Default_Aspect_Value
8759              (Entity (Get_Rep_Item (Typ, Name_Default_Value))));
8760       end if;
8761
8762       --  Discard_Names
8763
8764       if not Has_Rep_Item (Typ, Name_Discard_Names, False)
8765         and then Has_Rep_Item (Typ, Name_Discard_Names)
8766         and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
8767                    (Get_Rep_Item (Typ, Name_Discard_Names))
8768       then
8769          Set_Discard_Names (Typ);
8770       end if;
8771
8772       --  Invariants
8773
8774       if not Has_Rep_Item (Typ, Name_Invariant, False)
8775         and then Has_Rep_Item (Typ, Name_Invariant)
8776         and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
8777                    (Get_Rep_Item (Typ, Name_Invariant))
8778       then
8779          Set_Has_Invariants (Typ);
8780
8781          if Class_Present (Get_Rep_Item (Typ, Name_Invariant)) then
8782             Set_Has_Inheritable_Invariants (Typ);
8783          end if;
8784       end if;
8785
8786       --  Volatile
8787
8788       if not Has_Rep_Item (Typ, Name_Volatile, False)
8789         and then Has_Rep_Item (Typ, Name_Volatile)
8790         and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
8791                    (Get_Rep_Item (Typ, Name_Volatile))
8792       then
8793          Set_Treat_As_Volatile (Typ);
8794          Set_Is_Volatile (Typ);
8795       end if;
8796
8797       --  Inheritance for derived types only
8798
8799       if Is_Derived_Type (Typ) then
8800          declare
8801             Bas_Typ     : constant Entity_Id := Base_Type (Typ);
8802             Imp_Bas_Typ : constant Entity_Id := Implementation_Base_Type (Typ);
8803
8804          begin
8805             --  Atomic_Components
8806
8807             if not Has_Rep_Item (Typ, Name_Atomic_Components, False)
8808               and then Has_Rep_Item (Typ, Name_Atomic_Components)
8809               and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
8810                    (Get_Rep_Item (Typ, Name_Atomic_Components))
8811             then
8812                Set_Has_Atomic_Components (Imp_Bas_Typ);
8813             end if;
8814
8815             --  Volatile_Components
8816
8817             if not Has_Rep_Item (Typ, Name_Volatile_Components, False)
8818               and then Has_Rep_Item (Typ, Name_Volatile_Components)
8819               and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
8820                    (Get_Rep_Item (Typ, Name_Volatile_Components))
8821             then
8822                Set_Has_Volatile_Components (Imp_Bas_Typ);
8823             end if;
8824
8825             --  Finalize_Storage_Only.
8826
8827             if not Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only, False)
8828               and then Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only)
8829             then
8830                Set_Finalize_Storage_Only (Bas_Typ);
8831             end if;
8832
8833             --  Universal_Aliasing
8834
8835             if not Has_Rep_Item (Typ, Name_Universal_Aliasing, False)
8836               and then Has_Rep_Item (Typ, Name_Universal_Aliasing)
8837               and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
8838                    (Get_Rep_Item (Typ, Name_Universal_Aliasing))
8839             then
8840                Set_Universal_Aliasing (Imp_Bas_Typ);
8841             end if;
8842
8843             --  Record type specific aspects
8844
8845             if Is_Record_Type (Typ) then
8846
8847                --  Bit_Order
8848
8849                if not Has_Rep_Item (Typ, Name_Bit_Order, False)
8850                  and then Has_Rep_Item (Typ, Name_Bit_Order)
8851                then
8852                   Set_Reverse_Bit_Order (Bas_Typ,
8853                     Reverse_Bit_Order (Entity (Name
8854                       (Get_Rep_Item (Typ, Name_Bit_Order)))));
8855                end if;
8856
8857                --  Scalar_Storage_Order
8858
8859                if not Has_Rep_Item (Typ, Name_Scalar_Storage_Order, False)
8860                  and then Has_Rep_Item (Typ, Name_Scalar_Storage_Order)
8861                then
8862                   Set_Reverse_Storage_Order (Bas_Typ,
8863                     Reverse_Storage_Order (Entity (Name
8864                       (Get_Rep_Item (Typ, Name_Scalar_Storage_Order)))));
8865                end if;
8866             end if;
8867          end;
8868       end if;
8869    end Inherit_Aspects_At_Freeze_Point;
8870
8871    ----------------
8872    -- Initialize --
8873    ----------------
8874
8875    procedure Initialize is
8876    begin
8877       Address_Clause_Checks.Init;
8878       Independence_Checks.Init;
8879       Unchecked_Conversions.Init;
8880    end Initialize;
8881
8882    -------------------------
8883    -- Is_Operational_Item --
8884    -------------------------
8885
8886    function Is_Operational_Item (N : Node_Id) return Boolean is
8887    begin
8888       if Nkind (N) /= N_Attribute_Definition_Clause then
8889          return False;
8890
8891       else
8892          declare
8893             Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
8894          begin
8895             return    Id = Attribute_Input
8896               or else Id = Attribute_Output
8897               or else Id = Attribute_Read
8898               or else Id = Attribute_Write
8899               or else Id = Attribute_External_Tag;
8900          end;
8901       end if;
8902    end Is_Operational_Item;
8903
8904    ------------------
8905    -- Minimum_Size --
8906    ------------------
8907
8908    function Minimum_Size
8909      (T      : Entity_Id;
8910       Biased : Boolean := False) return Nat
8911    is
8912       Lo     : Uint    := No_Uint;
8913       Hi     : Uint    := No_Uint;
8914       LoR    : Ureal   := No_Ureal;
8915       HiR    : Ureal   := No_Ureal;
8916       LoSet  : Boolean := False;
8917       HiSet  : Boolean := False;
8918       B      : Uint;
8919       S      : Nat;
8920       Ancest : Entity_Id;
8921       R_Typ  : constant Entity_Id := Root_Type (T);
8922
8923    begin
8924       --  If bad type, return 0
8925
8926       if T = Any_Type then
8927          return 0;
8928
8929       --  For generic types, just return zero. There cannot be any legitimate
8930       --  need to know such a size, but this routine may be called with a
8931       --  generic type as part of normal processing.
8932
8933       elsif Is_Generic_Type (R_Typ)
8934         or else R_Typ = Any_Type
8935       then
8936          return 0;
8937
8938          --  Access types. Normally an access type cannot have a size smaller
8939          --  than the size of System.Address. The exception is on VMS, where
8940          --  we have short and long addresses, and it is possible for an access
8941          --  type to have a short address size (and thus be less than the size
8942          --  of System.Address itself). We simply skip the check for VMS, and
8943          --  leave it to the back end to do the check.
8944
8945       elsif Is_Access_Type (T) then
8946          if OpenVMS_On_Target then
8947             return 0;
8948          else
8949             return System_Address_Size;
8950          end if;
8951
8952       --  Floating-point types
8953
8954       elsif Is_Floating_Point_Type (T) then
8955          return UI_To_Int (Esize (R_Typ));
8956
8957       --  Discrete types
8958
8959       elsif Is_Discrete_Type (T) then
8960
8961          --  The following loop is looking for the nearest compile time known
8962          --  bounds following the ancestor subtype chain. The idea is to find
8963          --  the most restrictive known bounds information.
8964
8965          Ancest := T;
8966          loop
8967             if Ancest = Any_Type or else Etype (Ancest) = Any_Type then
8968                return 0;
8969             end if;
8970
8971             if not LoSet then
8972                if Compile_Time_Known_Value (Type_Low_Bound (Ancest)) then
8973                   Lo := Expr_Rep_Value (Type_Low_Bound (Ancest));
8974                   LoSet := True;
8975                   exit when HiSet;
8976                end if;
8977             end if;
8978
8979             if not HiSet then
8980                if Compile_Time_Known_Value (Type_High_Bound (Ancest)) then
8981                   Hi := Expr_Rep_Value (Type_High_Bound (Ancest));
8982                   HiSet := True;
8983                   exit when LoSet;
8984                end if;
8985             end if;
8986
8987             Ancest := Ancestor_Subtype (Ancest);
8988
8989             if No (Ancest) then
8990                Ancest := Base_Type (T);
8991
8992                if Is_Generic_Type (Ancest) then
8993                   return 0;
8994                end if;
8995             end if;
8996          end loop;
8997
8998       --  Fixed-point types. We can't simply use Expr_Value to get the
8999       --  Corresponding_Integer_Value values of the bounds, since these do not
9000       --  get set till the type is frozen, and this routine can be called
9001       --  before the type is frozen. Similarly the test for bounds being static
9002       --  needs to include the case where we have unanalyzed real literals for
9003       --  the same reason.
9004
9005       elsif Is_Fixed_Point_Type (T) then
9006
9007          --  The following loop is looking for the nearest compile time known
9008          --  bounds following the ancestor subtype chain. The idea is to find
9009          --  the most restrictive known bounds information.
9010
9011          Ancest := T;
9012          loop
9013             if Ancest = Any_Type or else Etype (Ancest) = Any_Type then
9014                return 0;
9015             end if;
9016
9017             --  Note: In the following two tests for LoSet and HiSet, it may
9018             --  seem redundant to test for N_Real_Literal here since normally
9019             --  one would assume that the test for the value being known at
9020             --  compile time includes this case. However, there is a glitch.
9021             --  If the real literal comes from folding a non-static expression,
9022             --  then we don't consider any non- static expression to be known
9023             --  at compile time if we are in configurable run time mode (needed
9024             --  in some cases to give a clearer definition of what is and what
9025             --  is not accepted). So the test is indeed needed. Without it, we
9026             --  would set neither Lo_Set nor Hi_Set and get an infinite loop.
9027
9028             if not LoSet then
9029                if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal
9030                  or else Compile_Time_Known_Value (Type_Low_Bound (Ancest))
9031                then
9032                   LoR := Expr_Value_R (Type_Low_Bound (Ancest));
9033                   LoSet := True;
9034                   exit when HiSet;
9035                end if;
9036             end if;
9037
9038             if not HiSet then
9039                if Nkind (Type_High_Bound (Ancest)) = N_Real_Literal
9040                  or else Compile_Time_Known_Value (Type_High_Bound (Ancest))
9041                then
9042                   HiR := Expr_Value_R (Type_High_Bound (Ancest));
9043                   HiSet := True;
9044                   exit when LoSet;
9045                end if;
9046             end if;
9047
9048             Ancest := Ancestor_Subtype (Ancest);
9049
9050             if No (Ancest) then
9051                Ancest := Base_Type (T);
9052
9053                if Is_Generic_Type (Ancest) then
9054                   return 0;
9055                end if;
9056             end if;
9057          end loop;
9058
9059          Lo := UR_To_Uint (LoR / Small_Value (T));
9060          Hi := UR_To_Uint (HiR / Small_Value (T));
9061
9062       --  No other types allowed
9063
9064       else
9065          raise Program_Error;
9066       end if;
9067
9068       --  Fall through with Hi and Lo set. Deal with biased case
9069
9070       if (Biased
9071            and then not Is_Fixed_Point_Type (T)
9072            and then not (Is_Enumeration_Type (T)
9073                           and then Has_Non_Standard_Rep (T)))
9074         or else Has_Biased_Representation (T)
9075       then
9076          Hi := Hi - Lo;
9077          Lo := Uint_0;
9078       end if;
9079
9080       --  Signed case. Note that we consider types like range 1 .. -1 to be
9081       --  signed for the purpose of computing the size, since the bounds have
9082       --  to be accommodated in the base type.
9083
9084       if Lo < 0 or else Hi < 0 then
9085          S := 1;
9086          B := Uint_1;
9087
9088          --  S = size, B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
9089          --  Note that we accommodate the case where the bounds cross. This
9090          --  can happen either because of the way the bounds are declared
9091          --  or because of the algorithm in Freeze_Fixed_Point_Type.
9092
9093          while Lo < -B
9094            or else Hi < -B
9095            or else Lo >= B
9096            or else Hi >= B
9097          loop
9098             B := Uint_2 ** S;
9099             S := S + 1;
9100          end loop;
9101
9102       --  Unsigned case
9103
9104       else
9105          --  If both bounds are positive, make sure that both are represen-
9106          --  table in the case where the bounds are crossed. This can happen
9107          --  either because of the way the bounds are declared, or because of
9108          --  the algorithm in Freeze_Fixed_Point_Type.
9109
9110          if Lo > Hi then
9111             Hi := Lo;
9112          end if;
9113
9114          --  S = size, (can accommodate 0 .. (2**size - 1))
9115
9116          S := 0;
9117          while Hi >= Uint_2 ** S loop
9118             S := S + 1;
9119          end loop;
9120       end if;
9121
9122       return S;
9123    end Minimum_Size;
9124
9125    ---------------------------
9126    -- New_Stream_Subprogram --
9127    ---------------------------
9128
9129    procedure New_Stream_Subprogram
9130      (N     : Node_Id;
9131       Ent   : Entity_Id;
9132       Subp  : Entity_Id;
9133       Nam   : TSS_Name_Type)
9134    is
9135       Loc       : constant Source_Ptr := Sloc (N);
9136       Sname     : constant Name_Id    := Make_TSS_Name (Base_Type (Ent), Nam);
9137       Subp_Id   : Entity_Id;
9138       Subp_Decl : Node_Id;
9139       F         : Entity_Id;
9140       Etyp      : Entity_Id;
9141
9142       Defer_Declaration : constant Boolean :=
9143                             Is_Tagged_Type (Ent) or else Is_Private_Type (Ent);
9144       --  For a tagged type, there is a declaration for each stream attribute
9145       --  at the freeze point, and we must generate only a completion of this
9146       --  declaration. We do the same for private types, because the full view
9147       --  might be tagged. Otherwise we generate a declaration at the point of
9148       --  the attribute definition clause.
9149
9150       function Build_Spec return Node_Id;
9151       --  Used for declaration and renaming declaration, so that this is
9152       --  treated as a renaming_as_body.
9153
9154       ----------------
9155       -- Build_Spec --
9156       ----------------
9157
9158       function Build_Spec return Node_Id is
9159          Out_P   : constant Boolean := (Nam = TSS_Stream_Read);
9160          Formals : List_Id;
9161          Spec    : Node_Id;
9162          T_Ref   : constant Node_Id := New_Reference_To (Etyp, Loc);
9163
9164       begin
9165          Subp_Id := Make_Defining_Identifier (Loc, Sname);
9166
9167          --  S : access Root_Stream_Type'Class
9168
9169          Formals := New_List (
9170                       Make_Parameter_Specification (Loc,
9171                         Defining_Identifier =>
9172                           Make_Defining_Identifier (Loc, Name_S),
9173                         Parameter_Type =>
9174                           Make_Access_Definition (Loc,
9175                             Subtype_Mark =>
9176                               New_Reference_To (
9177                                 Designated_Type (Etype (F)), Loc))));
9178
9179          if Nam = TSS_Stream_Input then
9180             Spec :=
9181               Make_Function_Specification (Loc,
9182                 Defining_Unit_Name       => Subp_Id,
9183                 Parameter_Specifications => Formals,
9184                 Result_Definition        => T_Ref);
9185          else
9186             --  V : [out] T
9187
9188             Append_To (Formals,
9189               Make_Parameter_Specification (Loc,
9190                 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
9191                 Out_Present         => Out_P,
9192                 Parameter_Type      => T_Ref));
9193
9194             Spec :=
9195               Make_Procedure_Specification (Loc,
9196                 Defining_Unit_Name       => Subp_Id,
9197                 Parameter_Specifications => Formals);
9198          end if;
9199
9200          return Spec;
9201       end Build_Spec;
9202
9203    --  Start of processing for New_Stream_Subprogram
9204
9205    begin
9206       F := First_Formal (Subp);
9207
9208       if Ekind (Subp) = E_Procedure then
9209          Etyp := Etype (Next_Formal (F));
9210       else
9211          Etyp := Etype (Subp);
9212       end if;
9213
9214       --  Prepare subprogram declaration and insert it as an action on the
9215       --  clause node. The visibility for this entity is used to test for
9216       --  visibility of the attribute definition clause (in the sense of
9217       --  8.3(23) as amended by AI-195).
9218
9219       if not Defer_Declaration then
9220          Subp_Decl :=
9221            Make_Subprogram_Declaration (Loc,
9222              Specification => Build_Spec);
9223
9224       --  For a tagged type, there is always a visible declaration for each
9225       --  stream TSS (it is a predefined primitive operation), and the
9226       --  completion of this declaration occurs at the freeze point, which is
9227       --  not always visible at places where the attribute definition clause is
9228       --  visible. So, we create a dummy entity here for the purpose of
9229       --  tracking the visibility of the attribute definition clause itself.
9230
9231       else
9232          Subp_Id :=
9233            Make_Defining_Identifier (Loc, New_External_Name (Sname, 'V'));
9234          Subp_Decl :=
9235            Make_Object_Declaration (Loc,
9236              Defining_Identifier => Subp_Id,
9237              Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc));
9238       end if;
9239
9240       Insert_Action (N, Subp_Decl);
9241       Set_Entity (N, Subp_Id);
9242
9243       Subp_Decl :=
9244         Make_Subprogram_Renaming_Declaration (Loc,
9245           Specification => Build_Spec,
9246           Name => New_Reference_To (Subp, Loc));
9247
9248       if Defer_Declaration then
9249          Set_TSS (Base_Type (Ent), Subp_Id);
9250       else
9251          Insert_Action (N, Subp_Decl);
9252          Copy_TSS (Subp_Id, Base_Type (Ent));
9253       end if;
9254    end New_Stream_Subprogram;
9255
9256    ------------------------
9257    -- Rep_Item_Too_Early --
9258    ------------------------
9259
9260    function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is
9261    begin
9262       --  Cannot apply non-operational rep items to generic types
9263
9264       if Is_Operational_Item (N) then
9265          return False;
9266
9267       elsif Is_Type (T)
9268         and then Is_Generic_Type (Root_Type (T))
9269       then
9270          Error_Msg_N ("representation item not allowed for generic type", N);
9271          return True;
9272       end if;
9273
9274       --  Otherwise check for incomplete type
9275
9276       if Is_Incomplete_Or_Private_Type (T)
9277         and then No (Underlying_Type (T))
9278         and then
9279           (Nkind (N) /= N_Pragma
9280             or else Get_Pragma_Id (N) /= Pragma_Import)
9281       then
9282          Error_Msg_N
9283            ("representation item must be after full type declaration", N);
9284          return True;
9285
9286       --  If the type has incomplete components, a representation clause is
9287       --  illegal but stream attributes and Convention pragmas are correct.
9288
9289       elsif Has_Private_Component (T) then
9290          if Nkind (N) = N_Pragma then
9291             return False;
9292
9293          else
9294             Error_Msg_N
9295               ("representation item must appear after type is fully defined",
9296                 N);
9297             return True;
9298          end if;
9299       else
9300          return False;
9301       end if;
9302    end Rep_Item_Too_Early;
9303
9304    -----------------------
9305    -- Rep_Item_Too_Late --
9306    -----------------------
9307
9308    function Rep_Item_Too_Late
9309      (T     : Entity_Id;
9310       N     : Node_Id;
9311       FOnly : Boolean := False) return Boolean
9312    is
9313       S           : Entity_Id;
9314       Parent_Type : Entity_Id;
9315
9316       procedure Too_Late;
9317       --  Output the too late message. Note that this is not considered a
9318       --  serious error, since the effect is simply that we ignore the
9319       --  representation clause in this case.
9320
9321       --------------
9322       -- Too_Late --
9323       --------------
9324
9325       procedure Too_Late is
9326       begin
9327          --  Other compilers seem more relaxed about rep items appearing too
9328          --  late. Since analysis tools typically don't care about rep items
9329          --  anyway, no reason to be too strict about this.
9330
9331          if not Relaxed_RM_Semantics then
9332             Error_Msg_N ("|representation item appears too late!", N);
9333          end if;
9334       end Too_Late;
9335
9336    --  Start of processing for Rep_Item_Too_Late
9337
9338    begin
9339       --  First make sure entity is not frozen (RM 13.1(9))
9340
9341       if Is_Frozen (T)
9342
9343         --  Exclude imported types, which may be frozen if they appear in a
9344         --  representation clause for a local type.
9345
9346         and then not From_With_Type (T)
9347
9348         --  Exclude generated entities (not coming from source). The common
9349         --  case is when we generate a renaming which prematurely freezes the
9350         --  renamed internal entity, but we still want to be able to set copies
9351         --  of attribute values such as Size/Alignment.
9352
9353         and then Comes_From_Source (T)
9354       then
9355          Too_Late;
9356          S := First_Subtype (T);
9357
9358          if Present (Freeze_Node (S)) then
9359             Error_Msg_NE
9360               ("??no more representation items for }", Freeze_Node (S), S);
9361          end if;
9362
9363          return True;
9364
9365       --  Check for case of non-tagged derived type whose parent either has
9366       --  primitive operations, or is a by reference type (RM 13.1(10)).
9367
9368       elsif Is_Type (T)
9369         and then not FOnly
9370         and then Is_Derived_Type (T)
9371         and then not Is_Tagged_Type (T)
9372       then
9373          Parent_Type := Etype (Base_Type (T));
9374
9375          if Has_Primitive_Operations (Parent_Type) then
9376             Too_Late;
9377             Error_Msg_NE
9378               ("primitive operations already defined for&!", N, Parent_Type);
9379             return True;
9380
9381          elsif Is_By_Reference_Type (Parent_Type) then
9382             Too_Late;
9383             Error_Msg_NE
9384               ("parent type & is a by reference type!", N, Parent_Type);
9385             return True;
9386          end if;
9387       end if;
9388
9389       --  No error, link item into head of chain of rep items for the entity,
9390       --  but avoid chaining if we have an overloadable entity, and the pragma
9391       --  is one that can apply to multiple overloaded entities.
9392
9393       if Is_Overloadable (T) and then Nkind (N) = N_Pragma then
9394          declare
9395             Pname : constant Name_Id := Pragma_Name (N);
9396          begin
9397             if Nam_In (Pname, Name_Convention, Name_Import,   Name_Export,
9398                               Name_External,   Name_Interface)
9399             then
9400                return False;
9401             end if;
9402          end;
9403       end if;
9404
9405       Record_Rep_Item (T, N);
9406       return False;
9407    end Rep_Item_Too_Late;
9408
9409    -------------------------------------
9410    -- Replace_Type_References_Generic --
9411    -------------------------------------
9412
9413    procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id) is
9414
9415       function Replace_Node (N : Node_Id) return Traverse_Result;
9416       --  Processes a single node in the traversal procedure below, checking
9417       --  if node N should be replaced, and if so, doing the replacement.
9418
9419       procedure Replace_Type_Refs is new Traverse_Proc (Replace_Node);
9420       --  This instantiation provides the body of Replace_Type_References
9421
9422       ------------------
9423       -- Replace_Node --
9424       ------------------
9425
9426       function Replace_Node (N : Node_Id) return Traverse_Result is
9427          S : Entity_Id;
9428          P : Node_Id;
9429
9430       begin
9431          --  Case of identifier
9432
9433          if Nkind (N) = N_Identifier then
9434
9435             --  If not the type name, all done with this node
9436
9437             if Chars (N) /= TName then
9438                return Skip;
9439
9440             --  Otherwise do the replacement and we are done with this node
9441
9442             else
9443                Replace_Type_Reference (N);
9444                return Skip;
9445             end if;
9446
9447          --  Case of selected component (which is what a qualification
9448          --  looks like in the unanalyzed tree, which is what we have.
9449
9450          elsif Nkind (N) = N_Selected_Component then
9451
9452             --  If selector name is not our type, keeping going (we might
9453             --  still have an occurrence of the type in the prefix).
9454
9455             if Nkind (Selector_Name (N)) /= N_Identifier
9456               or else Chars (Selector_Name (N)) /= TName
9457             then
9458                return OK;
9459
9460             --  Selector name is our type, check qualification
9461
9462             else
9463                --  Loop through scopes and prefixes, doing comparison
9464
9465                S := Current_Scope;
9466                P := Prefix (N);
9467                loop
9468                   --  Continue if no more scopes or scope with no name
9469
9470                   if No (S) or else Nkind (S) not in N_Has_Chars then
9471                      return OK;
9472                   end if;
9473
9474                   --  Do replace if prefix is an identifier matching the
9475                   --  scope that we are currently looking at.
9476
9477                   if Nkind (P) = N_Identifier
9478                     and then Chars (P) = Chars (S)
9479                   then
9480                      Replace_Type_Reference (N);
9481                      return Skip;
9482                   end if;
9483
9484                   --  Go check scope above us if prefix is itself of the
9485                   --  form of a selected component, whose selector matches
9486                   --  the scope we are currently looking at.
9487
9488                   if Nkind (P) = N_Selected_Component
9489                     and then Nkind (Selector_Name (P)) = N_Identifier
9490                     and then Chars (Selector_Name (P)) = Chars (S)
9491                   then
9492                      S := Scope (S);
9493                      P := Prefix (P);
9494
9495                   --  For anything else, we don't have a match, so keep on
9496                   --  going, there are still some weird cases where we may
9497                   --  still have a replacement within the prefix.
9498
9499                   else
9500                      return OK;
9501                   end if;
9502                end loop;
9503             end if;
9504
9505             --  Continue for any other node kind
9506
9507          else
9508             return OK;
9509          end if;
9510       end Replace_Node;
9511
9512    begin
9513       Replace_Type_Refs (N);
9514    end Replace_Type_References_Generic;
9515
9516    -------------------------
9517    -- Same_Representation --
9518    -------------------------
9519
9520    function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is
9521       T1 : constant Entity_Id := Underlying_Type (Typ1);
9522       T2 : constant Entity_Id := Underlying_Type (Typ2);
9523
9524    begin
9525       --  A quick check, if base types are the same, then we definitely have
9526       --  the same representation, because the subtype specific representation
9527       --  attributes (Size and Alignment) do not affect representation from
9528       --  the point of view of this test.
9529
9530       if Base_Type (T1) = Base_Type (T2) then
9531          return True;
9532
9533       elsif Is_Private_Type (Base_Type (T2))
9534         and then Base_Type (T1) = Full_View (Base_Type (T2))
9535       then
9536          return True;
9537       end if;
9538
9539       --  Tagged types never have differing representations
9540
9541       if Is_Tagged_Type (T1) then
9542          return True;
9543       end if;
9544
9545       --  Representations are definitely different if conventions differ
9546
9547       if Convention (T1) /= Convention (T2) then
9548          return False;
9549       end if;
9550
9551       --  Representations are different if component alignments or scalar
9552       --  storage orders differ.
9553
9554       if (Is_Record_Type (T1) or else Is_Array_Type (T1))
9555             and then
9556          (Is_Record_Type (T2) or else Is_Array_Type (T2))
9557         and then
9558          (Component_Alignment (T1) /= Component_Alignment (T2)
9559             or else
9560               Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
9561       then
9562          return False;
9563       end if;
9564
9565       --  For arrays, the only real issue is component size. If we know the
9566       --  component size for both arrays, and it is the same, then that's
9567       --  good enough to know we don't have a change of representation.
9568
9569       if Is_Array_Type (T1) then
9570          if Known_Component_Size (T1)
9571            and then Known_Component_Size (T2)
9572            and then Component_Size (T1) = Component_Size (T2)
9573          then
9574             if VM_Target = No_VM then
9575                return True;
9576
9577             --  In VM targets the representation of arrays with aliased
9578             --  components differs from arrays with non-aliased components
9579
9580             else
9581                return Has_Aliased_Components (Base_Type (T1))
9582                         =
9583                       Has_Aliased_Components (Base_Type (T2));
9584             end if;
9585          end if;
9586       end if;
9587
9588       --  Types definitely have same representation if neither has non-standard
9589       --  representation since default representations are always consistent.
9590       --  If only one has non-standard representation, and the other does not,
9591       --  then we consider that they do not have the same representation. They
9592       --  might, but there is no way of telling early enough.
9593
9594       if Has_Non_Standard_Rep (T1) then
9595          if not Has_Non_Standard_Rep (T2) then
9596             return False;
9597          end if;
9598       else
9599          return not Has_Non_Standard_Rep (T2);
9600       end if;
9601
9602       --  Here the two types both have non-standard representation, and we need
9603       --  to determine if they have the same non-standard representation.
9604
9605       --  For arrays, we simply need to test if the component sizes are the
9606       --  same. Pragma Pack is reflected in modified component sizes, so this
9607       --  check also deals with pragma Pack.
9608
9609       if Is_Array_Type (T1) then
9610          return Component_Size (T1) = Component_Size (T2);
9611
9612       --  Tagged types always have the same representation, because it is not
9613       --  possible to specify different representations for common fields.
9614
9615       elsif Is_Tagged_Type (T1) then
9616          return True;
9617
9618       --  Case of record types
9619
9620       elsif Is_Record_Type (T1) then
9621
9622          --  Packed status must conform
9623
9624          if Is_Packed (T1) /= Is_Packed (T2) then
9625             return False;
9626
9627          --  Otherwise we must check components. Typ2 maybe a constrained
9628          --  subtype with fewer components, so we compare the components
9629          --  of the base types.
9630
9631          else
9632             Record_Case : declare
9633                CD1, CD2 : Entity_Id;
9634
9635                function Same_Rep return Boolean;
9636                --  CD1 and CD2 are either components or discriminants. This
9637                --  function tests whether they have the same representation.
9638
9639                --------------
9640                -- Same_Rep --
9641                --------------
9642
9643                function Same_Rep return Boolean is
9644                begin
9645                   if No (Component_Clause (CD1)) then
9646                      return No (Component_Clause (CD2));
9647                   else
9648                      --  Note: at this point, component clauses have been
9649                      --  normalized to the default bit order, so that the
9650                      --  comparison of Component_Bit_Offsets is meaningful.
9651
9652                      return
9653                         Present (Component_Clause (CD2))
9654                           and then
9655                         Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2)
9656                           and then
9657                         Esize (CD1) = Esize (CD2);
9658                   end if;
9659                end Same_Rep;
9660
9661             --  Start of processing for Record_Case
9662
9663             begin
9664                if Has_Discriminants (T1) then
9665
9666                   --  The number of discriminants may be different if the
9667                   --  derived type has fewer (constrained by values). The
9668                   --  invisible discriminants retain the representation of
9669                   --  the original, so the discrepancy does not per se
9670                   --  indicate a different representation.
9671
9672                   CD1 := First_Discriminant (T1);
9673                   CD2 := First_Discriminant (T2);
9674                   while Present (CD1) and then Present (CD2) loop
9675                      if not Same_Rep then
9676                         return False;
9677                      else
9678                         Next_Discriminant (CD1);
9679                         Next_Discriminant (CD2);
9680                      end if;
9681                   end loop;
9682                end if;
9683
9684                CD1 := First_Component (Underlying_Type (Base_Type (T1)));
9685                CD2 := First_Component (Underlying_Type (Base_Type (T2)));
9686                while Present (CD1) loop
9687                   if not Same_Rep then
9688                      return False;
9689                   else
9690                      Next_Component (CD1);
9691                      Next_Component (CD2);
9692                   end if;
9693                end loop;
9694
9695                return True;
9696             end Record_Case;
9697          end if;
9698
9699       --  For enumeration types, we must check each literal to see if the
9700       --  representation is the same. Note that we do not permit enumeration
9701       --  representation clauses for Character and Wide_Character, so these
9702       --  cases were already dealt with.
9703
9704       elsif Is_Enumeration_Type (T1) then
9705          Enumeration_Case : declare
9706             L1, L2 : Entity_Id;
9707
9708          begin
9709             L1 := First_Literal (T1);
9710             L2 := First_Literal (T2);
9711             while Present (L1) loop
9712                if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then
9713                   return False;
9714                else
9715                   Next_Literal (L1);
9716                   Next_Literal (L2);
9717                end if;
9718             end loop;
9719
9720             return True;
9721          end Enumeration_Case;
9722
9723       --  Any other types have the same representation for these purposes
9724
9725       else
9726          return True;
9727       end if;
9728    end Same_Representation;
9729
9730    ----------------
9731    -- Set_Biased --
9732    ----------------
9733
9734    procedure Set_Biased
9735      (E      : Entity_Id;
9736       N      : Node_Id;
9737       Msg    : String;
9738       Biased : Boolean := True)
9739    is
9740    begin
9741       if Biased then
9742          Set_Has_Biased_Representation (E);
9743
9744          if Warn_On_Biased_Representation then
9745             Error_Msg_NE
9746               ("?B?" & Msg & " forces biased representation for&", N, E);
9747          end if;
9748       end if;
9749    end Set_Biased;
9750
9751    --------------------
9752    -- Set_Enum_Esize --
9753    --------------------
9754
9755    procedure Set_Enum_Esize (T : Entity_Id) is
9756       Lo : Uint;
9757       Hi : Uint;
9758       Sz : Nat;
9759
9760    begin
9761       Init_Alignment (T);
9762
9763       --  Find the minimum standard size (8,16,32,64) that fits
9764
9765       Lo := Enumeration_Rep (Entity (Type_Low_Bound (T)));
9766       Hi := Enumeration_Rep (Entity (Type_High_Bound (T)));
9767
9768       if Lo < 0 then
9769          if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then
9770             Sz := Standard_Character_Size;  -- May be > 8 on some targets
9771
9772          elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then
9773             Sz := 16;
9774
9775          elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then
9776             Sz := 32;
9777
9778          else pragma Assert (Lo >= -Uint_2**63 and then Hi < Uint_2**63);
9779             Sz := 64;
9780          end if;
9781
9782       else
9783          if Hi < Uint_2**08 then
9784             Sz := Standard_Character_Size;  -- May be > 8 on some targets
9785
9786          elsif Hi < Uint_2**16 then
9787             Sz := 16;
9788
9789          elsif Hi < Uint_2**32 then
9790             Sz := 32;
9791
9792          else pragma Assert (Hi < Uint_2**63);
9793             Sz := 64;
9794          end if;
9795       end if;
9796
9797       --  That minimum is the proper size unless we have a foreign convention
9798       --  and the size required is 32 or less, in which case we bump the size
9799       --  up to 32. This is required for C and C++ and seems reasonable for
9800       --  all other foreign conventions.
9801
9802       if Has_Foreign_Convention (T)
9803         and then Esize (T) < Standard_Integer_Size
9804       then
9805          Init_Esize (T, Standard_Integer_Size);
9806       else
9807          Init_Esize (T, Sz);
9808       end if;
9809    end Set_Enum_Esize;
9810
9811    ------------------------------
9812    -- Validate_Address_Clauses --
9813    ------------------------------
9814
9815    procedure Validate_Address_Clauses is
9816    begin
9817       for J in Address_Clause_Checks.First .. Address_Clause_Checks.Last loop
9818          declare
9819             ACCR : Address_Clause_Check_Record
9820                      renames Address_Clause_Checks.Table (J);
9821
9822             Expr : Node_Id;
9823
9824             X_Alignment : Uint;
9825             Y_Alignment : Uint;
9826
9827             X_Size : Uint;
9828             Y_Size : Uint;
9829
9830          begin
9831             --  Skip processing of this entry if warning already posted
9832
9833             if not Address_Warning_Posted (ACCR.N) then
9834                Expr := Original_Node (Expression (ACCR.N));
9835
9836                --  Get alignments
9837
9838                X_Alignment := Alignment (ACCR.X);
9839                Y_Alignment := Alignment (ACCR.Y);
9840
9841                --  Similarly obtain sizes
9842
9843                X_Size := Esize (ACCR.X);
9844                Y_Size := Esize (ACCR.Y);
9845
9846                --  Check for large object overlaying smaller one
9847
9848                if Y_Size > Uint_0
9849                  and then X_Size > Uint_0
9850                  and then X_Size > Y_Size
9851                then
9852                   Error_Msg_NE
9853                     ("?& overlays smaller object", ACCR.N, ACCR.X);
9854                   Error_Msg_N
9855                     ("\??program execution may be erroneous", ACCR.N);
9856                   Error_Msg_Uint_1 := X_Size;
9857                   Error_Msg_NE
9858                     ("\??size of & is ^", ACCR.N, ACCR.X);
9859                   Error_Msg_Uint_1 := Y_Size;
9860                   Error_Msg_NE
9861                     ("\??size of & is ^", ACCR.N, ACCR.Y);
9862
9863                --  Check for inadequate alignment, both of the base object
9864                --  and of the offset, if any.
9865
9866                --  Note: we do not check the alignment if we gave a size
9867                --  warning, since it would likely be redundant.
9868
9869                elsif Y_Alignment /= Uint_0
9870                  and then (Y_Alignment < X_Alignment
9871                              or else (ACCR.Off
9872                                         and then
9873                                           Nkind (Expr) = N_Attribute_Reference
9874                                         and then
9875                                           Attribute_Name (Expr) = Name_Address
9876                                         and then
9877                                           Has_Compatible_Alignment
9878                                             (ACCR.X, Prefix (Expr))
9879                                              /= Known_Compatible))
9880                then
9881                   Error_Msg_NE
9882                     ("??specified address for& may be inconsistent "
9883                        & "with alignment", ACCR.N, ACCR.X);
9884                   Error_Msg_N
9885                     ("\??program execution may be erroneous (RM 13.3(27))",
9886                      ACCR.N);
9887                   Error_Msg_Uint_1 := X_Alignment;
9888                   Error_Msg_NE
9889                     ("\??alignment of & is ^", ACCR.N, ACCR.X);
9890                   Error_Msg_Uint_1 := Y_Alignment;
9891                   Error_Msg_NE
9892                     ("\??alignment of & is ^", ACCR.N, ACCR.Y);
9893                   if Y_Alignment >= X_Alignment then
9894                      Error_Msg_N
9895                       ("\??but offset is not multiple of alignment", ACCR.N);
9896                   end if;
9897                end if;
9898             end if;
9899          end;
9900       end loop;
9901    end Validate_Address_Clauses;
9902
9903    ---------------------------
9904    -- Validate_Independence --
9905    ---------------------------
9906
9907    procedure Validate_Independence is
9908       SU   : constant Uint := UI_From_Int (System_Storage_Unit);
9909       N    : Node_Id;
9910       E    : Entity_Id;
9911       IC   : Boolean;
9912       Comp : Entity_Id;
9913       Addr : Node_Id;
9914       P    : Node_Id;
9915
9916       procedure Check_Array_Type (Atyp : Entity_Id);
9917       --  Checks if the array type Atyp has independent components, and
9918       --  if not, outputs an appropriate set of error messages.
9919
9920       procedure No_Independence;
9921       --  Output message that independence cannot be guaranteed
9922
9923       function OK_Component (C : Entity_Id) return Boolean;
9924       --  Checks one component to see if it is independently accessible, and
9925       --  if so yields True, otherwise yields False if independent access
9926       --  cannot be guaranteed. This is a conservative routine, it only
9927       --  returns True if it knows for sure, it returns False if it knows
9928       --  there is a problem, or it cannot be sure there is no problem.
9929
9930       procedure Reason_Bad_Component (C : Entity_Id);
9931       --  Outputs continuation message if a reason can be determined for
9932       --  the component C being bad.
9933
9934       ----------------------
9935       -- Check_Array_Type --
9936       ----------------------
9937
9938       procedure Check_Array_Type (Atyp : Entity_Id) is
9939          Ctyp : constant Entity_Id := Component_Type (Atyp);
9940
9941       begin
9942          --  OK if no alignment clause, no pack, and no component size
9943
9944          if not Has_Component_Size_Clause (Atyp)
9945            and then not Has_Alignment_Clause (Atyp)
9946            and then not Is_Packed (Atyp)
9947          then
9948             return;
9949          end if;
9950
9951          --  Check actual component size
9952
9953          if not Known_Component_Size (Atyp)
9954            or else not (Addressable (Component_Size (Atyp))
9955                           and then Component_Size (Atyp) < 64)
9956            or else Component_Size (Atyp) mod Esize (Ctyp) /= 0
9957          then
9958             No_Independence;
9959
9960             --  Bad component size, check reason
9961
9962             if Has_Component_Size_Clause (Atyp) then
9963                P := Get_Attribute_Definition_Clause
9964                       (Atyp, Attribute_Component_Size);
9965
9966                if Present (P) then
9967                   Error_Msg_Sloc := Sloc (P);
9968                   Error_Msg_N ("\because of Component_Size clause#", N);
9969                   return;
9970                end if;
9971             end if;
9972
9973             if Is_Packed (Atyp) then
9974                P := Get_Rep_Pragma (Atyp, Name_Pack);
9975
9976                if Present (P) then
9977                   Error_Msg_Sloc := Sloc (P);
9978                   Error_Msg_N ("\because of pragma Pack#", N);
9979                   return;
9980                end if;
9981             end if;
9982
9983             --  No reason found, just return
9984
9985             return;
9986          end if;
9987
9988          --  Array type is OK independence-wise
9989
9990          return;
9991       end Check_Array_Type;
9992
9993       ---------------------
9994       -- No_Independence --
9995       ---------------------
9996
9997       procedure No_Independence is
9998       begin
9999          if Pragma_Name (N) = Name_Independent then
10000             Error_Msg_NE ("independence cannot be guaranteed for&", N, E);
10001          else
10002             Error_Msg_NE
10003               ("independent components cannot be guaranteed for&", N, E);
10004          end if;
10005       end No_Independence;
10006
10007       ------------------
10008       -- OK_Component --
10009       ------------------
10010
10011       function OK_Component (C : Entity_Id) return Boolean is
10012          Rec  : constant Entity_Id := Scope (C);
10013          Ctyp : constant Entity_Id := Etype (C);
10014
10015       begin
10016          --  OK if no component clause, no Pack, and no alignment clause
10017
10018          if No (Component_Clause (C))
10019            and then not Is_Packed (Rec)
10020            and then not Has_Alignment_Clause (Rec)
10021          then
10022             return True;
10023          end if;
10024
10025          --  Here we look at the actual component layout. A component is
10026          --  addressable if its size is a multiple of the Esize of the
10027          --  component type, and its starting position in the record has
10028          --  appropriate alignment, and the record itself has appropriate
10029          --  alignment to guarantee the component alignment.
10030
10031          --  Make sure sizes are static, always assume the worst for any
10032          --  cases where we cannot check static values.
10033
10034          if not (Known_Static_Esize (C)
10035                   and then
10036                  Known_Static_Esize (Ctyp))
10037          then
10038             return False;
10039          end if;
10040
10041          --  Size of component must be addressable or greater than 64 bits
10042          --  and a multiple of bytes.
10043
10044          if not Addressable (Esize (C)) and then Esize (C) < Uint_64 then
10045             return False;
10046          end if;
10047
10048          --  Check size is proper multiple
10049
10050          if Esize (C) mod Esize (Ctyp) /= 0 then
10051             return False;
10052          end if;
10053
10054          --  Check alignment of component is OK
10055
10056          if not Known_Component_Bit_Offset (C)
10057            or else Component_Bit_Offset (C) < Uint_0
10058            or else Component_Bit_Offset (C) mod Esize (Ctyp) /= 0
10059          then
10060             return False;
10061          end if;
10062
10063          --  Check alignment of record type is OK
10064
10065          if not Known_Alignment (Rec)
10066            or else (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0
10067          then
10068             return False;
10069          end if;
10070
10071          --  All tests passed, component is addressable
10072
10073          return True;
10074       end OK_Component;
10075
10076       --------------------------
10077       -- Reason_Bad_Component --
10078       --------------------------
10079
10080       procedure Reason_Bad_Component (C : Entity_Id) is
10081          Rec  : constant Entity_Id := Scope (C);
10082          Ctyp : constant Entity_Id := Etype (C);
10083
10084       begin
10085          --  If component clause present assume that's the problem
10086
10087          if Present (Component_Clause (C)) then
10088             Error_Msg_Sloc := Sloc (Component_Clause (C));
10089             Error_Msg_N ("\because of Component_Clause#", N);
10090             return;
10091          end if;
10092
10093          --  If pragma Pack clause present, assume that's the problem
10094
10095          if Is_Packed (Rec) then
10096             P := Get_Rep_Pragma (Rec, Name_Pack);
10097
10098             if Present (P) then
10099                Error_Msg_Sloc := Sloc (P);
10100                Error_Msg_N ("\because of pragma Pack#", N);
10101                return;
10102             end if;
10103          end if;
10104
10105          --  See if record has bad alignment clause
10106
10107          if Has_Alignment_Clause (Rec)
10108            and then Known_Alignment (Rec)
10109            and then (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0
10110          then
10111             P := Get_Attribute_Definition_Clause (Rec, Attribute_Alignment);
10112
10113             if Present (P) then
10114                Error_Msg_Sloc := Sloc (P);
10115                Error_Msg_N ("\because of Alignment clause#", N);
10116             end if;
10117          end if;
10118
10119          --  Couldn't find a reason, so return without a message
10120
10121          return;
10122       end Reason_Bad_Component;
10123
10124    --  Start of processing for Validate_Independence
10125
10126    begin
10127       for J in Independence_Checks.First .. Independence_Checks.Last loop
10128          N  := Independence_Checks.Table (J).N;
10129          E  := Independence_Checks.Table (J).E;
10130          IC := Pragma_Name (N) = Name_Independent_Components;
10131
10132          --  Deal with component case
10133
10134          if Ekind (E) = E_Discriminant or else Ekind (E) = E_Component then
10135             if not OK_Component (E) then
10136                No_Independence;
10137                Reason_Bad_Component (E);
10138                goto Continue;
10139             end if;
10140          end if;
10141
10142          --  Deal with record with Independent_Components
10143
10144          if IC and then Is_Record_Type (E) then
10145             Comp := First_Component_Or_Discriminant (E);
10146             while Present (Comp) loop
10147                if not OK_Component (Comp) then
10148                   No_Independence;
10149                   Reason_Bad_Component (Comp);
10150                   goto Continue;
10151                end if;
10152
10153                Next_Component_Or_Discriminant (Comp);
10154             end loop;
10155          end if;
10156
10157          --  Deal with address clause case
10158
10159          if Is_Object (E) then
10160             Addr := Address_Clause (E);
10161
10162             if Present (Addr) then
10163                No_Independence;
10164                Error_Msg_Sloc := Sloc (Addr);
10165                Error_Msg_N ("\because of Address clause#", N);
10166                goto Continue;
10167             end if;
10168          end if;
10169
10170          --  Deal with independent components for array type
10171
10172          if IC and then Is_Array_Type (E) then
10173             Check_Array_Type (E);
10174          end if;
10175
10176          --  Deal with independent components for array object
10177
10178          if IC and then Is_Object (E) and then Is_Array_Type (Etype (E)) then
10179             Check_Array_Type (Etype (E));
10180          end if;
10181
10182       <<Continue>> null;
10183       end loop;
10184    end Validate_Independence;
10185
10186    -----------------------------------
10187    -- Validate_Unchecked_Conversion --
10188    -----------------------------------
10189
10190    procedure Validate_Unchecked_Conversion
10191      (N        : Node_Id;
10192       Act_Unit : Entity_Id)
10193    is
10194       Source : Entity_Id;
10195       Target : Entity_Id;
10196       Vnode  : Node_Id;
10197
10198    begin
10199       --  Obtain source and target types. Note that we call Ancestor_Subtype
10200       --  here because the processing for generic instantiation always makes
10201       --  subtypes, and we want the original frozen actual types.
10202
10203       --  If we are dealing with private types, then do the check on their
10204       --  fully declared counterparts if the full declarations have been
10205       --  encountered (they don't have to be visible, but they must exist!)
10206
10207       Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit)));
10208
10209       if Is_Private_Type (Source)
10210         and then Present (Underlying_Type (Source))
10211       then
10212          Source := Underlying_Type (Source);
10213       end if;
10214
10215       Target := Ancestor_Subtype (Etype (Act_Unit));
10216
10217       --  If either type is generic, the instantiation happens within a generic
10218       --  unit, and there is nothing to check. The proper check will happen
10219       --  when the enclosing generic is instantiated.
10220
10221       if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then
10222          return;
10223       end if;
10224
10225       if Is_Private_Type (Target)
10226         and then Present (Underlying_Type (Target))
10227       then
10228          Target := Underlying_Type (Target);
10229       end if;
10230
10231       --  Source may be unconstrained array, but not target
10232
10233       if Is_Array_Type (Target) and then not Is_Constrained (Target) then
10234          Error_Msg_N
10235            ("unchecked conversion to unconstrained array not allowed", N);
10236          return;
10237       end if;
10238
10239       --  Warn if conversion between two different convention pointers
10240
10241       if Is_Access_Type (Target)
10242         and then Is_Access_Type (Source)
10243         and then Convention (Target) /= Convention (Source)
10244         and then Warn_On_Unchecked_Conversion
10245       then
10246          --  Give warnings for subprogram pointers only on most targets. The
10247          --  exception is VMS, where data pointers can have different lengths
10248          --  depending on the pointer convention.
10249
10250          if Is_Access_Subprogram_Type (Target)
10251            or else Is_Access_Subprogram_Type (Source)
10252            or else OpenVMS_On_Target
10253          then
10254             Error_Msg_N
10255               ("?z?conversion between pointers with different conventions!",
10256                N);
10257          end if;
10258       end if;
10259
10260       --  Warn if one of the operands is Ada.Calendar.Time. Do not emit a
10261       --  warning when compiling GNAT-related sources.
10262
10263       if Warn_On_Unchecked_Conversion
10264         and then not In_Predefined_Unit (N)
10265         and then RTU_Loaded (Ada_Calendar)
10266         and then
10267           (Chars (Source) = Name_Time
10268              or else
10269            Chars (Target) = Name_Time)
10270       then
10271          --  If Ada.Calendar is loaded and the name of one of the operands is
10272          --  Time, there is a good chance that this is Ada.Calendar.Time.
10273
10274          declare
10275             Calendar_Time : constant Entity_Id :=
10276                               Full_View (RTE (RO_CA_Time));
10277          begin
10278             pragma Assert (Present (Calendar_Time));
10279
10280             if Source = Calendar_Time or else Target = Calendar_Time then
10281                Error_Msg_N
10282                  ("?z?representation of 'Time values may change between " &
10283                   "'G'N'A'T versions", N);
10284             end if;
10285          end;
10286       end if;
10287
10288       --  Make entry in unchecked conversion table for later processing by
10289       --  Validate_Unchecked_Conversions, which will check sizes and alignments
10290       --  (using values set by the back-end where possible). This is only done
10291       --  if the appropriate warning is active.
10292
10293       if Warn_On_Unchecked_Conversion then
10294          Unchecked_Conversions.Append
10295            (New_Val => UC_Entry'(Eloc   => Sloc (N),
10296                                  Source => Source,
10297                                  Target => Target));
10298
10299          --  If both sizes are known statically now, then back end annotation
10300          --  is not required to do a proper check but if either size is not
10301          --  known statically, then we need the annotation.
10302
10303          if Known_Static_RM_Size (Source)
10304               and then
10305             Known_Static_RM_Size (Target)
10306          then
10307             null;
10308          else
10309             Back_Annotate_Rep_Info := True;
10310          end if;
10311       end if;
10312
10313       --  If unchecked conversion to access type, and access type is declared
10314       --  in the same unit as the unchecked conversion, then set the flag
10315       --  No_Strict_Aliasing (no strict aliasing is implicit here)
10316
10317       if Is_Access_Type (Target) and then
10318         In_Same_Source_Unit (Target, N)
10319       then
10320          Set_No_Strict_Aliasing (Implementation_Base_Type (Target));
10321       end if;
10322
10323       --  Generate N_Validate_Unchecked_Conversion node for back end in case
10324       --  the back end needs to perform special validation checks.
10325
10326       --  Shouldn't this be in Exp_Ch13, since the check only gets done if we
10327       --  have full expansion and the back end is called ???
10328
10329       Vnode :=
10330         Make_Validate_Unchecked_Conversion (Sloc (N));
10331       Set_Source_Type (Vnode, Source);
10332       Set_Target_Type (Vnode, Target);
10333
10334       --  If the unchecked conversion node is in a list, just insert before it.
10335       --  If not we have some strange case, not worth bothering about.
10336
10337       if Is_List_Member (N) then
10338          Insert_After (N, Vnode);
10339       end if;
10340    end Validate_Unchecked_Conversion;
10341
10342    ------------------------------------
10343    -- Validate_Unchecked_Conversions --
10344    ------------------------------------
10345
10346    procedure Validate_Unchecked_Conversions is
10347    begin
10348       for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop
10349          declare
10350             T : UC_Entry renames Unchecked_Conversions.Table (N);
10351
10352             Eloc   : constant Source_Ptr := T.Eloc;
10353             Source : constant Entity_Id  := T.Source;
10354             Target : constant Entity_Id  := T.Target;
10355
10356             Source_Siz : Uint;
10357             Target_Siz : Uint;
10358
10359          begin
10360             --  This validation check, which warns if we have unequal sizes for
10361             --  unchecked conversion, and thus potentially implementation
10362             --  dependent semantics, is one of the few occasions on which we
10363             --  use the official RM size instead of Esize. See description in
10364             --  Einfo "Handling of Type'Size Values" for details.
10365
10366             if Serious_Errors_Detected = 0
10367               and then Known_Static_RM_Size (Source)
10368               and then Known_Static_RM_Size (Target)
10369
10370               --  Don't do the check if warnings off for either type, note the
10371               --  deliberate use of OR here instead of OR ELSE to get the flag
10372               --  Warnings_Off_Used set for both types if appropriate.
10373
10374               and then not (Has_Warnings_Off (Source)
10375                               or
10376                             Has_Warnings_Off (Target))
10377             then
10378                Source_Siz := RM_Size (Source);
10379                Target_Siz := RM_Size (Target);
10380
10381                if Source_Siz /= Target_Siz then
10382                   Error_Msg
10383                     ("?z?types for unchecked conversion have different sizes!",
10384                      Eloc);
10385
10386                   if All_Errors_Mode then
10387                      Error_Msg_Name_1 := Chars (Source);
10388                      Error_Msg_Uint_1 := Source_Siz;
10389                      Error_Msg_Name_2 := Chars (Target);
10390                      Error_Msg_Uint_2 := Target_Siz;
10391                      Error_Msg ("\size of % is ^, size of % is ^?z?", Eloc);
10392
10393                      Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz);
10394
10395                      if Is_Discrete_Type (Source)
10396                           and then
10397                         Is_Discrete_Type (Target)
10398                      then
10399                         if Source_Siz > Target_Siz then
10400                            Error_Msg
10401                              ("\?z?^ high order bits of source will "
10402                               & "be ignored!", Eloc);
10403
10404                         elsif Is_Unsigned_Type (Source) then
10405                            Error_Msg
10406                              ("\?z?source will be extended with ^ high order "
10407                               & "zero bits?!", Eloc);
10408
10409                         else
10410                            Error_Msg
10411                              ("\?z?source will be extended with ^ high order "
10412                               & "sign bits!", Eloc);
10413                         end if;
10414
10415                      elsif Source_Siz < Target_Siz then
10416                         if Is_Discrete_Type (Target) then
10417                            if Bytes_Big_Endian then
10418                               Error_Msg
10419                                 ("\?z?target value will include ^ undefined "
10420                                  & "low order bits!", Eloc);
10421                            else
10422                               Error_Msg
10423                                 ("\?z?target value will include ^ undefined "
10424                                  & "high order bits!", Eloc);
10425                            end if;
10426
10427                         else
10428                            Error_Msg
10429                              ("\?z?^ trailing bits of target value will be "
10430                               & "undefined!", Eloc);
10431                         end if;
10432
10433                      else pragma Assert (Source_Siz > Target_Siz);
10434                         Error_Msg
10435                           ("\?z?^ trailing bits of source will be ignored!",
10436                            Eloc);
10437                      end if;
10438                   end if;
10439                end if;
10440             end if;
10441
10442             --  If both types are access types, we need to check the alignment.
10443             --  If the alignment of both is specified, we can do it here.
10444
10445             if Serious_Errors_Detected = 0
10446               and then Ekind (Source) in Access_Kind
10447               and then Ekind (Target) in Access_Kind
10448               and then Target_Strict_Alignment
10449               and then Present (Designated_Type (Source))
10450               and then Present (Designated_Type (Target))
10451             then
10452                declare
10453                   D_Source : constant Entity_Id := Designated_Type (Source);
10454                   D_Target : constant Entity_Id := Designated_Type (Target);
10455
10456                begin
10457                   if Known_Alignment (D_Source)
10458                        and then
10459                      Known_Alignment (D_Target)
10460                   then
10461                      declare
10462                         Source_Align : constant Uint := Alignment (D_Source);
10463                         Target_Align : constant Uint := Alignment (D_Target);
10464
10465                      begin
10466                         if Source_Align < Target_Align
10467                           and then not Is_Tagged_Type (D_Source)
10468
10469                           --  Suppress warning if warnings suppressed on either
10470                           --  type or either designated type. Note the use of
10471                           --  OR here instead of OR ELSE. That is intentional,
10472                           --  we would like to set flag Warnings_Off_Used in
10473                           --  all types for which warnings are suppressed.
10474
10475                           and then not (Has_Warnings_Off (D_Source)
10476                                           or
10477                                         Has_Warnings_Off (D_Target)
10478                                           or
10479                                         Has_Warnings_Off (Source)
10480                                           or
10481                                         Has_Warnings_Off (Target))
10482                         then
10483                            Error_Msg_Uint_1 := Target_Align;
10484                            Error_Msg_Uint_2 := Source_Align;
10485                            Error_Msg_Node_1 := D_Target;
10486                            Error_Msg_Node_2 := D_Source;
10487                            Error_Msg
10488                              ("?z?alignment of & (^) is stricter than "
10489                               & "alignment of & (^)!", Eloc);
10490                            Error_Msg
10491                              ("\?z?resulting access value may have invalid "
10492                               & "alignment!", Eloc);
10493                         end if;
10494                      end;
10495                   end if;
10496                end;
10497             end if;
10498          end;
10499       end loop;
10500    end Validate_Unchecked_Conversions;
10501
10502 end Sem_Ch13;