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