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