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