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