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