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