gcc/ada/sem_ch13.adb

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