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 Atree;    use Atree;
  27 with Checks;   use Checks;
  28 with Einfo;    use Einfo;
  29 with Elists;   use Elists;
  30 with Errout;   use Errout;
  31 with Exp_Disp; use Exp_Disp;
  32 with Exp_Tss;  use Exp_Tss;
  33 with Exp_Util; use Exp_Util;
  34 with Lib;      use Lib;
  35 with Lib.Xref; use Lib.Xref;
  36 with Namet;    use Namet;
  37 with Nlists;   use Nlists;
  38 with Nmake;    use Nmake;
  39 with Opt;      use Opt;
  40 with Restrict; use Restrict;
  41 with Rident;   use Rident;
  42 with Rtsfind;  use Rtsfind;
  43 with Sem;      use Sem;
  44 with Sem_Aux;  use Sem_Aux;
  45 with Sem_Ch3;  use Sem_Ch3;
  46 with Sem_Ch8;  use Sem_Ch8;
  47 with Sem_Eval; use Sem_Eval;
  48 with Sem_Res;  use Sem_Res;
  49 with Sem_Type; use Sem_Type;
  50 with Sem_Util; use Sem_Util;
  51 with Sem_Warn; use Sem_Warn;
  52 with Snames;   use Snames;
  53 with Stand;    use Stand;
  54 with Sinfo;    use Sinfo;
  55 with Table;
  56 with Targparm; use Targparm;
  57 with Ttypes;   use Ttypes;
  58 with Tbuild;   use Tbuild;
  59 with Urealp;   use Urealp;
  60
  61 with GNAT.Heap_Sort_G;
  62
  63 package body Sem_Ch13 is
  64
  65    SSU : constant Pos := System_Storage_Unit;
  66    --  Convenient short hand for commonly used constant
  67
  68    -----------------------
  69    -- Local Subprograms --
  70    -----------------------
  71
  72    procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id);
  73    --  This routine is called after setting the Esize of type entity Typ.
  74    --  The purpose is to deal with the situation where an alignment has been
  75    --  inherited from a derived type that is no longer appropriate for the
  76    --  new Esize value. In this case, we reset the Alignment to unknown.
  77
  78    function Get_Alignment_Value (Expr : Node_Id) return Uint;
  79    --  Given the expression for an alignment value, returns the corresponding
  80    --  Uint value. If the value is inappropriate, then error messages are
  81    --  posted as required, and a value of No_Uint is returned.
  82
  83    function Is_Operational_Item (N : Node_Id) return Boolean;
  84    --  A specification for a stream attribute is allowed before the full
  85    --  type is declared, as explained in AI-00137 and the corrigendum.
  86    --  Attributes that do not specify a representation characteristic are
  87    --  operational attributes.
  88
  89    procedure New_Stream_Subprogram
  90      (N    : Node_Id;
  91       Ent  : Entity_Id;
  92       Subp : Entity_Id;
  93       Nam  : TSS_Name_Type);
  94    --  Create a subprogram renaming of a given stream attribute to the
  95    --  designated subprogram and then in the tagged case, provide this as a
  96    --  primitive operation, or in the non-tagged case make an appropriate TSS
  97    --  entry. This is more properly an expansion activity than just semantics,
  98    --  but the presence of user-defined stream functions for limited types is a
  99    --  legality check, which is why this takes place here rather than in
 100    --  exp_ch13, where it was previously. Nam indicates the name of the TSS
 101    --  function to be generated.
 102    --
 103    --  To avoid elaboration anomalies with freeze nodes, for untagged types
 104    --  we generate both a subprogram declaration and a subprogram renaming
 105    --  declaration, so that the attribute specification is handled as a
 106    --  renaming_as_body. For tagged types, the specification is one of the
 107    --  primitive specs.
 108
 109    procedure Set_Biased
 110      (E      : Entity_Id;
 111       N      : Node_Id;
 112       Msg    : String;
 113       Biased : Boolean := True);
 114    --  If Biased is True, sets Has_Biased_Representation flag for E, and
 115    --  outputs a warning message at node N if Warn_On_Biased_Representation is
 116    --  is True. This warning inserts the string Msg to describe the construct
 117    --  causing biasing.
 118
 119    ----------------------------------------------
 120    -- Table for Validate_Unchecked_Conversions --
 121    ----------------------------------------------
 122
 123    --  The following table collects unchecked conversions for validation.
 124    --  Entries are made by Validate_Unchecked_Conversion and then the
 125    --  call to Validate_Unchecked_Conversions does the actual error
 126    --  checking and posting of warnings. The reason for this delayed
 127    --  processing is to take advantage of back-annotations of size and
 128    --  alignment values performed by the back end.
 129
 130    --  Note: the reason we store a Source_Ptr value instead of a Node_Id
 131    --  is that by the time Validate_Unchecked_Conversions is called, Sprint
 132    --  will already have modified all Sloc values if the -gnatD option is set.
 133
 134    type UC_Entry is record
 135       Eloc   : Source_Ptr; -- node used for posting warnings
 136       Source : Entity_Id;  -- source type for unchecked conversion
 137       Target : Entity_Id;  -- target type for unchecked conversion
 138    end record;
 139
 140    package Unchecked_Conversions is new Table.Table (
 141      Table_Component_Type => UC_Entry,
 142      Table_Index_Type     => Int,
 143      Table_Low_Bound      => 1,
 144      Table_Initial        => 50,
 145      Table_Increment      => 200,
 146      Table_Name           => "Unchecked_Conversions");
 147
 148    ----------------------------------------
 149    -- Table for Validate_Address_Clauses --
 150    ----------------------------------------
 151
 152    --  If an address clause has the form
 153
 154    --    for X'Address use Expr
 155
 156    --  where Expr is of the form Y'Address or recursively is a reference
 157    --  to a constant of either of these forms, and X and Y are entities of
 158    --  objects, then if Y has a smaller alignment than X, that merits a
 159    --  warning about possible bad alignment. The following table collects
 160    --  address clauses of this kind. We put these in a table so that they
 161    --  can be checked after the back end has completed annotation of the
 162    --  alignments of objects, since we can catch more cases that way.
 163
 164    type Address_Clause_Check_Record is record
 165       N : Node_Id;
 166       --  The address clause
 167
 168       X : Entity_Id;
 169       --  The entity of the object overlaying Y
 170
 171       Y : Entity_Id;
 172       --  The entity of the object being overlaid
 173
 174       Off : Boolean;
 175       --  Whether the address is offseted within Y
 176    end record;
 177
 178    package Address_Clause_Checks is new Table.Table (
 179      Table_Component_Type => Address_Clause_Check_Record,
 180      Table_Index_Type     => Int,
 181      Table_Low_Bound      => 1,
 182      Table_Initial        => 20,
 183      Table_Increment      => 200,
 184      Table_Name           => "Address_Clause_Checks");
 185
 186    -----------------------------------------
 187    -- Adjust_Record_For_Reverse_Bit_Order --
 188    -----------------------------------------
 189
 190    procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is
 191       Comp : Node_Id;
 192       CC   : Node_Id;
 193
 194    begin
 195       --  Processing depends on version of Ada
 196
 197       --  For Ada 95, we just renumber bits within a storage unit. We do the
 198       --  same for Ada 83 mode, since we recognize pragma Bit_Order in Ada 83,
 199       --  and are free to add this extension.
 200
 201       if Ada_Version < Ada_2005 then
 202          Comp := First_Component_Or_Discriminant (R);
 203          while Present (Comp) loop
 204             CC := Component_Clause (Comp);
 205
 206             --  If component clause is present, then deal with the non-default
 207             --  bit order case for Ada 95 mode.
 208
 209             --  We only do this processing for the base type, and in fact that
 210             --  is important, since otherwise if there are record subtypes, we
 211             --  could reverse the bits once for each subtype, which is wrong.
 212
 213             if Present (CC)
 214               and then Ekind (R) = E_Record_Type
 215             then
 216                declare
 217                   CFB : constant Uint    := Component_Bit_Offset (Comp);
 218                   CSZ : constant Uint    := Esize (Comp);
 219                   CLC : constant Node_Id := Component_Clause (Comp);
 220                   Pos : constant Node_Id := Position (CLC);
 221                   FB  : constant Node_Id := First_Bit (CLC);
 222
 223                   Storage_Unit_Offset : constant Uint :=
 224                                           CFB / System_Storage_Unit;
 225
 226                   Start_Bit : constant Uint :=
 227                                 CFB mod System_Storage_Unit;
 228
 229                begin
 230                   --  Cases where field goes over storage unit boundary
 231
 232                   if Start_Bit + CSZ > System_Storage_Unit then
 233
 234                      --  Allow multi-byte field but generate warning
 235
 236                      if Start_Bit mod System_Storage_Unit = 0
 237                        and then CSZ mod System_Storage_Unit = 0
 238                      then
 239                         Error_Msg_N
 240                           ("multi-byte field specified with non-standard"
 241                            & " Bit_Order?", CLC);
 242
 243                         if Bytes_Big_Endian then
 244                            Error_Msg_N
 245                              ("bytes are not reversed "
 246                               & "(component is big-endian)?", CLC);
 247                         else
 248                            Error_Msg_N
 249                              ("bytes are not reversed "
 250                               & "(component is little-endian)?", CLC);
 251                         end if;
 252
 253                         --  Do not allow non-contiguous field
 254
 255                      else
 256                         Error_Msg_N
 257                           ("attempt to specify non-contiguous field "
 258                            & "not permitted", CLC);
 259                         Error_Msg_N
 260                           ("\caused by non-standard Bit_Order "
 261                            & "specified", CLC);
 262                         Error_Msg_N
 263                           ("\consider possibility of using "
 264                            & "Ada 2005 mode here", CLC);
 265                      end if;
 266
 267                   --  Case where field fits in one storage unit
 268
 269                   else
 270                      --  Give warning if suspicious component clause
 271
 272                      if Intval (FB) >= System_Storage_Unit
 273                        and then Warn_On_Reverse_Bit_Order
 274                      then
 275                         Error_Msg_N
 276                           ("?Bit_Order clause does not affect " &
 277                            "byte ordering", Pos);
 278                         Error_Msg_Uint_1 :=
 279                           Intval (Pos) + Intval (FB) /
 280                           System_Storage_Unit;
 281                         Error_Msg_N
 282                           ("?position normalized to ^ before bit " &
 283                            "order interpreted", Pos);
 284                      end if;
 285
 286                      --  Here is where we fix up the Component_Bit_Offset value
 287                      --  to account for the reverse bit order. Some examples of
 288                      --  what needs to be done are:
 289
 290                      --    First_Bit .. Last_Bit     Component_Bit_Offset
 291                      --      old          new          old       new
 292
 293                      --     0 .. 0       7 .. 7         0         7
 294                      --     0 .. 1       6 .. 7         0         6
 295                      --     0 .. 2       5 .. 7         0         5
 296                      --     0 .. 7       0 .. 7         0         4
 297
 298                      --     1 .. 1       6 .. 6         1         6
 299                      --     1 .. 4       3 .. 6         1         3
 300                      --     4 .. 7       0 .. 3         4         0
 301
 302                      --  The rule is that the first bit is is obtained by
 303                      --  subtracting the old ending bit from storage_unit - 1.
 304
 305                      Set_Component_Bit_Offset
 306                        (Comp,
 307                         (Storage_Unit_Offset * System_Storage_Unit) +
 308                           (System_Storage_Unit - 1) -
 309                           (Start_Bit + CSZ - 1));
 310
 311                      Set_Normalized_First_Bit
 312                        (Comp,
 313                         Component_Bit_Offset (Comp) mod
 314                           System_Storage_Unit);
 315                   end if;
 316                end;
 317             end if;
 318
 319             Next_Component_Or_Discriminant (Comp);
 320          end loop;
 321
 322       --  For Ada 2005, we do machine scalar processing, as fully described In
 323       --  AI-133. This involves gathering all components which start at the
 324       --  same byte offset and processing them together. Same approach is still
 325       --  valid in later versions including Ada 2012.
 326
 327       else
 328          declare
 329             Max_Machine_Scalar_Size : constant Uint :=
 330                                         UI_From_Int
 331                                           (Standard_Long_Long_Integer_Size);
 332             --  We use this as the maximum machine scalar size
 333
 334             Num_CC : Natural;
 335             SSU    : constant Uint := UI_From_Int (System_Storage_Unit);
 336
 337          begin
 338             --  This first loop through components does two things. First it
 339             --  deals with the case of components with component clauses whose
 340             --  length is greater than the maximum machine scalar size (either
 341             --  accepting them or rejecting as needed). Second, it counts the
 342             --  number of components with component clauses whose length does
 343             --  not exceed this maximum for later processing.
 344
 345             Num_CC := 0;
 346             Comp   := First_Component_Or_Discriminant (R);
 347             while Present (Comp) loop
 348                CC := Component_Clause (Comp);
 349
 350                if Present (CC) then
 351                   declare
 352                      Fbit : constant Uint :=
 353                               Static_Integer (First_Bit (CC));
 354
 355                   begin
 356                      --  Case of component with size > max machine scalar
 357
 358                      if Esize (Comp) > Max_Machine_Scalar_Size then
 359
 360                         --  Must begin on byte boundary
 361
 362                         if Fbit mod SSU /= 0 then
 363                            Error_Msg_N
 364                              ("illegal first bit value for "
 365                               & "reverse bit order",
 366                               First_Bit (CC));
 367                            Error_Msg_Uint_1 := SSU;
 368                            Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
 369
 370                            Error_Msg_N
 371                              ("\must be a multiple of ^ "
 372                               & "if size greater than ^",
 373                               First_Bit (CC));
 374
 375                            --  Must end on byte boundary
 376
 377                         elsif Esize (Comp) mod SSU /= 0 then
 378                            Error_Msg_N
 379                              ("illegal last bit value for "
 380                               & "reverse bit order",
 381                               Last_Bit (CC));
 382                            Error_Msg_Uint_1 := SSU;
 383                            Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
 384
 385                            Error_Msg_N
 386                              ("\must be a multiple of ^ if size "
 387                               & "greater than ^",
 388                               Last_Bit (CC));
 389
 390                            --  OK, give warning if enabled
 391
 392                         elsif Warn_On_Reverse_Bit_Order then
 393                            Error_Msg_N
 394                              ("multi-byte field specified with "
 395                               & "  non-standard Bit_Order?", CC);
 396
 397                            if Bytes_Big_Endian then
 398                               Error_Msg_N
 399                                 ("\bytes are not reversed "
 400                                  & "(component is big-endian)?", CC);
 401                            else
 402                               Error_Msg_N
 403                                 ("\bytes are not reversed "
 404                                  & "(component is little-endian)?", CC);
 405                            end if;
 406                         end if;
 407
 408                         --  Case where size is not greater than max machine
 409                         --  scalar. For now, we just count these.
 410
 411                      else
 412                         Num_CC := Num_CC + 1;
 413                      end if;
 414                   end;
 415                end if;
 416
 417                Next_Component_Or_Discriminant (Comp);
 418             end loop;
 419
 420             --  We need to sort the component clauses on the basis of the
 421             --  Position values in the clause, so we can group clauses with
 422             --  the same Position. together to determine the relevant machine
 423             --  scalar size.
 424
 425             Sort_CC : declare
 426                Comps : array (0 .. Num_CC) of Entity_Id;
 427                --  Array to collect component and discriminant entities. The
 428                --  data starts at index 1, the 0'th entry is for the sort
 429                --  routine.
 430
 431                function CP_Lt (Op1, Op2 : Natural) return Boolean;
 432                --  Compare routine for Sort
 433
 434                procedure CP_Move (From : Natural; To : Natural);
 435                --  Move routine for Sort
 436
 437                package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
 438
 439                Start : Natural;
 440                Stop  : Natural;
 441                --  Start and stop positions in the component list of the set of
 442                --  components with the same starting position (that constitute
 443                --  components in a single machine scalar).
 444
 445                MaxL  : Uint;
 446                --  Maximum last bit value of any component in this set
 447
 448                MSS   : Uint;
 449                --  Corresponding machine scalar size
 450
 451                -----------
 452                -- CP_Lt --
 453                -----------
 454
 455                function CP_Lt (Op1, Op2 : Natural) return Boolean is
 456                begin
 457                   return Position (Component_Clause (Comps (Op1))) <
 458                     Position (Component_Clause (Comps (Op2)));
 459                end CP_Lt;
 460
 461                -------------
 462                -- CP_Move --
 463                -------------
 464
 465                procedure CP_Move (From : Natural; To : Natural) is
 466                begin
 467                   Comps (To) := Comps (From);
 468                end CP_Move;
 469
 470                --  Start of processing for Sort_CC
 471
 472             begin
 473                --  Collect the component clauses
 474
 475                Num_CC := 0;
 476                Comp   := First_Component_Or_Discriminant (R);
 477                while Present (Comp) loop
 478                   if Present (Component_Clause (Comp))
 479                     and then Esize (Comp) <= Max_Machine_Scalar_Size
 480                   then
 481                      Num_CC := Num_CC + 1;
 482                      Comps (Num_CC) := Comp;
 483                   end if;
 484
 485                   Next_Component_Or_Discriminant (Comp);
 486                end loop;
 487
 488                --  Sort by ascending position number
 489
 490                Sorting.Sort (Num_CC);
 491
 492                --  We now have all the components whose size does not exceed
 493                --  the max machine scalar value, sorted by starting position.
 494                --  In this loop we gather groups of clauses starting at the
 495                --  same position, to process them in accordance with AI-133.
 496
 497                Stop := 0;
 498                while Stop < Num_CC loop
 499                   Start := Stop + 1;
 500                   Stop  := Start;
 501                   MaxL  :=
 502                     Static_Integer
 503                       (Last_Bit (Component_Clause (Comps (Start))));
 504                   while Stop < Num_CC loop
 505                      if Static_Integer
 506                           (Position (Component_Clause (Comps (Stop + 1)))) =
 507                         Static_Integer
 508                           (Position (Component_Clause (Comps (Stop))))
 509                      then
 510                         Stop := Stop + 1;
 511                         MaxL :=
 512                           UI_Max
 513                             (MaxL,
 514                              Static_Integer
 515                                (Last_Bit
 516                                   (Component_Clause (Comps (Stop)))));
 517                      else
 518                         exit;
 519                      end if;
 520                   end loop;
 521
 522                   --  Now we have a group of component clauses from Start to
 523                   --  Stop whose positions are identical, and MaxL is the
 524                   --  maximum last bit value of any of these components.
 525
 526                   --  We need to determine the corresponding machine scalar
 527                   --  size. This loop assumes that machine scalar sizes are
 528                   --  even, and that each possible machine scalar has twice
 529                   --  as many bits as the next smaller one.
 530
 531                   MSS := Max_Machine_Scalar_Size;
 532                   while MSS mod 2 = 0
 533                     and then (MSS / 2) >= SSU
 534                     and then (MSS / 2) > MaxL
 535                   loop
 536                      MSS := MSS / 2;
 537                   end loop;
 538
 539                   --  Here is where we fix up the Component_Bit_Offset value
 540                   --  to account for the reverse bit order. Some examples of
 541                   --  what needs to be done for the case of a machine scalar
 542                   --  size of 8 are:
 543
 544                   --    First_Bit .. Last_Bit     Component_Bit_Offset
 545                   --      old          new          old       new
 546
 547                   --     0 .. 0       7 .. 7         0         7
 548                   --     0 .. 1       6 .. 7         0         6
 549                   --     0 .. 2       5 .. 7         0         5
 550                   --     0 .. 7       0 .. 7         0         4
 551
 552                   --     1 .. 1       6 .. 6         1         6
 553                   --     1 .. 4       3 .. 6         1         3
 554                   --     4 .. 7       0 .. 3         4         0
 555
 556                   --  The rule is that the first bit is obtained by subtracting
 557                   --  the old ending bit from machine scalar size - 1.
 558
 559                   for C in Start .. Stop loop
 560                      declare
 561                         Comp : constant Entity_Id := Comps (C);
 562                         CC   : constant Node_Id   :=
 563                                  Component_Clause (Comp);
 564                         LB   : constant Uint :=
 565                                  Static_Integer (Last_Bit (CC));
 566                         NFB  : constant Uint := MSS - Uint_1 - LB;
 567                         NLB  : constant Uint := NFB + Esize (Comp) - 1;
 568                         Pos  : constant Uint :=
 569                                  Static_Integer (Position (CC));
 570
 571                      begin
 572                         if Warn_On_Reverse_Bit_Order then
 573                            Error_Msg_Uint_1 := MSS;
 574                            Error_Msg_N
 575                              ("info: reverse bit order in machine " &
 576                               "scalar of length^?", First_Bit (CC));
 577                            Error_Msg_Uint_1 := NFB;
 578                            Error_Msg_Uint_2 := NLB;
 579
 580                            if Bytes_Big_Endian then
 581                               Error_Msg_NE
 582                                 ("?\info: big-endian range for "
 583                                  & "component & is ^ .. ^",
 584                                  First_Bit (CC), Comp);
 585                            else
 586                               Error_Msg_NE
 587                                 ("?\info: little-endian range "
 588                                  & "for component & is ^ .. ^",
 589                                  First_Bit (CC), Comp);
 590                            end if;
 591                         end if;
 592
 593                         Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
 594                         Set_Normalized_First_Bit (Comp, NFB mod SSU);
 595                      end;
 596                   end loop;
 597                end loop;
 598             end Sort_CC;
 599          end;
 600       end if;
 601    end Adjust_Record_For_Reverse_Bit_Order;
 602
 603    --------------------------------------
 604    -- Alignment_Check_For_Esize_Change --
 605    --------------------------------------
 606
 607    procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id) is
 608    begin
 609       --  If the alignment is known, and not set by a rep clause, and is
 610       --  inconsistent with the size being set, then reset it to unknown,
 611       --  we assume in this case that the size overrides the inherited
 612       --  alignment, and that the alignment must be recomputed.
 613
 614       if Known_Alignment (Typ)
 615         and then not Has_Alignment_Clause (Typ)
 616         and then Esize (Typ) mod (Alignment (Typ) * SSU) /= 0
 617       then
 618          Init_Alignment (Typ);
 619       end if;
 620    end Alignment_Check_For_Esize_Change;
 621
 622    -----------------------
 623    -- Analyze_At_Clause --
 624    -----------------------
 625
 626    --  An at clause is replaced by the corresponding Address attribute
 627    --  definition clause that is the preferred approach in Ada 95.
 628
 629    procedure Analyze_At_Clause (N : Node_Id) is
 630       CS : constant Boolean := Comes_From_Source (N);
 631
 632    begin
 633       --  This is an obsolescent feature
 634
 635       Check_Restriction (No_Obsolescent_Features, N);
 636
 637       if Warn_On_Obsolescent_Feature then
 638          Error_Msg_N
 639            ("at clause is an obsolescent feature (RM J.7(2))?", N);
 640          Error_Msg_N
 641            ("\use address attribute definition clause instead?", N);
 642       end if;
 643
 644       --  Rewrite as address clause
 645
 646       Rewrite (N,
 647         Make_Attribute_Definition_Clause (Sloc (N),
 648           Name  => Identifier (N),
 649           Chars => Name_Address,
 650           Expression => Expression (N)));
 651
 652       --  We preserve Comes_From_Source, since logically the clause still
 653       --  comes from the source program even though it is changed in form.
 654
 655       Set_Comes_From_Source (N, CS);
 656
 657       --  Analyze rewritten clause
 658
 659       Analyze_Attribute_Definition_Clause (N);
 660    end Analyze_At_Clause;
 661
 662    -----------------------------------------
 663    -- Analyze_Attribute_Definition_Clause --
 664    -----------------------------------------
 665
 666    procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is
 667       Loc   : constant Source_Ptr   := Sloc (N);
 668       Nam   : constant Node_Id      := Name (N);
 669       Attr  : constant Name_Id      := Chars (N);
 670       Expr  : constant Node_Id      := Expression (N);
 671       Id    : constant Attribute_Id := Get_Attribute_Id (Attr);
 672       Ent   : Entity_Id;
 673       U_Ent : Entity_Id;
 674
 675       FOnly : Boolean := False;
 676       --  Reset to True for subtype specific attribute (Alignment, Size)
 677       --  and for stream attributes, i.e. those cases where in the call
 678       --  to Rep_Item_Too_Late, FOnly is set True so that only the freezing
 679       --  rules are checked. Note that the case of stream attributes is not
 680       --  clear from the RM, but see AI95-00137. Also, the RM seems to
 681       --  disallow Storage_Size for derived task types, but that is also
 682       --  clearly unintentional.
 683
 684       procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type);
 685       --  Common processing for 'Read, 'Write, 'Input and 'Output attribute
 686       --  definition clauses.
 687
 688       -----------------------------------
 689       -- Analyze_Stream_TSS_Definition --
 690       -----------------------------------
 691
 692       procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is
 693          Subp : Entity_Id := Empty;
 694          I    : Interp_Index;
 695          It   : Interp;
 696          Pnam : Entity_Id;
 697
 698          Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read);
 699
 700          function Has_Good_Profile (Subp : Entity_Id) return Boolean;
 701          --  Return true if the entity is a subprogram with an appropriate
 702          --  profile for the attribute being defined.
 703
 704          ----------------------
 705          -- Has_Good_Profile --
 706          ----------------------
 707
 708          function Has_Good_Profile (Subp : Entity_Id) return Boolean is
 709             F              : Entity_Id;
 710             Is_Function    : constant Boolean := (TSS_Nam = TSS_Stream_Input);
 711             Expected_Ekind : constant array (Boolean) of Entity_Kind :=
 712                                (False => E_Procedure, True => E_Function);
 713             Typ            : Entity_Id;
 714
 715          begin
 716             if Ekind (Subp) /= Expected_Ekind (Is_Function) then
 717                return False;
 718             end if;
 719
 720             F := First_Formal (Subp);
 721
 722             if No (F)
 723               or else Ekind (Etype (F)) /= E_Anonymous_Access_Type
 724               or else Designated_Type (Etype (F)) /=
 725                                Class_Wide_Type (RTE (RE_Root_Stream_Type))
 726             then
 727                return False;
 728             end if;
 729
 730             if not Is_Function then
 731                Next_Formal (F);
 732
 733                declare
 734                   Expected_Mode : constant array (Boolean) of Entity_Kind :=
 735                                     (False => E_In_Parameter,
 736                                      True  => E_Out_Parameter);
 737                begin
 738                   if Parameter_Mode (F) /= Expected_Mode (Is_Read) then
 739                      return False;
 740                   end if;
 741                end;
 742
 743                Typ := Etype (F);
 744
 745             else
 746                Typ := Etype (Subp);
 747             end if;
 748
 749             return Base_Type (Typ) = Base_Type (Ent)
 750               and then No (Next_Formal (F));
 751          end Has_Good_Profile;
 752
 753       --  Start of processing for Analyze_Stream_TSS_Definition
 754
 755       begin
 756          FOnly := True;
 757
 758          if not Is_Type (U_Ent) then
 759             Error_Msg_N ("local name must be a subtype", Nam);
 760             return;
 761          end if;
 762
 763          Pnam := TSS (Base_Type (U_Ent), TSS_Nam);
 764
 765          --  If Pnam is present, it can be either inherited from an ancestor
 766          --  type (in which case it is legal to redefine it for this type), or
 767          --  be a previous definition of the attribute for the same type (in
 768          --  which case it is illegal).
 769
 770          --  In the first case, it will have been analyzed already, and we
 771          --  can check that its profile does not match the expected profile
 772          --  for a stream attribute of U_Ent. In the second case, either Pnam
 773          --  has been analyzed (and has the expected profile), or it has not
 774          --  been analyzed yet (case of a type that has not been frozen yet
 775          --  and for which the stream attribute has been set using Set_TSS).
 776
 777          if Present (Pnam)
 778            and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam))
 779          then
 780             Error_Msg_Sloc := Sloc (Pnam);
 781             Error_Msg_Name_1 := Attr;
 782             Error_Msg_N ("% attribute already defined #", Nam);
 783             return;
 784          end if;
 785
 786          Analyze (Expr);
 787
 788          if Is_Entity_Name (Expr) then
 789             if not Is_Overloaded (Expr) then
 790                if Has_Good_Profile (Entity (Expr)) then
 791                   Subp := Entity (Expr);
 792                end if;
 793
 794             else
 795                Get_First_Interp (Expr, I, It);
 796                while Present (It.Nam) loop
 797                   if Has_Good_Profile (It.Nam) then
 798                      Subp := It.Nam;
 799                      exit;
 800                   end if;
 801
 802                   Get_Next_Interp (I, It);
 803                end loop;
 804             end if;
 805          end if;
 806
 807          if Present (Subp) then
 808             if Is_Abstract_Subprogram (Subp) then
 809                Error_Msg_N ("stream subprogram must not be abstract", Expr);
 810                return;
 811             end if;
 812
 813             Set_Entity (Expr, Subp);
 814             Set_Etype (Expr, Etype (Subp));
 815
 816             New_Stream_Subprogram (N, U_Ent, Subp, TSS_Nam);
 817
 818          else
 819             Error_Msg_Name_1 := Attr;
 820             Error_Msg_N ("incorrect expression for% attribute", Expr);
 821          end if;
 822       end Analyze_Stream_TSS_Definition;
 823
 824    --  Start of processing for Analyze_Attribute_Definition_Clause
 825
 826    begin
 827       --  Process Ignore_Rep_Clauses option
 828
 829       if Ignore_Rep_Clauses then
 830          case Id is
 831
 832             --  The following should be ignored. They do not affect legality
 833             --  and may be target dependent. The basic idea of -gnatI is to
 834             --  ignore any rep clauses that may be target dependent but do not
 835             --  affect legality (except possibly to be rejected because they
 836             --  are incompatible with the compilation target).
 837
 838             when Attribute_Alignment      |
 839                  Attribute_Bit_Order      |
 840                  Attribute_Component_Size |
 841                  Attribute_Machine_Radix  |
 842                  Attribute_Object_Size    |
 843                  Attribute_Size           |
 844                  Attribute_Small          |
 845                  Attribute_Stream_Size    |
 846                  Attribute_Value_Size     =>
 847
 848                Rewrite (N, Make_Null_Statement (Sloc (N)));
 849                return;
 850
 851             --  The following should not be ignored, because in the first place
 852             --  they are reasonably portable, and should not cause problems in
 853             --  compiling code from another target, and also they do affect
 854             --  legality, e.g. failing to provide a stream attribute for a
 855             --  type may make a program illegal.
 856
 857             when Attribute_External_Tag   |
 858                  Attribute_Input          |
 859                  Attribute_Output         |
 860                  Attribute_Read           |
 861                  Attribute_Storage_Pool   |
 862                  Attribute_Storage_Size   |
 863                  Attribute_Write          =>
 864                null;
 865
 866             --  Other cases are errors ("attribute& cannot be set with
 867             --  definition clause"), which will be caught below.
 868
 869             when others =>
 870                null;
 871          end case;
 872       end if;
 873
 874       Analyze (Nam);
 875       Ent := Entity (Nam);
 876
 877       if Rep_Item_Too_Early (Ent, N) then
 878          return;
 879       end if;
 880
 881       --  Rep clause applies to full view of incomplete type or private type if
 882       --  we have one (if not, this is a premature use of the type). However,
 883       --  certain semantic checks need to be done on the specified entity (i.e.
 884       --  the private view), so we save it in Ent.
 885
 886       if Is_Private_Type (Ent)
 887         and then Is_Derived_Type (Ent)
 888         and then not Is_Tagged_Type (Ent)
 889         and then No (Full_View (Ent))
 890       then
 891          --  If this is a private type whose completion is a derivation from
 892          --  another private type, there is no full view, and the attribute
 893          --  belongs to the type itself, not its underlying parent.
 894
 895          U_Ent := Ent;
 896
 897       elsif Ekind (Ent) = E_Incomplete_Type then
 898
 899          --  The attribute applies to the full view, set the entity of the
 900          --  attribute definition accordingly.
 901
 902          Ent := Underlying_Type (Ent);
 903          U_Ent := Ent;
 904          Set_Entity (Nam, Ent);
 905
 906       else
 907          U_Ent := Underlying_Type (Ent);
 908       end if;
 909
 910       --  Complete other routine error checks
 911
 912       if Etype (Nam) = Any_Type then
 913          return;
 914
 915       elsif Scope (Ent) /= Current_Scope then
 916          Error_Msg_N ("entity must be declared in this scope", Nam);
 917          return;
 918
 919       elsif No (U_Ent) then
 920          U_Ent := Ent;
 921
 922       elsif Is_Type (U_Ent)
 923         and then not Is_First_Subtype (U_Ent)
 924         and then Id /= Attribute_Object_Size
 925         and then Id /= Attribute_Value_Size
 926         and then not From_At_Mod (N)
 927       then
 928          Error_Msg_N ("cannot specify attribute for subtype", Nam);
 929          return;
 930       end if;
 931
 932       --  Switch on particular attribute
 933
 934       case Id is
 935
 936          -------------
 937          -- Address --
 938          -------------
 939
 940          --  Address attribute definition clause
 941
 942          when Attribute_Address => Address : begin
 943
 944             --  A little error check, catch for X'Address use X'Address;
 945
 946             if Nkind (Nam) = N_Identifier
 947               and then Nkind (Expr) = N_Attribute_Reference
 948               and then Attribute_Name (Expr) = Name_Address
 949               and then Nkind (Prefix (Expr)) = N_Identifier
 950               and then Chars (Nam) = Chars (Prefix (Expr))
 951             then
 952                Error_Msg_NE
 953                  ("address for & is self-referencing", Prefix (Expr), Ent);
 954                return;
 955             end if;
 956
 957             --  Not that special case, carry on with analysis of expression
 958
 959             Analyze_And_Resolve (Expr, RTE (RE_Address));
 960
 961             --  Even when ignoring rep clauses we need to indicate that the
 962             --  entity has an address clause and thus it is legal to declare
 963             --  it imported.
 964
 965             if Ignore_Rep_Clauses then
 966                if Ekind_In (U_Ent, E_Variable, E_Constant) then
 967                   Record_Rep_Item (U_Ent, N);
 968                end if;
 969
 970                return;
 971             end if;
 972
 973             if Present (Address_Clause (U_Ent)) then
 974                Error_Msg_N ("address already given for &", Nam);
 975
 976             --  Case of address clause for subprogram
 977
 978             elsif Is_Subprogram (U_Ent) then
 979                if Has_Homonym (U_Ent) then
 980                   Error_Msg_N
 981                     ("address clause cannot be given " &
 982                      "for overloaded subprogram",
 983                      Nam);
 984                   return;
 985                end if;
 986
 987                --  For subprograms, all address clauses are permitted, and we
 988                --  mark the subprogram as having a deferred freeze so that Gigi
 989                --  will not elaborate it too soon.
 990
 991                --  Above needs more comments, what is too soon about???
 992
 993                Set_Has_Delayed_Freeze (U_Ent);
 994
 995             --  Case of address clause for entry
 996
 997             elsif Ekind (U_Ent) = E_Entry then
 998                if Nkind (Parent (N)) = N_Task_Body then
 999                   Error_Msg_N
1000                     ("entry address must be specified in task spec", Nam);
1001                   return;
1002                end if;
1003
1004                --  For entries, we require a constant address
1005
1006                Check_Constant_Address_Clause (Expr, U_Ent);
1007
1008                --  Special checks for task types
1009
1010                if Is_Task_Type (Scope (U_Ent))
1011                  and then Comes_From_Source (Scope (U_Ent))
1012                then
1013                   Error_Msg_N
1014                     ("?entry address declared for entry in task type", N);
1015                   Error_Msg_N
1016                     ("\?only one task can be declared of this type", N);
1017                end if;
1018
1019                --  Entry address clauses are obsolescent
1020
1021                Check_Restriction (No_Obsolescent_Features, N);
1022
1023                if Warn_On_Obsolescent_Feature then
1024                   Error_Msg_N
1025                     ("attaching interrupt to task entry is an " &
1026                      "obsolescent feature (RM J.7.1)?", N);
1027                   Error_Msg_N
1028                     ("\use interrupt procedure instead?", N);
1029                end if;
1030
1031             --  Case of an address clause for a controlled object which we
1032             --  consider to be erroneous.
1033
1034             elsif Is_Controlled (Etype (U_Ent))
1035               or else Has_Controlled_Component (Etype (U_Ent))
1036             then
1037                Error_Msg_NE
1038                  ("?controlled object& must not be overlaid", Nam, U_Ent);
1039                Error_Msg_N
1040                  ("\?Program_Error will be raised at run time", Nam);
1041                Insert_Action (Declaration_Node (U_Ent),
1042                  Make_Raise_Program_Error (Loc,
1043                    Reason => PE_Overlaid_Controlled_Object));
1044                return;
1045
1046             --  Case of address clause for a (non-controlled) object
1047
1048             elsif
1049               Ekind (U_Ent) = E_Variable
1050                 or else
1051               Ekind (U_Ent) = E_Constant
1052             then
1053                declare
1054                   Expr  : constant Node_Id := Expression (N);
1055                   O_Ent : Entity_Id;
1056                   Off   : Boolean;
1057
1058                begin
1059                   --  Exported variables cannot have an address clause, because
1060                   --  this cancels the effect of the pragma Export.
1061
1062                   if Is_Exported (U_Ent) then
1063                      Error_Msg_N
1064                        ("cannot export object with address clause", Nam);
1065                      return;
1066                   end if;
1067
1068                   Find_Overlaid_Entity (N, O_Ent, Off);
1069
1070                   --  Overlaying controlled objects is erroneous
1071
1072                   if Present (O_Ent)
1073                     and then (Has_Controlled_Component (Etype (O_Ent))
1074                                 or else Is_Controlled (Etype (O_Ent)))
1075                   then
1076                      Error_Msg_N
1077                        ("?cannot overlay with controlled object", Expr);
1078                      Error_Msg_N
1079                        ("\?Program_Error will be raised at run time", Expr);
1080                      Insert_Action (Declaration_Node (U_Ent),
1081                        Make_Raise_Program_Error (Loc,
1082                          Reason => PE_Overlaid_Controlled_Object));
1083                      return;
1084
1085                   elsif Present (O_Ent)
1086                     and then Ekind (U_Ent) = E_Constant
1087                     and then not Is_Constant_Object (O_Ent)
1088                   then
1089                      Error_Msg_N ("constant overlays a variable?", Expr);
1090
1091                   elsif Present (Renamed_Object (U_Ent)) then
1092                      Error_Msg_N
1093                        ("address clause not allowed"
1094                           & " for a renaming declaration (RM 13.1(6))", Nam);
1095                      return;
1096
1097                   --  Imported variables can have an address clause, but then
1098                   --  the import is pretty meaningless except to suppress
1099                   --  initializations, so we do not need such variables to
1100                   --  be statically allocated (and in fact it causes trouble
1101                   --  if the address clause is a local value).
1102
1103                   elsif Is_Imported (U_Ent) then
1104                      Set_Is_Statically_Allocated (U_Ent, False);
1105                   end if;
1106
1107                   --  We mark a possible modification of a variable with an
1108                   --  address clause, since it is likely aliasing is occurring.
1109
1110                   Note_Possible_Modification (Nam, Sure => False);
1111
1112                   --  Here we are checking for explicit overlap of one variable
1113                   --  by another, and if we find this then mark the overlapped
1114                   --  variable as also being volatile to prevent unwanted
1115                   --  optimizations. This is a significant pessimization so
1116                   --  avoid it when there is an offset, i.e. when the object
1117                   --  is composite; they cannot be optimized easily anyway.
1118
1119                   if Present (O_Ent)
1120                     and then Is_Object (O_Ent)
1121                     and then not Off
1122                   then
1123                      Set_Treat_As_Volatile (O_Ent);
1124                   end if;
1125
1126                   --  Legality checks on the address clause for initialized
1127                   --  objects is deferred until the freeze point, because
1128                   --  a subsequent pragma might indicate that the object is
1129                   --  imported and thus not initialized.
1130
1131                   Set_Has_Delayed_Freeze (U_Ent);
1132
1133                   --  If an initialization call has been generated for this
1134                   --  object, it needs to be deferred to after the freeze node
1135                   --  we have just now added, otherwise GIGI will see a
1136                   --  reference to the variable (as actual to the IP call)
1137                   --  before its definition.
1138
1139                   declare
1140                      Init_Call : constant Node_Id := Find_Init_Call (U_Ent, N);
1141                   begin
1142                      if Present (Init_Call) then
1143                         Remove (Init_Call);
1144                         Append_Freeze_Action (U_Ent, Init_Call);
1145                      end if;
1146                   end;
1147
1148                   if Is_Exported (U_Ent) then
1149                      Error_Msg_N
1150                        ("& cannot be exported if an address clause is given",
1151                         Nam);
1152                      Error_Msg_N
1153                        ("\define and export a variable " &
1154                         "that holds its address instead",
1155                         Nam);
1156                   end if;
1157
1158                   --  Entity has delayed freeze, so we will generate an
1159                   --  alignment check at the freeze point unless suppressed.
1160
1161                   if not Range_Checks_Suppressed (U_Ent)
1162                     and then not Alignment_Checks_Suppressed (U_Ent)
1163                   then
1164                      Set_Check_Address_Alignment (N);
1165                   end if;
1166
1167                   --  Kill the size check code, since we are not allocating
1168                   --  the variable, it is somewhere else.
1169
1170                   Kill_Size_Check_Code (U_Ent);
1171
1172                   --  If the address clause is of the form:
1173
1174                   --    for Y'Address use X'Address
1175
1176                   --  or
1177
1178                   --    Const : constant Address := X'Address;
1179                   --    ...
1180                   --    for Y'Address use Const;
1181
1182                   --  then we make an entry in the table for checking the size
1183                   --  and alignment of the overlaying variable. We defer this
1184                   --  check till after code generation to take full advantage
1185                   --  of the annotation done by the back end. This entry is
1186                   --  only made if the address clause comes from source.
1187                   --  If the entity has a generic type, the check will be
1188                   --  performed in the instance if the actual type justifies
1189                   --  it, and we do not insert the clause in the table to
1190                   --  prevent spurious warnings.
1191
1192                   if Address_Clause_Overlay_Warnings
1193                     and then Comes_From_Source (N)
1194                     and then Present (O_Ent)
1195                     and then Is_Object (O_Ent)
1196                   then
1197                      if not Is_Generic_Type (Etype (U_Ent)) then
1198                         Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off));
1199                      end if;
1200
1201                      --  If variable overlays a constant view, and we are
1202                      --  warning on overlays, then mark the variable as
1203                      --  overlaying a constant (we will give warnings later
1204                      --  if this variable is assigned).
1205
1206                      if Is_Constant_Object (O_Ent)
1207                        and then Ekind (U_Ent) = E_Variable
1208                      then
1209                         Set_Overlays_Constant (U_Ent);
1210                      end if;
1211                   end if;
1212                end;
1213
1214             --  Not a valid entity for an address clause
1215
1216             else
1217                Error_Msg_N ("address cannot be given for &", Nam);
1218             end if;
1219          end Address;
1220
1221          ---------------
1222          -- Alignment --
1223          ---------------
1224
1225          --  Alignment attribute definition clause
1226
1227          when Attribute_Alignment => Alignment : declare
1228             Align : constant Uint := Get_Alignment_Value (Expr);
1229
1230          begin
1231             FOnly := True;
1232
1233             if not Is_Type (U_Ent)
1234               and then Ekind (U_Ent) /= E_Variable
1235               and then Ekind (U_Ent) /= E_Constant
1236             then
1237                Error_Msg_N ("alignment cannot be given for &", Nam);
1238
1239             elsif Has_Alignment_Clause (U_Ent) then
1240                Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent));
1241                Error_Msg_N ("alignment clause previously given#", N);
1242
1243             elsif Align /= No_Uint then
1244                Set_Has_Alignment_Clause (U_Ent);
1245                Set_Alignment            (U_Ent, Align);
1246
1247                --  For an array type, U_Ent is the first subtype. In that case,
1248                --  also set the alignment of the anonymous base type so that
1249                --  other subtypes (such as the itypes for aggregates of the
1250                --  type) also receive the expected alignment.
1251
1252                if Is_Array_Type (U_Ent) then
1253                   Set_Alignment (Base_Type (U_Ent), Align);
1254                end if;
1255             end if;
1256          end Alignment;
1257
1258          ---------------
1259          -- Bit_Order --
1260          ---------------
1261
1262          --  Bit_Order attribute definition clause
1263
1264          when Attribute_Bit_Order => Bit_Order : declare
1265          begin
1266             if not Is_Record_Type (U_Ent) then
1267                Error_Msg_N
1268                  ("Bit_Order can only be defined for record type", Nam);
1269
1270             else
1271                Analyze_And_Resolve (Expr, RTE (RE_Bit_Order));
1272
1273                if Etype (Expr) = Any_Type then
1274                   return;
1275
1276                elsif not Is_Static_Expression (Expr) then
1277                   Flag_Non_Static_Expr
1278                     ("Bit_Order requires static expression!", Expr);
1279
1280                else
1281                   if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
1282                      Set_Reverse_Bit_Order (U_Ent, True);
1283                   end if;
1284                end if;
1285             end if;
1286          end Bit_Order;
1287
1288          --------------------
1289          -- Component_Size --
1290          --------------------
1291
1292          --  Component_Size attribute definition clause
1293
1294          when Attribute_Component_Size => Component_Size_Case : declare
1295             Csize    : constant Uint := Static_Integer (Expr);
1296             Ctyp     : Entity_Id;
1297             Btype    : Entity_Id;
1298             Biased   : Boolean;
1299             New_Ctyp : Entity_Id;
1300             Decl     : Node_Id;
1301
1302          begin
1303             if not Is_Array_Type (U_Ent) then
1304                Error_Msg_N ("component size requires array type", Nam);
1305                return;
1306             end if;
1307
1308             Btype := Base_Type (U_Ent);
1309             Ctyp := Component_Type (Btype);
1310
1311             if Has_Component_Size_Clause (Btype) then
1312                Error_Msg_N
1313                  ("component size clause for& previously given", Nam);
1314
1315             elsif Rep_Item_Too_Early (Btype, N) then
1316                null;
1317
1318             elsif Csize /= No_Uint then
1319                Check_Size (Expr, Ctyp, Csize, Biased);
1320
1321                --  For the biased case, build a declaration for a subtype
1322                --  that will be used to represent the biased subtype that
1323                --  reflects the biased representation of components. We need
1324                --  this subtype to get proper conversions on referencing
1325                --  elements of the array. Note that component size clauses
1326                --  are ignored in VM mode.
1327
1328                if VM_Target = No_VM then
1329                   if Biased then
1330                      New_Ctyp :=
1331                        Make_Defining_Identifier (Loc,
1332                          Chars =>
1333                            New_External_Name (Chars (U_Ent), 'C', 0, 'T'));
1334
1335                      Decl :=
1336                        Make_Subtype_Declaration (Loc,
1337                          Defining_Identifier => New_Ctyp,
1338                          Subtype_Indication  =>
1339                            New_Occurrence_Of (Component_Type (Btype), Loc));
1340
1341                      Set_Parent (Decl, N);
1342                      Analyze (Decl, Suppress => All_Checks);
1343
1344                      Set_Has_Delayed_Freeze        (New_Ctyp, False);
1345                      Set_Esize                     (New_Ctyp, Csize);
1346                      Set_RM_Size                   (New_Ctyp, Csize);
1347                      Init_Alignment                (New_Ctyp);
1348                      Set_Is_Itype                  (New_Ctyp, True);
1349                      Set_Associated_Node_For_Itype (New_Ctyp, U_Ent);
1350
1351                      Set_Component_Type (Btype, New_Ctyp);
1352                      Set_Biased (New_Ctyp, N, "component size clause");
1353                   end if;
1354
1355                   Set_Component_Size (Btype, Csize);
1356
1357                --  For VM case, we ignore component size clauses
1358
1359                else
1360                   --  Give a warning unless we are in GNAT mode, in which case
1361                   --  the warning is suppressed since it is not useful.
1362
1363                   if not GNAT_Mode then
1364                      Error_Msg_N
1365                        ("?component size ignored in this configuration", N);
1366                   end if;
1367                end if;
1368
1369                --  Deal with warning on overridden size
1370
1371                if Warn_On_Overridden_Size
1372                  and then Has_Size_Clause (Ctyp)
1373                  and then RM_Size (Ctyp) /= Csize
1374                then
1375                   Error_Msg_NE
1376                     ("?component size overrides size clause for&",
1377                      N, Ctyp);
1378                end if;
1379
1380                Set_Has_Component_Size_Clause (Btype, True);
1381                Set_Has_Non_Standard_Rep (Btype, True);
1382             end if;
1383          end Component_Size_Case;
1384
1385          ------------------
1386          -- External_Tag --
1387          ------------------
1388
1389          when Attribute_External_Tag => External_Tag :
1390          begin
1391             if not Is_Tagged_Type (U_Ent) then
1392                Error_Msg_N ("should be a tagged type", Nam);
1393             end if;
1394
1395             Analyze_And_Resolve (Expr, Standard_String);
1396
1397             if not Is_Static_Expression (Expr) then
1398                Flag_Non_Static_Expr
1399                  ("static string required for tag name!", Nam);
1400             end if;
1401
1402             if VM_Target = No_VM then
1403                Set_Has_External_Tag_Rep_Clause (U_Ent);
1404             else
1405                Error_Msg_Name_1 := Attr;
1406                Error_Msg_N
1407                  ("% attribute unsupported in this configuration", Nam);
1408             end if;
1409
1410             if not Is_Library_Level_Entity (U_Ent) then
1411                Error_Msg_NE
1412                  ("?non-unique external tag supplied for &", N, U_Ent);
1413                Error_Msg_N
1414                  ("?\same external tag applies to all subprogram calls", N);
1415                Error_Msg_N
1416                  ("?\corresponding internal tag cannot be obtained", N);
1417             end if;
1418          end External_Tag;
1419
1420          -----------
1421          -- Input --
1422          -----------
1423
1424          when Attribute_Input =>
1425             Analyze_Stream_TSS_Definition (TSS_Stream_Input);
1426             Set_Has_Specified_Stream_Input (Ent);
1427
1428          -------------------
1429          -- Machine_Radix --
1430          -------------------
1431
1432          --  Machine radix attribute definition clause
1433
1434          when Attribute_Machine_Radix => Machine_Radix : declare
1435             Radix : constant Uint := Static_Integer (Expr);
1436
1437          begin
1438             if not Is_Decimal_Fixed_Point_Type (U_Ent) then
1439                Error_Msg_N ("decimal fixed-point type expected for &", Nam);
1440
1441             elsif Has_Machine_Radix_Clause (U_Ent) then
1442                Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent));
1443                Error_Msg_N ("machine radix clause previously given#", N);
1444
1445             elsif Radix /= No_Uint then
1446                Set_Has_Machine_Radix_Clause (U_Ent);
1447                Set_Has_Non_Standard_Rep (Base_Type (U_Ent));
1448
1449                if Radix = 2 then
1450                   null;
1451                elsif Radix = 10 then
1452                   Set_Machine_Radix_10 (U_Ent);
1453                else
1454                   Error_Msg_N ("machine radix value must be 2 or 10", Expr);
1455                end if;
1456             end if;
1457          end Machine_Radix;
1458
1459          -----------------
1460          -- Object_Size --
1461          -----------------
1462
1463          --  Object_Size attribute definition clause
1464
1465          when Attribute_Object_Size => Object_Size : declare
1466             Size : constant Uint := Static_Integer (Expr);
1467
1468             Biased : Boolean;
1469             pragma Warnings (Off, Biased);
1470
1471          begin
1472             if not Is_Type (U_Ent) then
1473                Error_Msg_N ("Object_Size cannot be given for &", Nam);
1474
1475             elsif Has_Object_Size_Clause (U_Ent) then
1476                Error_Msg_N ("Object_Size already given for &", Nam);
1477
1478             else
1479                Check_Size (Expr, U_Ent, Size, Biased);
1480
1481                if Size /= 8
1482                     and then
1483                   Size /= 16
1484                     and then
1485                   Size /= 32
1486                     and then
1487                   UI_Mod (Size, 64) /= 0
1488                then
1489                   Error_Msg_N
1490                     ("Object_Size must be 8, 16, 32, or multiple of 64",
1491                      Expr);
1492                end if;
1493
1494                Set_Esize (U_Ent, Size);
1495                Set_Has_Object_Size_Clause (U_Ent);
1496                Alignment_Check_For_Esize_Change (U_Ent);
1497             end if;
1498          end Object_Size;
1499
1500          ------------
1501          -- Output --
1502          ------------
1503
1504          when Attribute_Output =>
1505             Analyze_Stream_TSS_Definition (TSS_Stream_Output);
1506             Set_Has_Specified_Stream_Output (Ent);
1507
1508          ----------
1509          -- Read --
1510          ----------
1511
1512          when Attribute_Read =>
1513             Analyze_Stream_TSS_Definition (TSS_Stream_Read);
1514             Set_Has_Specified_Stream_Read (Ent);
1515
1516          ----------
1517          -- Size --
1518          ----------
1519
1520          --  Size attribute definition clause
1521
1522          when Attribute_Size => Size : declare
1523             Size   : constant Uint := Static_Integer (Expr);
1524             Etyp   : Entity_Id;
1525             Biased : Boolean;
1526
1527          begin
1528             FOnly := True;
1529
1530             if Has_Size_Clause (U_Ent) then
1531                Error_Msg_N ("size already given for &", Nam);
1532
1533             elsif not Is_Type (U_Ent)
1534               and then Ekind (U_Ent) /= E_Variable
1535               and then Ekind (U_Ent) /= E_Constant
1536             then
1537                Error_Msg_N ("size cannot be given for &", Nam);
1538
1539             elsif Is_Array_Type (U_Ent)
1540               and then not Is_Constrained (U_Ent)
1541             then
1542                Error_Msg_N
1543                  ("size cannot be given for unconstrained array", Nam);
1544
1545             elsif Size /= No_Uint then
1546
1547                if VM_Target /= No_VM and then not GNAT_Mode then
1548
1549                   --  Size clause is not handled properly on VM targets.
1550                   --  Display a warning unless we are in GNAT mode, in which
1551                   --  case this is useless.
1552
1553                   Error_Msg_N
1554                     ("?size clauses are ignored in this configuration", N);
1555                end if;
1556
1557                if Is_Type (U_Ent) then
1558                   Etyp := U_Ent;
1559                else
1560                   Etyp := Etype (U_Ent);
1561                end if;
1562
1563                --  Check size, note that Gigi is in charge of checking that the
1564                --  size of an array or record type is OK. Also we do not check
1565                --  the size in the ordinary fixed-point case, since it is too
1566                --  early to do so (there may be subsequent small clause that
1567                --  affects the size). We can check the size if a small clause
1568                --  has already been given.
1569
1570                if not Is_Ordinary_Fixed_Point_Type (U_Ent)
1571                  or else Has_Small_Clause (U_Ent)
1572                then
1573                   Check_Size (Expr, Etyp, Size, Biased);
1574                   Set_Biased (U_Ent, N, "size clause", Biased);
1575                end if;
1576
1577                --  For types set RM_Size and Esize if possible
1578
1579                if Is_Type (U_Ent) then
1580                   Set_RM_Size (U_Ent, Size);
1581
1582                   --  For scalar types, increase Object_Size to power of 2, but
1583                   --  not less than a storage unit in any case (i.e., normally
1584                   --  this means it will be byte addressable).
1585
1586                   if Is_Scalar_Type (U_Ent) then
1587                      if Size <= System_Storage_Unit then
1588                         Init_Esize (U_Ent, System_Storage_Unit);
1589                      elsif Size <= 16 then
1590                         Init_Esize (U_Ent, 16);
1591                      elsif Size <= 32 then
1592                         Init_Esize (U_Ent, 32);
1593                      else
1594                         Set_Esize  (U_Ent, (Size + 63) / 64 * 64);
1595                      end if;
1596
1597                   --  For all other types, object size = value size. The
1598                   --  backend will adjust as needed.
1599
1600                   else
1601                      Set_Esize (U_Ent, Size);
1602                   end if;
1603
1604                   Alignment_Check_For_Esize_Change (U_Ent);
1605
1606                --  For objects, set Esize only
1607
1608                else
1609                   if Is_Elementary_Type (Etyp) then
1610                      if Size /= System_Storage_Unit
1611                           and then
1612                         Size /= System_Storage_Unit * 2
1613                           and then
1614                         Size /= System_Storage_Unit * 4
1615                            and then
1616                         Size /= System_Storage_Unit * 8
1617                      then
1618                         Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
1619                         Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
1620                         Error_Msg_N
1621                           ("size for primitive object must be a power of 2"
1622                             & " in the range ^-^", N);
1623                      end if;
1624                   end if;
1625
1626                   Set_Esize (U_Ent, Size);
1627                end if;
1628
1629                Set_Has_Size_Clause (U_Ent);
1630             end if;
1631          end Size;
1632
1633          -----------
1634          -- Small --
1635          -----------
1636
1637          --  Small attribute definition clause
1638
1639          when Attribute_Small => Small : declare
1640             Implicit_Base : constant Entity_Id := Base_Type (U_Ent);
1641             Small         : Ureal;
1642
1643          begin
1644             Analyze_And_Resolve (Expr, Any_Real);
1645
1646             if Etype (Expr) = Any_Type then
1647                return;
1648
1649             elsif not Is_Static_Expression (Expr) then
1650                Flag_Non_Static_Expr
1651                  ("small requires static expression!", Expr);
1652                return;
1653
1654             else
1655                Small := Expr_Value_R (Expr);
1656
1657                if Small <= Ureal_0 then
1658                   Error_Msg_N ("small value must be greater than zero", Expr);
1659                   return;
1660                end if;
1661
1662             end if;
1663
1664             if not Is_Ordinary_Fixed_Point_Type (U_Ent) then
1665                Error_Msg_N
1666                  ("small requires an ordinary fixed point type", Nam);
1667
1668             elsif Has_Small_Clause (U_Ent) then
1669                Error_Msg_N ("small already given for &", Nam);
1670
1671             elsif Small > Delta_Value (U_Ent) then
1672                Error_Msg_N
1673                  ("small value must not be greater then delta value", Nam);
1674
1675             else
1676                Set_Small_Value (U_Ent, Small);
1677                Set_Small_Value (Implicit_Base, Small);
1678                Set_Has_Small_Clause (U_Ent);
1679                Set_Has_Small_Clause (Implicit_Base);
1680                Set_Has_Non_Standard_Rep (Implicit_Base);
1681             end if;
1682          end Small;
1683
1684          ------------------
1685          -- Storage_Pool --
1686          ------------------
1687
1688          --  Storage_Pool attribute definition clause
1689
1690          when Attribute_Storage_Pool => Storage_Pool : declare
1691             Pool : Entity_Id;
1692             T    : Entity_Id;
1693
1694          begin
1695             if Ekind (U_Ent) = E_Access_Subprogram_Type then
1696                Error_Msg_N
1697                  ("storage pool cannot be given for access-to-subprogram type",
1698                   Nam);
1699                return;
1700
1701             elsif not
1702               Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type)
1703             then
1704                Error_Msg_N
1705                  ("storage pool can only be given for access types", Nam);
1706                return;
1707
1708             elsif Is_Derived_Type (U_Ent) then
1709                Error_Msg_N
1710                  ("storage pool cannot be given for a derived access type",
1711                   Nam);
1712
1713             elsif Has_Storage_Size_Clause (U_Ent) then
1714                Error_Msg_N ("storage size already given for &", Nam);
1715                return;
1716
1717             elsif Present (Associated_Storage_Pool (U_Ent)) then
1718                Error_Msg_N ("storage pool already given for &", Nam);
1719                return;
1720             end if;
1721
1722             Analyze_And_Resolve
1723               (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
1724
1725             if not Denotes_Variable (Expr) then
1726                Error_Msg_N ("storage pool must be a variable", Expr);
1727                return;
1728             end if;
1729
1730             if Nkind (Expr) = N_Type_Conversion then
1731                T := Etype (Expression (Expr));
1732             else
1733                T := Etype (Expr);
1734             end if;
1735
1736             --  The Stack_Bounded_Pool is used internally for implementing
1737             --  access types with a Storage_Size. Since it only work
1738             --  properly when used on one specific type, we need to check
1739             --  that it is not hijacked improperly:
1740             --    type T is access Integer;
1741             --    for T'Storage_Size use n;
1742             --    type Q is access Float;
1743             --    for Q'Storage_Size use T'Storage_Size; -- incorrect
1744
1745             if RTE_Available (RE_Stack_Bounded_Pool)
1746               and then Base_Type (T) = RTE (RE_Stack_Bounded_Pool)
1747             then
1748                Error_Msg_N ("non-shareable internal Pool", Expr);
1749                return;
1750             end if;
1751
1752             --  If the argument is a name that is not an entity name, then
1753             --  we construct a renaming operation to define an entity of
1754             --  type storage pool.
1755
1756             if not Is_Entity_Name (Expr)
1757               and then Is_Object_Reference (Expr)
1758             then
1759                Pool := Make_Temporary (Loc, 'P', Expr);
1760
1761                declare
1762                   Rnode : constant Node_Id :=
1763                             Make_Object_Renaming_Declaration (Loc,
1764                               Defining_Identifier => Pool,
1765                               Subtype_Mark        =>
1766                                 New_Occurrence_Of (Etype (Expr), Loc),
1767                               Name                => Expr);
1768
1769                begin
1770                   Insert_Before (N, Rnode);
1771                   Analyze (Rnode);
1772                   Set_Associated_Storage_Pool (U_Ent, Pool);
1773                end;
1774
1775             elsif Is_Entity_Name (Expr) then
1776                Pool := Entity (Expr);
1777
1778                --  If pool is a renamed object, get original one. This can
1779                --  happen with an explicit renaming, and within instances.
1780
1781                while Present (Renamed_Object (Pool))
1782                  and then Is_Entity_Name (Renamed_Object (Pool))
1783                loop
1784                   Pool := Entity (Renamed_Object (Pool));
1785                end loop;
1786
1787                if Present (Renamed_Object (Pool))
1788                  and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion
1789                  and then Is_Entity_Name (Expression (Renamed_Object (Pool)))
1790                then
1791                   Pool := Entity (Expression (Renamed_Object (Pool)));
1792                end if;
1793
1794                Set_Associated_Storage_Pool (U_Ent, Pool);
1795
1796             elsif Nkind (Expr) = N_Type_Conversion
1797               and then Is_Entity_Name (Expression (Expr))
1798               and then Nkind (Original_Node (Expr)) = N_Attribute_Reference
1799             then
1800                Pool := Entity (Expression (Expr));
1801                Set_Associated_Storage_Pool (U_Ent, Pool);
1802
1803             else
1804                Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
1805                return;
1806             end if;
1807          end Storage_Pool;
1808
1809          ------------------
1810          -- Storage_Size --
1811          ------------------
1812
1813          --  Storage_Size attribute definition clause
1814
1815          when Attribute_Storage_Size => Storage_Size : declare
1816             Btype : constant Entity_Id := Base_Type (U_Ent);
1817             Sprag : Node_Id;
1818
1819          begin
1820             if Is_Task_Type (U_Ent) then
1821                Check_Restriction (No_Obsolescent_Features, N);
1822
1823                if Warn_On_Obsolescent_Feature then
1824                   Error_Msg_N
1825                     ("storage size clause for task is an " &
1826                      "obsolescent feature (RM J.9)?", N);
1827                   Error_Msg_N ("\use Storage_Size pragma instead?", N);
1828                end if;
1829
1830                FOnly := True;
1831             end if;
1832
1833             if not Is_Access_Type (U_Ent)
1834               and then Ekind (U_Ent) /= E_Task_Type
1835             then
1836                Error_Msg_N ("storage size cannot be given for &", Nam);
1837
1838             elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then
1839                Error_Msg_N
1840                  ("storage size cannot be given for a derived access type",
1841                   Nam);
1842
1843             elsif Has_Storage_Size_Clause (Btype) then
1844                Error_Msg_N ("storage size already given for &", Nam);
1845
1846             else
1847                Analyze_And_Resolve (Expr, Any_Integer);
1848
1849                if Is_Access_Type (U_Ent) then
1850                   if Present (Associated_Storage_Pool (U_Ent)) then
1851                      Error_Msg_N ("storage pool already given for &", Nam);
1852                      return;
1853                   end if;
1854
1855                   if Is_OK_Static_Expression (Expr)
1856                     and then Expr_Value (Expr) = 0
1857                   then
1858                      Set_No_Pool_Assigned (Btype);
1859                   end if;
1860
1861                else -- Is_Task_Type (U_Ent)
1862                   Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size);
1863
1864                   if Present (Sprag) then
1865                      Error_Msg_Sloc := Sloc (Sprag);
1866                      Error_Msg_N
1867                        ("Storage_Size already specified#", Nam);
1868                      return;
1869                   end if;
1870                end if;
1871
1872                Set_Has_Storage_Size_Clause (Btype);
1873             end if;
1874          end Storage_Size;
1875
1876          -----------------
1877          -- Stream_Size --
1878          -----------------
1879
1880          when Attribute_Stream_Size => Stream_Size : declare
1881             Size : constant Uint := Static_Integer (Expr);
1882
1883          begin
1884             if Ada_Version <= Ada_95 then
1885                Check_Restriction (No_Implementation_Attributes, N);
1886             end if;
1887
1888             if Has_Stream_Size_Clause (U_Ent) then
1889                Error_Msg_N ("Stream_Size already given for &", Nam);
1890
1891             elsif Is_Elementary_Type (U_Ent) then
1892                if Size /= System_Storage_Unit
1893                     and then
1894                   Size /= System_Storage_Unit * 2
1895                     and then
1896                   Size /= System_Storage_Unit * 4
1897                      and then
1898                   Size /= System_Storage_Unit * 8
1899                then
1900                   Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
1901                   Error_Msg_N
1902                     ("stream size for elementary type must be a"
1903                        & " power of 2 and at least ^", N);
1904
1905                elsif RM_Size (U_Ent) > Size then
1906                   Error_Msg_Uint_1 := RM_Size (U_Ent);
1907                   Error_Msg_N
1908                     ("stream size for elementary type must be a"
1909                        & " power of 2 and at least ^", N);
1910                end if;
1911
1912                Set_Has_Stream_Size_Clause (U_Ent);
1913
1914             else
1915                Error_Msg_N ("Stream_Size cannot be given for &", Nam);
1916             end if;
1917          end Stream_Size;
1918
1919          ----------------
1920          -- Value_Size --
1921          ----------------
1922
1923          --  Value_Size attribute definition clause
1924
1925          when Attribute_Value_Size => Value_Size : declare
1926             Size   : constant Uint := Static_Integer (Expr);
1927             Biased : Boolean;
1928
1929          begin
1930             if not Is_Type (U_Ent) then
1931                Error_Msg_N ("Value_Size cannot be given for &", Nam);
1932
1933             elsif Present
1934                    (Get_Attribute_Definition_Clause
1935                      (U_Ent, Attribute_Value_Size))
1936             then
1937                Error_Msg_N ("Value_Size already given for &", Nam);
1938
1939             elsif Is_Array_Type (U_Ent)
1940               and then not Is_Constrained (U_Ent)
1941             then
1942                Error_Msg_N
1943                  ("Value_Size cannot be given for unconstrained array", Nam);
1944
1945             else
1946                if Is_Elementary_Type (U_Ent) then
1947                   Check_Size (Expr, U_Ent, Size, Biased);
1948                   Set_Biased (U_Ent, N, "value size clause", Biased);
1949                end if;
1950
1951                Set_RM_Size (U_Ent, Size);
1952             end if;
1953          end Value_Size;
1954
1955          -----------
1956          -- Write --
1957          -----------
1958
1959          when Attribute_Write =>
1960             Analyze_Stream_TSS_Definition (TSS_Stream_Write);
1961             Set_Has_Specified_Stream_Write (Ent);
1962
1963          --  All other attributes cannot be set
1964
1965          when others =>
1966             Error_Msg_N
1967               ("attribute& cannot be set with definition clause", N);
1968       end case;
1969
1970       --  The test for the type being frozen must be performed after
1971       --  any expression the clause has been analyzed since the expression
1972       --  itself might cause freezing that makes the clause illegal.
1973
1974       if Rep_Item_Too_Late (U_Ent, N, FOnly) then
1975          return;
1976       end if;
1977    end Analyze_Attribute_Definition_Clause;
1978
1979    ----------------------------
1980    -- Analyze_Code_Statement --
1981    ----------------------------
1982
1983    procedure Analyze_Code_Statement (N : Node_Id) is
1984       HSS   : constant Node_Id   := Parent (N);
1985       SBody : constant Node_Id   := Parent (HSS);
1986       Subp  : constant Entity_Id := Current_Scope;
1987       Stmt  : Node_Id;
1988       Decl  : Node_Id;
1989       StmtO : Node_Id;
1990       DeclO : Node_Id;
1991
1992    begin
1993       --  Analyze and check we get right type, note that this implements the
1994       --  requirement (RM 13.8(1)) that Machine_Code be with'ed, since that
1995       --  is the only way that Asm_Insn could possibly be visible.
1996
1997       Analyze_And_Resolve (Expression (N));
1998
1999       if Etype (Expression (N)) = Any_Type then
2000          return;
2001       elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then
2002          Error_Msg_N ("incorrect type for code statement", N);
2003          return;
2004       end if;
2005
2006       Check_Code_Statement (N);
2007
2008       --  Make sure we appear in the handled statement sequence of a
2009       --  subprogram (RM 13.8(3)).
2010
2011       if Nkind (HSS) /= N_Handled_Sequence_Of_Statements
2012         or else Nkind (SBody) /= N_Subprogram_Body
2013       then
2014          Error_Msg_N
2015            ("code statement can only appear in body of subprogram", N);
2016          return;
2017       end if;
2018
2019       --  Do remaining checks (RM 13.8(3)) if not already done
2020
2021       if not Is_Machine_Code_Subprogram (Subp) then
2022          Set_Is_Machine_Code_Subprogram (Subp);
2023
2024          --  No exception handlers allowed
2025
2026          if Present (Exception_Handlers (HSS)) then
2027             Error_Msg_N
2028               ("exception handlers not permitted in machine code subprogram",
2029                First (Exception_Handlers (HSS)));
2030          end if;
2031
2032          --  No declarations other than use clauses and pragmas (we allow
2033          --  certain internally generated declarations as well).
2034
2035          Decl := First (Declarations (SBody));
2036          while Present (Decl) loop
2037             DeclO := Original_Node (Decl);
2038             if Comes_From_Source (DeclO)
2039               and not Nkind_In (DeclO, N_Pragma,
2040                                        N_Use_Package_Clause,
2041                                        N_Use_Type_Clause,
2042                                        N_Implicit_Label_Declaration)
2043             then
2044                Error_Msg_N
2045                  ("this declaration not allowed in machine code subprogram",
2046                   DeclO);
2047             end if;
2048
2049             Next (Decl);
2050          end loop;
2051
2052          --  No statements other than code statements, pragmas, and labels.
2053          --  Again we allow certain internally generated statements.
2054
2055          Stmt := First (Statements (HSS));
2056          while Present (Stmt) loop
2057             StmtO := Original_Node (Stmt);
2058             if Comes_From_Source (StmtO)
2059               and then not Nkind_In (StmtO, N_Pragma,
2060                                             N_Label,
2061                                             N_Code_Statement)
2062             then
2063                Error_Msg_N
2064                  ("this statement is not allowed in machine code subprogram",
2065                   StmtO);
2066             end if;
2067
2068             Next (Stmt);
2069          end loop;
2070       end if;
2071    end Analyze_Code_Statement;
2072
2073    -----------------------------------------------
2074    -- Analyze_Enumeration_Representation_Clause --
2075    -----------------------------------------------
2076
2077    procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is
2078       Ident    : constant Node_Id    := Identifier (N);
2079       Aggr     : constant Node_Id    := Array_Aggregate (N);
2080       Enumtype : Entity_Id;
2081       Elit     : Entity_Id;
2082       Expr     : Node_Id;
2083       Assoc    : Node_Id;
2084       Choice   : Node_Id;
2085       Val      : Uint;
2086       Err      : Boolean := False;
2087
2088       Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer));
2089       Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer));
2090       --  Allowed range of universal integer (= allowed range of enum lit vals)
2091
2092       Min : Uint;
2093       Max : Uint;
2094       --  Minimum and maximum values of entries
2095
2096       Max_Node : Node_Id;
2097       --  Pointer to node for literal providing max value
2098
2099    begin
2100       if Ignore_Rep_Clauses then
2101          return;
2102       end if;
2103
2104       --  First some basic error checks
2105
2106       Find_Type (Ident);
2107       Enumtype := Entity (Ident);
2108
2109       if Enumtype = Any_Type
2110         or else Rep_Item_Too_Early (Enumtype, N)
2111       then
2112          return;
2113       else
2114          Enumtype := Underlying_Type (Enumtype);
2115       end if;
2116
2117       if not Is_Enumeration_Type (Enumtype) then
2118          Error_Msg_NE
2119            ("enumeration type required, found}",
2120             Ident, First_Subtype (Enumtype));
2121          return;
2122       end if;
2123
2124       --  Ignore rep clause on generic actual type. This will already have
2125       --  been flagged on the template as an error, and this is the safest
2126       --  way to ensure we don't get a junk cascaded message in the instance.
2127
2128       if Is_Generic_Actual_Type (Enumtype) then
2129          return;
2130
2131       --  Type must be in current scope
2132
2133       elsif Scope (Enumtype) /= Current_Scope then
2134          Error_Msg_N ("type must be declared in this scope", Ident);
2135          return;
2136
2137       --  Type must be a first subtype
2138
2139       elsif not Is_First_Subtype (Enumtype) then
2140          Error_Msg_N ("cannot give enumeration rep clause for subtype", N);
2141          return;
2142
2143       --  Ignore duplicate rep clause
2144
2145       elsif Has_Enumeration_Rep_Clause (Enumtype) then
2146          Error_Msg_N ("duplicate enumeration rep clause ignored", N);
2147          return;
2148
2149       --  Don't allow rep clause for standard [wide_[wide_]]character
2150
2151       elsif Is_Standard_Character_Type (Enumtype) then
2152          Error_Msg_N ("enumeration rep clause not allowed for this type", N);
2153          return;
2154
2155       --  Check that the expression is a proper aggregate (no parentheses)
2156
2157       elsif Paren_Count (Aggr) /= 0 then
2158          Error_Msg
2159            ("extra parentheses surrounding aggregate not allowed",
2160             First_Sloc (Aggr));
2161          return;
2162
2163       --  All tests passed, so set rep clause in place
2164
2165       else
2166          Set_Has_Enumeration_Rep_Clause (Enumtype);
2167          Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype));
2168       end if;
2169
2170       --  Now we process the aggregate. Note that we don't use the normal
2171       --  aggregate code for this purpose, because we don't want any of the
2172       --  normal expansion activities, and a number of special semantic
2173       --  rules apply (including the component type being any integer type)
2174
2175       Elit := First_Literal (Enumtype);
2176
2177       --  First the positional entries if any
2178
2179       if Present (Expressions (Aggr)) then
2180          Expr := First (Expressions (Aggr));
2181          while Present (Expr) loop
2182             if No (Elit) then
2183                Error_Msg_N ("too many entries in aggregate", Expr);
2184                return;
2185             end if;
2186
2187             Val := Static_Integer (Expr);
2188
2189             --  Err signals that we found some incorrect entries processing
2190             --  the list. The final checks for completeness and ordering are
2191             --  skipped in this case.
2192
2193             if Val = No_Uint then
2194                Err := True;
2195             elsif Val < Lo or else Hi < Val then
2196                Error_Msg_N ("value outside permitted range", Expr);
2197                Err := True;
2198             end if;
2199
2200             Set_Enumeration_Rep (Elit, Val);
2201             Set_Enumeration_Rep_Expr (Elit, Expr);
2202             Next (Expr);
2203             Next (Elit);
2204          end loop;
2205       end if;
2206
2207       --  Now process the named entries if present
2208
2209       if Present (Component_Associations (Aggr)) then
2210          Assoc := First (Component_Associations (Aggr));
2211          while Present (Assoc) loop
2212             Choice := First (Choices (Assoc));
2213
2214             if Present (Next (Choice)) then
2215                Error_Msg_N
2216                  ("multiple choice not allowed here", Next (Choice));
2217                Err := True;
2218             end if;
2219
2220             if Nkind (Choice) = N_Others_Choice then
2221                Error_Msg_N ("others choice not allowed here", Choice);
2222                Err := True;
2223
2224             elsif Nkind (Choice) = N_Range then
2225                --  ??? should allow zero/one element range here
2226                Error_Msg_N ("range not allowed here", Choice);
2227                Err := True;
2228
2229             else
2230                Analyze_And_Resolve (Choice, Enumtype);
2231
2232                if Is_Entity_Name (Choice)
2233                  and then Is_Type (Entity (Choice))
2234                then
2235                   Error_Msg_N ("subtype name not allowed here", Choice);
2236                   Err := True;
2237                   --  ??? should allow static subtype with zero/one entry
2238
2239                elsif Etype (Choice) = Base_Type (Enumtype) then
2240                   if not Is_Static_Expression (Choice) then
2241                      Flag_Non_Static_Expr
2242                        ("non-static expression used for choice!", Choice);
2243                      Err := True;
2244
2245                   else
2246                      Elit := Expr_Value_E (Choice);
2247
2248                      if Present (Enumeration_Rep_Expr (Elit)) then
2249                         Error_Msg_Sloc := Sloc (Enumeration_Rep_Expr (Elit));
2250                         Error_Msg_NE
2251                           ("representation for& previously given#",
2252                            Choice, Elit);
2253                         Err := True;
2254                      end if;
2255
2256                      Set_Enumeration_Rep_Expr (Elit, Expression (Assoc));
2257
2258                      Expr := Expression (Assoc);
2259                      Val := Static_Integer (Expr);
2260
2261                      if Val = No_Uint then
2262                         Err := True;
2263
2264                      elsif Val < Lo or else Hi < Val then
2265                         Error_Msg_N ("value outside permitted range", Expr);
2266                         Err := True;
2267                      end if;
2268
2269                      Set_Enumeration_Rep (Elit, Val);
2270                   end if;
2271                end if;
2272             end if;
2273
2274             Next (Assoc);
2275          end loop;
2276       end if;
2277
2278       --  Aggregate is fully processed. Now we check that a full set of
2279       --  representations was given, and that they are in range and in order.
2280       --  These checks are only done if no other errors occurred.
2281
2282       if not Err then
2283          Min  := No_Uint;
2284          Max  := No_Uint;
2285
2286          Elit := First_Literal (Enumtype);
2287          while Present (Elit) loop
2288             if No (Enumeration_Rep_Expr (Elit)) then
2289                Error_Msg_NE ("missing representation for&!", N, Elit);
2290
2291             else
2292                Val := Enumeration_Rep (Elit);
2293
2294                if Min = No_Uint then
2295                   Min := Val;
2296                end if;
2297
2298                if Val /= No_Uint then
2299                   if Max /= No_Uint and then Val <= Max then
2300                      Error_Msg_NE
2301                        ("enumeration value for& not ordered!",
2302                         Enumeration_Rep_Expr (Elit), Elit);
2303                   end if;
2304
2305                   Max_Node := Enumeration_Rep_Expr (Elit);
2306                   Max := Val;
2307                end if;
2308
2309                --  If there is at least one literal whose representation is not
2310                --  equal to the Pos value, then note that this enumeration type
2311                --  has a non-standard representation.
2312
2313                if Val /= Enumeration_Pos (Elit) then
2314                   Set_Has_Non_Standard_Rep (Base_Type (Enumtype));
2315                end if;
2316             end if;
2317
2318             Next (Elit);
2319          end loop;
2320
2321          --  Now set proper size information
2322
2323          declare
2324             Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype));
2325
2326          begin
2327             if Has_Size_Clause (Enumtype) then
2328
2329                --  All OK, if size is OK now
2330
2331                if RM_Size (Enumtype) >= Minsize then
2332                   null;
2333
2334                else
2335                   --  Try if we can get by with biasing
2336
2337                   Minsize :=
2338                     UI_From_Int (Minimum_Size (Enumtype, Biased => True));
2339
2340                   --  Error message if even biasing does not work
2341
2342                   if RM_Size (Enumtype) < Minsize then
2343                      Error_Msg_Uint_1 := RM_Size (Enumtype);
2344                      Error_Msg_Uint_2 := Max;
2345                      Error_Msg_N
2346                        ("previously given size (^) is too small "
2347                         & "for this value (^)", Max_Node);
2348
2349                   --  If biasing worked, indicate that we now have biased rep
2350
2351                   else
2352                      Set_Biased
2353                        (Enumtype, Size_Clause (Enumtype), "size clause");
2354                   end if;
2355                end if;
2356
2357             else
2358                Set_RM_Size    (Enumtype, Minsize);
2359                Set_Enum_Esize (Enumtype);
2360             end if;
2361
2362             Set_RM_Size   (Base_Type (Enumtype), RM_Size   (Enumtype));
2363             Set_Esize     (Base_Type (Enumtype), Esize     (Enumtype));
2364             Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype));
2365          end;
2366       end if;
2367
2368       --  We repeat the too late test in case it froze itself!
2369
2370       if Rep_Item_Too_Late (Enumtype, N) then
2371          null;
2372       end if;
2373    end Analyze_Enumeration_Representation_Clause;
2374
2375    ----------------------------
2376    -- Analyze_Free_Statement --
2377    ----------------------------
2378
2379    procedure Analyze_Free_Statement (N : Node_Id) is
2380    begin
2381       Analyze (Expression (N));
2382    end Analyze_Free_Statement;
2383
2384    ---------------------------
2385    -- Analyze_Freeze_Entity --
2386    ---------------------------
2387
2388    procedure Analyze_Freeze_Entity (N : Node_Id) is
2389       E : constant Entity_Id := Entity (N);
2390
2391    begin
2392       --  Remember that we are processing a freezing entity. Required to
2393       --  ensure correct decoration of internal entities associated with
2394       --  interfaces (see New_Overloaded_Entity).
2395
2396       Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
2397
2398       --  For tagged types covering interfaces add internal entities that link
2399       --  the primitives of the interfaces with the primitives that cover them.
2400       --  Note: These entities were originally generated only when generating
2401       --  code because their main purpose was to provide support to initialize
2402       --  the secondary dispatch tables. They are now generated also when
2403       --  compiling with no code generation to provide ASIS the relationship
2404       --  between interface primitives and tagged type primitives. They are
2405       --  also used to locate primitives covering interfaces when processing
2406       --  generics (see Derive_Subprograms).
2407
2408       if Ada_Version >= Ada_05
2409         and then Ekind (E) = E_Record_Type
2410         and then Is_Tagged_Type (E)
2411         and then not Is_Interface (E)
2412         and then Has_Interfaces (E)
2413       then
2414          --  This would be a good common place to call the routine that checks
2415          --  overriding of interface primitives (and thus factorize calls to
2416          --  Check_Abstract_Overriding located at different contexts in the
2417          --  compiler). However, this is not possible because it causes
2418          --  spurious errors in case of late overriding.
2419
2420          Add_Internal_Interface_Entities (E);
2421       end if;
2422
2423       --  Check CPP types
2424
2425       if Ekind (E) = E_Record_Type
2426         and then Is_CPP_Class (E)
2427         and then Is_Tagged_Type (E)
2428         and then Tagged_Type_Expansion
2429         and then Expander_Active
2430       then
2431          if CPP_Num_Prims (E) = 0 then
2432
2433             --  If the CPP type has user defined components then it must import
2434             --  primitives from C++. This is required because if the C++ class
2435             --  has no primitives then the C++ compiler does not added the _tag
2436             --  component to the type.
2437
2438             pragma Assert (Chars (First_Entity (E)) = Name_uTag);
2439
2440             if First_Entity (E) /= Last_Entity (E) then
2441                Error_Msg_N
2442                  ("?'C'P'P type must import at least one primitive from C++",
2443                   E);
2444             end if;
2445          end if;
2446
2447          --  Check that all its primitives are abstract or imported from C++.
2448          --  Check also availability of the C++ constructor.
2449
2450          declare
2451             Has_Constructors : constant Boolean := Has_CPP_Constructors (E);
2452             Elmt             : Elmt_Id;
2453             Error_Reported   : Boolean := False;
2454             Prim             : Node_Id;
2455
2456          begin
2457             Elmt := First_Elmt (Primitive_Operations (E));
2458             while Present (Elmt) loop
2459                Prim := Node (Elmt);
2460
2461                if Comes_From_Source (Prim) then
2462                   if Is_Abstract_Subprogram (Prim) then
2463                      null;
2464
2465                   elsif not Is_Imported (Prim)
2466                     or else Convention (Prim) /= Convention_CPP
2467                   then
2468                      Error_Msg_N
2469                        ("?primitives of 'C'P'P types must be imported from C++"
2470                         & " or abstract", Prim);
2471
2472                   elsif not Has_Constructors
2473                      and then not Error_Reported
2474                   then
2475                      Error_Msg_Name_1 := Chars (E);
2476                      Error_Msg_N
2477                        ("?'C'P'P constructor required for type %", Prim);
2478                      Error_Reported := True;
2479                   end if;
2480                end if;
2481
2482                Next_Elmt (Elmt);
2483             end loop;
2484          end;
2485       end if;
2486
2487       Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
2488    end Analyze_Freeze_Entity;
2489
2490    ------------------------------------------
2491    -- Analyze_Record_Representation_Clause --
2492    ------------------------------------------
2493
2494    --  Note: we check as much as we can here, but we can't do any checks
2495    --  based on the position values (e.g. overlap checks) until freeze time
2496    --  because especially in Ada 2005 (machine scalar mode), the processing
2497    --  for non-standard bit order can substantially change the positions.
2498    --  See procedure Check_Record_Representation_Clause (called from Freeze)
2499    --  for the remainder of this processing.
2500
2501    procedure Analyze_Record_Representation_Clause (N : Node_Id) is
2502       Ident   : constant Node_Id := Identifier (N);
2503       Biased  : Boolean;
2504       CC      : Node_Id;
2505       Comp    : Entity_Id;
2506       Fbit    : Uint;
2507       Hbit    : Uint := Uint_0;
2508       Lbit    : Uint;
2509       Ocomp   : Entity_Id;
2510       Posit   : Uint;
2511       Rectype : Entity_Id;
2512
2513       CR_Pragma : Node_Id := Empty;
2514       --  Points to N_Pragma node if Complete_Representation pragma present
2515
2516    begin
2517       if Ignore_Rep_Clauses then
2518          return;
2519       end if;
2520
2521       Find_Type (Ident);
2522       Rectype := Entity (Ident);
2523
2524       if Rectype = Any_Type
2525         or else Rep_Item_Too_Early (Rectype, N)
2526       then
2527          return;
2528       else
2529          Rectype := Underlying_Type (Rectype);
2530       end if;
2531
2532       --  First some basic error checks
2533
2534       if not Is_Record_Type (Rectype) then
2535          Error_Msg_NE
2536            ("record type required, found}", Ident, First_Subtype (Rectype));
2537          return;
2538
2539       elsif Scope (Rectype) /= Current_Scope then
2540          Error_Msg_N ("type must be declared in this scope", N);
2541          return;
2542
2543       elsif not Is_First_Subtype (Rectype) then
2544          Error_Msg_N ("cannot give record rep clause for subtype", N);
2545          return;
2546
2547       elsif Has_Record_Rep_Clause (Rectype) then
2548          Error_Msg_N ("duplicate record rep clause ignored", N);
2549          return;
2550
2551       elsif Rep_Item_Too_Late (Rectype, N) then
2552          return;
2553       end if;
2554
2555       if Present (Mod_Clause (N)) then
2556          declare
2557             Loc     : constant Source_Ptr := Sloc (N);
2558             M       : constant Node_Id := Mod_Clause (N);
2559             P       : constant List_Id := Pragmas_Before (M);
2560             AtM_Nod : Node_Id;
2561
2562             Mod_Val : Uint;
2563             pragma Warnings (Off, Mod_Val);
2564
2565          begin
2566             Check_Restriction (No_Obsolescent_Features, Mod_Clause (N));
2567
2568             if Warn_On_Obsolescent_Feature then
2569                Error_Msg_N
2570                  ("mod clause is an obsolescent feature (RM J.8)?", N);
2571                Error_Msg_N
2572                  ("\use alignment attribute definition clause instead?", N);
2573             end if;
2574
2575             if Present (P) then
2576                Analyze_List (P);
2577             end if;
2578
2579             --  In ASIS_Mode mode, expansion is disabled, but we must convert
2580             --  the Mod clause into an alignment clause anyway, so that the
2581             --  back-end can compute and back-annotate properly the size and
2582             --  alignment of types that may include this record.
2583
2584             --  This seems dubious, this destroys the source tree in a manner
2585             --  not detectable by ASIS ???
2586
2587             if Operating_Mode = Check_Semantics
2588               and then ASIS_Mode
2589             then
2590                AtM_Nod :=
2591                  Make_Attribute_Definition_Clause (Loc,
2592                    Name       => New_Reference_To (Base_Type (Rectype), Loc),
2593                    Chars      => Name_Alignment,
2594                    Expression => Relocate_Node (Expression (M)));
2595
2596                Set_From_At_Mod (AtM_Nod);
2597                Insert_After (N, AtM_Nod);
2598                Mod_Val := Get_Alignment_Value (Expression (AtM_Nod));
2599                Set_Mod_Clause (N, Empty);
2600
2601             else
2602                --  Get the alignment value to perform error checking
2603
2604                Mod_Val := Get_Alignment_Value (Expression (M));
2605             end if;
2606          end;
2607       end if;
2608
2609       --  For untagged types, clear any existing component clauses for the
2610       --  type. If the type is derived, this is what allows us to override
2611       --  a rep clause for the parent. For type extensions, the representation
2612       --  of the inherited components is inherited, so we want to keep previous
2613       --  component clauses for completeness.
2614
2615       if not Is_Tagged_Type (Rectype) then
2616          Comp := First_Component_Or_Discriminant (Rectype);
2617          while Present (Comp) loop
2618             Set_Component_Clause (Comp, Empty);
2619             Next_Component_Or_Discriminant (Comp);
2620          end loop;
2621       end if;
2622
2623       --  All done if no component clauses
2624
2625       CC := First (Component_Clauses (N));
2626
2627       if No (CC) then
2628          return;
2629       end if;
2630
2631       --  A representation like this applies to the base type
2632
2633       Set_Has_Record_Rep_Clause (Base_Type (Rectype));
2634       Set_Has_Non_Standard_Rep  (Base_Type (Rectype));
2635       Set_Has_Specified_Layout  (Base_Type (Rectype));
2636
2637       --  Process the component clauses
2638
2639       while Present (CC) loop
2640
2641          --  Pragma
2642
2643          if Nkind (CC) = N_Pragma then
2644             Analyze (CC);
2645
2646             --  The only pragma of interest is Complete_Representation
2647
2648             if Pragma_Name (CC) = Name_Complete_Representation then
2649                CR_Pragma := CC;
2650             end if;
2651
2652          --  Processing for real component clause
2653
2654          else
2655             Posit := Static_Integer (Position  (CC));
2656             Fbit  := Static_Integer (First_Bit (CC));
2657             Lbit  := Static_Integer (Last_Bit  (CC));
2658
2659             if Posit /= No_Uint
2660               and then Fbit /= No_Uint
2661               and then Lbit /= No_Uint
2662             then
2663                if Posit < 0 then
2664                   Error_Msg_N
2665                     ("position cannot be negative", Position (CC));
2666
2667                elsif Fbit < 0 then
2668                   Error_Msg_N
2669                     ("first bit cannot be negative", First_Bit (CC));
2670
2671                --  The Last_Bit specified in a component clause must not be
2672                --  less than the First_Bit minus one (RM-13.5.1(10)).
2673
2674                elsif Lbit < Fbit - 1 then
2675                   Error_Msg_N
2676                     ("last bit cannot be less than first bit minus one",
2677                      Last_Bit (CC));
2678
2679                --  Values look OK, so find the corresponding record component
2680                --  Even though the syntax allows an attribute reference for
2681                --  implementation-defined components, GNAT does not allow the
2682                --  tag to get an explicit position.
2683
2684                elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then
2685                   if Attribute_Name (Component_Name (CC)) = Name_Tag then
2686                      Error_Msg_N ("position of tag cannot be specified", CC);
2687                   else
2688                      Error_Msg_N ("illegal component name", CC);
2689                   end if;
2690
2691                else
2692                   Comp := First_Entity (Rectype);
2693                   while Present (Comp) loop
2694                      exit when Chars (Comp) = Chars (Component_Name (CC));
2695                      Next_Entity (Comp);
2696                   end loop;
2697
2698                   if No (Comp) then
2699
2700                      --  Maybe component of base type that is absent from
2701                      --  statically constrained first subtype.
2702
2703                      Comp := First_Entity (Base_Type (Rectype));
2704                      while Present (Comp) loop
2705                         exit when Chars (Comp) = Chars (Component_Name (CC));
2706                         Next_Entity (Comp);
2707                      end loop;
2708                   end if;
2709
2710                   if No (Comp) then
2711                      Error_Msg_N
2712                        ("component clause is for non-existent field", CC);
2713
2714                   --  Ada 2012 (AI05-0026): Any name that denotes a
2715                   --  discriminant of an object of an unchecked union type
2716                   --  shall not occur within a record_representation_clause.
2717
2718                   --  The general restriction of using record rep clauses on
2719                   --  Unchecked_Union types has now been lifted. Since it is
2720                   --  possible to introduce a record rep clause which mentions
2721                   --  the discriminant of an Unchecked_Union in non-Ada 2012
2722                   --  code, this check is applied to all versions of the
2723                   --  language.
2724
2725                   elsif Ekind (Comp) = E_Discriminant
2726                     and then Is_Unchecked_Union (Rectype)
2727                   then
2728                      Error_Msg_N
2729                        ("cannot reference discriminant of Unchecked_Union",
2730                         Component_Name (CC));
2731
2732                   elsif Present (Component_Clause (Comp)) then
2733
2734                      --  Diagnose duplicate rep clause, or check consistency
2735                      --  if this is an inherited component. In a double fault,
2736                      --  there may be a duplicate inconsistent clause for an
2737                      --  inherited component.
2738
2739                      if Scope (Original_Record_Component (Comp)) = Rectype
2740                        or else Parent (Component_Clause (Comp)) = N
2741                      then
2742                         Error_Msg_Sloc := Sloc (Component_Clause (Comp));
2743                         Error_Msg_N ("component clause previously given#", CC);
2744
2745                      else
2746                         declare
2747                            Rep1 : constant Node_Id := Component_Clause (Comp);
2748                         begin
2749                            if Intval (Position (Rep1)) /=
2750                                                    Intval (Position (CC))
2751                              or else Intval (First_Bit (Rep1)) /=
2752                                                    Intval (First_Bit (CC))
2753                              or else Intval (Last_Bit (Rep1)) /=
2754                                                    Intval (Last_Bit (CC))
2755                            then
2756                               Error_Msg_N ("component clause inconsistent "
2757                                 & "with representation of ancestor", CC);
2758                            elsif Warn_On_Redundant_Constructs then
2759                               Error_Msg_N ("?redundant component clause "
2760                                 & "for inherited component!", CC);
2761                            end if;
2762                         end;
2763                      end if;
2764
2765                   --  Normal case where this is the first component clause we
2766                   --  have seen for this entity, so set it up properly.
2767
2768                   else
2769                      --  Make reference for field in record rep clause and set
2770                      --  appropriate entity field in the field identifier.
2771
2772                      Generate_Reference
2773                        (Comp, Component_Name (CC), Set_Ref => False);
2774                      Set_Entity (Component_Name (CC), Comp);
2775
2776                      --  Update Fbit and Lbit to the actual bit number
2777
2778                      Fbit := Fbit + UI_From_Int (SSU) * Posit;
2779                      Lbit := Lbit + UI_From_Int (SSU) * Posit;
2780
2781                      if Has_Size_Clause (Rectype)
2782                        and then Esize (Rectype) <= Lbit
2783                      then
2784                         Error_Msg_N
2785                           ("bit number out of range of specified size",
2786                            Last_Bit (CC));
2787                      else
2788                         Set_Component_Clause     (Comp, CC);
2789                         Set_Component_Bit_Offset (Comp, Fbit);
2790                         Set_Esize                (Comp, 1 + (Lbit - Fbit));
2791                         Set_Normalized_First_Bit (Comp, Fbit mod SSU);
2792                         Set_Normalized_Position  (Comp, Fbit / SSU);
2793
2794                         if Warn_On_Overridden_Size
2795                           and then Has_Size_Clause (Etype (Comp))
2796                           and then RM_Size (Etype (Comp)) /= Esize (Comp)
2797                         then
2798                            Error_Msg_NE
2799                              ("?component size overrides size clause for&",
2800                               Component_Name (CC), Etype (Comp));
2801                         end if;
2802
2803                         --  This information is also set in the corresponding
2804                         --  component of the base type, found by accessing the
2805                         --  Original_Record_Component link if it is present.
2806
2807                         Ocomp := Original_Record_Component (Comp);
2808
2809                         if Hbit < Lbit then
2810                            Hbit := Lbit;
2811                         end if;
2812
2813                         Check_Size
2814                           (Component_Name (CC),
2815                            Etype (Comp),
2816                            Esize (Comp),
2817                            Biased);
2818
2819                         Set_Biased
2820                           (Comp, First_Node (CC), "component clause", Biased);
2821
2822                         if Present (Ocomp) then
2823                            Set_Component_Clause     (Ocomp, CC);
2824                            Set_Component_Bit_Offset (Ocomp, Fbit);
2825                            Set_Normalized_First_Bit (Ocomp, Fbit mod SSU);
2826                            Set_Normalized_Position  (Ocomp, Fbit / SSU);
2827                            Set_Esize                (Ocomp, 1 + (Lbit - Fbit));
2828
2829                            Set_Normalized_Position_Max
2830                              (Ocomp, Normalized_Position (Ocomp));
2831
2832                            --  Note: we don't use Set_Biased here, because we
2833                            --  already gave a warning above if needed, and we
2834                            --  would get a duplicate for the same name here.
2835
2836                            Set_Has_Biased_Representation
2837                              (Ocomp, Has_Biased_Representation (Comp));
2838                         end if;
2839
2840                         if Esize (Comp) < 0 then
2841                            Error_Msg_N ("component size is negative", CC);
2842                         end if;
2843                      end if;
2844                   end if;
2845                end if;
2846             end if;
2847          end if;
2848
2849          Next (CC);
2850       end loop;
2851
2852       --  Check missing components if Complete_Representation pragma appeared
2853
2854       if Present (CR_Pragma) then
2855          Comp := First_Component_Or_Discriminant (Rectype);
2856          while Present (Comp) loop
2857             if No (Component_Clause (Comp)) then
2858                Error_Msg_NE
2859                  ("missing component clause for &", CR_Pragma, Comp);
2860             end if;
2861
2862             Next_Component_Or_Discriminant (Comp);
2863          end loop;
2864
2865          --  If no Complete_Representation pragma, warn if missing components
2866
2867       elsif Warn_On_Unrepped_Components then
2868          declare
2869             Num_Repped_Components   : Nat := 0;
2870             Num_Unrepped_Components : Nat := 0;
2871
2872          begin
2873             --  First count number of repped and unrepped components
2874
2875             Comp := First_Component_Or_Discriminant (Rectype);
2876             while Present (Comp) loop
2877                if Present (Component_Clause (Comp)) then
2878                   Num_Repped_Components := Num_Repped_Components + 1;
2879                else
2880                   Num_Unrepped_Components := Num_Unrepped_Components + 1;
2881                end if;
2882
2883                Next_Component_Or_Discriminant (Comp);
2884             end loop;
2885
2886             --  We are only interested in the case where there is at least one
2887             --  unrepped component, and at least half the components have rep
2888             --  clauses. We figure that if less than half have them, then the
2889             --  partial rep clause is really intentional. If the component
2890             --  type has no underlying type set at this point (as for a generic
2891             --  formal type), we don't know enough to give a warning on the
2892             --  component.
2893
2894             if Num_Unrepped_Components > 0
2895               and then Num_Unrepped_Components < Num_Repped_Components
2896             then
2897                Comp := First_Component_Or_Discriminant (Rectype);
2898                while Present (Comp) loop
2899                   if No (Component_Clause (Comp))
2900                     and then Comes_From_Source (Comp)
2901                     and then Present (Underlying_Type (Etype (Comp)))
2902                     and then (Is_Scalar_Type (Underlying_Type (Etype (Comp)))
2903                                or else Size_Known_At_Compile_Time
2904                                          (Underlying_Type (Etype (Comp))))
2905                     and then not Has_Warnings_Off (Rectype)
2906                   then
2907                      Error_Msg_Sloc := Sloc (Comp);
2908                      Error_Msg_NE
2909                        ("?no component clause given for & declared #",
2910                         N, Comp);
2911                   end if;
2912
2913                   Next_Component_Or_Discriminant (Comp);
2914                end loop;
2915             end if;
2916          end;
2917       end if;
2918    end Analyze_Record_Representation_Clause;
2919
2920    -----------------------------------
2921    -- Check_Constant_Address_Clause --
2922    -----------------------------------
2923
2924    procedure Check_Constant_Address_Clause
2925      (Expr  : Node_Id;
2926       U_Ent : Entity_Id)
2927    is
2928       procedure Check_At_Constant_Address (Nod : Node_Id);
2929       --  Checks that the given node N represents a name whose 'Address is
2930       --  constant (in the same sense as OK_Constant_Address_Clause, i.e. the
2931       --  address value is the same at the point of declaration of U_Ent and at
2932       --  the time of elaboration of the address clause.
2933
2934       procedure Check_Expr_Constants (Nod : Node_Id);
2935       --  Checks that Nod meets the requirements for a constant address clause
2936       --  in the sense of the enclosing procedure.
2937
2938       procedure Check_List_Constants (Lst : List_Id);
2939       --  Check that all elements of list Lst meet the requirements for a
2940       --  constant address clause in the sense of the enclosing procedure.
2941
2942       -------------------------------
2943       -- Check_At_Constant_Address --
2944       -------------------------------
2945
2946       procedure Check_At_Constant_Address (Nod : Node_Id) is
2947       begin
2948          if Is_Entity_Name (Nod) then
2949             if Present (Address_Clause (Entity ((Nod)))) then
2950                Error_Msg_NE
2951                  ("invalid address clause for initialized object &!",
2952                            Nod, U_Ent);
2953                Error_Msg_NE
2954                  ("address for& cannot" &
2955                     " depend on another address clause! (RM 13.1(22))!",
2956                   Nod, U_Ent);
2957
2958             elsif In_Same_Source_Unit (Entity (Nod), U_Ent)
2959               and then Sloc (U_Ent) < Sloc (Entity (Nod))
2960             then
2961                Error_Msg_NE
2962                  ("invalid address clause for initialized object &!",
2963                   Nod, U_Ent);
2964                Error_Msg_Node_2 := U_Ent;
2965                Error_Msg_NE
2966                  ("\& must be defined before & (RM 13.1(22))!",
2967                   Nod, Entity (Nod));
2968             end if;
2969
2970          elsif Nkind (Nod) = N_Selected_Component then
2971             declare
2972                T : constant Entity_Id := Etype (Prefix (Nod));
2973
2974             begin
2975                if (Is_Record_Type (T)
2976                     and then Has_Discriminants (T))
2977                  or else
2978                   (Is_Access_Type (T)
2979                      and then Is_Record_Type (Designated_Type (T))
2980                      and then Has_Discriminants (Designated_Type (T)))
2981                then
2982                   Error_Msg_NE
2983                     ("invalid address clause for initialized object &!",
2984                      Nod, U_Ent);
2985                   Error_Msg_N
2986                     ("\address cannot depend on component" &
2987                      " of discriminated record (RM 13.1(22))!",
2988                      Nod);
2989                else
2990                   Check_At_Constant_Address (Prefix (Nod));
2991                end if;
2992             end;
2993
2994          elsif Nkind (Nod) = N_Indexed_Component then
2995             Check_At_Constant_Address (Prefix (Nod));
2996             Check_List_Constants (Expressions (Nod));
2997
2998          else
2999             Check_Expr_Constants (Nod);
3000          end if;
3001       end Check_At_Constant_Address;
3002
3003       --------------------------
3004       -- Check_Expr_Constants --
3005       --------------------------
3006
3007       procedure Check_Expr_Constants (Nod : Node_Id) is
3008          Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent);
3009          Ent       : Entity_Id           := Empty;
3010
3011       begin
3012          if Nkind (Nod) in N_Has_Etype
3013            and then Etype (Nod) = Any_Type
3014          then
3015             return;
3016          end if;
3017
3018          case Nkind (Nod) is
3019             when N_Empty | N_Error =>
3020                return;
3021
3022             when N_Identifier | N_Expanded_Name =>
3023                Ent := Entity (Nod);
3024
3025                --  We need to look at the original node if it is different
3026                --  from the node, since we may have rewritten things and
3027                --  substituted an identifier representing the rewrite.
3028
3029                if Original_Node (Nod) /= Nod then
3030                   Check_Expr_Constants (Original_Node (Nod));
3031
3032                   --  If the node is an object declaration without initial
3033                   --  value, some code has been expanded, and the expression
3034                   --  is not constant, even if the constituents might be
3035                   --  acceptable, as in A'Address + offset.
3036
3037                   if Ekind (Ent) = E_Variable
3038                     and then
3039                       Nkind (Declaration_Node (Ent)) = N_Object_Declaration
3040                     and then
3041                       No (Expression (Declaration_Node (Ent)))
3042                   then
3043                      Error_Msg_NE
3044                        ("invalid address clause for initialized object &!",
3045                         Nod, U_Ent);
3046
3047                   --  If entity is constant, it may be the result of expanding
3048                   --  a check. We must verify that its declaration appears
3049                   --  before the object in question, else we also reject the
3050                   --  address clause.
3051
3052                   elsif Ekind (Ent) = E_Constant
3053                     and then In_Same_Source_Unit (Ent, U_Ent)
3054                     and then Sloc (Ent) > Loc_U_Ent
3055                   then
3056                      Error_Msg_NE
3057                        ("invalid address clause for initialized object &!",
3058                         Nod, U_Ent);
3059                   end if;
3060
3061                   return;
3062                end if;
3063
3064                --  Otherwise look at the identifier and see if it is OK
3065
3066                if Ekind_In (Ent, E_Named_Integer, E_Named_Real)
3067                  or else Is_Type (Ent)
3068                then
3069                   return;
3070
3071                elsif
3072                   Ekind (Ent) = E_Constant
3073                     or else
3074                   Ekind (Ent) = E_In_Parameter
3075                then
3076                   --  This is the case where we must have Ent defined before
3077                   --  U_Ent. Clearly if they are in different units this
3078                   --  requirement is met since the unit containing Ent is
3079                   --  already processed.
3080
3081                   if not In_Same_Source_Unit (Ent, U_Ent) then
3082                      return;
3083
3084                   --  Otherwise location of Ent must be before the location
3085                   --  of U_Ent, that's what prior defined means.
3086
3087                   elsif Sloc (Ent) < Loc_U_Ent then
3088                      return;
3089
3090                   else
3091                      Error_Msg_NE
3092                        ("invalid address clause for initialized object &!",
3093                         Nod, U_Ent);
3094                      Error_Msg_Node_2 := U_Ent;
3095                      Error_Msg_NE
3096                        ("\& must be defined before & (RM 13.1(22))!",
3097                         Nod, Ent);
3098                   end if;
3099
3100                elsif Nkind (Original_Node (Nod)) = N_Function_Call then
3101                   Check_Expr_Constants (Original_Node (Nod));
3102
3103                else
3104                   Error_Msg_NE
3105                     ("invalid address clause for initialized object &!",
3106                      Nod, U_Ent);
3107
3108                   if Comes_From_Source (Ent) then
3109                      Error_Msg_NE
3110                        ("\reference to variable& not allowed"
3111                           & " (RM 13.1(22))!", Nod, Ent);
3112                   else
3113                      Error_Msg_N
3114                        ("non-static expression not allowed"
3115                           & " (RM 13.1(22))!", Nod);
3116                   end if;
3117                end if;
3118
3119             when N_Integer_Literal   =>
3120
3121                --  If this is a rewritten unchecked conversion, in a system
3122                --  where Address is an integer type, always use the base type
3123                --  for a literal value. This is user-friendly and prevents
3124                --  order-of-elaboration issues with instances of unchecked
3125                --  conversion.
3126
3127                if Nkind (Original_Node (Nod)) = N_Function_Call then
3128                   Set_Etype (Nod, Base_Type (Etype (Nod)));
3129                end if;
3130
3131             when N_Real_Literal      |
3132                  N_String_Literal    |
3133                  N_Character_Literal =>
3134                return;
3135
3136             when N_Range =>
3137                Check_Expr_Constants (Low_Bound (Nod));
3138                Check_Expr_Constants (High_Bound (Nod));
3139
3140             when N_Explicit_Dereference =>
3141                Check_Expr_Constants (Prefix (Nod));
3142
3143             when N_Indexed_Component =>
3144                Check_Expr_Constants (Prefix (Nod));
3145                Check_List_Constants (Expressions (Nod));
3146
3147             when N_Slice =>
3148                Check_Expr_Constants (Prefix (Nod));
3149                Check_Expr_Constants (Discrete_Range (Nod));
3150
3151             when N_Selected_Component =>
3152                Check_Expr_Constants (Prefix (Nod));
3153
3154             when N_Attribute_Reference =>
3155                if Attribute_Name (Nod) = Name_Address
3156                    or else
3157                   Attribute_Name (Nod) = Name_Access
3158                     or else
3159                   Attribute_Name (Nod) = Name_Unchecked_Access
3160                     or else
3161                   Attribute_Name (Nod) = Name_Unrestricted_Access
3162                then
3163                   Check_At_Constant_Address (Prefix (Nod));
3164
3165                else
3166                   Check_Expr_Constants (Prefix (Nod));
3167                   Check_List_Constants (Expressions (Nod));
3168                end if;
3169
3170             when N_Aggregate =>
3171                Check_List_Constants (Component_Associations (Nod));
3172                Check_List_Constants (Expressions (Nod));
3173
3174             when N_Component_Association =>
3175                Check_Expr_Constants (Expression (Nod));
3176
3177             when N_Extension_Aggregate =>
3178                Check_Expr_Constants (Ancestor_Part (Nod));
3179                Check_List_Constants (Component_Associations (Nod));
3180                Check_List_Constants (Expressions (Nod));
3181
3182             when N_Null =>
3183                return;
3184
3185             when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
3186                Check_Expr_Constants (Left_Opnd (Nod));
3187                Check_Expr_Constants (Right_Opnd (Nod));
3188
3189             when N_Unary_Op =>
3190                Check_Expr_Constants (Right_Opnd (Nod));
3191
3192             when N_Type_Conversion           |
3193                  N_Qualified_Expression      |
3194                  N_Allocator                 =>
3195                Check_Expr_Constants (Expression (Nod));
3196
3197             when N_Unchecked_Type_Conversion =>
3198                Check_Expr_Constants (Expression (Nod));
3199
3200                --  If this is a rewritten unchecked conversion, subtypes in
3201                --  this node are those created within the instance. To avoid
3202                --  order of elaboration issues, replace them with their base
3203                --  types. Note that address clauses can cause order of
3204                --  elaboration problems because they are elaborated by the
3205                --  back-end at the point of definition, and may mention
3206                --  entities declared in between (as long as everything is
3207                --  static). It is user-friendly to allow unchecked conversions
3208                --  in this context.
3209
3210                if Nkind (Original_Node (Nod)) = N_Function_Call then
3211                   Set_Etype (Expression (Nod),
3212                     Base_Type (Etype (Expression (Nod))));
3213                   Set_Etype (Nod, Base_Type (Etype (Nod)));
3214                end if;
3215
3216             when N_Function_Call =>
3217                if not Is_Pure (Entity (Name (Nod))) then
3218                   Error_Msg_NE
3219                     ("invalid address clause for initialized object &!",
3220                      Nod, U_Ent);
3221
3222                   Error_Msg_NE
3223                     ("\function & is not pure (RM 13.1(22))!",
3224                      Nod, Entity (Name (Nod)));
3225
3226                else
3227                   Check_List_Constants (Parameter_Associations (Nod));
3228                end if;
3229
3230             when N_Parameter_Association =>
3231                Check_Expr_Constants (Explicit_Actual_Parameter (Nod));
3232
3233             when others =>
3234                Error_Msg_NE
3235                  ("invalid address clause for initialized object &!",
3236                   Nod, U_Ent);
3237                Error_Msg_NE
3238                  ("\must be constant defined before& (RM 13.1(22))!",
3239                   Nod, U_Ent);
3240          end case;
3241       end Check_Expr_Constants;
3242
3243       --------------------------
3244       -- Check_List_Constants --
3245       --------------------------
3246
3247       procedure Check_List_Constants (Lst : List_Id) is
3248          Nod1 : Node_Id;
3249
3250       begin
3251          if Present (Lst) then
3252             Nod1 := First (Lst);
3253             while Present (Nod1) loop
3254                Check_Expr_Constants (Nod1);
3255                Next (Nod1);
3256             end loop;
3257          end if;
3258       end Check_List_Constants;
3259
3260    --  Start of processing for Check_Constant_Address_Clause
3261
3262    begin
3263       --  If rep_clauses are to be ignored, no need for legality checks. In
3264       --  particular, no need to pester user about rep clauses that violate
3265       --  the rule on constant addresses, given that these clauses will be
3266       --  removed by Freeze before they reach the back end.
3267
3268       if not Ignore_Rep_Clauses then
3269          Check_Expr_Constants (Expr);
3270       end if;
3271    end Check_Constant_Address_Clause;
3272
3273    ----------------------------------------
3274    -- Check_Record_Representation_Clause --
3275    ----------------------------------------
3276
3277    procedure Check_Record_Representation_Clause (N : Node_Id) is
3278       Loc     : constant Source_Ptr := Sloc (N);
3279       Ident   : constant Node_Id    := Identifier (N);
3280       Rectype : Entity_Id;
3281       Fent    : Entity_Id;
3282       CC      : Node_Id;
3283       Fbit    : Uint;
3284       Lbit    : Uint;
3285       Hbit    : Uint := Uint_0;
3286       Comp    : Entity_Id;
3287       Pcomp   : Entity_Id;
3288
3289       Max_Bit_So_Far : Uint;
3290       --  Records the maximum bit position so far. If all field positions
3291       --  are monotonically increasing, then we can skip the circuit for
3292       --  checking for overlap, since no overlap is possible.
3293
3294       Tagged_Parent : Entity_Id := Empty;
3295       --  This is set in the case of a derived tagged type for which we have
3296       --  Is_Fully_Repped_Tagged_Type True (indicating that all components are
3297       --  positioned by record representation clauses). In this case we must
3298       --  check for overlap between components of this tagged type, and the
3299       --  components of its parent. Tagged_Parent will point to this parent
3300       --  type. For all other cases Tagged_Parent is left set to Empty.
3301
3302       Parent_Last_Bit : Uint;
3303       --  Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the
3304       --  last bit position for any field in the parent type. We only need to
3305       --  check overlap for fields starting below this point.
3306
3307       Overlap_Check_Required : Boolean;
3308       --  Used to keep track of whether or not an overlap check is required
3309
3310       Overlap_Detected : Boolean := False;
3311       --  Set True if an overlap is detected
3312
3313       Ccount : Natural := 0;
3314       --  Number of component clauses in record rep clause
3315
3316       procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id);
3317       --  Given two entities for record components or discriminants, checks
3318       --  if they have overlapping component clauses and issues errors if so.
3319
3320       procedure Find_Component;
3321       --  Finds component entity corresponding to current component clause (in
3322       --  CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin
3323       --  start/stop bits for the field. If there is no matching component or
3324       --  if the matching component does not have a component clause, then
3325       --  that's an error and Comp is set to Empty, but no error message is
3326       --  issued, since the message was already given. Comp is also set to
3327       --  Empty if the current "component clause" is in fact a pragma.
3328
3329       -----------------------------
3330       -- Check_Component_Overlap --
3331       -----------------------------
3332
3333       procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is
3334          CC1 : constant Node_Id := Component_Clause (C1_Ent);
3335          CC2 : constant Node_Id := Component_Clause (C2_Ent);
3336
3337       begin
3338          if Present (CC1) and then Present (CC2) then
3339
3340             --  Exclude odd case where we have two tag fields in the same
3341             --  record, both at location zero. This seems a bit strange, but
3342             --  it seems to happen in some circumstances, perhaps on an error.
3343
3344             if Chars (C1_Ent) = Name_uTag
3345                  and then
3346                Chars (C2_Ent) = Name_uTag
3347             then
3348                return;
3349             end if;
3350
3351             --  Here we check if the two fields overlap
3352
3353             declare
3354                S1 : constant Uint := Component_Bit_Offset (C1_Ent);
3355                S2 : constant Uint := Component_Bit_Offset (C2_Ent);
3356                E1 : constant Uint := S1 + Esize (C1_Ent);
3357                E2 : constant Uint := S2 + Esize (C2_Ent);
3358
3359             begin
3360                if E2 <= S1 or else E1 <= S2 then
3361                   null;
3362                else
3363                   Error_Msg_Node_2 := Component_Name (CC2);
3364                   Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
3365                   Error_Msg_Node_1 := Component_Name (CC1);
3366                   Error_Msg_N
3367                     ("component& overlaps & #", Component_Name (CC1));
3368                   Overlap_Detected := True;
3369                end if;
3370             end;
3371          end if;
3372       end Check_Component_Overlap;
3373
3374       --------------------
3375       -- Find_Component --
3376       --------------------
3377
3378       procedure Find_Component is
3379
3380          procedure Search_Component (R : Entity_Id);
3381          --  Search components of R for a match. If found, Comp is set.
3382
3383          ----------------------
3384          -- Search_Component --
3385          ----------------------
3386
3387          procedure Search_Component (R : Entity_Id) is
3388          begin
3389             Comp := First_Component_Or_Discriminant (R);
3390             while Present (Comp) loop
3391
3392                --  Ignore error of attribute name for component name (we
3393                --  already gave an error message for this, so no need to
3394                --  complain here)
3395
3396                if Nkind (Component_Name (CC)) = N_Attribute_Reference then
3397                   null;
3398                else
3399                   exit when Chars (Comp) = Chars (Component_Name (CC));
3400                end if;
3401
3402                Next_Component_Or_Discriminant (Comp);
3403             end loop;
3404          end Search_Component;
3405
3406       --  Start of processing for Find_Component
3407
3408       begin
3409          --  Return with Comp set to Empty if we have a pragma
3410
3411          if Nkind (CC) = N_Pragma then
3412             Comp := Empty;
3413             return;
3414          end if;
3415
3416          --  Search current record for matching component
3417
3418          Search_Component (Rectype);
3419
3420          --  If not found, maybe component of base type that is absent from
3421          --  statically constrained first subtype.
3422
3423          if No (Comp) then
3424             Search_Component (Base_Type (Rectype));
3425          end if;
3426
3427          --  If no component, or the component does not reference the component
3428          --  clause in question, then there was some previous error for which
3429          --  we already gave a message, so just return with Comp Empty.
3430
3431          if No (Comp)
3432            or else Component_Clause (Comp) /= CC
3433          then
3434             Comp := Empty;
3435
3436          --  Normal case where we have a component clause
3437
3438          else
3439             Fbit := Component_Bit_Offset (Comp);
3440             Lbit := Fbit + Esize (Comp) - 1;
3441          end if;
3442       end Find_Component;
3443
3444    --  Start of processing for Check_Record_Representation_Clause
3445
3446    begin
3447       Find_Type (Ident);
3448       Rectype := Entity (Ident);
3449
3450       if Rectype = Any_Type then
3451          return;
3452       else
3453          Rectype := Underlying_Type (Rectype);
3454       end if;
3455
3456       --  See if we have a fully repped derived tagged type
3457
3458       declare
3459          PS : constant Entity_Id := Parent_Subtype (Rectype);
3460
3461       begin
3462          if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then
3463             Tagged_Parent := PS;
3464
3465             --  Find maximum bit of any component of the parent type
3466
3467             Parent_Last_Bit := UI_From_Int (System_Address_Size - 1);
3468             Pcomp := First_Entity (Tagged_Parent);
3469             while Present (Pcomp) loop
3470                if Ekind_In (Pcomp, E_Discriminant, E_Component) then
3471                   if Component_Bit_Offset (Pcomp) /= No_Uint
3472                     and then Known_Static_Esize (Pcomp)
3473                   then
3474                      Parent_Last_Bit :=
3475                        UI_Max
3476                          (Parent_Last_Bit,
3477                           Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1);
3478                   end if;
3479
3480                   Next_Entity (Pcomp);
3481                end if;
3482             end loop;
3483          end if;
3484       end;
3485
3486       --  All done if no component clauses
3487
3488       CC := First (Component_Clauses (N));
3489
3490       if No (CC) then
3491          return;
3492       end if;
3493
3494       --  If a tag is present, then create a component clause that places it
3495       --  at the start of the record (otherwise gigi may place it after other
3496       --  fields that have rep clauses).
3497
3498       Fent := First_Entity (Rectype);
3499
3500       if Nkind (Fent) = N_Defining_Identifier
3501         and then Chars (Fent) = Name_uTag
3502       then
3503          Set_Component_Bit_Offset    (Fent, Uint_0);
3504          Set_Normalized_Position     (Fent, Uint_0);
3505          Set_Normalized_First_Bit    (Fent, Uint_0);
3506          Set_Normalized_Position_Max (Fent, Uint_0);
3507          Init_Esize                  (Fent, System_Address_Size);
3508
3509          Set_Component_Clause (Fent,
3510            Make_Component_Clause (Loc,
3511              Component_Name =>
3512                Make_Identifier (Loc,
3513                  Chars => Name_uTag),
3514
3515              Position  =>
3516                Make_Integer_Literal (Loc,
3517                  Intval => Uint_0),
3518
3519              First_Bit =>
3520                Make_Integer_Literal (Loc,
3521                  Intval => Uint_0),
3522
3523              Last_Bit  =>
3524                Make_Integer_Literal (Loc,
3525                  UI_From_Int (System_Address_Size))));
3526
3527          Ccount := Ccount + 1;
3528       end if;
3529
3530       Max_Bit_So_Far := Uint_Minus_1;
3531       Overlap_Check_Required := False;
3532
3533       --  Process the component clauses
3534
3535       while Present (CC) loop
3536          Find_Component;
3537
3538          if Present (Comp) then
3539             Ccount := Ccount + 1;
3540
3541             --  We need a full overlap check if record positions non-monotonic
3542
3543             if Fbit <= Max_Bit_So_Far then
3544                Overlap_Check_Required := True;
3545             end if;
3546
3547             Max_Bit_So_Far := Lbit;
3548
3549             --  Check bit position out of range of specified size
3550
3551             if Has_Size_Clause (Rectype)
3552               and then Esize (Rectype) <= Lbit
3553             then
3554                Error_Msg_N
3555                  ("bit number out of range of specified size",
3556                   Last_Bit (CC));
3557
3558                --  Check for overlap with tag field
3559
3560             else
3561                if Is_Tagged_Type (Rectype)
3562                  and then Fbit < System_Address_Size
3563                then
3564                   Error_Msg_NE
3565                     ("component overlaps tag field of&",
3566                      Component_Name (CC), Rectype);
3567                   Overlap_Detected := True;
3568                end if;
3569
3570                if Hbit < Lbit then
3571                   Hbit := Lbit;
3572                end if;
3573             end if;
3574
3575             --  Check parent overlap if component might overlap parent field
3576
3577             if Present (Tagged_Parent)
3578               and then Fbit <= Parent_Last_Bit
3579             then
3580                Pcomp := First_Component_Or_Discriminant (Tagged_Parent);
3581                while Present (Pcomp) loop
3582                   if not Is_Tag (Pcomp)
3583                     and then Chars (Pcomp) /= Name_uParent
3584                   then
3585                      Check_Component_Overlap (Comp, Pcomp);
3586                   end if;
3587
3588                   Next_Component_Or_Discriminant (Pcomp);
3589                end loop;
3590             end if;
3591          end if;
3592
3593          Next (CC);
3594       end loop;
3595
3596       --  Now that we have processed all the component clauses, check for
3597       --  overlap. We have to leave this till last, since the components can
3598       --  appear in any arbitrary order in the representation clause.
3599
3600       --  We do not need this check if all specified ranges were monotonic,
3601       --  as recorded by Overlap_Check_Required being False at this stage.
3602
3603       --  This first section checks if there are any overlapping entries at
3604       --  all. It does this by sorting all entries and then seeing if there are
3605       --  any overlaps. If there are none, then that is decisive, but if there
3606       --  are overlaps, they may still be OK (they may result from fields in
3607       --  different variants).
3608
3609       if Overlap_Check_Required then
3610          Overlap_Check1 : declare
3611
3612             OC_Fbit : array (0 .. Ccount) of Uint;
3613             --  First-bit values for component clauses, the value is the offset
3614             --  of the first bit of the field from start of record. The zero
3615             --  entry is for use in sorting.
3616
3617             OC_Lbit : array (0 .. Ccount) of Uint;
3618             --  Last-bit values for component clauses, the value is the offset
3619             --  of the last bit of the field from start of record. The zero
3620             --  entry is for use in sorting.
3621
3622             OC_Count : Natural := 0;
3623             --  Count of entries in OC_Fbit and OC_Lbit
3624
3625             function OC_Lt (Op1, Op2 : Natural) return Boolean;
3626             --  Compare routine for Sort
3627
3628             procedure OC_Move (From : Natural; To : Natural);
3629             --  Move routine for Sort
3630
3631             package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt);
3632
3633             -----------
3634             -- OC_Lt --
3635             -----------
3636
3637             function OC_Lt (Op1, Op2 : Natural) return Boolean is
3638             begin
3639                return OC_Fbit (Op1) < OC_Fbit (Op2);
3640             end OC_Lt;
3641
3642             -------------
3643             -- OC_Move --
3644             -------------
3645
3646             procedure OC_Move (From : Natural; To : Natural) is
3647             begin
3648                OC_Fbit (To) := OC_Fbit (From);
3649                OC_Lbit (To) := OC_Lbit (From);
3650             end OC_Move;
3651
3652             --  Start of processing for Overlap_Check
3653
3654          begin
3655             CC := First (Component_Clauses (N));
3656             while Present (CC) loop
3657
3658                --  Exclude component clause already marked in error
3659
3660                if not Error_Posted (CC) then
3661                   Find_Component;
3662
3663                   if Present (Comp) then
3664                      OC_Count := OC_Count + 1;
3665                      OC_Fbit (OC_Count) := Fbit;
3666                      OC_Lbit (OC_Count) := Lbit;
3667                   end if;
3668                end if;
3669
3670                Next (CC);
3671             end loop;
3672
3673             Sorting.Sort (OC_Count);
3674
3675             Overlap_Check_Required := False;
3676             for J in 1 .. OC_Count - 1 loop
3677                if OC_Lbit (J) >= OC_Fbit (J + 1) then
3678                   Overlap_Check_Required := True;
3679                   exit;
3680                end if;
3681             end loop;
3682          end Overlap_Check1;
3683       end if;
3684
3685       --  If Overlap_Check_Required is still True, then we have to do the full
3686       --  scale overlap check, since we have at least two fields that do
3687       --  overlap, and we need to know if that is OK since they are in
3688       --  different variant, or whether we have a definite problem.
3689
3690       if Overlap_Check_Required then
3691          Overlap_Check2 : declare
3692             C1_Ent, C2_Ent : Entity_Id;
3693             --  Entities of components being checked for overlap
3694
3695             Clist : Node_Id;
3696             --  Component_List node whose Component_Items are being checked
3697
3698             Citem : Node_Id;
3699             --  Component declaration for component being checked
3700
3701          begin
3702             C1_Ent := First_Entity (Base_Type (Rectype));
3703
3704             --  Loop through all components in record. For each component check
3705             --  for overlap with any of the preceding elements on the component
3706             --  list containing the component and also, if the component is in
3707             --  a variant, check against components outside the case structure.
3708             --  This latter test is repeated recursively up the variant tree.
3709
3710             Main_Component_Loop : while Present (C1_Ent) loop
3711                if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then
3712                   goto Continue_Main_Component_Loop;
3713                end if;
3714
3715                --  Skip overlap check if entity has no declaration node. This
3716                --  happens with discriminants in constrained derived types.
3717                --  Possibly we are missing some checks as a result, but that
3718                --  does not seem terribly serious.
3719
3720                if No (Declaration_Node (C1_Ent)) then
3721                   goto Continue_Main_Component_Loop;
3722                end if;
3723
3724                Clist := Parent (List_Containing (Declaration_Node (C1_Ent)));
3725
3726                --  Loop through component lists that need checking. Check the
3727                --  current component list and all lists in variants above us.
3728
3729                Component_List_Loop : loop
3730
3731                   --  If derived type definition, go to full declaration
3732                   --  If at outer level, check discriminants if there are any.
3733
3734                   if Nkind (Clist) = N_Derived_Type_Definition then
3735                      Clist := Parent (Clist);
3736                   end if;
3737
3738                   --  Outer level of record definition, check discriminants
3739
3740                   if Nkind_In (Clist, N_Full_Type_Declaration,
3741                                N_Private_Type_Declaration)
3742                   then
3743                      if Has_Discriminants (Defining_Identifier (Clist)) then
3744                         C2_Ent :=
3745                           First_Discriminant (Defining_Identifier (Clist));
3746                         while Present (C2_Ent) loop
3747                            exit when C1_Ent = C2_Ent;
3748                            Check_Component_Overlap (C1_Ent, C2_Ent);
3749                            Next_Discriminant (C2_Ent);
3750                         end loop;
3751                      end if;
3752
3753                      --  Record extension case
3754
3755                   elsif Nkind (Clist) = N_Derived_Type_Definition then
3756                      Clist := Empty;
3757
3758                      --  Otherwise check one component list
3759
3760                   else
3761                      Citem := First (Component_Items (Clist));
3762                      while Present (Citem) loop
3763                         if Nkind (Citem) = N_Component_Declaration then
3764                            C2_Ent := Defining_Identifier (Citem);
3765                            exit when C1_Ent = C2_Ent;
3766                            Check_Component_Overlap (C1_Ent, C2_Ent);
3767                         end if;
3768
3769                         Next (Citem);
3770                      end loop;
3771                   end if;
3772
3773                   --  Check for variants above us (the parent of the Clist can
3774                   --  be a variant, in which case its parent is a variant part,
3775                   --  and the parent of the variant part is a component list
3776                   --  whose components must all be checked against the current
3777                   --  component for overlap).
3778
3779                   if Nkind (Parent (Clist)) = N_Variant then
3780                      Clist := Parent (Parent (Parent (Clist)));
3781
3782                      --  Check for possible discriminant part in record, this
3783                      --  is treated essentially as another level in the
3784                      --  recursion. For this case the parent of the component
3785                      --  list is the record definition, and its parent is the
3786                      --  full type declaration containing the discriminant
3787                      --  specifications.
3788
3789                   elsif Nkind (Parent (Clist)) = N_Record_Definition then
3790                      Clist := Parent (Parent ((Clist)));
3791
3792                      --  If neither of these two cases, we are at the top of
3793                      --  the tree.
3794
3795                   else
3796                      exit Component_List_Loop;
3797                   end if;
3798                end loop Component_List_Loop;
3799
3800                <<Continue_Main_Component_Loop>>
3801                Next_Entity (C1_Ent);
3802
3803             end loop Main_Component_Loop;
3804          end Overlap_Check2;
3805       end if;
3806
3807       --  The following circuit deals with warning on record holes (gaps). We
3808       --  skip this check if overlap was detected, since it makes sense for the
3809       --  programmer to fix this illegality before worrying about warnings.
3810
3811       if not Overlap_Detected and Warn_On_Record_Holes then
3812          Record_Hole_Check : declare
3813             Decl : constant Node_Id := Declaration_Node (Base_Type (Rectype));
3814             --  Full declaration of record type
3815
3816             procedure Check_Component_List
3817               (CL   : Node_Id;
3818                Sbit : Uint;
3819                DS   : List_Id);
3820             --  Check component list CL for holes. The starting bit should be
3821             --  Sbit. which is zero for the main record component list and set
3822             --  appropriately for recursive calls for variants. DS is set to
3823             --  a list of discriminant specifications to be included in the
3824             --  consideration of components. It is No_List if none to consider.
3825
3826             --------------------------
3827             -- Check_Component_List --
3828             --------------------------
3829
3830             procedure Check_Component_List
3831               (CL   : Node_Id;
3832                Sbit : Uint;
3833                DS   : List_Id)
3834             is
3835                Compl : Integer;
3836
3837             begin
3838                Compl := Integer (List_Length (Component_Items (CL)));
3839
3840                if DS /= No_List then
3841                   Compl := Compl + Integer (List_Length (DS));
3842                end if;
3843
3844                declare
3845                   Comps : array (Natural range 0 .. Compl) of Entity_Id;
3846                   --  Gather components (zero entry is for sort routine)
3847
3848                   Ncomps : Natural := 0;
3849                   --  Number of entries stored in Comps (starting at Comps (1))
3850
3851                   Citem : Node_Id;
3852                   --  One component item or discriminant specification
3853
3854                   Nbit  : Uint;
3855                   --  Starting bit for next component
3856
3857                   CEnt  : Entity_Id;
3858                   --  Component entity
3859
3860                   Variant : Node_Id;
3861                   --  One variant
3862
3863                   function Lt (Op1, Op2 : Natural) return Boolean;
3864                   --  Compare routine for Sort
3865
3866                   procedure Move (From : Natural; To : Natural);
3867                   --  Move routine for Sort
3868
3869                   package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
3870
3871                   --------
3872                   -- Lt --
3873                   --------
3874
3875                   function Lt (Op1, Op2 : Natural) return Boolean is
3876                   begin
3877                      return Component_Bit_Offset (Comps (Op1))
3878                        <
3879                        Component_Bit_Offset (Comps (Op2));
3880                   end Lt;
3881
3882                   ----------
3883                   -- Move --
3884                   ----------
3885
3886                   procedure Move (From : Natural; To : Natural) is
3887                   begin
3888                      Comps (To) := Comps (From);
3889                   end Move;
3890
3891                begin
3892                   --  Gather discriminants into Comp
3893
3894                   if DS /= No_List then
3895                      Citem := First (DS);
3896                      while Present (Citem) loop
3897                         if Nkind (Citem) = N_Discriminant_Specification then
3898                            declare
3899                               Ent : constant Entity_Id :=
3900                                       Defining_Identifier (Citem);
3901                            begin
3902                               if Ekind (Ent) = E_Discriminant then
3903                                  Ncomps := Ncomps + 1;
3904                                  Comps (Ncomps) := Ent;
3905                               end if;
3906                            end;
3907                         end if;
3908
3909                         Next (Citem);
3910                      end loop;
3911                   end if;
3912
3913                   --  Gather component entities into Comp
3914
3915                   Citem := First (Component_Items (CL));
3916                   while Present (Citem) loop
3917                      if Nkind (Citem) = N_Component_Declaration then
3918                         Ncomps := Ncomps + 1;
3919                         Comps (Ncomps) := Defining_Identifier (Citem);
3920                      end if;
3921
3922                      Next (Citem);
3923                   end loop;
3924
3925                   --  Now sort the component entities based on the first bit.
3926                   --  Note we already know there are no overlapping components.
3927
3928                   Sorting.Sort (Ncomps);
3929
3930                   --  Loop through entries checking for holes
3931
3932                   Nbit := Sbit;
3933                   for J in 1 .. Ncomps loop
3934                      CEnt := Comps (J);
3935                      Error_Msg_Uint_1 := Component_Bit_Offset (CEnt) - Nbit;
3936
3937                      if Error_Msg_Uint_1 > 0 then
3938                         Error_Msg_NE
3939                           ("?^-bit gap before component&",
3940                            Component_Name (Component_Clause (CEnt)), CEnt);
3941                      end if;
3942
3943                      Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt);
3944                   end loop;
3945
3946                   --  Process variant parts recursively if present
3947
3948                   if Present (Variant_Part (CL)) then
3949                      Variant := First (Variants (Variant_Part (CL)));
3950                      while Present (Variant) loop
3951                         Check_Component_List
3952                           (Component_List (Variant), Nbit, No_List);
3953                         Next (Variant);
3954                      end loop;
3955                   end if;
3956                end;
3957             end Check_Component_List;
3958
3959          --  Start of processing for Record_Hole_Check
3960
3961          begin
3962             declare
3963                Sbit : Uint;
3964
3965             begin
3966                if Is_Tagged_Type (Rectype) then
3967                   Sbit := UI_From_Int (System_Address_Size);
3968                else
3969                   Sbit := Uint_0;
3970                end if;
3971
3972                if Nkind (Decl) = N_Full_Type_Declaration
3973                  and then Nkind (Type_Definition (Decl)) = N_Record_Definition
3974                then
3975                   Check_Component_List
3976                     (Component_List (Type_Definition (Decl)),
3977                      Sbit,
3978                      Discriminant_Specifications (Decl));
3979                end if;
3980             end;
3981          end Record_Hole_Check;
3982       end if;
3983
3984       --  For records that have component clauses for all components, and whose
3985       --  size is less than or equal to 32, we need to know the size in the
3986       --  front end to activate possible packed array processing where the
3987       --  component type is a record.
3988
3989       --  At this stage Hbit + 1 represents the first unused bit from all the
3990       --  component clauses processed, so if the component clauses are
3991       --  complete, then this is the length of the record.
3992
3993       --  For records longer than System.Storage_Unit, and for those where not
3994       --  all components have component clauses, the back end determines the
3995       --  length (it may for example be appropriate to round up the size
3996       --  to some convenient boundary, based on alignment considerations, etc).
3997
3998       if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then
3999
4000          --  Nothing to do if at least one component has no component clause
4001
4002          Comp := First_Component_Or_Discriminant (Rectype);
4003          while Present (Comp) loop
4004             exit when No (Component_Clause (Comp));
4005             Next_Component_Or_Discriminant (Comp);
4006          end loop;
4007
4008          --  If we fall out of loop, all components have component clauses
4009          --  and so we can set the size to the maximum value.
4010
4011          if No (Comp) then
4012             Set_RM_Size (Rectype, Hbit + 1);
4013          end if;
4014       end if;
4015    end Check_Record_Representation_Clause;
4016
4017    ----------------
4018    -- Check_Size --
4019    ----------------
4020
4021    procedure Check_Size
4022      (N      : Node_Id;
4023       T      : Entity_Id;
4024       Siz    : Uint;
4025       Biased : out Boolean)
4026    is
4027       UT : constant Entity_Id := Underlying_Type (T);
4028       M  : Uint;
4029
4030    begin
4031       Biased := False;
4032
4033       --  Dismiss cases for generic types or types with previous errors
4034
4035       if No (UT)
4036         or else UT = Any_Type
4037         or else Is_Generic_Type (UT)
4038         or else Is_Generic_Type (Root_Type (UT))
4039       then
4040          return;
4041
4042       --  Check case of bit packed array
4043
4044       elsif Is_Array_Type (UT)
4045         and then Known_Static_Component_Size (UT)
4046         and then Is_Bit_Packed_Array (UT)
4047       then
4048          declare
4049             Asiz : Uint;
4050             Indx : Node_Id;
4051             Ityp : Entity_Id;
4052
4053          begin
4054             Asiz := Component_Size (UT);
4055             Indx := First_Index (UT);
4056             loop
4057                Ityp := Etype (Indx);
4058
4059                --  If non-static bound, then we are not in the business of
4060                --  trying to check the length, and indeed an error will be
4061                --  issued elsewhere, since sizes of non-static array types
4062                --  cannot be set implicitly or explicitly.
4063
4064                if not Is_Static_Subtype (Ityp) then
4065                   return;
4066                end if;
4067
4068                --  Otherwise accumulate next dimension
4069
4070                Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) -
4071                                Expr_Value (Type_Low_Bound  (Ityp)) +
4072                                Uint_1);
4073
4074                Next_Index (Indx);
4075                exit when No (Indx);
4076             end loop;
4077
4078             if Asiz <= Siz then
4079                return;
4080             else
4081                Error_Msg_Uint_1 := Asiz;
4082                Error_Msg_NE
4083                  ("size for& too small, minimum allowed is ^", N, T);
4084                Set_Esize   (T, Asiz);
4085                Set_RM_Size (T, Asiz);
4086             end if;
4087          end;
4088
4089       --  All other composite types are ignored
4090
4091       elsif Is_Composite_Type (UT) then
4092          return;
4093
4094       --  For fixed-point types, don't check minimum if type is not frozen,
4095       --  since we don't know all the characteristics of the type that can
4096       --  affect the size (e.g. a specified small) till freeze time.
4097
4098       elsif Is_Fixed_Point_Type (UT)
4099         and then not Is_Frozen (UT)
4100       then
4101          null;
4102
4103       --  Cases for which a minimum check is required
4104
4105       else
4106          --  Ignore if specified size is correct for the type
4107
4108          if Known_Esize (UT) and then Siz = Esize (UT) then
4109             return;
4110          end if;
4111
4112          --  Otherwise get minimum size
4113
4114          M := UI_From_Int (Minimum_Size (UT));
4115
4116          if Siz < M then
4117
4118             --  Size is less than minimum size, but one possibility remains
4119             --  that we can manage with the new size if we bias the type.
4120
4121             M := UI_From_Int (Minimum_Size (UT, Biased => True));
4122
4123             if Siz < M then
4124                Error_Msg_Uint_1 := M;
4125                Error_Msg_NE
4126                  ("size for& too small, minimum allowed is ^", N, T);
4127                Set_Esize (T, M);
4128                Set_RM_Size (T, M);
4129             else
4130                Biased := True;
4131             end if;
4132          end if;
4133       end if;
4134    end Check_Size;
4135
4136    -------------------------
4137    -- Get_Alignment_Value --
4138    -------------------------
4139
4140    function Get_Alignment_Value (Expr : Node_Id) return Uint is
4141       Align : constant Uint := Static_Integer (Expr);
4142
4143    begin
4144       if Align = No_Uint then
4145          return No_Uint;
4146
4147       elsif Align <= 0 then
4148          Error_Msg_N ("alignment value must be positive", Expr);
4149          return No_Uint;
4150
4151       else
4152          for J in Int range 0 .. 64 loop
4153             declare
4154                M : constant Uint := Uint_2 ** J;
4155
4156             begin
4157                exit when M = Align;
4158
4159                if M > Align then
4160                   Error_Msg_N
4161                     ("alignment value must be power of 2", Expr);
4162                   return No_Uint;
4163                end if;
4164             end;
4165          end loop;
4166
4167          return Align;
4168       end if;
4169    end Get_Alignment_Value;
4170
4171    ----------------
4172    -- Initialize --
4173    ----------------
4174
4175    procedure Initialize is
4176    begin
4177       Unchecked_Conversions.Init;
4178    end Initialize;
4179
4180    -------------------------
4181    -- Is_Operational_Item --
4182    -------------------------
4183
4184    function Is_Operational_Item (N : Node_Id) return Boolean is
4185    begin
4186       if Nkind (N) /= N_Attribute_Definition_Clause then
4187          return False;
4188       else
4189          declare
4190             Id    : constant Attribute_Id := Get_Attribute_Id (Chars (N));
4191          begin
4192             return   Id = Attribute_Input
4193               or else Id = Attribute_Output
4194               or else Id = Attribute_Read
4195               or else Id = Attribute_Write
4196               or else Id = Attribute_External_Tag;
4197          end;
4198       end if;
4199    end Is_Operational_Item;
4200
4201    ------------------
4202    -- Minimum_Size --
4203    ------------------
4204
4205    function Minimum_Size
4206      (T      : Entity_Id;
4207       Biased : Boolean := False) return Nat
4208    is
4209       Lo     : Uint    := No_Uint;
4210       Hi     : Uint    := No_Uint;
4211       LoR    : Ureal   := No_Ureal;
4212       HiR    : Ureal   := No_Ureal;
4213       LoSet  : Boolean := False;
4214       HiSet  : Boolean := False;
4215       B      : Uint;
4216       S      : Nat;
4217       Ancest : Entity_Id;
4218       R_Typ  : constant Entity_Id := Root_Type (T);
4219
4220    begin
4221       --  If bad type, return 0
4222
4223       if T = Any_Type then
4224          return 0;
4225
4226       --  For generic types, just return zero. There cannot be any legitimate
4227       --  need to know such a size, but this routine may be called with a
4228       --  generic type as part of normal processing.
4229
4230       elsif Is_Generic_Type (R_Typ)
4231         or else R_Typ = Any_Type
4232       then
4233          return 0;
4234
4235          --  Access types. Normally an access type cannot have a size smaller
4236          --  than the size of System.Address. The exception is on VMS, where
4237          --  we have short and long addresses, and it is possible for an access
4238          --  type to have a short address size (and thus be less than the size
4239          --  of System.Address itself). We simply skip the check for VMS, and
4240          --  leave it to the back end to do the check.
4241
4242       elsif Is_Access_Type (T) then
4243          if OpenVMS_On_Target then
4244             return 0;
4245          else
4246             return System_Address_Size;
4247          end if;
4248
4249       --  Floating-point types
4250
4251       elsif Is_Floating_Point_Type (T) then
4252          return UI_To_Int (Esize (R_Typ));
4253
4254       --  Discrete types
4255
4256       elsif Is_Discrete_Type (T) then
4257
4258          --  The following loop is looking for the nearest compile time known
4259          --  bounds following the ancestor subtype chain. The idea is to find
4260          --  the most restrictive known bounds information.
4261
4262          Ancest := T;
4263          loop
4264             if Ancest = Any_Type or else Etype (Ancest) = Any_Type then
4265                return 0;
4266             end if;
4267
4268             if not LoSet then
4269                if Compile_Time_Known_Value (Type_Low_Bound (Ancest)) then
4270                   Lo := Expr_Rep_Value (Type_Low_Bound (Ancest));
4271                   LoSet := True;
4272                   exit when HiSet;
4273                end if;
4274             end if;
4275
4276             if not HiSet then
4277                if Compile_Time_Known_Value (Type_High_Bound (Ancest)) then
4278                   Hi := Expr_Rep_Value (Type_High_Bound (Ancest));
4279                   HiSet := True;
4280                   exit when LoSet;
4281                end if;
4282             end if;
4283
4284             Ancest := Ancestor_Subtype (Ancest);
4285
4286             if No (Ancest) then
4287                Ancest := Base_Type (T);
4288
4289                if Is_Generic_Type (Ancest) then
4290                   return 0;
4291                end if;
4292             end if;
4293          end loop;
4294
4295       --  Fixed-point types. We can't simply use Expr_Value to get the
4296       --  Corresponding_Integer_Value values of the bounds, since these do not
4297       --  get set till the type is frozen, and this routine can be called
4298       --  before the type is frozen. Similarly the test for bounds being static
4299       --  needs to include the case where we have unanalyzed real literals for
4300       --  the same reason.
4301
4302       elsif Is_Fixed_Point_Type (T) then
4303
4304          --  The following loop is looking for the nearest compile time known
4305          --  bounds following the ancestor subtype chain. The idea is to find
4306          --  the most restrictive known bounds information.
4307
4308          Ancest := T;
4309          loop
4310             if Ancest = Any_Type or else Etype (Ancest) = Any_Type then
4311                return 0;
4312             end if;
4313
4314             --  Note: In the following two tests for LoSet and HiSet, it may
4315             --  seem redundant to test for N_Real_Literal here since normally
4316             --  one would assume that the test for the value being known at
4317             --  compile time includes this case. However, there is a glitch.
4318             --  If the real literal comes from folding a non-static expression,
4319             --  then we don't consider any non- static expression to be known
4320             --  at compile time if we are in configurable run time mode (needed
4321             --  in some cases to give a clearer definition of what is and what
4322             --  is not accepted). So the test is indeed needed. Without it, we
4323             --  would set neither Lo_Set nor Hi_Set and get an infinite loop.
4324
4325             if not LoSet then
4326                if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal
4327                  or else Compile_Time_Known_Value (Type_Low_Bound (Ancest))
4328                then
4329                   LoR := Expr_Value_R (Type_Low_Bound (Ancest));
4330                   LoSet := True;
4331                   exit when HiSet;
4332                end if;
4333             end if;
4334
4335             if not HiSet then
4336                if Nkind (Type_High_Bound (Ancest)) = N_Real_Literal
4337                  or else Compile_Time_Known_Value (Type_High_Bound (Ancest))
4338                then
4339                   HiR := Expr_Value_R (Type_High_Bound (Ancest));
4340                   HiSet := True;
4341                   exit when LoSet;
4342                end if;
4343             end if;
4344
4345             Ancest := Ancestor_Subtype (Ancest);
4346
4347             if No (Ancest) then
4348                Ancest := Base_Type (T);
4349
4350                if Is_Generic_Type (Ancest) then
4351                   return 0;
4352                end if;
4353             end if;
4354          end loop;
4355
4356          Lo := UR_To_Uint (LoR / Small_Value (T));
4357          Hi := UR_To_Uint (HiR / Small_Value (T));
4358
4359       --  No other types allowed
4360
4361       else
4362          raise Program_Error;
4363       end if;
4364
4365       --  Fall through with Hi and Lo set. Deal with biased case
4366
4367       if (Biased
4368            and then not Is_Fixed_Point_Type (T)
4369            and then not (Is_Enumeration_Type (T)
4370                           and then Has_Non_Standard_Rep (T)))
4371         or else Has_Biased_Representation (T)
4372       then
4373          Hi := Hi - Lo;
4374          Lo := Uint_0;
4375       end if;
4376
4377       --  Signed case. Note that we consider types like range 1 .. -1 to be
4378       --  signed for the purpose of computing the size, since the bounds have
4379       --  to be accommodated in the base type.
4380
4381       if Lo < 0 or else Hi < 0 then
4382          S := 1;
4383          B := Uint_1;
4384
4385          --  S = size, B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
4386          --  Note that we accommodate the case where the bounds cross. This
4387          --  can happen either because of the way the bounds are declared
4388          --  or because of the algorithm in Freeze_Fixed_Point_Type.
4389
4390          while Lo < -B
4391            or else Hi < -B
4392            or else Lo >= B
4393            or else Hi >= B
4394          loop
4395             B := Uint_2 ** S;
4396             S := S + 1;
4397          end loop;
4398
4399       --  Unsigned case
4400
4401       else
4402          --  If both bounds are positive, make sure that both are represen-
4403          --  table in the case where the bounds are crossed. This can happen
4404          --  either because of the way the bounds are declared, or because of
4405          --  the algorithm in Freeze_Fixed_Point_Type.
4406
4407          if Lo > Hi then
4408             Hi := Lo;
4409          end if;
4410
4411          --  S = size, (can accommodate 0 .. (2**size - 1))
4412
4413          S := 0;
4414          while Hi >= Uint_2 ** S loop
4415             S := S + 1;
4416          end loop;
4417       end if;
4418
4419       return S;
4420    end Minimum_Size;
4421
4422    ---------------------------
4423    -- New_Stream_Subprogram --
4424    ---------------------------
4425
4426    procedure New_Stream_Subprogram
4427      (N     : Node_Id;
4428       Ent   : Entity_Id;
4429       Subp  : Entity_Id;
4430       Nam   : TSS_Name_Type)
4431    is
4432       Loc       : constant Source_Ptr := Sloc (N);
4433       Sname     : constant Name_Id    := Make_TSS_Name (Base_Type (Ent), Nam);
4434       Subp_Id   : Entity_Id;
4435       Subp_Decl : Node_Id;
4436       F         : Entity_Id;
4437       Etyp      : Entity_Id;
4438
4439       Defer_Declaration : constant Boolean :=
4440                             Is_Tagged_Type (Ent) or else Is_Private_Type (Ent);
4441       --  For a tagged type, there is a declaration for each stream attribute
4442       --  at the freeze point, and we must generate only a completion of this
4443       --  declaration. We do the same for private types, because the full view
4444       --  might be tagged. Otherwise we generate a declaration at the point of
4445       --  the attribute definition clause.
4446
4447       function Build_Spec return Node_Id;
4448       --  Used for declaration and renaming declaration, so that this is
4449       --  treated as a renaming_as_body.
4450
4451       ----------------
4452       -- Build_Spec --
4453       ----------------
4454
4455       function Build_Spec return Node_Id is
4456          Out_P   : constant Boolean := (Nam = TSS_Stream_Read);
4457          Formals : List_Id;
4458          Spec    : Node_Id;
4459          T_Ref   : constant Node_Id := New_Reference_To (Etyp, Loc);
4460
4461       begin
4462          Subp_Id := Make_Defining_Identifier (Loc, Sname);
4463
4464          --  S : access Root_Stream_Type'Class
4465
4466          Formals := New_List (
4467                       Make_Parameter_Specification (Loc,
4468                         Defining_Identifier =>
4469                           Make_Defining_Identifier (Loc, Name_S),
4470                         Parameter_Type =>
4471                           Make_Access_Definition (Loc,
4472                             Subtype_Mark =>
4473                               New_Reference_To (
4474                                 Designated_Type (Etype (F)), Loc))));
4475
4476          if Nam = TSS_Stream_Input then
4477             Spec := Make_Function_Specification (Loc,
4478                       Defining_Unit_Name       => Subp_Id,
4479                       Parameter_Specifications => Formals,
4480                       Result_Definition        => T_Ref);
4481          else
4482             --  V : [out] T
4483
4484             Append_To (Formals,
4485               Make_Parameter_Specification (Loc,
4486                 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
4487                 Out_Present         => Out_P,
4488                 Parameter_Type      => T_Ref));
4489
4490             Spec :=
4491               Make_Procedure_Specification (Loc,
4492                 Defining_Unit_Name       => Subp_Id,
4493                 Parameter_Specifications => Formals);
4494          end if;
4495
4496          return Spec;
4497       end Build_Spec;
4498
4499    --  Start of processing for New_Stream_Subprogram
4500
4501    begin
4502       F := First_Formal (Subp);
4503
4504       if Ekind (Subp) = E_Procedure then
4505          Etyp := Etype (Next_Formal (F));
4506       else
4507          Etyp := Etype (Subp);
4508       end if;
4509
4510       --  Prepare subprogram declaration and insert it as an action on the
4511       --  clause node. The visibility for this entity is used to test for
4512       --  visibility of the attribute definition clause (in the sense of
4513       --  8.3(23) as amended by AI-195).
4514
4515       if not Defer_Declaration then
4516          Subp_Decl :=
4517            Make_Subprogram_Declaration (Loc,
4518              Specification => Build_Spec);
4519
4520       --  For a tagged type, there is always a visible declaration for each
4521       --  stream TSS (it is a predefined primitive operation), and the
4522       --  completion of this declaration occurs at the freeze point, which is
4523       --  not always visible at places where the attribute definition clause is
4524       --  visible. So, we create a dummy entity here for the purpose of
4525       --  tracking the visibility of the attribute definition clause itself.
4526
4527       else
4528          Subp_Id :=
4529            Make_Defining_Identifier (Loc,
4530              Chars => New_External_Name (Sname, 'V'));
4531          Subp_Decl :=
4532            Make_Object_Declaration (Loc,
4533              Defining_Identifier => Subp_Id,
4534              Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc));
4535       end if;
4536
4537       Insert_Action (N, Subp_Decl);
4538       Set_Entity (N, Subp_Id);
4539
4540       Subp_Decl :=
4541         Make_Subprogram_Renaming_Declaration (Loc,
4542           Specification => Build_Spec,
4543           Name => New_Reference_To (Subp, Loc));
4544
4545       if Defer_Declaration then
4546          Set_TSS (Base_Type (Ent), Subp_Id);
4547       else
4548          Insert_Action (N, Subp_Decl);
4549          Copy_TSS (Subp_Id, Base_Type (Ent));
4550       end if;
4551    end New_Stream_Subprogram;
4552
4553    ------------------------
4554    -- Rep_Item_Too_Early --
4555    ------------------------
4556
4557    function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is
4558    begin
4559       --  Cannot apply non-operational rep items to generic types
4560
4561       if Is_Operational_Item (N) then
4562          return False;
4563
4564       elsif Is_Type (T)
4565         and then Is_Generic_Type (Root_Type (T))
4566       then
4567          Error_Msg_N ("representation item not allowed for generic type", N);
4568          return True;
4569       end if;
4570
4571       --  Otherwise check for incomplete type
4572
4573       if Is_Incomplete_Or_Private_Type (T)
4574         and then No (Underlying_Type (T))
4575       then
4576          Error_Msg_N
4577            ("representation item must be after full type declaration", N);
4578          return True;
4579
4580       --  If the type has incomplete components, a representation clause is
4581       --  illegal but stream attributes and Convention pragmas are correct.
4582
4583       elsif Has_Private_Component (T) then
4584          if Nkind (N) = N_Pragma then
4585             return False;
4586          else
4587             Error_Msg_N
4588               ("representation item must appear after type is fully defined",
4589                 N);
4590             return True;
4591          end if;
4592       else
4593          return False;
4594       end if;
4595    end Rep_Item_Too_Early;
4596
4597    -----------------------
4598    -- Rep_Item_Too_Late --
4599    -----------------------
4600
4601    function Rep_Item_Too_Late
4602      (T     : Entity_Id;
4603       N     : Node_Id;
4604       FOnly : Boolean := False) return Boolean
4605    is
4606       S           : Entity_Id;
4607       Parent_Type : Entity_Id;
4608
4609       procedure Too_Late;
4610       --  Output the too late message. Note that this is not considered a
4611       --  serious error, since the effect is simply that we ignore the
4612       --  representation clause in this case.
4613
4614       --------------
4615       -- Too_Late --
4616       --------------
4617
4618       procedure Too_Late is
4619       begin
4620          Error_Msg_N ("|representation item appears too late!", N);
4621       end Too_Late;
4622
4623    --  Start of processing for Rep_Item_Too_Late
4624
4625    begin
4626       --  First make sure entity is not frozen (RM 13.1(9)). Exclude imported
4627       --  types, which may be frozen if they appear in a representation clause
4628       --  for a local type.
4629
4630       if Is_Frozen (T)
4631         and then not From_With_Type (T)
4632       then
4633          Too_Late;
4634          S := First_Subtype (T);
4635
4636          if Present (Freeze_Node (S)) then
4637             Error_Msg_NE
4638               ("?no more representation items for }", Freeze_Node (S), S);
4639          end if;
4640
4641          return True;
4642
4643       --  Check for case of non-tagged derived type whose parent either has
4644       --  primitive operations, or is a by reference type (RM 13.1(10)).
4645
4646       elsif Is_Type (T)
4647         and then not FOnly
4648         and then Is_Derived_Type (T)
4649         and then not Is_Tagged_Type (T)
4650       then
4651          Parent_Type := Etype (Base_Type (T));
4652
4653          if Has_Primitive_Operations (Parent_Type) then
4654             Too_Late;
4655             Error_Msg_NE
4656               ("primitive operations already defined for&!", N, Parent_Type);
4657             return True;
4658
4659          elsif Is_By_Reference_Type (Parent_Type) then
4660             Too_Late;
4661             Error_Msg_NE
4662               ("parent type & is a by reference type!", N, Parent_Type);
4663             return True;
4664          end if;
4665       end if;
4666
4667       --  No error, link item into head of chain of rep items for the entity,
4668       --  but avoid chaining if we have an overloadable entity, and the pragma
4669       --  is one that can apply to multiple overloaded entities.
4670
4671       if Is_Overloadable (T)
4672         and then Nkind (N) = N_Pragma
4673       then
4674          declare
4675             Pname : constant Name_Id := Pragma_Name (N);
4676          begin
4677             if Pname = Name_Convention or else
4678                Pname = Name_Import     or else
4679                Pname = Name_Export     or else
4680                Pname = Name_External   or else
4681                Pname = Name_Interface
4682             then
4683                return False;
4684             end if;
4685          end;
4686       end if;
4687
4688       Record_Rep_Item (T, N);
4689       return False;
4690    end Rep_Item_Too_Late;
4691
4692    -------------------------
4693    -- Same_Representation --
4694    -------------------------
4695
4696    function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is
4697       T1 : constant Entity_Id := Underlying_Type (Typ1);
4698       T2 : constant Entity_Id := Underlying_Type (Typ2);
4699
4700    begin
4701       --  A quick check, if base types are the same, then we definitely have
4702       --  the same representation, because the subtype specific representation
4703       --  attributes (Size and Alignment) do not affect representation from
4704       --  the point of view of this test.
4705
4706       if Base_Type (T1) = Base_Type (T2) then
4707          return True;
4708
4709       elsif Is_Private_Type (Base_Type (T2))
4710         and then Base_Type (T1) = Full_View (Base_Type (T2))
4711       then
4712          return True;
4713       end if;
4714
4715       --  Tagged types never have differing representations
4716
4717       if Is_Tagged_Type (T1) then
4718          return True;
4719       end if;
4720
4721       --  Representations are definitely different if conventions differ
4722
4723       if Convention (T1) /= Convention (T2) then
4724          return False;
4725       end if;
4726
4727       --  Representations are different if component alignments differ
4728
4729       if (Is_Record_Type (T1) or else Is_Array_Type (T1))
4730         and then
4731          (Is_Record_Type (T2) or else Is_Array_Type (T2))
4732         and then Component_Alignment (T1) /= Component_Alignment (T2)
4733       then
4734          return False;
4735       end if;
4736
4737       --  For arrays, the only real issue is component size. If we know the
4738       --  component size for both arrays, and it is the same, then that's
4739       --  good enough to know we don't have a change of representation.
4740
4741       if Is_Array_Type (T1) then
4742          if Known_Component_Size (T1)
4743            and then Known_Component_Size (T2)
4744            and then Component_Size (T1) = Component_Size (T2)
4745          then
4746             return True;
4747          end if;
4748       end if;
4749
4750       --  Types definitely have same representation if neither has non-standard
4751       --  representation since default representations are always consistent.
4752       --  If only one has non-standard representation, and the other does not,
4753       --  then we consider that they do not have the same representation. They
4754       --  might, but there is no way of telling early enough.
4755
4756       if Has_Non_Standard_Rep (T1) then
4757          if not Has_Non_Standard_Rep (T2) then
4758             return False;
4759          end if;
4760       else
4761          return not Has_Non_Standard_Rep (T2);
4762       end if;
4763
4764       --  Here the two types both have non-standard representation, and we need
4765       --  to determine if they have the same non-standard representation.
4766
4767       --  For arrays, we simply need to test if the component sizes are the
4768       --  same. Pragma Pack is reflected in modified component sizes, so this
4769       --  check also deals with pragma Pack.
4770
4771       if Is_Array_Type (T1) then
4772          return Component_Size (T1) = Component_Size (T2);
4773
4774       --  Tagged types always have the same representation, because it is not
4775       --  possible to specify different representations for common fields.
4776
4777       elsif Is_Tagged_Type (T1) then
4778          return True;
4779
4780       --  Case of record types
4781
4782       elsif Is_Record_Type (T1) then
4783
4784          --  Packed status must conform
4785
4786          if Is_Packed (T1) /= Is_Packed (T2) then
4787             return False;
4788
4789          --  Otherwise we must check components. Typ2 maybe a constrained
4790          --  subtype with fewer components, so we compare the components
4791          --  of the base types.
4792
4793          else
4794             Record_Case : declare
4795                CD1, CD2 : Entity_Id;
4796
4797                function Same_Rep return Boolean;
4798                --  CD1 and CD2 are either components or discriminants. This
4799                --  function tests whether the two have the same representation
4800
4801                --------------
4802                -- Same_Rep --
4803                --------------
4804
4805                function Same_Rep return Boolean is
4806                begin
4807                   if No (Component_Clause (CD1)) then
4808                      return No (Component_Clause (CD2));
4809
4810                   else
4811                      return
4812                         Present (Component_Clause (CD2))
4813                           and then
4814                         Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2)
4815                           and then
4816                         Esize (CD1) = Esize (CD2);
4817                   end if;
4818                end Same_Rep;
4819
4820             --  Start of processing for Record_Case
4821
4822             begin
4823                if Has_Discriminants (T1) then
4824                   CD1 := First_Discriminant (T1);
4825                   CD2 := First_Discriminant (T2);
4826
4827                   --  The number of discriminants may be different if the
4828                   --  derived type has fewer (constrained by values). The
4829                   --  invisible discriminants retain the representation of
4830                   --  the original, so the discrepancy does not per se
4831                   --  indicate a different representation.
4832
4833                   while Present (CD1)
4834                     and then Present (CD2)
4835                   loop
4836                      if not Same_Rep then
4837                         return False;
4838                      else
4839                         Next_Discriminant (CD1);
4840                         Next_Discriminant (CD2);
4841                      end if;
4842                   end loop;
4843                end if;
4844
4845                CD1 := First_Component (Underlying_Type (Base_Type (T1)));
4846                CD2 := First_Component (Underlying_Type (Base_Type (T2)));
4847
4848                while Present (CD1) loop
4849                   if not Same_Rep then
4850                      return False;
4851                   else
4852                      Next_Component (CD1);
4853                      Next_Component (CD2);
4854                   end if;
4855                end loop;
4856
4857                return True;
4858             end Record_Case;
4859          end if;
4860
4861       --  For enumeration types, we must check each literal to see if the
4862       --  representation is the same. Note that we do not permit enumeration
4863       --  representation clauses for Character and Wide_Character, so these
4864       --  cases were already dealt with.
4865
4866       elsif Is_Enumeration_Type (T1) then
4867          Enumeration_Case : declare
4868             L1, L2 : Entity_Id;
4869
4870          begin
4871             L1 := First_Literal (T1);
4872             L2 := First_Literal (T2);
4873
4874             while Present (L1) loop
4875                if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then
4876                   return False;
4877                else
4878                   Next_Literal (L1);
4879                   Next_Literal (L2);
4880                end if;
4881             end loop;
4882
4883             return True;
4884
4885          end Enumeration_Case;
4886
4887       --  Any other types have the same representation for these purposes
4888
4889       else
4890          return True;
4891       end if;
4892    end Same_Representation;
4893
4894    ----------------
4895    -- Set_Biased --
4896    ----------------
4897
4898    procedure Set_Biased
4899      (E      : Entity_Id;
4900       N      : Node_Id;
4901       Msg    : String;
4902       Biased : Boolean := True)
4903    is
4904    begin
4905       if Biased then
4906          Set_Has_Biased_Representation (E);
4907
4908          if Warn_On_Biased_Representation then
4909             Error_Msg_NE
4910               ("?" & Msg & " forces biased representation for&", N, E);
4911          end if;
4912       end if;
4913    end Set_Biased;
4914
4915    --------------------
4916    -- Set_Enum_Esize --
4917    --------------------
4918
4919    procedure Set_Enum_Esize (T : Entity_Id) is
4920       Lo : Uint;
4921       Hi : Uint;
4922       Sz : Nat;
4923
4924    begin
4925       Init_Alignment (T);
4926
4927       --  Find the minimum standard size (8,16,32,64) that fits
4928
4929       Lo := Enumeration_Rep (Entity (Type_Low_Bound (T)));
4930       Hi := Enumeration_Rep (Entity (Type_High_Bound (T)));
4931
4932       if Lo < 0 then
4933          if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then
4934             Sz := Standard_Character_Size;  -- May be > 8 on some targets
4935
4936          elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then
4937             Sz := 16;
4938
4939          elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then
4940             Sz := 32;
4941
4942          else pragma Assert (Lo >= -Uint_2**63 and then Hi < Uint_2**63);
4943             Sz := 64;
4944          end if;
4945
4946       else
4947          if Hi < Uint_2**08 then
4948             Sz := Standard_Character_Size;  -- May be > 8 on some targets
4949
4950          elsif Hi < Uint_2**16 then
4951             Sz := 16;
4952
4953          elsif Hi < Uint_2**32 then
4954             Sz := 32;
4955
4956          else pragma Assert (Hi < Uint_2**63);
4957             Sz := 64;
4958          end if;
4959       end if;
4960
4961       --  That minimum is the proper size unless we have a foreign convention
4962       --  and the size required is 32 or less, in which case we bump the size
4963       --  up to 32. This is required for C and C++ and seems reasonable for
4964       --  all other foreign conventions.
4965
4966       if Has_Foreign_Convention (T)
4967         and then Esize (T) < Standard_Integer_Size
4968       then
4969          Init_Esize (T, Standard_Integer_Size);
4970       else
4971          Init_Esize (T, Sz);
4972       end if;
4973    end Set_Enum_Esize;
4974
4975    ------------------------------
4976    -- Validate_Address_Clauses --
4977    ------------------------------
4978
4979    procedure Validate_Address_Clauses is
4980    begin
4981       for J in Address_Clause_Checks.First .. Address_Clause_Checks.Last loop
4982          declare
4983             ACCR : Address_Clause_Check_Record
4984                      renames Address_Clause_Checks.Table (J);
4985
4986             Expr : Node_Id;
4987
4988             X_Alignment : Uint;
4989             Y_Alignment : Uint;
4990
4991             X_Size : Uint;
4992             Y_Size : Uint;
4993
4994          begin
4995             --  Skip processing of this entry if warning already posted
4996
4997             if not Address_Warning_Posted (ACCR.N) then
4998
4999                Expr := Original_Node (Expression (ACCR.N));
5000
5001                --  Get alignments
5002
5003                X_Alignment := Alignment (ACCR.X);
5004                Y_Alignment := Alignment (ACCR.Y);
5005
5006                --  Similarly obtain sizes
5007
5008                X_Size := Esize (ACCR.X);
5009                Y_Size := Esize (ACCR.Y);
5010
5011                --  Check for large object overlaying smaller one
5012
5013                if Y_Size > Uint_0
5014                  and then X_Size > Uint_0
5015                  and then X_Size > Y_Size
5016                then
5017                   Error_Msg_NE
5018                     ("?& overlays smaller object", ACCR.N, ACCR.X);
5019                   Error_Msg_N
5020                     ("\?program execution may be erroneous", ACCR.N);
5021                   Error_Msg_Uint_1 := X_Size;
5022                   Error_Msg_NE
5023                     ("\?size of & is ^", ACCR.N, ACCR.X);
5024                   Error_Msg_Uint_1 := Y_Size;
5025                   Error_Msg_NE
5026                     ("\?size of & is ^", ACCR.N, ACCR.Y);
5027
5028                --  Check for inadequate alignment, both of the base object
5029                --  and of the offset, if any.
5030
5031                --  Note: we do not check the alignment if we gave a size
5032                --  warning, since it would likely be redundant.
5033
5034                elsif Y_Alignment /= Uint_0
5035                  and then (Y_Alignment < X_Alignment
5036                              or else (ACCR.Off
5037                                         and then
5038                                           Nkind (Expr) = N_Attribute_Reference
5039                                         and then
5040                                           Attribute_Name (Expr) = Name_Address
5041                                         and then
5042                                           Has_Compatible_Alignment
5043                                             (ACCR.X, Prefix (Expr))
5044                                              /= Known_Compatible))
5045                then
5046                   Error_Msg_NE
5047                     ("?specified address for& may be inconsistent "
5048                        & "with alignment",
5049                      ACCR.N, ACCR.X);
5050                   Error_Msg_N
5051                     ("\?program execution may be erroneous (RM 13.3(27))",
5052                      ACCR.N);
5053                   Error_Msg_Uint_1 := X_Alignment;
5054                   Error_Msg_NE
5055                     ("\?alignment of & is ^",
5056                      ACCR.N, ACCR.X);
5057                   Error_Msg_Uint_1 := Y_Alignment;
5058                   Error_Msg_NE
5059                     ("\?alignment of & is ^",
5060                      ACCR.N, ACCR.Y);
5061                   if Y_Alignment >= X_Alignment then
5062                      Error_Msg_N
5063                       ("\?but offset is not multiple of alignment",
5064                        ACCR.N);
5065                   end if;
5066                end if;
5067             end if;
5068          end;
5069       end loop;
5070    end Validate_Address_Clauses;
5071
5072    -----------------------------------
5073    -- Validate_Unchecked_Conversion --
5074    -----------------------------------
5075
5076    procedure Validate_Unchecked_Conversion
5077      (N        : Node_Id;
5078       Act_Unit : Entity_Id)
5079    is
5080       Source : Entity_Id;
5081       Target : Entity_Id;
5082       Vnode  : Node_Id;
5083
5084    begin
5085       --  Obtain source and target types. Note that we call Ancestor_Subtype
5086       --  here because the processing for generic instantiation always makes
5087       --  subtypes, and we want the original frozen actual types.
5088
5089       --  If we are dealing with private types, then do the check on their
5090       --  fully declared counterparts if the full declarations have been
5091       --  encountered (they don't have to be visible, but they must exist!)
5092
5093       Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit)));
5094
5095       if Is_Private_Type (Source)
5096         and then Present (Underlying_Type (Source))
5097       then
5098          Source := Underlying_Type (Source);
5099       end if;
5100
5101       Target := Ancestor_Subtype (Etype (Act_Unit));
5102
5103       --  If either type is generic, the instantiation happens within a generic
5104       --  unit, and there is nothing to check. The proper check
5105       --  will happen when the enclosing generic is instantiated.
5106
5107       if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then
5108          return;
5109       end if;
5110
5111       if Is_Private_Type (Target)
5112         and then Present (Underlying_Type (Target))
5113       then
5114          Target := Underlying_Type (Target);
5115       end if;
5116
5117       --  Source may be unconstrained array, but not target
5118
5119       if Is_Array_Type (Target)
5120         and then not Is_Constrained (Target)
5121       then
5122          Error_Msg_N
5123            ("unchecked conversion to unconstrained array not allowed", N);
5124          return;
5125       end if;
5126
5127       --  Warn if conversion between two different convention pointers
5128
5129       if Is_Access_Type (Target)
5130         and then Is_Access_Type (Source)
5131         and then Convention (Target) /= Convention (Source)
5132         and then Warn_On_Unchecked_Conversion
5133       then
5134          --  Give warnings for subprogram pointers only on most targets. The
5135          --  exception is VMS, where data pointers can have different lengths
5136          --  depending on the pointer convention.
5137
5138          if Is_Access_Subprogram_Type (Target)
5139            or else Is_Access_Subprogram_Type (Source)
5140            or else OpenVMS_On_Target
5141          then
5142             Error_Msg_N
5143               ("?conversion between pointers with different conventions!", N);
5144          end if;
5145       end if;
5146
5147       --  Warn if one of the operands is Ada.Calendar.Time. Do not emit a
5148       --  warning when compiling GNAT-related sources.
5149
5150       if Warn_On_Unchecked_Conversion
5151         and then not In_Predefined_Unit (N)
5152         and then RTU_Loaded (Ada_Calendar)
5153         and then
5154           (Chars (Source) = Name_Time
5155              or else
5156            Chars (Target) = Name_Time)
5157       then
5158          --  If Ada.Calendar is loaded and the name of one of the operands is
5159          --  Time, there is a good chance that this is Ada.Calendar.Time.
5160
5161          declare
5162             Calendar_Time : constant Entity_Id :=
5163                               Full_View (RTE (RO_CA_Time));
5164          begin
5165             pragma Assert (Present (Calendar_Time));
5166
5167             if Source = Calendar_Time
5168               or else Target = Calendar_Time
5169             then
5170                Error_Msg_N
5171                  ("?representation of 'Time values may change between " &
5172                   "'G'N'A'T versions", N);
5173             end if;
5174          end;
5175       end if;
5176
5177       --  Make entry in unchecked conversion table for later processing by
5178       --  Validate_Unchecked_Conversions, which will check sizes and alignments
5179       --  (using values set by the back-end where possible). This is only done
5180       --  if the appropriate warning is active.
5181
5182       if Warn_On_Unchecked_Conversion then
5183          Unchecked_Conversions.Append
5184            (New_Val => UC_Entry'
5185               (Eloc   => Sloc (N),
5186                Source => Source,
5187                Target => Target));
5188
5189          --  If both sizes are known statically now, then back end annotation
5190          --  is not required to do a proper check but if either size is not
5191          --  known statically, then we need the annotation.
5192
5193          if Known_Static_RM_Size (Source)
5194            and then Known_Static_RM_Size (Target)
5195          then
5196             null;
5197          else
5198             Back_Annotate_Rep_Info := True;
5199          end if;
5200       end if;
5201
5202       --  If unchecked conversion to access type, and access type is declared
5203       --  in the same unit as the unchecked conversion, then set the
5204       --  No_Strict_Aliasing flag (no strict aliasing is implicit in this
5205       --  situation).
5206
5207       if Is_Access_Type (Target) and then
5208         In_Same_Source_Unit (Target, N)
5209       then
5210          Set_No_Strict_Aliasing (Implementation_Base_Type (Target));
5211       end if;
5212
5213       --  Generate N_Validate_Unchecked_Conversion node for back end in
5214       --  case the back end needs to perform special validation checks.
5215
5216       --  Shouldn't this be in Exp_Ch13, since the check only gets done
5217       --  if we have full expansion and the back end is called ???
5218
5219       Vnode :=
5220         Make_Validate_Unchecked_Conversion (Sloc (N));
5221       Set_Source_Type (Vnode, Source);
5222       Set_Target_Type (Vnode, Target);
5223
5224       --  If the unchecked conversion node is in a list, just insert before it.
5225       --  If not we have some strange case, not worth bothering about.
5226
5227       if Is_List_Member (N) then
5228          Insert_After (N, Vnode);
5229       end if;
5230    end Validate_Unchecked_Conversion;
5231
5232    ------------------------------------
5233    -- Validate_Unchecked_Conversions --
5234    ------------------------------------
5235
5236    procedure Validate_Unchecked_Conversions is
5237    begin
5238       for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop
5239          declare
5240             T : UC_Entry renames Unchecked_Conversions.Table (N);
5241
5242             Eloc   : constant Source_Ptr := T.Eloc;
5243             Source : constant Entity_Id  := T.Source;
5244             Target : constant Entity_Id  := T.Target;
5245
5246             Source_Siz    : Uint;
5247             Target_Siz    : Uint;
5248
5249          begin
5250             --  This validation check, which warns if we have unequal sizes for
5251             --  unchecked conversion, and thus potentially implementation
5252             --  dependent semantics, is one of the few occasions on which we
5253             --  use the official RM size instead of Esize. See description in
5254             --  Einfo "Handling of Type'Size Values" for details.
5255
5256             if Serious_Errors_Detected = 0
5257               and then Known_Static_RM_Size (Source)
5258               and then Known_Static_RM_Size (Target)
5259
5260               --  Don't do the check if warnings off for either type, note the
5261               --  deliberate use of OR here instead of OR ELSE to get the flag
5262               --  Warnings_Off_Used set for both types if appropriate.
5263
5264               and then not (Has_Warnings_Off (Source)
5265                               or
5266                             Has_Warnings_Off (Target))
5267             then
5268                Source_Siz := RM_Size (Source);
5269                Target_Siz := RM_Size (Target);
5270
5271                if Source_Siz /= Target_Siz then
5272                   Error_Msg
5273                     ("?types for unchecked conversion have different sizes!",
5274                      Eloc);
5275
5276                   if All_Errors_Mode then
5277                      Error_Msg_Name_1 := Chars (Source);
5278                      Error_Msg_Uint_1 := Source_Siz;
5279                      Error_Msg_Name_2 := Chars (Target);
5280                      Error_Msg_Uint_2 := Target_Siz;
5281                      Error_Msg ("\size of % is ^, size of % is ^?", Eloc);
5282
5283                      Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz);
5284
5285                      if Is_Discrete_Type (Source)
5286                        and then Is_Discrete_Type (Target)
5287                      then
5288                         if Source_Siz > Target_Siz then
5289                            Error_Msg
5290                              ("\?^ high order bits of source will be ignored!",
5291                               Eloc);
5292
5293                         elsif Is_Unsigned_Type (Source) then
5294                            Error_Msg
5295                              ("\?source will be extended with ^ high order " &
5296                               "zero bits?!", Eloc);
5297
5298                         else
5299                            Error_Msg
5300                              ("\?source will be extended with ^ high order " &
5301                               "sign bits!",
5302                               Eloc);
5303                         end if;
5304
5305                      elsif Source_Siz < Target_Siz then
5306                         if Is_Discrete_Type (Target) then
5307                            if Bytes_Big_Endian then
5308                               Error_Msg
5309                                 ("\?target value will include ^ undefined " &
5310                                  "low order bits!",
5311                                  Eloc);
5312                            else
5313                               Error_Msg
5314                                 ("\?target value will include ^ undefined " &
5315                                  "high order bits!",
5316                                  Eloc);
5317                            end if;
5318
5319                         else
5320                            Error_Msg
5321                              ("\?^ trailing bits of target value will be " &
5322                               "undefined!", Eloc);
5323                         end if;
5324
5325                      else pragma Assert (Source_Siz > Target_Siz);
5326                         Error_Msg
5327                           ("\?^ trailing bits of source will be ignored!",
5328                            Eloc);
5329                      end if;
5330                   end if;
5331                end if;
5332             end if;
5333
5334             --  If both types are access types, we need to check the alignment.
5335             --  If the alignment of both is specified, we can do it here.
5336
5337             if Serious_Errors_Detected = 0
5338               and then Ekind (Source) in Access_Kind
5339               and then Ekind (Target) in Access_Kind
5340               and then Target_Strict_Alignment
5341               and then Present (Designated_Type (Source))
5342               and then Present (Designated_Type (Target))
5343             then
5344                declare
5345                   D_Source : constant Entity_Id := Designated_Type (Source);
5346                   D_Target : constant Entity_Id := Designated_Type (Target);
5347
5348                begin
5349                   if Known_Alignment (D_Source)
5350                     and then Known_Alignment (D_Target)
5351                   then
5352                      declare
5353                         Source_Align : constant Uint := Alignment (D_Source);
5354                         Target_Align : constant Uint := Alignment (D_Target);
5355
5356                      begin
5357                         if Source_Align < Target_Align
5358                           and then not Is_Tagged_Type (D_Source)
5359
5360                           --  Suppress warning if warnings suppressed on either
5361                           --  type or either designated type. Note the use of
5362                           --  OR here instead of OR ELSE. That is intentional,
5363                           --  we would like to set flag Warnings_Off_Used in
5364                           --  all types for which warnings are suppressed.
5365
5366                           and then not (Has_Warnings_Off (D_Source)
5367                                           or
5368                                         Has_Warnings_Off (D_Target)
5369                                           or
5370                                         Has_Warnings_Off (Source)
5371                                           or
5372                                         Has_Warnings_Off (Target))
5373                         then
5374                            Error_Msg_Uint_1 := Target_Align;
5375                            Error_Msg_Uint_2 := Source_Align;
5376                            Error_Msg_Node_1 := D_Target;
5377                            Error_Msg_Node_2 := D_Source;
5378                            Error_Msg
5379                              ("?alignment of & (^) is stricter than " &
5380                               "alignment of & (^)!", Eloc);
5381                            Error_Msg
5382                              ("\?resulting access value may have invalid " &
5383                               "alignment!", Eloc);
5384                         end if;
5385                      end;
5386                   end if;
5387                end;
5388             end if;
5389          end;
5390       end loop;
5391    end Validate_Unchecked_Conversions;
5392
5393 end Sem_Ch13;