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