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