gcc/ada/sem_ch13.adb

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