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