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