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