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