gcc/ada/sem_ch13.adb

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