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