gcc/ada/sem_ch13.adb

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