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