gcc/ada/freeze.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               F R E E Z E                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2002, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Debug;    use Debug;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Errout;   use Errout;
  32 with Exp_Ch7;  use Exp_Ch7;
  33 with Exp_Ch11; use Exp_Ch11;
  34 with Exp_Pakd; use Exp_Pakd;
  35 with Exp_Util; use Exp_Util;
  36 with Layout;   use Layout;
  37 with Lib.Xref; use Lib.Xref;
  38 with Nlists;   use Nlists;
  39 with Nmake;    use Nmake;
  40 with Opt;      use Opt;
  41 with Restrict; use Restrict;
  42 with Sem;      use Sem;
  43 with Sem_Cat;  use Sem_Cat;
  44 with Sem_Ch6;  use Sem_Ch6;
  45 with Sem_Ch7;  use Sem_Ch7;
  46 with Sem_Ch8;  use Sem_Ch8;
  47 with Sem_Ch13; use Sem_Ch13;
  48 with Sem_Eval; use Sem_Eval;
  49 with Sem_Mech; use Sem_Mech;
  50 with Sem_Prag; use Sem_Prag;
  51 with Sem_Res;  use Sem_Res;
  52 with Sem_Util; use Sem_Util;
  53 with Sinfo;    use Sinfo;
  54 with Snames;   use Snames;
  55 with Stand;    use Stand;
  56 with Targparm; use Targparm;
  57 with Tbuild;   use Tbuild;
  58 with Ttypes;   use Ttypes;
  59 with Uintp;    use Uintp;
  60 with Urealp;   use Urealp;
  61
  62 package body Freeze is
  63
  64    -----------------------
  65    -- Local Subprograms --
  66    -----------------------
  67
  68    procedure Adjust_Esize_For_Alignment (Typ : Entity_Id);
  69    --  Typ is a type that is being frozen. If no size clause is given,
  70    --  but a default Esize has been computed, then this default Esize is
  71    --  adjusted up if necessary to be consistent with a given alignment,
  72    --  but never to a value greater than Long_Long_Integer'Size. This
  73    --  is used for all discrete types and for fixed-point types.
  74
  75    procedure Build_And_Analyze_Renamed_Body
  76      (Decl  : Node_Id;
  77       New_S : Entity_Id;
  78       After : in out Node_Id);
  79    --  Build body for a renaming declaration, insert in tree and analyze.
  80
  81    procedure Check_Strict_Alignment (E : Entity_Id);
  82    --  E is a base type. If E is tagged or has a component that is aliased
  83    --  or tagged or contains something this is aliased or tagged, set
  84    --  Strict_Alignment.
  85
  86    procedure Check_Unsigned_Type (E : Entity_Id);
  87    pragma Inline (Check_Unsigned_Type);
  88    --  If E is a fixed-point or discrete type, then all the necessary work
  89    --  to freeze it is completed except for possible setting of the flag
  90    --  Is_Unsigned_Type, which is done by this procedure. The call has no
  91    --  effect if the entity E is not a discrete or fixed-point type.
  92
  93    procedure Freeze_And_Append
  94      (Ent    : Entity_Id;
  95       Loc    : Source_Ptr;
  96       Result : in out List_Id);
  97    --  Freezes Ent using Freeze_Entity, and appends the resulting list of
  98    --  nodes to Result, modifying Result from No_List if necessary.
  99
 100    procedure Freeze_Enumeration_Type (Typ : Entity_Id);
 101    --  Freeze enumeration type. The Esize field is set as processing
 102    --  proceeds (i.e. set by default when the type is declared and then
 103    --  adjusted by rep clauses. What this procedure does is to make sure
 104    --  that if a foreign convention is specified, and no specific size
 105    --  is given, then the size must be at least Integer'Size.
 106
 107    procedure Freeze_Static_Object (E : Entity_Id);
 108    --  If an object is frozen which has Is_Statically_Allocated set, then
 109    --  all referenced types must also be marked with this flag. This routine
 110    --  is in charge of meeting this requirement for the object entity E.
 111
 112    procedure Freeze_Subprogram (E : Entity_Id);
 113    --  Perform freezing actions for a subprogram (create extra formals,
 114    --  and set proper default mechanism values). Note that this routine
 115    --  is not called for internal subprograms, for which neither of these
 116    --  actions is needed (or desirable, we do not want for example to have
 117    --  these extra formals present in initialization procedures, where they
 118    --  would serve no purpose). In this call E is either a subprogram or
 119    --  a subprogram type (i.e. an access to a subprogram).
 120
 121    function Is_Fully_Defined (T : Entity_Id) return Boolean;
 122    --  true if T is not private, or has a full view.
 123
 124    procedure Process_Default_Expressions
 125      (E     : Entity_Id;
 126       After : in out Node_Id);
 127    --  This procedure is called for each subprogram to complete processing
 128    --  of default expressions at the point where all types are known to be
 129    --  frozen. The expressions must be analyzed in full, to make sure that
 130    --  all error processing is done (they have only been pre-analyzed). If
 131    --  the expression is not an entity or literal, its analysis may generate
 132    --  code which must not be executed. In that case we build a function
 133    --  body to hold that code. This wrapper function serves no other purpose
 134    --  (it used to be called to evaluate the default, but now the default is
 135    --  inlined at each point of call).
 136
 137    procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id);
 138    --  Typ is a record or array type that is being frozen. This routine
 139    --  sets the default component alignment from the scope stack values
 140    --  if the alignment is otherwise not specified.
 141
 142    procedure Check_Debug_Info_Needed (T : Entity_Id);
 143    --  As each entity is frozen, this routine is called to deal with the
 144    --  setting of Debug_Info_Needed for the entity. This flag is set if
 145    --  the entity comes from source, or if we are in Debug_Generated_Code
 146    --  mode or if the -gnatdV debug flag is set. However, it never sets
 147    --  the flag if Debug_Info_Off is set.
 148
 149    procedure Set_Debug_Info_Needed (T : Entity_Id);
 150    --  Sets the Debug_Info_Needed flag on entity T if not already set, and
 151    --  also on any entities that are needed by T (for an object, the type
 152    --  of the object is needed, and for a type, the subsidiary types are
 153    --  needed -- see body for details). Never has any effect on T if the
 154    --  Debug_Info_Off flag is set.
 155
 156    -------------------------------
 157    -- Adjust_Esize_For_Alignment --
 158    -------------------------------
 159
 160    procedure Adjust_Esize_For_Alignment (Typ : Entity_Id) is
 161       Align : Uint;
 162
 163    begin
 164       if Known_Esize (Typ) and then Known_Alignment (Typ) then
 165          Align := Alignment_In_Bits (Typ);
 166
 167          if Align > Esize (Typ)
 168            and then Align <= Standard_Long_Long_Integer_Size
 169          then
 170             Set_Esize (Typ, Align);
 171          end if;
 172       end if;
 173    end Adjust_Esize_For_Alignment;
 174
 175    ------------------------------------
 176    -- Build_And_Analyze_Renamed_Body --
 177    ------------------------------------
 178
 179    procedure Build_And_Analyze_Renamed_Body
 180      (Decl  : Node_Id;
 181       New_S : Entity_Id;
 182       After : in out Node_Id)
 183    is
 184       Body_Node : constant Node_Id := Build_Renamed_Body (Decl, New_S);
 185
 186    begin
 187       Insert_After (After, Body_Node);
 188       Mark_Rewrite_Insertion (Body_Node);
 189       Analyze (Body_Node);
 190       After := Body_Node;
 191    end Build_And_Analyze_Renamed_Body;
 192
 193    ------------------------
 194    -- Build_Renamed_Body --
 195    ------------------------
 196
 197    function Build_Renamed_Body
 198      (Decl  : Node_Id;
 199       New_S : Entity_Id)
 200       return Node_Id
 201    is
 202       Loc : constant Source_Ptr := Sloc (New_S);
 203       --  We use for the source location of the renamed body, the location
 204       --  of the spec entity. It might seem more natural to use the location
 205       --  of the renaming declaration itself, but that would be wrong, since
 206       --  then the body we create would look as though it was created far
 207       --  too late, and this could cause problems with elaboration order
 208       --  analysis, particularly in connection with instantiations.
 209
 210       N          : constant Node_Id := Unit_Declaration_Node (New_S);
 211       Nam        : constant Node_Id := Name (N);
 212       Old_S      : Entity_Id;
 213       Spec       : constant Node_Id := New_Copy_Tree (Specification (Decl));
 214       Actuals    : List_Id := No_List;
 215       Call_Node  : Node_Id;
 216       Call_Name  : Node_Id;
 217       Body_Node  : Node_Id;
 218       Formal     : Entity_Id;
 219       O_Formal   : Entity_Id;
 220       Param_Spec : Node_Id;
 221
 222    begin
 223       --  Determine the entity being renamed, which is the target of the
 224       --  call statement. If the name is an explicit dereference, this is
 225       --  a renaming of a subprogram type rather than a subprogram. The
 226       --  name itself is fully analyzed.
 227
 228       if Nkind (Nam) = N_Selected_Component then
 229          Old_S := Entity (Selector_Name (Nam));
 230
 231       elsif Nkind (Nam) = N_Explicit_Dereference then
 232          Old_S := Etype (Nam);
 233
 234       elsif Nkind (Nam) = N_Indexed_Component then
 235
 236          if Is_Entity_Name (Prefix (Nam)) then
 237             Old_S := Entity (Prefix (Nam));
 238          else
 239             Old_S := Entity (Selector_Name (Prefix (Nam)));
 240          end if;
 241
 242       elsif Nkind (Nam) = N_Character_Literal then
 243          Old_S := Etype (New_S);
 244
 245       else
 246          Old_S := Entity (Nam);
 247       end if;
 248
 249       if Is_Entity_Name (Nam) then
 250
 251          --  If the renamed entity is a predefined operator, retain full
 252          --  name to ensure its visibility.
 253
 254          if Ekind (Old_S) = E_Operator
 255            and then Nkind (Nam) = N_Expanded_Name
 256          then
 257             Call_Name := New_Copy (Name (N));
 258          else
 259             Call_Name := New_Reference_To (Old_S, Loc);
 260          end if;
 261
 262       else
 263          Call_Name := New_Copy (Name (N));
 264
 265          --  The original name may have been overloaded, but
 266          --  is fully resolved now.
 267
 268          Set_Is_Overloaded (Call_Name, False);
 269       end if;
 270
 271       --  For simple renamings, subsequent calls can be expanded directly
 272       --  as called to the renamed entity. The body must be generated in
 273       --  any case for calls they may appear elsewhere.
 274
 275       if (Ekind (Old_S) = E_Function
 276            or else Ekind (Old_S) = E_Procedure)
 277         and then Nkind (Decl) = N_Subprogram_Declaration
 278       then
 279          Set_Body_To_Inline (Decl, Old_S);
 280       end if;
 281
 282       --  The body generated for this renaming is an internal artifact, and
 283       --  does not  constitute a freeze point for the called entity.
 284
 285       Set_Must_Not_Freeze (Call_Name);
 286
 287       Formal := First_Formal (Defining_Entity (Decl));
 288
 289       if Present (Formal) then
 290          Actuals := New_List;
 291
 292          while Present (Formal) loop
 293             Append (New_Reference_To (Formal, Loc), Actuals);
 294             Next_Formal (Formal);
 295          end loop;
 296       end if;
 297
 298       --  If the renamed entity is an entry, inherit its profile. For
 299       --  other renamings as bodies, both profiles must be subtype
 300       --  conformant, so it is not necessary to replace the profile given
 301       --  in the declaration. However, default values that are aggregates
 302       --  are rewritten when partially analyzed, so we recover the original
 303       --  aggregate to insure that subsequent conformity checking works.
 304       --  Similarly, if the default expression was constant-folded, recover
 305       --  the original expression.
 306
 307       Formal := First_Formal (Defining_Entity (Decl));
 308
 309       if Present (Formal) then
 310          O_Formal := First_Formal (Old_S);
 311          Param_Spec := First (Parameter_Specifications (Spec));
 312
 313          while Present (Formal) loop
 314             if Is_Entry (Old_S) then
 315
 316                if Nkind (Parameter_Type (Param_Spec)) /=
 317                                                     N_Access_Definition
 318                then
 319                   Set_Etype (Formal, Etype (O_Formal));
 320                   Set_Entity (Parameter_Type (Param_Spec), Etype (O_Formal));
 321                end if;
 322
 323             elsif Nkind (Default_Value (O_Formal)) = N_Aggregate
 324               or else Nkind (Original_Node (Default_Value (O_Formal))) /=
 325                                            Nkind (Default_Value (O_Formal))
 326             then
 327                Set_Expression (Param_Spec,
 328                  New_Copy_Tree (Original_Node (Default_Value (O_Formal))));
 329             end if;
 330
 331             Next_Formal (Formal);
 332             Next_Formal (O_Formal);
 333             Next (Param_Spec);
 334          end loop;
 335       end if;
 336
 337       --  If the renamed entity is a function, the generated body contains a
 338       --  return statement. Otherwise, build a procedure call. If the entity is
 339       --  an entry, subsequent analysis of the call will transform it into the
 340       --  proper entry or protected operation call. If the renamed entity is
 341       --  a character literal, return it directly.
 342
 343       if Ekind (Old_S) = E_Function
 344         or else Ekind (Old_S) = E_Operator
 345         or else (Ekind (Old_S) = E_Subprogram_Type
 346                   and then Etype (Old_S) /= Standard_Void_Type)
 347       then
 348          Call_Node :=
 349            Make_Return_Statement (Loc,
 350               Expression =>
 351                 Make_Function_Call (Loc,
 352                   Name => Call_Name,
 353                   Parameter_Associations => Actuals));
 354
 355       elsif Ekind (Old_S) = E_Enumeration_Literal then
 356          Call_Node :=
 357            Make_Return_Statement (Loc,
 358               Expression => New_Occurrence_Of (Old_S, Loc));
 359
 360       elsif Nkind (Nam) = N_Character_Literal then
 361          Call_Node :=
 362            Make_Return_Statement (Loc,
 363              Expression => Call_Name);
 364
 365       else
 366          Call_Node :=
 367            Make_Procedure_Call_Statement (Loc,
 368              Name => Call_Name,
 369              Parameter_Associations => Actuals);
 370       end if;
 371
 372       --  Create entities for subprogram body and formals.
 373
 374       Set_Defining_Unit_Name (Spec,
 375         Make_Defining_Identifier (Loc, Chars => Chars (New_S)));
 376
 377       Param_Spec := First (Parameter_Specifications (Spec));
 378
 379       while Present (Param_Spec) loop
 380          Set_Defining_Identifier (Param_Spec,
 381            Make_Defining_Identifier (Loc,
 382              Chars => Chars (Defining_Identifier (Param_Spec))));
 383          Next (Param_Spec);
 384       end loop;
 385
 386       Body_Node :=
 387         Make_Subprogram_Body (Loc,
 388           Specification => Spec,
 389           Declarations => New_List,
 390           Handled_Statement_Sequence =>
 391             Make_Handled_Sequence_Of_Statements (Loc,
 392               Statements => New_List (Call_Node)));
 393
 394       if Nkind (Decl) /= N_Subprogram_Declaration then
 395          Rewrite (N,
 396            Make_Subprogram_Declaration (Loc,
 397              Specification => Specification (N)));
 398       end if;
 399
 400       --  Link the body to the entity whose declaration it completes. If
 401       --  the body is analyzed when the renamed entity is frozen, it may be
 402       --  necessary to restore the proper scope (see package Exp_Ch13).
 403
 404       if Nkind (N) =  N_Subprogram_Renaming_Declaration
 405         and then Present (Corresponding_Spec (N))
 406       then
 407          Set_Corresponding_Spec (Body_Node, Corresponding_Spec (N));
 408       else
 409          Set_Corresponding_Spec (Body_Node, New_S);
 410       end if;
 411
 412       return Body_Node;
 413    end Build_Renamed_Body;
 414
 415    -----------------------------
 416    -- Check_Compile_Time_Size --
 417    -----------------------------
 418
 419    procedure Check_Compile_Time_Size (T : Entity_Id) is
 420
 421       procedure Set_Small_Size (S : Uint);
 422       --  Sets the compile time known size (32 bits or less) in the Esize
 423       --  field, checking for a size clause that was given which attempts
 424       --  to give a smaller size.
 425
 426       function Size_Known (T : Entity_Id) return Boolean;
 427       --  Recursive function that does all the work
 428
 429       function Static_Discriminated_Components (T : Entity_Id) return Boolean;
 430       --  If T is a constrained subtype, its size is not known if any of its
 431       --  discriminant constraints is not static and it is not a null record.
 432       --  The test is conservative  and doesn't check that the components are
 433       --  in fact constrained by non-static discriminant values. Could be made
 434       --  more precise ???
 435
 436       --------------------
 437       -- Set_Small_Size --
 438       --------------------
 439
 440       procedure Set_Small_Size (S : Uint) is
 441       begin
 442          if S > 32 then
 443             return;
 444
 445          elsif Has_Size_Clause (T) then
 446             if RM_Size (T) < S then
 447                Error_Msg_Uint_1 := S;
 448                Error_Msg_NE
 449                  ("size for & is too small, minimum is ^",
 450                   Size_Clause (T), T);
 451
 452             elsif Unknown_Esize (T) then
 453                Set_Esize (T, S);
 454             end if;
 455
 456          --  Set sizes if not set already
 457
 458          else
 459             if Unknown_Esize (T) then
 460                Set_Esize (T, S);
 461             end if;
 462
 463             if Unknown_RM_Size (T) then
 464                Set_RM_Size (T, S);
 465             end if;
 466          end if;
 467       end Set_Small_Size;
 468
 469       ----------------
 470       -- Size_Known --
 471       ----------------
 472
 473       function Size_Known (T : Entity_Id) return Boolean is
 474          Index : Entity_Id;
 475          Comp  : Entity_Id;
 476          Ctyp  : Entity_Id;
 477          Low   : Node_Id;
 478          High  : Node_Id;
 479
 480       begin
 481          if Size_Known_At_Compile_Time (T) then
 482             return True;
 483
 484          elsif Is_Scalar_Type (T)
 485            or else Is_Task_Type (T)
 486          then
 487             return not Is_Generic_Type (T);
 488
 489          elsif Is_Array_Type (T) then
 490
 491             if Ekind (T) = E_String_Literal_Subtype then
 492                Set_Small_Size (Component_Size (T) * String_Literal_Length (T));
 493                return True;
 494
 495             elsif not Is_Constrained (T) then
 496                return False;
 497
 498             --  Don't do any recursion on type with error posted, since
 499             --  we may have a malformed type that leads us into a loop
 500
 501             elsif Error_Posted (T) then
 502                return False;
 503
 504             elsif not Size_Known (Component_Type (T)) then
 505                return False;
 506             end if;
 507
 508             --  Check for all indexes static, and also compute possible
 509             --  size (in case it is less than 32 and may be packable).
 510
 511             declare
 512                Esiz : Uint := Component_Size (T);
 513                Dim  : Uint;
 514
 515             begin
 516                Index := First_Index (T);
 517
 518                while Present (Index) loop
 519                   if Nkind (Index) = N_Range then
 520                      Get_Index_Bounds (Index, Low, High);
 521
 522                   elsif Error_Posted (Scalar_Range (Etype (Index))) then
 523                      return False;
 524
 525                   else
 526                      Low  := Type_Low_Bound (Etype (Index));
 527                      High := Type_High_Bound (Etype (Index));
 528                   end if;
 529
 530                   if not Compile_Time_Known_Value (Low)
 531                     or else not Compile_Time_Known_Value (High)
 532                     or else Etype (Index) = Any_Type
 533                   then
 534                      return False;
 535
 536                   else
 537                      Dim := Expr_Value (High) - Expr_Value (Low) + 1;
 538
 539                      if Dim >= 0 then
 540                         Esiz := Esiz * Dim;
 541                      else
 542                         Esiz := Uint_0;
 543                      end if;
 544                   end if;
 545
 546                   Next_Index (Index);
 547                end loop;
 548
 549                Set_Small_Size (Esiz);
 550                return True;
 551             end;
 552
 553          elsif Is_Access_Type (T) then
 554             return True;
 555
 556          elsif Is_Private_Type (T)
 557            and then not Is_Generic_Type (T)
 558            and then Present (Underlying_Type (T))
 559          then
 560             --  Don't do any recursion on type with error posted, since
 561             --  we may have a malformed type that leads us into a loop
 562
 563             if Error_Posted (T) then
 564                return False;
 565             else
 566                return Size_Known (Underlying_Type (T));
 567             end if;
 568
 569          elsif Is_Record_Type (T) then
 570             if Is_Class_Wide_Type (T) then
 571                return False;
 572
 573             elsif T /= Base_Type (T) then
 574                return Size_Known_At_Compile_Time (Base_Type (T))
 575                  and then Static_Discriminated_Components (T);
 576
 577             --  Don't do any recursion on type with error posted, since
 578             --  we may have a malformed type that leads us into a loop
 579
 580             elsif Error_Posted (T) then
 581                return False;
 582
 583             else
 584                declare
 585                   Packed_Size_Known : Boolean := Is_Packed (T);
 586                   Packed_Size       : Uint    := Uint_0;
 587
 588                begin
 589                   --  Test for variant part present
 590
 591                   if Has_Discriminants (T)
 592                     and then Present (Parent (T))
 593                     and then Nkind (Parent (T)) = N_Full_Type_Declaration
 594                     and then Nkind (Type_Definition (Parent (T))) =
 595                                N_Record_Definition
 596                     and then not Null_Present (Type_Definition (Parent (T)))
 597                     and then Present (Variant_Part
 598                                (Component_List (Type_Definition (Parent (T)))))
 599                   then
 600                      --  If variant part is present, and type is unconstrained,
 601                      --  then we must have defaulted discriminants, or a size
 602                      --  clause must be present for the type, or else the size
 603                      --  is definitely not known at compile time.
 604
 605                      if not Is_Constrained (T)
 606                        and then
 607                          No (Discriminant_Default_Value
 608                               (First_Discriminant (T)))
 609                        and then Unknown_Esize (T)
 610                      then
 611                         return False;
 612                      else
 613                         --  We do not know the packed size, it is too much
 614                         --  trouble to figure it out.
 615
 616                         Packed_Size_Known := False;
 617                      end if;
 618                   end if;
 619
 620                   Comp := First_Entity (T);
 621
 622                   while Present (Comp) loop
 623                      if Ekind (Comp) = E_Component
 624                           or else
 625                         Ekind (Comp) = E_Discriminant
 626                      then
 627                         Ctyp := Etype (Comp);
 628
 629                         if Present (Component_Clause (Comp)) then
 630                            Packed_Size_Known := False;
 631                         end if;
 632
 633                         if not Size_Known (Ctyp) then
 634                            return False;
 635
 636                         elsif Packed_Size_Known then
 637
 638                            --  If RM_Size is known and static, then we can
 639                            --  keep accumulating the packed size.
 640
 641                            if Known_Static_RM_Size (Ctyp) then
 642
 643                               --  A little glitch, to be removed sometime ???
 644                               --  gigi does not understand zero sizes yet.
 645
 646                               if RM_Size (Ctyp) = Uint_0 then
 647                                  Packed_Size_Known := False;
 648                               end if;
 649
 650                               Packed_Size :=
 651                                 Packed_Size + RM_Size (Ctyp);
 652
 653                            --  If we have a field whose RM_Size is not known
 654                            --  then we can't figure out the packed size here.
 655
 656                            else
 657                               Packed_Size_Known := False;
 658                            end if;
 659                         end if;
 660                      end if;
 661
 662                      Next_Entity (Comp);
 663                   end loop;
 664
 665                   if Packed_Size_Known then
 666                      Set_Small_Size (Packed_Size);
 667                   end if;
 668
 669                   return True;
 670                end;
 671             end if;
 672
 673          else
 674             return False;
 675          end if;
 676       end Size_Known;
 677
 678       -------------------------------------
 679       -- Static_Discriminated_Components --
 680       -------------------------------------
 681
 682       function Static_Discriminated_Components
 683         (T    : Entity_Id)
 684          return Boolean
 685       is
 686          Constraint : Elmt_Id;
 687
 688       begin
 689          if Has_Discriminants (T)
 690            and then Present (Discriminant_Constraint (T))
 691            and then Present (First_Component (T))
 692          then
 693             Constraint := First_Elmt (Discriminant_Constraint (T));
 694
 695             while Present (Constraint) loop
 696                if not Compile_Time_Known_Value (Node (Constraint)) then
 697                   return False;
 698                end if;
 699
 700                Next_Elmt (Constraint);
 701             end loop;
 702          end if;
 703
 704          return True;
 705       end Static_Discriminated_Components;
 706
 707    --  Start of processing for Check_Compile_Time_Size
 708
 709    begin
 710       Set_Size_Known_At_Compile_Time (T, Size_Known (T));
 711    end Check_Compile_Time_Size;
 712
 713    -----------------------------
 714    -- Check_Debug_Info_Needed --
 715    -----------------------------
 716
 717    procedure Check_Debug_Info_Needed (T : Entity_Id) is
 718    begin
 719       if Needs_Debug_Info (T) or else Debug_Info_Off (T) then
 720          return;
 721
 722       elsif Comes_From_Source (T)
 723         or else Debug_Generated_Code
 724         or else Debug_Flag_VV
 725       then
 726          Set_Debug_Info_Needed (T);
 727       end if;
 728    end Check_Debug_Info_Needed;
 729
 730    ----------------------------
 731    -- Check_Strict_Alignment --
 732    ----------------------------
 733
 734    procedure Check_Strict_Alignment (E : Entity_Id) is
 735       Comp  : Entity_Id;
 736
 737    begin
 738       if Is_Tagged_Type (E) or else Is_Concurrent_Type (E) then
 739          Set_Strict_Alignment (E);
 740
 741       elsif Is_Array_Type (E) then
 742          Set_Strict_Alignment (E, Strict_Alignment (Component_Type (E)));
 743
 744       elsif Is_Record_Type (E) then
 745          if Is_Limited_Record (E) then
 746             Set_Strict_Alignment (E);
 747             return;
 748          end if;
 749
 750          Comp := First_Component (E);
 751
 752          while Present (Comp) loop
 753             if not Is_Type (Comp)
 754               and then (Strict_Alignment (Etype (Comp))
 755                         or else Is_Aliased (Comp))
 756             then
 757                Set_Strict_Alignment (E);
 758                return;
 759             end if;
 760
 761             Next_Component (Comp);
 762          end loop;
 763       end if;
 764    end Check_Strict_Alignment;
 765
 766    -------------------------
 767    -- Check_Unsigned_Type --
 768    -------------------------
 769
 770    procedure Check_Unsigned_Type (E : Entity_Id) is
 771       Ancestor : Entity_Id;
 772       Lo_Bound : Node_Id;
 773       Btyp     : Entity_Id;
 774
 775    begin
 776       if not Is_Discrete_Or_Fixed_Point_Type (E) then
 777          return;
 778       end if;
 779
 780       --  Do not attempt to analyze case where range was in error
 781
 782       if Error_Posted (Scalar_Range (E)) then
 783          return;
 784       end if;
 785
 786       --  The situation that is non trivial is something like
 787
 788       --     subtype x1 is integer range -10 .. +10;
 789       --     subtype x2 is x1 range 0 .. V1;
 790       --     subtype x3 is x2 range V2 .. V3;
 791       --     subtype x4 is x3 range V4 .. V5;
 792
 793       --  where Vn are variables. Here the base type is signed, but we still
 794       --  know that x4 is unsigned because of the lower bound of x2.
 795
 796       --  The only way to deal with this is to look up the ancestor chain
 797
 798       Ancestor := E;
 799       loop
 800          if Ancestor = Any_Type or else Etype (Ancestor) = Any_Type then
 801             return;
 802          end if;
 803
 804          Lo_Bound := Type_Low_Bound (Ancestor);
 805
 806          if Compile_Time_Known_Value (Lo_Bound) then
 807
 808             if Expr_Rep_Value (Lo_Bound) >= 0 then
 809                Set_Is_Unsigned_Type (E, True);
 810             end if;
 811
 812             return;
 813
 814          else
 815             Ancestor := Ancestor_Subtype (Ancestor);
 816
 817             --  If no ancestor had a static lower bound, go to base type
 818
 819             if No (Ancestor) then
 820
 821                --  Note: the reason we still check for a compile time known
 822                --  value for the base type is that at least in the case of
 823                --  generic formals, we can have bounds that fail this test,
 824                --  and there may be other cases in error situations.
 825
 826                Btyp := Base_Type (E);
 827
 828                if Btyp = Any_Type or else Etype (Btyp) = Any_Type then
 829                   return;
 830                end if;
 831
 832                Lo_Bound := Type_Low_Bound (Base_Type (E));
 833
 834                if Compile_Time_Known_Value (Lo_Bound)
 835                  and then Expr_Rep_Value (Lo_Bound) >= 0
 836                then
 837                   Set_Is_Unsigned_Type (E, True);
 838                end if;
 839
 840                return;
 841
 842             end if;
 843          end if;
 844       end loop;
 845    end Check_Unsigned_Type;
 846
 847    ----------------
 848    -- Freeze_All --
 849    ----------------
 850
 851    --  Note: the easy coding for this procedure would be to just build a
 852    --  single list of freeze nodes and then insert them and analyze them
 853    --  all at once. This won't work, because the analysis of earlier freeze
 854    --  nodes may recursively freeze types which would otherwise appear later
 855    --  on in the freeze list. So we must analyze and expand the freeze nodes
 856    --  as they are generated.
 857
 858    procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is
 859       Loc   : constant Source_Ptr := Sloc (After);
 860       E     : Entity_Id;
 861       Decl  : Node_Id;
 862
 863       procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id);
 864       --  This is the internal recursive routine that does freezing of
 865       --  entities (but NOT the analysis of default expressions, which
 866       --  should not be recursive, we don't want to analyze those till
 867       --  we are sure that ALL the types are frozen).
 868
 869       procedure Freeze_All_Ent
 870         (From  : Entity_Id;
 871          After : in out Node_Id)
 872       is
 873          E     : Entity_Id;
 874          Flist : List_Id;
 875          Lastn : Node_Id;
 876
 877          procedure Process_Flist;
 878          --  If freeze nodes are present, insert and analyze, and reset
 879          --  cursor for next insertion.
 880
 881          procedure Process_Flist is
 882          begin
 883             if Is_Non_Empty_List (Flist) then
 884                Lastn := Next (After);
 885                Insert_List_After_And_Analyze (After, Flist);
 886
 887                if Present (Lastn) then
 888                   After := Prev (Lastn);
 889                else
 890                   After := Last (List_Containing (After));
 891                end if;
 892             end if;
 893          end Process_Flist;
 894
 895       begin
 896          E := From;
 897          while Present (E) loop
 898
 899             --  If the entity is an inner package which is not a package
 900             --  renaming, then its entities must be frozen at this point.
 901             --  Note that such entities do NOT get frozen at the end of
 902             --  the nested package itself (only library packages freeze).
 903
 904             --  Same is true for task declarations, where anonymous records
 905             --  created for entry parameters must be frozen.
 906
 907             if Ekind (E) = E_Package
 908               and then No (Renamed_Object (E))
 909               and then not Is_Child_Unit (E)
 910               and then not Is_Frozen (E)
 911             then
 912                New_Scope (E);
 913                Install_Visible_Declarations (E);
 914                Install_Private_Declarations (E);
 915
 916                Freeze_All (First_Entity (E), After);
 917
 918                End_Package_Scope (E);
 919
 920             elsif Ekind (E) in Task_Kind
 921               and then
 922                 (Nkind (Parent (E)) = N_Task_Type_Declaration
 923                   or else
 924                  Nkind (Parent (E)) = N_Single_Task_Declaration)
 925             then
 926                New_Scope (E);
 927                Freeze_All (First_Entity (E), After);
 928                End_Scope;
 929
 930             --  For a derived tagged type, we must ensure that all the
 931             --  primitive operations of the parent have been frozen, so
 932             --  that their addresses will be in the parent's dispatch table
 933             --  at the point it is inherited.
 934
 935             elsif Ekind (E) = E_Record_Type
 936               and then Is_Tagged_Type (E)
 937               and then Is_Tagged_Type (Etype (E))
 938               and then Is_Derived_Type (E)
 939             then
 940                declare
 941                   Prim_List : constant Elist_Id :=
 942                                Primitive_Operations (Etype (E));
 943                   Prim      : Elmt_Id;
 944                   Subp      : Entity_Id;
 945
 946                begin
 947                   Prim  := First_Elmt (Prim_List);
 948
 949                   while Present (Prim) loop
 950                      Subp := Node (Prim);
 951
 952                      if Comes_From_Source (Subp)
 953                        and then not Is_Frozen (Subp)
 954                      then
 955                         Flist := Freeze_Entity (Subp, Loc);
 956                         Process_Flist;
 957                      end if;
 958
 959                      Next_Elmt (Prim);
 960                   end loop;
 961                end;
 962             end if;
 963
 964             if not Is_Frozen (E) then
 965                Flist := Freeze_Entity (E, Loc);
 966                Process_Flist;
 967             end if;
 968
 969             Next_Entity (E);
 970          end loop;
 971       end Freeze_All_Ent;
 972
 973    --  Start of processing for Freeze_All
 974
 975    begin
 976       Freeze_All_Ent (From, After);
 977
 978       --  Now that all types are frozen, we can deal with default expressions
 979       --  that require us to build a default expression functions. This is the
 980       --  point at which such functions are constructed (after all types that
 981       --  might be used in such expressions have been frozen).
 982       --  We also add finalization chains to access types whose designated
 983       --  types are controlled. This is normally done when freezing the type,
 984       --  but this misses recursive type definitions where the later members
 985       --  of the recursion introduce controlled components (e.g. 5624-001).
 986
 987       --  Loop through entities
 988
 989       E := From;
 990       while Present (E) loop
 991
 992          if Is_Subprogram (E) then
 993
 994             if not Default_Expressions_Processed (E) then
 995                Process_Default_Expressions (E, After);
 996             end if;
 997
 998             if not Has_Completion (E) then
 999                Decl := Unit_Declaration_Node (E);
1000
1001                if Nkind (Decl) = N_Subprogram_Renaming_Declaration then
1002                   Build_And_Analyze_Renamed_Body (Decl, E, After);
1003
1004                elsif Nkind (Decl) = N_Subprogram_Declaration
1005                  and then Present (Corresponding_Body (Decl))
1006                  and then
1007                    Nkind (Unit_Declaration_Node (Corresponding_Body (Decl)))
1008                    = N_Subprogram_Renaming_Declaration
1009                then
1010                   Build_And_Analyze_Renamed_Body
1011                     (Decl, Corresponding_Body (Decl), After);
1012                end if;
1013             end if;
1014
1015          elsif Ekind (E) in Task_Kind
1016            and then
1017              (Nkind (Parent (E)) = N_Task_Type_Declaration
1018                or else
1019               Nkind (Parent (E)) = N_Single_Task_Declaration)
1020          then
1021             declare
1022                Ent : Entity_Id;
1023
1024             begin
1025                Ent := First_Entity (E);
1026
1027                while Present (Ent) loop
1028
1029                   if Is_Entry (Ent)
1030                     and then not Default_Expressions_Processed (Ent)
1031                   then
1032                      Process_Default_Expressions (Ent, After);
1033                   end if;
1034
1035                   Next_Entity (Ent);
1036                end loop;
1037             end;
1038
1039          elsif Is_Access_Type (E)
1040            and then Comes_From_Source (E)
1041            and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type
1042            and then Controlled_Type (Designated_Type (E))
1043            and then No (Associated_Final_Chain (E))
1044          then
1045             Build_Final_List (Parent (E), E);
1046          end if;
1047
1048          Next_Entity (E);
1049       end loop;
1050
1051    end Freeze_All;
1052
1053    -----------------------
1054    -- Freeze_And_Append --
1055    -----------------------
1056
1057    procedure Freeze_And_Append
1058      (Ent    : Entity_Id;
1059       Loc    : Source_Ptr;
1060       Result : in out List_Id)
1061    is
1062       L : constant List_Id := Freeze_Entity (Ent, Loc);
1063
1064    begin
1065       if Is_Non_Empty_List (L) then
1066          if Result = No_List then
1067             Result := L;
1068          else
1069             Append_List (L, Result);
1070          end if;
1071       end if;
1072    end Freeze_And_Append;
1073
1074    -------------------
1075    -- Freeze_Before --
1076    -------------------
1077
1078    procedure Freeze_Before (N : Node_Id; T : Entity_Id) is
1079       Freeze_Nodes : constant List_Id := Freeze_Entity (T, Sloc (N));
1080       F            : Node_Id;
1081
1082    begin
1083       if Is_Non_Empty_List (Freeze_Nodes) then
1084          F := First (Freeze_Nodes);
1085
1086          if Present (F) then
1087             Insert_Actions (N, Freeze_Nodes);
1088          end if;
1089       end if;
1090    end Freeze_Before;
1091
1092    -------------------
1093    -- Freeze_Entity --
1094    -------------------
1095
1096    function Freeze_Entity (E : Entity_Id; Loc : Source_Ptr) return List_Id is
1097       Comp   : Entity_Id;
1098       F_Node : Node_Id;
1099       Result : List_Id;
1100       Indx   : Node_Id;
1101       Formal : Entity_Id;
1102       Atype  : Entity_Id;
1103
1104       procedure Check_Current_Instance (Comp_Decl : Node_Id);
1105       --  Check that an Access or Unchecked_Access attribute with
1106       --  a prefix which is the current instance type can only be
1107       --  applied when the type is limited.
1108
1109       function After_Last_Declaration return Boolean;
1110       --  If Loc is a freeze_entity that appears after the last declaration
1111       --  in the scope, inhibit error messages on late completion.
1112
1113       procedure Freeze_Record_Type (Rec : Entity_Id);
1114       --  Freeze each component, handle some representation clauses, and
1115       --  freeze primitive operations if this is a tagged type.
1116
1117       ----------------------------
1118       -- After_Last_Declaration --
1119       ----------------------------
1120
1121       function After_Last_Declaration return Boolean is
1122          Spec  : Node_Id := Parent (Current_Scope);
1123
1124       begin
1125          if Nkind (Spec) = N_Package_Specification then
1126             if Present (Private_Declarations (Spec)) then
1127                return Loc >= Sloc (Last (Private_Declarations (Spec)));
1128
1129             elsif Present (Visible_Declarations (Spec)) then
1130                return Loc >= Sloc (Last (Visible_Declarations (Spec)));
1131             else
1132                return False;
1133             end if;
1134
1135          else
1136             return False;
1137          end if;
1138       end After_Last_Declaration;
1139
1140       ----------------------------
1141       -- Check_Current_Instance --
1142       ----------------------------
1143
1144       procedure Check_Current_Instance (Comp_Decl : Node_Id) is
1145
1146          function Process (N : Node_Id) return Traverse_Result;
1147          --  Process routine to apply check to given node.
1148
1149          function Process (N : Node_Id) return Traverse_Result is
1150          begin
1151             case Nkind (N) is
1152                when N_Attribute_Reference =>
1153                   if  (Attribute_Name (N) = Name_Access
1154                         or else
1155                       Attribute_Name (N) = Name_Unchecked_Access)
1156                     and then Is_Entity_Name (Prefix (N))
1157                     and then Is_Type (Entity (Prefix (N)))
1158                     and then Entity (Prefix (N)) = E
1159                   then
1160                      Error_Msg_N
1161                        ("current instance must be a limited type", Prefix (N));
1162                      return Abandon;
1163                   else
1164                      return OK;
1165                   end if;
1166
1167                when others => return OK;
1168             end case;
1169          end Process;
1170
1171          procedure Traverse is new Traverse_Proc (Process);
1172
1173       --  Start of processing for Check_Current_Instance
1174
1175       begin
1176          Traverse (Comp_Decl);
1177       end Check_Current_Instance;
1178
1179       ------------------------
1180       -- Freeze_Record_Type --
1181       ------------------------
1182
1183       procedure Freeze_Record_Type (Rec : Entity_Id) is
1184          Comp : Entity_Id;
1185          Junk : Boolean;
1186          ADC  : Node_Id;
1187
1188          Unplaced_Component : Boolean := False;
1189          --  Set True if we find at least one component with no component
1190          --  clause (used to warn about useless Pack pragmas).
1191
1192          Placed_Component : Boolean := False;
1193          --  Set True if we find at least one component with a component
1194          --  clause (used to warn about useless Bit_Order pragmas).
1195
1196       begin
1197          --  Freeze components and embedded subtypes
1198
1199          Comp := First_Entity (Rec);
1200
1201          while Present (Comp) loop
1202
1203             if not Is_Type (Comp) then
1204                Freeze_And_Append (Etype (Comp), Loc, Result);
1205             end if;
1206
1207             --  If the component is an access type with an allocator
1208             --  as default value, the designated type will be frozen
1209             --  by the corresponding expression in init_proc. In  order
1210             --  to place the freeze node for the designated type before
1211             --  that for the current record type, freeze it now.
1212
1213             --  Same process if the component is an array of access types,
1214             --  initialized with an aggregate. If the designated type is
1215             --  private, it cannot contain allocators, and it is premature
1216             --  to freeze the type, so we check for this as well.
1217
1218             if Is_Access_Type (Etype (Comp))
1219               and then Present (Parent (Comp))
1220               and then Present (Expression (Parent (Comp)))
1221               and then Nkind (Expression (Parent (Comp))) = N_Allocator
1222             then
1223                declare
1224                   Alloc : constant Node_Id := Expression (Parent (Comp));
1225
1226                begin
1227                   --  If component is pointer to a classwide type, freeze
1228                   --  the specific type in the expression being allocated.
1229                   --  The expression may be a subtype indication, in which
1230                   --  case freeze the subtype mark.
1231
1232                   if Is_Class_Wide_Type (Designated_Type (Etype (Comp))) then
1233
1234                      if Is_Entity_Name (Expression (Alloc)) then
1235                         Freeze_And_Append
1236                           (Entity (Expression (Alloc)), Loc, Result);
1237                      elsif
1238                        Nkind (Expression (Alloc)) = N_Subtype_Indication
1239                      then
1240                         Freeze_And_Append
1241                          (Entity (Subtype_Mark (Expression (Alloc))),
1242                            Loc, Result);
1243                      end if;
1244                   else
1245                      Freeze_And_Append
1246                        (Designated_Type (Etype (Comp)), Loc, Result);
1247                   end if;
1248                end;
1249
1250             --  If this is a constrained subtype of an already frozen type,
1251             --  make the subtype frozen as well. It might otherwise be frozen
1252             --  in the wrong scope, and a freeze node on subtype has no effect.
1253
1254             elsif Is_Access_Type (Etype (Comp))
1255               and then not Is_Frozen (Designated_Type (Etype (Comp)))
1256               and then Is_Itype (Designated_Type (Etype (Comp)))
1257               and then Is_Frozen (Base_Type (Designated_Type (Etype (Comp))))
1258             then
1259                Set_Is_Frozen (Designated_Type (Etype (Comp)));
1260
1261             elsif Is_Array_Type (Etype (Comp))
1262               and then Is_Access_Type (Component_Type (Etype (Comp)))
1263               and then Present (Parent (Comp))
1264               and then Nkind (Parent (Comp)) = N_Component_Declaration
1265               and then Present (Expression (Parent (Comp)))
1266               and then Nkind (Expression (Parent (Comp))) = N_Aggregate
1267               and then Is_Fully_Defined
1268                  (Designated_Type (Component_Type (Etype (Comp))))
1269             then
1270                Freeze_And_Append
1271                  (Designated_Type
1272                    (Component_Type (Etype (Comp))), Loc, Result);
1273             end if;
1274
1275             --  Processing for real components (exclude anonymous subtypes)
1276
1277             if Ekind (Comp) = E_Component
1278               or else Ekind (Comp) = E_Discriminant
1279             then
1280                --  Check for error of component clause given for variable
1281                --  sized type. We have to delay this test till this point,
1282                --  since the component type has to be frozen for us to know
1283                --  if it is variable length. We omit this test in a generic
1284                --  context, it will be applied at instantiation time.
1285
1286                declare
1287                   CC : constant Node_Id := Component_Clause (Comp);
1288
1289                begin
1290                   if Present (CC) then
1291                      Placed_Component := True;
1292
1293                      if Inside_A_Generic then
1294                         null;
1295
1296                      elsif not Size_Known_At_Compile_Time
1297                               (Underlying_Type (Etype (Comp)))
1298                      then
1299                         Error_Msg_N
1300                           ("component clause not allowed for variable " &
1301                            "length component", CC);
1302                      end if;
1303
1304                   else
1305                      Unplaced_Component := True;
1306                   end if;
1307                end;
1308
1309                --  If component clause is present, then deal with the
1310                --  non-default bit order case. We cannot do this before
1311                --  the freeze point, because there is no required order
1312                --  for the component clause and the bit_order clause.
1313
1314                --  We only do this processing for the base type, and in
1315                --  fact that's important, since otherwise if there are
1316                --  record subtypes, we could reverse the bits once for
1317                --  each subtype, which would be incorrect.
1318
1319                if Present (Component_Clause (Comp))
1320                  and then Reverse_Bit_Order (Rec)
1321                  and then Ekind (E) = E_Record_Type
1322                then
1323                   declare
1324                      CFB : constant Uint    := Component_Bit_Offset (Comp);
1325                      CSZ : constant Uint    := Esize (Comp);
1326                      CLC : constant Node_Id := Component_Clause (Comp);
1327                      Pos : constant Node_Id := Position (CLC);
1328                      FB  : constant Node_Id := First_Bit (CLC);
1329
1330                      Storage_Unit_Offset : constant Uint :=
1331                                              CFB / System_Storage_Unit;
1332
1333                      Start_Bit : constant Uint :=
1334                                    CFB mod System_Storage_Unit;
1335
1336                   begin
1337                      --  Cases where field goes over storage unit boundary
1338
1339                      if Start_Bit + CSZ > System_Storage_Unit then
1340
1341                         --  Allow multi-byte field but generate warning
1342
1343                         if Start_Bit mod System_Storage_Unit = 0
1344                           and then CSZ mod System_Storage_Unit = 0
1345                         then
1346                            Error_Msg_N
1347                              ("multi-byte field specified with non-standard"
1348                                 & " Bit_Order?", CLC);
1349
1350                            if Bytes_Big_Endian then
1351                               Error_Msg_N
1352                                 ("bytes are not reversed "
1353                                    & "(component is big-endian)?", CLC);
1354                            else
1355                               Error_Msg_N
1356                                 ("bytes are not reversed "
1357                                    & "(component is little-endian)?", CLC);
1358                            end if;
1359
1360                         --  Do not allow non-contiguous field
1361
1362                         else
1363                            Error_Msg_N
1364                              ("attempt to specify non-contiguous field"
1365                                 & " not permitted", CLC);
1366                            Error_Msg_N
1367                              ("\(caused by non-standard Bit_Order "
1368                                 & "specified)", CLC);
1369                         end if;
1370
1371                      --  Case where field fits in one storage unit
1372
1373                      else
1374                         --  Give warning if suspicious component clause
1375
1376                         if Intval (FB) >= System_Storage_Unit then
1377                            Error_Msg_N
1378                              ("?Bit_Order clause does not affect " &
1379                               "byte ordering", Pos);
1380                            Error_Msg_Uint_1 :=
1381                              Intval (Pos) + Intval (FB) / System_Storage_Unit;
1382                            Error_Msg_N
1383                              ("?position normalized to ^ before bit " &
1384                               "order interpreted", Pos);
1385                         end if;
1386
1387                         --  Here is where we fix up the Component_Bit_Offset
1388                         --  value to account for the reverse bit order.
1389                         --  Some examples of what needs to be done are:
1390
1391                         --    First_Bit .. Last_Bit     Component_Bit_Offset
1392                         --      old          new          old       new
1393
1394                         --     0 .. 0       7 .. 7         0         7
1395                         --     0 .. 1       6 .. 7         0         6
1396                         --     0 .. 2       5 .. 7         0         5
1397                         --     0 .. 7       0 .. 7         0         4
1398
1399                         --     1 .. 1       6 .. 6         1         6
1400                         --     1 .. 4       3 .. 6         1         3
1401                         --     4 .. 7       0 .. 3         4         0
1402
1403                         --  The general rule is that the first bit is
1404                         --  is obtained by subtracting the old ending bit
1405                         --  from storage_unit - 1.
1406
1407                         Set_Component_Bit_Offset (Comp,
1408                           (Storage_Unit_Offset * System_Storage_Unit)
1409                           + (System_Storage_Unit - 1)
1410                           - (Start_Bit + CSZ - 1));
1411
1412                         Set_Normalized_First_Bit (Comp,
1413                           Component_Bit_Offset (Comp) mod System_Storage_Unit);
1414                      end if;
1415                   end;
1416                end if;
1417             end if;
1418
1419             Next_Entity (Comp);
1420          end loop;
1421
1422          --  Check for useless pragma Bit_Order
1423
1424          if not Placed_Component and then Reverse_Bit_Order (Rec) then
1425             ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order);
1426             Error_Msg_N ("?Bit_Order specification has no effect", ADC);
1427             Error_Msg_N ("\?since no component clauses were specified", ADC);
1428          end if;
1429
1430          --  Check for useless pragma Pack when all components placed
1431
1432          if Is_Packed (Rec)
1433            and then not Unplaced_Component
1434            and then Warn_On_Redundant_Constructs
1435          then
1436             Error_Msg_N
1437               ("?pragma Pack has no effect, no unplaced components",
1438                Get_Rep_Pragma (Rec, Name_Pack));
1439             Set_Is_Packed (Rec, False);
1440          end if;
1441
1442          --  If this is the record corresponding to a remote type,
1443          --  freeze the remote type here since that is what we are
1444          --  semantically freeing.  This prevents having the freeze node
1445          --  for that type in an inner scope.
1446
1447          --  Also, Check for controlled components and unchecked unions.
1448          --  Finally, enforce the restriction that access attributes with
1449          --  a current instance prefix can only apply to limited types.
1450
1451          if  Ekind (Rec) = E_Record_Type then
1452
1453             if Present (Corresponding_Remote_Type (Rec)) then
1454                Freeze_And_Append
1455                  (Corresponding_Remote_Type (Rec), Loc, Result);
1456             end if;
1457
1458             Comp := First_Component (Rec);
1459
1460             while Present (Comp) loop
1461                if Has_Controlled_Component (Etype (Comp))
1462                  or else (Chars (Comp) /= Name_uParent
1463                            and then Is_Controlled (Etype (Comp)))
1464                  or else (Is_Protected_Type (Etype (Comp))
1465                            and then Present
1466                              (Corresponding_Record_Type (Etype (Comp)))
1467                            and then Has_Controlled_Component
1468                              (Corresponding_Record_Type (Etype (Comp))))
1469                then
1470                   Set_Has_Controlled_Component (Rec);
1471                   exit;
1472                end if;
1473
1474                if Has_Unchecked_Union (Etype (Comp)) then
1475                   Set_Has_Unchecked_Union (Rec);
1476                end if;
1477
1478                if Has_Per_Object_Constraint (Comp)
1479                  and then not Is_Limited_Type (Rec)
1480                then
1481                   --  Scan component declaration for likely misuses of
1482                   --  current instance, either in a constraint or in a
1483                   --  default expression.
1484
1485                   Check_Current_Instance (Parent (Comp));
1486                end if;
1487
1488                Next_Component (Comp);
1489             end loop;
1490          end if;
1491
1492          Set_Component_Alignment_If_Not_Set (Rec);
1493
1494          --  For first subtypes, check if there are any fixed-point
1495          --  fields with component clauses, where we must check the size.
1496          --  This is not done till the freeze point, since for fixed-point
1497          --  types, we do not know the size until the type is frozen.
1498
1499          if Is_First_Subtype (Rec) then
1500             Comp := First_Component (Rec);
1501
1502             while Present (Comp) loop
1503                if Present (Component_Clause (Comp))
1504                  and then Is_Fixed_Point_Type (Etype (Comp))
1505                then
1506                   Check_Size
1507                     (Component_Clause (Comp),
1508                      Etype (Comp),
1509                      Esize (Comp),
1510                      Junk);
1511                end if;
1512
1513                Next_Component (Comp);
1514             end loop;
1515          end if;
1516       end Freeze_Record_Type;
1517
1518    --  Start of processing for Freeze_Entity
1519
1520    begin
1521       --  Do not freeze if already frozen since we only need one freeze node.
1522
1523       if Is_Frozen (E) then
1524          return No_List;
1525
1526       --  It is improper to freeze an external entity within a generic
1527       --  because its freeze node will appear in a non-valid context.
1528       --  ??? We should probably freeze the entity at that point and insert
1529       --  the freeze node in a proper place but this proper place is not
1530       --  easy to find, and the proper scope is not easy to restore. For
1531       --  now, just wait to get out of the generic to freeze ???
1532
1533       elsif Inside_A_Generic and then External_Ref_In_Generic (E) then
1534          return No_List;
1535
1536       --  Do not freeze a global entity within an inner scope created during
1537       --  expansion. A call to subprogram E within some internal procedure
1538       --  (a stream attribute for example) might require freezing E, but the
1539       --  freeze node must appear in the same declarative part as E itself.
1540       --  The two-pass elaboration mechanism in gigi guarantees that E will
1541       --  be frozen before the inner call is elaborated. We exclude constants
1542       --  from this test, because deferred constants may be frozen early, and
1543       --  must be diagnosed (see e.g. 1522-005). If the enclosing subprogram
1544       --  comes from source, or is a generic instance, then the freeze point
1545       --  is the one mandated by the language. and we freze the entity.
1546
1547       elsif In_Open_Scopes (Scope (E))
1548         and then Scope (E) /= Current_Scope
1549         and then Ekind (E) /= E_Constant
1550       then
1551          declare
1552             S : Entity_Id := Current_Scope;
1553
1554          begin
1555             while Present (S) loop
1556                if Is_Overloadable (S) then
1557                   if Comes_From_Source (S)
1558                     or else Is_Generic_Instance (S)
1559                   then
1560                      exit;
1561                   else
1562                      return No_List;
1563                   end if;
1564                end if;
1565
1566                S := Scope (S);
1567             end loop;
1568          end;
1569       end if;
1570
1571       --  Here to freeze the entity
1572
1573       Result := No_List;
1574       Set_Is_Frozen (E);
1575
1576       --  Case of entity being frozen is other than a type
1577
1578       if not Is_Type (E) then
1579
1580          --  If entity is exported or imported and does not have an external
1581          --  name, now is the time to provide the appropriate default name.
1582          --  Skip this if the entity is stubbed, since we don't need a name
1583          --  for any stubbed routine.
1584
1585          if (Is_Imported (E) or else Is_Exported (E))
1586            and then No (Interface_Name (E))
1587            and then Convention (E) /= Convention_Stubbed
1588          then
1589             Set_Encoded_Interface_Name
1590               (E, Get_Default_External_Name (E));
1591          end if;
1592
1593          --  For a subprogram, freeze all parameter types and also the return
1594          --  type (RM 13.14(13)). However skip this for internal subprograms.
1595          --  This is also the point where any extra formal parameters are
1596          --  created since we now know whether the subprogram will use
1597          --  a foreign convention.
1598
1599          if Is_Subprogram (E) then
1600
1601             if not Is_Internal (E) then
1602
1603                declare
1604                   F_Type : Entity_Id;
1605
1606                   function Is_Fat_C_Ptr_Type (T : Entity_Id) return Boolean;
1607                   --  Determines if given type entity is a fat pointer type
1608                   --  used as an argument type or return type to a subprogram
1609                   --  with C or C++ convention set.
1610
1611                   --------------------------
1612                   -- Is_Fat_C_Access_Type --
1613                   --------------------------
1614
1615                   function Is_Fat_C_Ptr_Type (T : Entity_Id) return Boolean is
1616                   begin
1617                      return (Convention (E) = Convention_C
1618                                or else
1619                              Convention (E) = Convention_CPP)
1620                        and then Is_Access_Type (T)
1621                        and then Esize (T) > Ttypes.System_Address_Size;
1622                   end Is_Fat_C_Ptr_Type;
1623
1624                begin
1625                   --  Loop through formals
1626
1627                   Formal := First_Formal (E);
1628
1629                   while Present (Formal) loop
1630
1631                      F_Type := Etype (Formal);
1632                      Freeze_And_Append (F_Type, Loc, Result);
1633
1634                      if Is_Private_Type (F_Type)
1635                        and then Is_Private_Type (Base_Type (F_Type))
1636                        and then No (Full_View (Base_Type (F_Type)))
1637                        and then not Is_Generic_Type (F_Type)
1638                        and then not Is_Derived_Type (F_Type)
1639                      then
1640                         --  If the type of a formal is incomplete, subprogram
1641                         --  is being frozen prematurely. Within an instance
1642                         --  (but not within a wrapper package) this is an
1643                         --  an artifact of our need to regard the end of an
1644                         --  instantiation as a freeze point. Otherwise it is
1645                         --  a definite error.
1646                         --  and then not Is_Wrapper_Package (Current_Scope) ???
1647
1648                         if In_Instance then
1649                            Set_Is_Frozen (E, False);
1650                            return No_List;
1651
1652                         elsif not After_Last_Declaration then
1653                            Error_Msg_Node_1 := F_Type;
1654                            Error_Msg
1655                              ("type& must be fully defined before this point",
1656                                Loc);
1657                         end if;
1658                      end if;
1659
1660                      --  Check bad use of fat C pointer
1661
1662                      if Is_Fat_C_Ptr_Type (F_Type) then
1663                         Error_Msg_Qual_Level := 1;
1664                         Error_Msg_N
1665                            ("?type of & does not correspond to C pointer",
1666                             Formal);
1667                         Error_Msg_Qual_Level := 0;
1668                      end if;
1669
1670                      --  Check for unconstrained array in exported foreign
1671                      --  convention case.
1672
1673                      if Convention (E) in Foreign_Convention
1674                        and then not Is_Imported (E)
1675                        and then Is_Array_Type (F_Type)
1676                        and then not Is_Constrained (F_Type)
1677                      then
1678                         Error_Msg_Qual_Level := 1;
1679                         Error_Msg_N
1680                           ("?type of argument& is unconstrained array",
1681                            Formal);
1682                         Error_Msg_N
1683                           ("?foreign caller must pass bounds explicitly",
1684                            Formal);
1685                         Error_Msg_Qual_Level := 0;
1686                      end if;
1687
1688                      Next_Formal (Formal);
1689                   end loop;
1690
1691                   --  Check return type
1692
1693                   if Ekind (E) = E_Function then
1694                      Freeze_And_Append (Etype (E), Loc, Result);
1695
1696                      if Is_Fat_C_Ptr_Type (Etype (E)) then
1697                         Error_Msg_N
1698                           ("?return type of& does not correspond to C pointer",
1699                            E);
1700
1701                      elsif Is_Array_Type (Etype (E))
1702                        and then not Is_Constrained (Etype (E))
1703                        and then not Is_Imported (E)
1704                        and then Convention (E) in Foreign_Convention
1705                      then
1706                         Error_Msg_N
1707                           ("foreign convention function may not " &
1708                            "return unconstrained array", E);
1709                      end if;
1710                   end if;
1711                end;
1712             end if;
1713
1714             --  Must freeze its parent first if it is a derived subprogram
1715
1716             if Present (Alias (E)) then
1717                Freeze_And_Append (Alias (E), Loc, Result);
1718             end if;
1719
1720             --  If the return type requires a transient scope, and we are on
1721             --  a target allowing functions to return with a depressed stack
1722             --  pointer, then we mark the function as requiring this treatment.
1723
1724             if Ekind (E) = E_Function
1725               and then Functions_Return_By_DSP_On_Target
1726               and then Requires_Transient_Scope (Etype (E))
1727             then
1728                Set_Function_Returns_With_DSP (E);
1729             end if;
1730
1731             if not Is_Internal (E) then
1732                Freeze_Subprogram (E);
1733             end if;
1734
1735          --  Here for other than a subprogram or type
1736
1737          else
1738             --  If entity has a type, and it is not a generic unit, then
1739             --  freeze it first (RM 13.14(10))
1740
1741             if Present (Etype (E))
1742               and then Ekind (E) /= E_Generic_Function
1743             then
1744                Freeze_And_Append (Etype (E), Loc, Result);
1745             end if;
1746
1747             --  For object created by object declaration, perform required
1748             --  categorization (preelaborate and pure) checks. Defer these
1749             --  checks to freeze time since pragma Import inhibits default
1750             --  initialization and thus pragma Import affects these checks.
1751
1752             if Nkind (Declaration_Node (E)) = N_Object_Declaration then
1753                Validate_Object_Declaration (Declaration_Node (E));
1754             end if;
1755
1756             --  Check that a constant which has a pragma Volatile[_Components]
1757             --  or Atomic[_Components] also has a pragma Import (RM C.6(13))
1758
1759             --  Note: Atomic[_Components] also sets Volatile[_Components]
1760
1761             if Ekind (E) = E_Constant
1762               and then (Has_Volatile_Components (E) or else Is_Volatile (E))
1763               and then not Is_Imported (E)
1764             then
1765                --  Make sure we actually have a pragma, and have not merely
1766                --  inherited the indication from elsewhere (e.g. an address
1767                --  clause, which is not good enough in RM terms!)
1768
1769                if Present (Get_Rep_Pragma (E, Name_Atomic))            or else
1770                   Present (Get_Rep_Pragma (E, Name_Atomic_Components)) or else
1771                   Present (Get_Rep_Pragma (E, Name_Volatile))          or else
1772                   Present (Get_Rep_Pragma (E, Name_Volatile_Components))
1773                then
1774                   Error_Msg_N
1775                     ("stand alone atomic/volatile constant must be imported",
1776                      E);
1777                end if;
1778             end if;
1779
1780             --  Static objects require special handling
1781
1782             if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
1783               and then Is_Statically_Allocated (E)
1784             then
1785                Freeze_Static_Object (E);
1786             end if;
1787
1788             --  Remaining step is to layout objects
1789
1790             if Ekind (E) = E_Variable
1791                  or else
1792                Ekind (E) = E_Constant
1793                  or else
1794                Ekind (E) = E_Loop_Parameter
1795                  or else
1796                Is_Formal (E)
1797             then
1798                Layout_Object (E);
1799             end if;
1800          end if;
1801
1802       --  Case of a type or subtype being frozen
1803
1804       else
1805          --  The type may be defined in a generic unit. This can occur when
1806          --  freezing a generic function that returns the type (which is
1807          --  defined in a parent unit). It is clearly meaningless to freeze
1808          --  this type. However, if it is a subtype, its size may be determi-
1809          --  nable and used in subsequent checks, so might as well try to
1810          --  compute it.
1811
1812          if Present (Scope (E))
1813            and then Is_Generic_Unit (Scope (E))
1814          then
1815             Check_Compile_Time_Size (E);
1816             return No_List;
1817          end if;
1818
1819          --  Deal with special cases of freezing for subtype
1820
1821          if E /= Base_Type (E) then
1822
1823             --  If ancestor subtype present, freeze that first.
1824             --  Note that this will also get the base type frozen.
1825
1826             Atype := Ancestor_Subtype (E);
1827
1828             if Present (Atype) then
1829                Freeze_And_Append (Atype, Loc, Result);
1830
1831             --  Otherwise freeze the base type of the entity before
1832             --  freezing the entity itself, (RM 13.14(14)).
1833
1834             elsif E /= Base_Type (E) then
1835                Freeze_And_Append (Base_Type (E), Loc, Result);
1836             end if;
1837
1838          --  For a derived type, freeze its parent type first (RM 13.14(14))
1839
1840          elsif Is_Derived_Type (E) then
1841             Freeze_And_Append (Etype (E), Loc, Result);
1842             Freeze_And_Append (First_Subtype (Etype (E)), Loc, Result);
1843          end if;
1844
1845          --  For array type, freeze index types and component type first
1846          --  before freezing the array (RM 13.14(14)).
1847
1848          if Is_Array_Type (E) then
1849             declare
1850                Ctyp  : constant Entity_Id := Component_Type (E);
1851
1852                Non_Standard_Enum : Boolean := False;
1853                --  Set true if any of the index types is an enumeration
1854                --  type with a non-standard representation.
1855
1856             begin
1857                Freeze_And_Append (Ctyp, Loc, Result);
1858
1859                Indx := First_Index (E);
1860                while Present (Indx) loop
1861                   Freeze_And_Append (Etype (Indx), Loc, Result);
1862
1863                   if Is_Enumeration_Type (Etype (Indx))
1864                     and then Has_Non_Standard_Rep (Etype (Indx))
1865                   then
1866                      Non_Standard_Enum := True;
1867                   end if;
1868
1869                   Next_Index (Indx);
1870                end loop;
1871
1872                --  Processing that is done only for base types
1873
1874                if Ekind (E) = E_Array_Type then
1875
1876                   --  Propagate flags for component type
1877
1878                   if Is_Controlled (Component_Type (E))
1879                     or else Has_Controlled_Component (Ctyp)
1880                   then
1881                      Set_Has_Controlled_Component (E);
1882                   end if;
1883
1884                   if Has_Unchecked_Union (Component_Type (E)) then
1885                      Set_Has_Unchecked_Union (E);
1886                   end if;
1887
1888                   --  If packing was requested or if the component size was set
1889                   --  explicitly, then see if bit packing is required. This
1890                   --  processing is only done for base types, since all the
1891                   --  representation aspects involved are type-related. This
1892                   --  is not just an optimization, if we start processing the
1893                   --  subtypes, they intefere with the settings on the base
1894                   --  type (this is because Is_Packed has a slightly different
1895                   --  meaning before and after freezing).
1896
1897                   declare
1898                      Csiz : Uint;
1899                      Esiz : Uint;
1900
1901                   begin
1902                      if (Is_Packed (E) or else Has_Pragma_Pack (E))
1903                        and then not Has_Atomic_Components (E)
1904                        and then Known_Static_RM_Size (Ctyp)
1905                      then
1906                         Csiz := UI_Max (RM_Size (Ctyp), 1);
1907
1908                      elsif Known_Component_Size (E) then
1909                         Csiz := Component_Size (E);
1910
1911                      elsif not Known_Static_Esize (Ctyp) then
1912                         Csiz := Uint_0;
1913
1914                      else
1915                         Esiz := Esize (Ctyp);
1916
1917                         --  We can set the component size if it is less than
1918                         --  16, rounding it up to the next storage unit size.
1919
1920                         if Esiz <= 8 then
1921                            Csiz := Uint_8;
1922                         elsif Esiz <= 16 then
1923                            Csiz := Uint_16;
1924                         else
1925                            Csiz := Uint_0;
1926                         end if;
1927
1928                         --  Set component size up to match alignment if
1929                         --  it would otherwise be less than the alignment.
1930                         --  This deals with cases of types whose alignment
1931                         --  exceeds their sizes (padded types).
1932
1933                         if Csiz /= 0 then
1934                            declare
1935                               A : constant Uint := Alignment_In_Bits (Ctyp);
1936
1937                            begin
1938                               if Csiz < A then
1939                                  Csiz := A;
1940                               end if;
1941                            end;
1942                         end if;
1943
1944                      end if;
1945
1946                      if 1 <= Csiz and then Csiz <= 64 then
1947
1948                         --  We set the component size for all cases 1-64
1949
1950                         Set_Component_Size (Base_Type (E), Csiz);
1951
1952                         --  Actual packing is not needed for 8,16,32,64
1953                         --  Also not needed for 24 if alignment is 1
1954
1955                         if        Csiz = 8
1956                           or else Csiz = 16
1957                           or else Csiz = 32
1958                           or else Csiz = 64
1959                           or else (Csiz = 24 and then Alignment (Ctyp) = 1)
1960                         then
1961                            --  Here the array was requested to be packed, but
1962                            --  the packing request had no effect, so Is_Packed
1963                            --  is reset.
1964
1965                            --  Note: semantically this means that we lose
1966                            --  track of the fact that a derived type inherited
1967                            --  a pack pragma that was non-effective, but that
1968                            --  seems fine.
1969
1970                            --  We regard a Pack pragma as a request to set a
1971                            --  representation characteristic, and this request
1972                            --  may be ignored.
1973
1974                            Set_Is_Packed (Base_Type (E), False);
1975
1976                         --  In all other cases, packing is indeed needed
1977
1978                         else
1979                            Set_Has_Non_Standard_Rep (Base_Type (E));
1980                            Set_Is_Bit_Packed_Array  (Base_Type (E));
1981                            Set_Is_Packed            (Base_Type (E));
1982                         end if;
1983                      end if;
1984                   end;
1985
1986                --  Processing that is done only for subtypes
1987
1988                else
1989                   --  Acquire alignment from base type
1990
1991                   if Unknown_Alignment (E) then
1992                      Set_Alignment (E, Alignment (Base_Type (E)));
1993                   end if;
1994                end if;
1995
1996                --  Check one common case of a size given where the array
1997                --  needs to be packed, but was not so the size cannot be
1998                --  honored. This would of course be caught by the backend,
1999                --  and indeed we don't catch all cases. The point is that
2000                --  we can give a better error message in those cases that
2001                --  we do catch with the circuitry here.
2002
2003                if Present (Size_Clause (E))
2004                  and then Known_Static_Esize (E)
2005                  and then not Has_Pragma_Pack (E)
2006                  and then Number_Dimensions (E) = 1
2007                  and then not Has_Component_Size_Clause (E)
2008                  and then Known_Static_Component_Size (E)
2009                then
2010                   declare
2011                      Lo, Hi : Node_Id;
2012                      Ctyp   : constant Entity_Id := Component_Type (E);
2013
2014                   begin
2015                      Get_Index_Bounds (First_Index (E), Lo, Hi);
2016
2017                      if Compile_Time_Known_Value (Lo)
2018                        and then Compile_Time_Known_Value (Hi)
2019                        and then Known_Static_RM_Size (Ctyp)
2020                        and then RM_Size (Ctyp) < 64
2021                      then
2022                         declare
2023                            Lov : constant Uint := Expr_Value (Lo);
2024                            Hiv : constant Uint := Expr_Value (Hi);
2025                            Len : constant Uint :=
2026                                    UI_Max (Uint_0, Hiv - Lov + 1);
2027
2028                         begin
2029                            if Esize (E) < Len * Component_Size (E)
2030                              and then Esize (E) = Len * RM_Size (Ctyp)
2031                            then
2032                               Error_Msg_NE
2033                                 ("size given for& too small",
2034                                    Size_Clause (E), E);
2035                               Error_Msg_N
2036                                 ("\explicit pragma Pack is required",
2037                                    Size_Clause (E));
2038                            end if;
2039                         end;
2040                      end if;
2041                   end;
2042                end if;
2043
2044                --  If any of the index types was an enumeration type with
2045                --  a non-standard rep clause, then we indicate that the
2046                --  array type is always packed (even if it is not bit packed).
2047
2048                if Non_Standard_Enum then
2049                   Set_Has_Non_Standard_Rep (Base_Type (E));
2050                   Set_Is_Packed            (Base_Type (E));
2051                end if;
2052             end;
2053
2054             Set_Component_Alignment_If_Not_Set (E);
2055
2056             --  If the array is packed, we must create the packed array
2057             --  type to be used to actually implement the type. This is
2058             --  only needed for real array types (not for string literal
2059             --  types, since they are present only for the front end).
2060
2061             if Is_Packed (E)
2062               and then Ekind (E) /= E_String_Literal_Subtype
2063             then
2064                Create_Packed_Array_Type (E);
2065                Freeze_And_Append (Packed_Array_Type (E), Loc, Result);
2066
2067                --  Size information of packed array type is copied to the
2068                --  array type, since this is really the representation.
2069
2070                Set_Size_Info (E, Packed_Array_Type (E));
2071                Set_RM_Size   (E, RM_Size (Packed_Array_Type (E)));
2072             end if;
2073
2074          --  For a class wide type, the corresponding specific type is
2075          --  frozen as well (RM 13.14(14))
2076
2077          elsif Is_Class_Wide_Type (E) then
2078             Freeze_And_Append (Root_Type (E), Loc, Result);
2079
2080             --  If the Class_Wide_Type is an Itype (when type is the anonymous
2081             --  parent of a derived type) and it is a library-level entity,
2082             --  generate an itype reference for it. Otherwise, its first
2083             --  explicit reference may be in an inner scope, which will be
2084             --  rejected by the back-end.
2085
2086             if Is_Itype (E)
2087               and then Is_Compilation_Unit (Scope (E))
2088             then
2089
2090                declare
2091                   Ref : Node_Id := Make_Itype_Reference (Loc);
2092
2093                begin
2094                   Set_Itype (Ref, E);
2095                   if No (Result) then
2096                      Result := New_List (Ref);
2097                   else
2098                      Append (Ref, Result);
2099                   end if;
2100                end;
2101             end if;
2102
2103          --  For record (sub)type, freeze all the component types (RM
2104          --  13.14(14). We test for E_Record_(sub)Type here, rather than
2105          --  using Is_Record_Type, because we don't want to attempt the
2106          --  freeze for the case of a private type with record extension
2107          --  (we will do that later when the full type is frozen).
2108
2109          elsif Ekind (E) = E_Record_Type
2110            or else  Ekind (E) = E_Record_Subtype
2111          then
2112             Freeze_Record_Type (E);
2113
2114          --  For a concurrent type, freeze corresponding record type. This
2115          --  does not correpond to any specific rule in the RM, but the
2116          --  record type is essentially part of the concurrent type.
2117          --  Freeze as well all local entities. This includes record types
2118          --  created for entry parameter blocks, and whatever local entities
2119          --  may appear in the private part.
2120
2121          elsif Is_Concurrent_Type (E) then
2122             if Present (Corresponding_Record_Type (E)) then
2123                Freeze_And_Append
2124                  (Corresponding_Record_Type (E), Loc, Result);
2125             end if;
2126
2127             Comp := First_Entity (E);
2128
2129             while Present (Comp) loop
2130                if Is_Type (Comp) then
2131                   Freeze_And_Append (Comp, Loc, Result);
2132
2133                elsif (Ekind (Comp)) /= E_Function then
2134                   Freeze_And_Append (Etype (Comp), Loc, Result);
2135                end if;
2136
2137                Next_Entity (Comp);
2138             end loop;
2139
2140          --  Private types are required to point to the same freeze node
2141          --  as their corresponding full views. The freeze node itself
2142          --  has to point to the partial view of the entity (because
2143          --  from the partial view, we can retrieve the full view, but
2144          --  not the reverse). However, in order to freeze correctly,
2145          --  we need to freeze the full view. If we are freezing at the
2146          --  end of a scope (or within the scope of the private type),
2147          --  the partial and full views will have been swapped, the
2148          --  full view appears first in the entity chain and the swapping
2149          --  mechanism enusres that the pointers are properly set (on
2150          --  scope exit).
2151
2152          --  If we encounter the partial view before the full view
2153          --  (e.g. when freezing from another scope), we freeze the
2154          --  full view, and then set the pointers appropriately since
2155          --  we cannot rely on swapping to fix things up (subtypes in an
2156          --  outer scope might not get swapped).
2157
2158          elsif Is_Incomplete_Or_Private_Type (E)
2159            and then not Is_Generic_Type (E)
2160          then
2161             --  Case of full view present
2162
2163             if Present (Full_View (E)) then
2164
2165                --  If full view has already been frozen, then no
2166                --  further processing is required
2167
2168                if Is_Frozen (Full_View (E)) then
2169
2170                   Set_Has_Delayed_Freeze (E, False);
2171                   Set_Freeze_Node (E, Empty);
2172                   Check_Debug_Info_Needed (E);
2173
2174                --  Otherwise freeze full view and patch the pointers
2175
2176                else
2177                   if Is_Private_Type (Full_View (E))
2178                     and then Present (Underlying_Full_View (Full_View (E)))
2179                   then
2180                      Freeze_And_Append
2181                        (Underlying_Full_View (Full_View (E)), Loc, Result);
2182                   end if;
2183
2184                   Freeze_And_Append (Full_View (E), Loc, Result);
2185
2186                   if Has_Delayed_Freeze (E) then
2187                      F_Node := Freeze_Node (Full_View (E));
2188
2189                      if Present (F_Node) then
2190                         Set_Freeze_Node (E, F_Node);
2191                         Set_Entity (F_Node, E);
2192                      else
2193                         --  {Incomplete,Private}_Subtypes
2194                         --  with Full_Views constrained by discriminants
2195
2196                         Set_Has_Delayed_Freeze (E, False);
2197                         Set_Freeze_Node (E, Empty);
2198                      end if;
2199                   end if;
2200
2201                   Check_Debug_Info_Needed (E);
2202                end if;
2203
2204                --  AI-117 requires that the convention of a partial view
2205                --  be the same as the convention of the full view. Note
2206                --  that this is a recognized breach of privacy, but it's
2207                --  essential for logical consistency of representation,
2208                --  and the lack of a rule in RM95 was an oversight.
2209
2210                Set_Convention (E, Convention (Full_View (E)));
2211
2212                Set_Size_Known_At_Compile_Time (E,
2213                  Size_Known_At_Compile_Time (Full_View (E)));
2214
2215                --  Size information is copied from the full view to the
2216                --  incomplete or private view for consistency
2217
2218                --  We skip this is the full view is not a type. This is
2219                --  very strange of course, and can only happen as a result
2220                --  of certain illegalities, such as a premature attempt to
2221                --  derive from an incomplete type.
2222
2223                if Is_Type (Full_View (E)) then
2224                   Set_Size_Info (E, Full_View (E));
2225                   Set_RM_Size   (E, RM_Size (Full_View (E)));
2226                end if;
2227
2228                return Result;
2229
2230             --  Case of no full view present. If entity is derived or subtype,
2231             --  it is safe to freeze, correctness depends on the frozen status
2232             --  of parent. Otherwise it is either premature usage, or a Taft
2233             --  amendment type, so diagnosis is at the point of use and the
2234             --  type might be frozen later.
2235
2236             elsif E /= Base_Type (E)
2237               or else Is_Derived_Type (E)
2238             then
2239                null;
2240
2241             else
2242                Set_Is_Frozen (E, False);
2243                return No_List;
2244             end if;
2245
2246          --  For access subprogram, freeze types of all formals, the return
2247          --  type was already frozen, since it is the Etype of the function.
2248
2249          elsif Ekind (E) = E_Subprogram_Type then
2250             Formal := First_Formal (E);
2251             while Present (Formal) loop
2252                Freeze_And_Append (Etype (Formal), Loc, Result);
2253                Next_Formal (Formal);
2254             end loop;
2255
2256             --  If the return type requires a transient scope, and we are on
2257             --  a target allowing functions to return with a depressed stack
2258             --  pointer, then we mark the function as requiring this treatment.
2259
2260             if Functions_Return_By_DSP_On_Target
2261               and then Requires_Transient_Scope (Etype (E))
2262             then
2263                Set_Function_Returns_With_DSP (E);
2264             end if;
2265
2266             Freeze_Subprogram (E);
2267
2268          --  For access to a protected subprogram, freeze the equivalent
2269          --  type (however this is not set if we are not generating code)
2270          --  or if this is an anonymous type used just for resolution).
2271
2272          elsif Ekind (E) = E_Access_Protected_Subprogram_Type
2273            and then Operating_Mode = Generate_Code
2274            and then Present (Equivalent_Type (E))
2275          then
2276             Freeze_And_Append (Equivalent_Type (E), Loc, Result);
2277          end if;
2278
2279          --  Generic types are never seen by the back-end, and are also not
2280          --  processed by the expander (since the expander is turned off for
2281          --  generic processing), so we never need freeze nodes for them.
2282
2283          if Is_Generic_Type (E) then
2284             return Result;
2285          end if;
2286
2287          --  Some special processing for non-generic types to complete
2288          --  representation details not known till the freeze point.
2289
2290          if Is_Fixed_Point_Type (E) then
2291             Freeze_Fixed_Point_Type (E);
2292
2293          elsif Is_Enumeration_Type (E) then
2294             Freeze_Enumeration_Type (E);
2295
2296          elsif Is_Integer_Type (E) then
2297             Adjust_Esize_For_Alignment (E);
2298
2299          elsif Is_Access_Type (E)
2300            and then No (Associated_Storage_Pool (E))
2301          then
2302             Check_Restriction (No_Standard_Storage_Pools, E);
2303          end if;
2304
2305          --  If the current entity is an array or record subtype and has
2306          --  discriminants used to constrain it, it must not freeze, because
2307          --  Freeze_Entity nodes force Gigi to process the frozen type.
2308
2309          if Is_Composite_Type (E) then
2310
2311             if Is_Array_Type (E) then
2312
2313                declare
2314                   Index : Node_Id := First_Index (E);
2315                   Expr1 : Node_Id;
2316                   Expr2 : Node_Id;
2317
2318                begin
2319                   while Present (Index) loop
2320                      if Etype (Index) /= Any_Type then
2321                         Get_Index_Bounds (Index, Expr1, Expr2);
2322
2323                         for J in 1 .. 2 loop
2324                            if Nkind (Expr1) = N_Identifier
2325                              and then Ekind (Entity (Expr1)) = E_Discriminant
2326                            then
2327                               Set_Has_Delayed_Freeze (E, False);
2328                               Set_Freeze_Node (E, Empty);
2329                               Check_Debug_Info_Needed (E);
2330                               return Result;
2331                            end if;
2332
2333                            Expr1 := Expr2;
2334                         end loop;
2335                      end if;
2336
2337                      Next_Index (Index);
2338                   end loop;
2339                end;
2340
2341             elsif Has_Discriminants (E)
2342               and Is_Constrained (E)
2343             then
2344                declare
2345                   Constraint : Elmt_Id;
2346                   Expr       : Node_Id;
2347
2348                begin
2349                   Constraint := First_Elmt (Discriminant_Constraint (E));
2350
2351                   while Present (Constraint) loop
2352
2353                      Expr := Node (Constraint);
2354                      if Nkind (Expr) = N_Identifier
2355                        and then Ekind (Entity (Expr)) = E_Discriminant
2356                      then
2357                         Set_Has_Delayed_Freeze (E, False);
2358                         Set_Freeze_Node (E, Empty);
2359                         Check_Debug_Info_Needed (E);
2360                         return Result;
2361                      end if;
2362
2363                      Next_Elmt (Constraint);
2364                   end loop;
2365                end;
2366
2367             end if;
2368
2369             --  AI-117 requires that all new primitives of a tagged type
2370             --  must inherit the convention of the full view of the type.
2371             --  Inherited and overriding operations are defined to inherit
2372             --  the convention of their parent or overridden subprogram
2373             --  (also specified in AI-117), and that will have occurred
2374             --  earlier (in Derive_Subprogram and New_Overloaded_Entity).
2375             --  Here we set the convention of primitives that are still
2376             --  convention Ada, which will ensure that any new primitives
2377             --  inherit the type's convention. Class-wide types can have
2378             --  a foreign convention inherited from their specific type,
2379             --  but are excluded from this since they don't have any
2380             --  associated primitives.
2381
2382             if Is_Tagged_Type (E)
2383               and then not Is_Class_Wide_Type (E)
2384               and then Convention (E) /= Convention_Ada
2385             then
2386                declare
2387                   Prim_List : constant Elist_Id := Primitive_Operations (E);
2388                   Prim      : Elmt_Id;
2389
2390                begin
2391                   Prim := First_Elmt (Prim_List);
2392                   while Present (Prim) loop
2393                      if Convention (Node (Prim)) = Convention_Ada then
2394                         Set_Convention (Node (Prim), Convention (E));
2395                      end if;
2396
2397                      Next_Elmt (Prim);
2398                   end loop;
2399                end;
2400             end if;
2401          end if;
2402
2403          --  Generate primitive operation references for a tagged type
2404
2405          if Is_Tagged_Type (E)
2406            and then not Is_Class_Wide_Type (E)
2407          then
2408             declare
2409                Prim_List : constant Elist_Id := Primitive_Operations (E);
2410                Prim      : Elmt_Id;
2411                Ent       : Entity_Id;
2412
2413             begin
2414                Prim := First_Elmt (Prim_List);
2415                while Present (Prim) loop
2416                   Ent := Node (Prim);
2417
2418                   --  If the operation is derived, get the original for
2419                   --  cross-reference purposes (it is the original for
2420                   --  which we want the xref, and for which the comes
2421                   --  from source test needs to be performed).
2422
2423                   while Present (Alias (Ent)) loop
2424                      Ent := Alias (Ent);
2425                   end loop;
2426
2427                   Generate_Reference (E, Ent, 'p', Set_Ref => False);
2428                   Next_Elmt (Prim);
2429                end loop;
2430
2431             --  If we get an exception, then something peculiar has happened
2432             --  probably as a result of a previous error. Since this is only
2433             --  for non-critical cross-references, ignore the error.
2434
2435             exception
2436                when others => null;
2437             end;
2438          end if;
2439
2440          --  Now that all types from which E may depend are frozen, see
2441          --  if the size is known at compile time, if it must be unsigned,
2442          --  or if strict alignent is required
2443
2444          Check_Compile_Time_Size (E);
2445          Check_Unsigned_Type (E);
2446
2447          if Base_Type (E) = E then
2448             Check_Strict_Alignment (E);
2449          end if;
2450
2451          --  Do not allow a size clause for a type which does not have a size
2452          --  that is known at compile time
2453
2454          if Has_Size_Clause (E)
2455            and then not Size_Known_At_Compile_Time (E)
2456          then
2457             --  Supress this message if errors posted on E, even if we are
2458             --  in all errors mode, since this is often a junk message
2459
2460             if not Error_Posted (E) then
2461                Error_Msg_N
2462                  ("size clause not allowed for variable length type",
2463                   Size_Clause (E));
2464             end if;
2465          end if;
2466
2467          --  Remaining process is to set/verify the representation information,
2468          --  in particular the size and alignment values. This processing is
2469          --  not required for generic types, since generic types do not play
2470          --  any part in code generation, and so the size and alignment values
2471          --  for suhc types are irrelevant.
2472
2473          if Is_Generic_Type (E) then
2474             return Result;
2475
2476          --  Otherwise we call the layout procedure
2477
2478          else
2479             Layout_Type (E);
2480          end if;
2481
2482          --  End of freeze processing for type entities
2483       end if;
2484
2485       --  Here is where we logically freeze the current entity. If it has a
2486       --  freeze node, then this is the point at which the freeze node is
2487       --  linked into the result list.
2488
2489       if Has_Delayed_Freeze (E) then
2490
2491          --  If a freeze node is already allocated, use it, otherwise allocate
2492          --  a new one. The preallocation happens in the case of anonymous base
2493          --  types, where we preallocate so that we can set First_Subtype_Link.
2494          --  Note that we reset the Sloc to the current freeze location.
2495
2496          if Present (Freeze_Node (E)) then
2497             F_Node := Freeze_Node (E);
2498             Set_Sloc (F_Node, Loc);
2499
2500          else
2501             F_Node := New_Node (N_Freeze_Entity, Loc);
2502             Set_Freeze_Node (E, F_Node);
2503             Set_Access_Types_To_Process (F_Node, No_Elist);
2504             Set_TSS_Elist (F_Node, No_Elist);
2505             Set_Actions (F_Node, No_List);
2506          end if;
2507
2508          Set_Entity (F_Node, E);
2509
2510          if Result = No_List then
2511             Result := New_List (F_Node);
2512          else
2513             Append (F_Node, Result);
2514          end if;
2515
2516       end if;
2517
2518       --  When a type is frozen, the first subtype of the type is frozen as
2519       --  well (RM 13.14(15)). This has to be done after freezing the type,
2520       --  since obviously the first subtype depends on its own base type.
2521
2522       if Is_Type (E) then
2523          Freeze_And_Append (First_Subtype (E), Loc, Result);
2524
2525          --  If we just froze a tagged non-class wide record, then freeze the
2526          --  corresponding class-wide type. This must be done after the tagged
2527          --  type itself is frozen, because the class-wide type refers to the
2528          --  tagged type which generates the class.
2529
2530          if Is_Tagged_Type (E)
2531            and then not Is_Class_Wide_Type (E)
2532            and then Present (Class_Wide_Type (E))
2533          then
2534             Freeze_And_Append (Class_Wide_Type (E), Loc, Result);
2535          end if;
2536       end if;
2537
2538       Check_Debug_Info_Needed (E);
2539
2540       --  Special handling for subprograms
2541
2542       if Is_Subprogram (E) then
2543
2544          --  If subprogram has address clause then reset Is_Public flag, since
2545          --  we do not want the backend to generate external references.
2546
2547          if Present (Address_Clause (E))
2548            and then not Is_Library_Level_Entity (E)
2549          then
2550             Set_Is_Public (E, False);
2551
2552          --  If no address clause and not intrinsic, then for imported
2553          --  subprogram in main unit, generate descriptor if we are in
2554          --  Propagate_Exceptions mode.
2555
2556          elsif Propagate_Exceptions
2557            and then Is_Imported (E)
2558            and then not Is_Intrinsic_Subprogram (E)
2559            and then Convention (E) /= Convention_Stubbed
2560          then
2561             if Result = No_List then
2562                Result := Empty_List;
2563             end if;
2564
2565             Generate_Subprogram_Descriptor_For_Imported_Subprogram
2566               (E, Result);
2567          end if;
2568
2569       end if;
2570
2571       return Result;
2572    end Freeze_Entity;
2573
2574    -----------------------------
2575    -- Freeze_Enumeration_Type --
2576    -----------------------------
2577
2578    procedure Freeze_Enumeration_Type (Typ : Entity_Id) is
2579    begin
2580       if Has_Foreign_Convention (Typ)
2581         and then not Has_Size_Clause (Typ)
2582         and then Esize (Typ) < Standard_Integer_Size
2583       then
2584          Init_Esize (Typ, Standard_Integer_Size);
2585
2586       else
2587          Adjust_Esize_For_Alignment (Typ);
2588       end if;
2589    end Freeze_Enumeration_Type;
2590
2591    -----------------------
2592    -- Freeze_Expression --
2593    -----------------------
2594
2595    procedure Freeze_Expression (N : Node_Id) is
2596       In_Def_Exp : constant Boolean := In_Default_Expression;
2597       Typ        : Entity_Id;
2598       Nam        : Entity_Id;
2599       Desig_Typ  : Entity_Id;
2600       P          : Node_Id;
2601       Parent_P   : Node_Id;
2602
2603       Freeze_Outside : Boolean := False;
2604       --  This flag is set true if the entity must be frozen outside the
2605       --  current subprogram. This happens in the case of expander generated
2606       --  subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do
2607       --  not freeze all entities like other bodies, but which nevertheless
2608       --  may reference entities that have to be frozen before the body and
2609       --  obviously cannot be frozen inside the body.
2610
2611       function In_Exp_Body (N : Node_Id) return Boolean;
2612       --  Given an N_Handled_Sequence_Of_Statements node N, determines whether
2613       --  it is the handled statement sequence of an expander generated
2614       --  subprogram (init proc, or stream subprogram). If so, it returns
2615       --  True, otherwise False.
2616
2617       function In_Exp_Body (N : Node_Id) return Boolean is
2618          P : Node_Id;
2619
2620       begin
2621          if Nkind (N) = N_Subprogram_Body then
2622             P := N;
2623          else
2624             P := Parent (N);
2625          end if;
2626
2627          if Nkind (P) /= N_Subprogram_Body then
2628             return False;
2629
2630          else
2631             P := Defining_Unit_Name (Specification (P));
2632
2633             if Nkind (P) = N_Defining_Identifier
2634               and then (Chars (P) = Name_uInit_Proc or else
2635                         Chars (P) = Name_uInput     or else
2636                         Chars (P) = Name_uOutput    or else
2637                         Chars (P) = Name_uRead      or else
2638                         Chars (P) = Name_uWrite)
2639             then
2640                return True;
2641             else
2642                return False;
2643             end if;
2644          end if;
2645
2646       end In_Exp_Body;
2647
2648    --  Start of processing for Freeze_Expression
2649
2650    begin
2651       --  Immediate return if freezing is inhibited. This flag is set by
2652       --  the analyzer to stop freezing on generated expressions that would
2653       --  cause freezing if they were in the source program, but which are
2654       --  not supposed to freeze, since they are created.
2655
2656       if Must_Not_Freeze (N) then
2657          return;
2658       end if;
2659
2660       --  If expression is non-static, then it does not freeze in a default
2661       --  expression, see section "Handling of Default Expressions" in the
2662       --  spec of package Sem for further details. Note that we have to
2663       --  make sure that we actually have a real expression (if we have
2664       --  a subtype indication, we can't test Is_Static_Expression!)
2665
2666       if In_Def_Exp
2667         and then Nkind (N) in N_Subexpr
2668         and then not Is_Static_Expression (N)
2669       then
2670          return;
2671       end if;
2672
2673       --  Freeze type of expression if not frozen already
2674
2675       if Nkind (N) in N_Has_Etype
2676         and then not Is_Frozen (Etype (N))
2677       then
2678          Typ := Etype (N);
2679       else
2680          Typ := Empty;
2681       end if;
2682
2683       --  For entity name, freeze entity if not frozen already. A special
2684       --  exception occurs for an identifier that did not come from source.
2685       --  We don't let such identifiers freeze a non-internal entity, i.e.
2686       --  an entity that did come from source, since such an identifier was
2687       --  generated by the expander, and cannot have any semantic effect on
2688       --  the freezing semantics. For example, this stops the parameter of
2689       --  an initialization procedure from freezing the variable.
2690
2691       if Is_Entity_Name (N)
2692         and then not Is_Frozen (Entity (N))
2693         and then (Nkind (N) /= N_Identifier
2694                    or else Comes_From_Source (N)
2695                    or else not Comes_From_Source (Entity (N)))
2696       then
2697          Nam := Entity (N);
2698
2699       else
2700          Nam := Empty;
2701       end if;
2702
2703       --  For an allocator freeze designated type if not frozen already.
2704
2705       --  For an aggregate whose component type is an access type, freeze
2706       --  the designated type now, so that its freeze  does not appear within
2707       --  the loop that might be created in the expansion of the aggregate.
2708       --  If the designated type is a private type without full view, the
2709       --  expression cannot contain an allocator, so the type is not frozen.
2710
2711       Desig_Typ := Empty;
2712       case Nkind (N) is
2713
2714          when N_Allocator =>
2715             Desig_Typ := Designated_Type (Etype (N));
2716
2717          when N_Aggregate =>
2718             if Is_Array_Type (Etype (N))
2719               and then Is_Access_Type (Component_Type (Etype (N)))
2720             then
2721                Desig_Typ := Designated_Type (Component_Type (Etype (N)));
2722             end if;
2723
2724          when N_Selected_Component |
2725             N_Indexed_Component    |
2726             N_Slice                =>
2727
2728             if Is_Access_Type (Etype (Prefix (N))) then
2729                Desig_Typ := Designated_Type (Etype (Prefix (N)));
2730             end if;
2731
2732          when others =>
2733             null;
2734
2735       end case;
2736
2737       if Desig_Typ /= Empty
2738         and then (Is_Frozen (Desig_Typ)
2739                    or else (not Is_Fully_Defined (Desig_Typ)))
2740       then
2741          Desig_Typ := Empty;
2742       end if;
2743
2744       --  All done if nothing needs freezing
2745
2746       if No (Typ)
2747         and then No (Nam)
2748         and then No (Desig_Typ)
2749       then
2750          return;
2751       end if;
2752
2753       --  Loop for looking at the right place to insert the freeze nodes
2754       --  exiting from the loop when it is appropriate to insert the freeze
2755       --  node before the current node P.
2756
2757       --  Also checks some special exceptions to the freezing rules. These
2758       --  cases result in a direct return, bypassing the freeze action.
2759
2760       P := N;
2761       loop
2762          Parent_P := Parent (P);
2763
2764          --  If we don't have a parent, then we are not in a well-formed
2765          --  tree. This is an unusual case, but there are some legitimate
2766          --  situations in which this occurs, notably when the expressions
2767          --  in the range of a type declaration are resolved. We simply
2768          --  ignore the freeze request in this case. Is this right ???
2769
2770          if No (Parent_P) then
2771             return;
2772          end if;
2773
2774          --  See if we have got to an appropriate point in the tree
2775
2776          case Nkind (Parent_P) is
2777
2778             --  A special test for the exception of (RM 13.14(8)) for the
2779             --  case of per-object expressions (RM 3.8(18)) occurring in a
2780             --  component definition or a discrete subtype definition. Note
2781             --  that we test for a component declaration which includes both
2782             --  cases we are interested in, and furthermore the tree does not
2783             --  have explicit nodes for either of these two constructs.
2784
2785             when N_Component_Declaration =>
2786
2787                --  The case we want to test for here is an identifier that is
2788                --  a per-object expression, this is either a discriminant that
2789                --  appears in a context other than the component declaration
2790                --  or it is a reference to the type of the enclosing construct.
2791
2792                --  For either of these cases, we skip the freezing
2793
2794                if not In_Default_Expression
2795                  and then Nkind (N) = N_Identifier
2796                  and then (Present (Entity (N)))
2797                then
2798                   --  We recognize the discriminant case by just looking for
2799                   --  a reference to a discriminant. It can only be one for
2800                   --  the enclosing construct. Skip freezing in this case.
2801
2802                   if Ekind (Entity (N)) = E_Discriminant then
2803                      return;
2804
2805                   --  For the case of a reference to the enclosing record,
2806                   --  (or task or protected type), we look for a type that
2807                   --  matches the current scope.
2808
2809                   elsif Entity (N) = Current_Scope then
2810                      return;
2811                   end if;
2812                end if;
2813
2814             --  If we have an enumeration literal that appears as the
2815             --  choice in the aggregate of an enumeration representation
2816             --  clause, then freezing does not occur (RM 13.14(9)).
2817
2818             when N_Enumeration_Representation_Clause =>
2819
2820                --  The case we are looking for is an enumeration literal
2821
2822                if (Nkind (N) = N_Identifier or Nkind (N) = N_Character_Literal)
2823                  and then Is_Enumeration_Type (Etype (N))
2824                then
2825                   --  If enumeration literal appears directly as the choice,
2826                   --  do not freeze (this is the normal non-overloade case)
2827
2828                   if Nkind (Parent (N)) = N_Component_Association
2829                     and then First (Choices (Parent (N))) = N
2830                   then
2831                      return;
2832
2833                   --  If enumeration literal appears as the name of a
2834                   --  function which is the choice, then also do not freeze.
2835                   --  This happens in the overloaded literal case, where the
2836                   --  enumeration literal is temporarily changed to a function
2837                   --  call for overloading analysis purposes.
2838
2839                   elsif Nkind (Parent (N)) = N_Function_Call
2840                      and then
2841                        Nkind (Parent (Parent (N))) = N_Component_Association
2842                      and then
2843                        First (Choices (Parent (Parent (N)))) = Parent (N)
2844                   then
2845                      return;
2846                   end if;
2847                end if;
2848
2849             --  Normally if the parent is a handled sequence of statements,
2850             --  then the current node must be a statement, and that is an
2851             --  appropriate place to insert a freeze node.
2852
2853             when N_Handled_Sequence_Of_Statements =>
2854
2855                --  An exception occurs when the sequence of statements is
2856                --  for an expander generated body that did not do the usual
2857                --  freeze all operation. In this case we usually want to
2858                --  freeze outside this body, not inside it, and we skip
2859                --  past the subprogram body that we are inside.
2860
2861                if In_Exp_Body (Parent_P) then
2862
2863                   --  However, we *do* want to freeze at this point if we have
2864                   --  an entity to freeze, and that entity is declared *inside*
2865                   --  the body of the expander generated procedure. This case
2866                   --  is recognized by the scope of the type, which is either
2867                   --  the spec for some enclosing body, or (in the case of
2868                   --  init_procs, for which there are no separate specs) the
2869                   --  current scope.
2870
2871                   declare
2872                      Subp : constant Node_Id := Parent (Parent_P);
2873                      Cspc : Entity_Id;
2874
2875                   begin
2876                      if Nkind (Subp) = N_Subprogram_Body then
2877                         Cspc := Corresponding_Spec (Subp);
2878
2879                         if (Present (Typ) and then Scope (Typ) = Cspc)
2880                              or else
2881                            (Present (Nam) and then Scope (Nam) = Cspc)
2882                         then
2883                            exit;
2884
2885                         elsif Present (Typ)
2886                           and then Scope (Typ) = Current_Scope
2887                           and then Current_Scope = Defining_Entity (Subp)
2888                         then
2889                            exit;
2890                         end if;
2891                      end if;
2892                   end;
2893
2894                   --  If not that exception to the exception, then this is
2895                   --  where we delay the freeze till outside the body.
2896
2897                   Parent_P := Parent (Parent_P);
2898                   Freeze_Outside := True;
2899
2900                --  Here if normal case where we are in handled statement
2901                --  sequence and want to do the insertion right there.
2902
2903                else
2904                   exit;
2905                end if;
2906
2907             --  If parent is a body or a spec or a block, then the current
2908             --  node is a statement or declaration and we can insert the
2909             --  freeze node before it.
2910
2911             when N_Package_Specification |
2912                  N_Package_Body          |
2913                  N_Subprogram_Body       |
2914                  N_Task_Body             |
2915                  N_Protected_Body        |
2916                  N_Entry_Body            |
2917                  N_Block_Statement       => exit;
2918
2919             --  The expander is allowed to define types in any statements list,
2920             --  so any of the following parent nodes also mark a freezing point
2921             --  if the actual node is in a list of statements or declarations.
2922
2923             when N_Exception_Handler          |
2924                  N_If_Statement               |
2925                  N_Elsif_Part                 |
2926                  N_Case_Statement_Alternative |
2927                  N_Compilation_Unit_Aux       |
2928                  N_Selective_Accept           |
2929                  N_Accept_Alternative         |
2930                  N_Delay_Alternative          |
2931                  N_Conditional_Entry_Call     |
2932                  N_Entry_Call_Alternative     |
2933                  N_Triggering_Alternative     |
2934                  N_Abortable_Part             |
2935                  N_Freeze_Entity              =>
2936
2937                exit when Is_List_Member (P);
2938
2939             --  Note: The N_Loop_Statement is a special case. A type that
2940             --  appears in the source can never be frozen in a loop (this
2941             --  occurs only because of a loop expanded by the expander),
2942             --  so we keep on going. Otherwise we terminate the search.
2943             --  Same is true of any entity which comes from source. (if they
2944             --  have a predefined type, that type does not appear to come
2945             --  from source, but the entity should not be frozen here).
2946
2947             when N_Loop_Statement =>
2948                exit when not Comes_From_Source (Etype (N))
2949                  and then (No (Nam) or else not Comes_From_Source (Nam));
2950
2951             --  For all other cases, keep looking at parents
2952
2953             when others =>
2954                null;
2955          end case;
2956
2957          --  We fall through the case if we did not yet find the proper
2958          --  place in the free for inserting the freeze node, so climb!
2959
2960          P := Parent_P;
2961       end loop;
2962
2963       --  If the expression appears in a record or an initialization
2964       --  procedure, the freeze nodes are collected and attached to
2965       --  the current scope, to be inserted and analyzed on exit from
2966       --  the scope, to insure that generated entities appear in the
2967       --  correct scope. If the expression is a default for a discriminant
2968       --  specification, the scope is still void. The expression can also
2969       --  appear in the discriminant part of a private or concurrent type.
2970
2971       --  The other case requiring this special handling is if we are in
2972       --  a default expression, since in that case we are about to freeze
2973       --  a static type, and the freeze scope needs to be the outer scope,
2974       --  not the scope of the subprogram with the default parameter.
2975
2976       --  For default expressions in generic units, the Move_Freeze_Nodes
2977       --  mechanism (see sem_ch12.adb) takes care of placing them at the
2978       --  proper place, after the generic unit.
2979
2980       if (In_Def_Exp and not Inside_A_Generic)
2981         or else Freeze_Outside
2982         or else (Is_Type (Current_Scope)
2983                   and then (not Is_Concurrent_Type (Current_Scope)
2984                              or else not Has_Completion (Current_Scope)))
2985         or else Ekind (Current_Scope) = E_Void
2986       then
2987          declare
2988             Loc          : constant Source_Ptr := Sloc (Current_Scope);
2989             Freeze_Nodes : List_Id := No_List;
2990
2991          begin
2992             if Present (Desig_Typ) then
2993                Freeze_And_Append (Desig_Typ, Loc, Freeze_Nodes);
2994             end if;
2995
2996             if Present (Typ) then
2997                Freeze_And_Append (Typ, Loc, Freeze_Nodes);
2998             end if;
2999
3000             if Present (Nam) then
3001                Freeze_And_Append (Nam, Loc, Freeze_Nodes);
3002             end if;
3003
3004             if Is_Non_Empty_List (Freeze_Nodes) then
3005
3006                if No (Scope_Stack.Table
3007                  (Scope_Stack.Last).Pending_Freeze_Actions)
3008                then
3009                   Scope_Stack.Table
3010                     (Scope_Stack.Last).Pending_Freeze_Actions :=
3011                       Freeze_Nodes;
3012                else
3013                   Append_List (Freeze_Nodes, Scope_Stack.Table
3014                                    (Scope_Stack.Last).Pending_Freeze_Actions);
3015                end if;
3016             end if;
3017          end;
3018
3019          return;
3020       end if;
3021
3022       --  Now we have the right place to do the freezing. First, a special
3023       --  adjustment, if we are in default expression analysis mode, these
3024       --  freeze actions must not be thrown away (normally all inserted
3025       --  actions are thrown away in this mode. However, the freeze actions
3026       --  are from static expressions and one of the important reasons we
3027       --  are doing this special analysis is to get these freeze actions.
3028       --  Therefore we turn off the In_Default_Expression mode to propagate
3029       --  these freeze actions. This also means they get properly analyzed
3030       --  and expanded.
3031
3032       In_Default_Expression := False;
3033
3034       --  Freeze the designated type of an allocator (RM 13.14(12))
3035
3036       if Present (Desig_Typ) then
3037          Freeze_Before (P, Desig_Typ);
3038       end if;
3039
3040       --  Freeze type of expression (RM 13.14(9)). Note that we took care of
3041       --  the enumeration representation clause exception in the loop above.
3042
3043       if Present (Typ) then
3044          Freeze_Before (P, Typ);
3045       end if;
3046
3047       --  Freeze name if one is present (RM 13.14(10))
3048
3049       if Present (Nam) then
3050          Freeze_Before (P, Nam);
3051       end if;
3052
3053       In_Default_Expression := In_Def_Exp;
3054    end Freeze_Expression;
3055
3056    -----------------------------
3057    -- Freeze_Fixed_Point_Type --
3058    -----------------------------
3059
3060    --  Certain fixed-point types and subtypes, including implicit base
3061    --  types and declared first subtypes, have not yet set up a range.
3062    --  This is because the range cannot be set until the Small and Size
3063    --  values are known, and these are not known till the type is frozen.
3064
3065    --  To signal this case, Scalar_Range contains an unanalyzed syntactic
3066    --  range whose bounds are unanalyzed real literals. This routine will
3067    --  recognize this case, and transform this range node into a properly
3068    --  typed range with properly analyzed and resolved values.
3069
3070    procedure Freeze_Fixed_Point_Type (Typ : Entity_Id) is
3071       Rng   : constant Node_Id    := Scalar_Range (Typ);
3072       Lo    : constant Node_Id    := Low_Bound (Rng);
3073       Hi    : constant Node_Id    := High_Bound (Rng);
3074       Btyp  : constant Entity_Id  := Base_Type (Typ);
3075       Brng  : constant Node_Id    := Scalar_Range (Btyp);
3076       BLo   : constant Node_Id    := Low_Bound (Brng);
3077       BHi   : constant Node_Id    := High_Bound (Brng);
3078       Small : constant Ureal      := Small_Value (Typ);
3079       Loval : Ureal;
3080       Hival : Ureal;
3081       Atype : Entity_Id;
3082
3083       Actual_Size : Nat;
3084
3085       function Fsize (Lov, Hiv : Ureal) return Nat;
3086       --  Returns size of type with given bounds. Also leaves these
3087       --  bounds set as the current bounds of the Typ.
3088
3089       function Fsize (Lov, Hiv : Ureal) return Nat is
3090       begin
3091          Set_Realval (Lo, Lov);
3092          Set_Realval (Hi, Hiv);
3093          return Minimum_Size (Typ);
3094       end Fsize;
3095
3096    --  Start of processing for Freeze_Fixed_Point_Type;
3097
3098    begin
3099       --  If Esize of a subtype has not previously been set, set it now
3100
3101       if Unknown_Esize (Typ) then
3102          Atype := Ancestor_Subtype (Typ);
3103
3104          if Present (Atype) then
3105             Set_Size_Info (Typ, Atype);
3106          else
3107             Set_Size_Info (Typ, Base_Type (Typ));
3108          end if;
3109       end if;
3110
3111       --  Immediate return if the range is already analyzed. This means
3112       --  that the range is already set, and does not need to be computed
3113       --  by this routine.
3114
3115       if Analyzed (Rng) then
3116          return;
3117       end if;
3118
3119       --  Immediate return if either of the bounds raises Constraint_Error
3120
3121       if Raises_Constraint_Error (Lo)
3122         or else Raises_Constraint_Error (Hi)
3123       then
3124          return;
3125       end if;
3126
3127       Loval := Realval (Lo);
3128       Hival := Realval (Hi);
3129
3130       --  Ordinary fixed-point case
3131
3132       if Is_Ordinary_Fixed_Point_Type (Typ) then
3133
3134          --  For the ordinary fixed-point case, we are allowed to fudge the
3135          --  end-points up or down by small. Generally we prefer to fudge
3136          --  up, i.e. widen the bounds for non-model numbers so that the
3137          --  end points are included. However there are cases in which this
3138          --  cannot be done, and indeed cases in which we may need to narrow
3139          --  the bounds. The following circuit makes the decision.
3140
3141          --  Note: our terminology here is that Incl_EP means that the
3142          --  bounds are widened by Small if necessary to include the end
3143          --  points, and Excl_EP means that the bounds are narrowed by
3144          --  Small to exclude the end-points if this reduces the size.
3145
3146          --  Note that in the Incl case, all we care about is including the
3147          --  end-points. In the Excl case, we want to narrow the bounds as
3148          --  much as permitted by the RM, to give the smallest possible size.
3149
3150          Fudge : declare
3151             Loval_Incl_EP : Ureal;
3152             Hival_Incl_EP : Ureal;
3153
3154             Loval_Excl_EP : Ureal;
3155             Hival_Excl_EP : Ureal;
3156
3157             Size_Incl_EP  : Nat;
3158             Size_Excl_EP  : Nat;
3159
3160             Model_Num     : Ureal;
3161             First_Subt    : Entity_Id;
3162             Actual_Lo     : Ureal;
3163             Actual_Hi     : Ureal;
3164
3165          begin
3166             --  First step. Base types are required to be symmetrical. Right
3167             --  now, the base type range is a copy of the first subtype range.
3168             --  This will be corrected before we are done, but right away we
3169             --  need to deal with the case where both bounds are non-negative.
3170             --  In this case, we set the low bound to the negative of the high
3171             --  bound, to make sure that the size is computed to include the
3172             --  required sign. Note that we do not need to worry about the
3173             --  case of both bounds negative, because the sign will be dealt
3174             --  with anyway. Furthermore we can't just go making such a bound
3175             --  symmetrical, since in a twos-complement system, there is an
3176             --  extra negative value which could not be accomodated on the
3177             --  positive side.
3178
3179             if Typ = Btyp
3180               and then not UR_Is_Negative (Loval)
3181               and then Hival > Loval
3182             then
3183                Loval := -Hival;
3184                Set_Realval (Lo, Loval);
3185             end if;
3186
3187             --  Compute the fudged bounds. If the number is a model number,
3188             --  then we do nothing to include it, but we are allowed to
3189             --  backoff to the next adjacent model number when we exclude
3190             --  it. If it is not a model number then we straddle the two
3191             --  values with the model numbers on either side.
3192
3193             Model_Num := UR_Trunc (Loval / Small) * Small;
3194
3195             if Loval = Model_Num then
3196                Loval_Incl_EP := Model_Num;
3197             else
3198                Loval_Incl_EP := Model_Num - Small;
3199             end if;
3200
3201             --  The low value excluding the end point is Small greater, but
3202             --  we do not do this exclusion if the low value is positive,
3203             --  since it can't help the size and could actually hurt by
3204             --  crossing the high bound.
3205
3206             if UR_Is_Negative (Loval_Incl_EP) then
3207                Loval_Excl_EP := Loval_Incl_EP + Small;
3208             else
3209                Loval_Excl_EP := Loval_Incl_EP;
3210             end if;
3211
3212             --  Similar processing for upper bound and high value
3213
3214             Model_Num := UR_Trunc (Hival / Small) * Small;
3215
3216             if Hival = Model_Num then
3217                Hival_Incl_EP := Model_Num;
3218             else
3219                Hival_Incl_EP := Model_Num + Small;
3220             end if;
3221
3222             if UR_Is_Positive (Hival_Incl_EP) then
3223                Hival_Excl_EP := Hival_Incl_EP - Small;
3224             else
3225                Hival_Excl_EP := Hival_Incl_EP;
3226             end if;
3227
3228             --  One further adjustment is needed. In the case of subtypes,
3229             --  we cannot go outside the range of the base type, or we get
3230             --  peculiarities, and the base type range is already set. This
3231             --  only applies to the Incl values, since clearly the Excl
3232             --  values are already as restricted as they are allowed to be.
3233
3234             if Typ /= Btyp then
3235                Loval_Incl_EP := UR_Max (Loval_Incl_EP, Realval (BLo));
3236                Hival_Incl_EP := UR_Min (Hival_Incl_EP, Realval (BHi));
3237             end if;
3238
3239             --  Get size including and excluding end points
3240
3241             Size_Incl_EP := Fsize (Loval_Incl_EP, Hival_Incl_EP);
3242             Size_Excl_EP := Fsize (Loval_Excl_EP, Hival_Excl_EP);
3243
3244             --  No need to exclude end-points if it does not reduce size
3245
3246             if Fsize (Loval_Incl_EP, Hival_Excl_EP) = Size_Excl_EP then
3247                Loval_Excl_EP := Loval_Incl_EP;
3248             end if;
3249
3250             if Fsize (Loval_Excl_EP, Hival_Incl_EP) = Size_Excl_EP then
3251                Hival_Excl_EP := Hival_Incl_EP;
3252             end if;
3253
3254             --  Now we set the actual size to be used. We want to use the
3255             --  bounds fudged up to include the end-points but only if this
3256             --  can be done without violating a specifically given size
3257             --  size clause or causing an unacceptable increase in size.
3258
3259             --  Case of size clause given
3260
3261             if Has_Size_Clause (Typ) then
3262
3263                --  Use the inclusive size only if it is consistent with
3264                --  the explicitly specified size.
3265
3266                if Size_Incl_EP <= RM_Size (Typ) then
3267                   Actual_Lo   := Loval_Incl_EP;
3268                   Actual_Hi   := Hival_Incl_EP;
3269                   Actual_Size := Size_Incl_EP;
3270
3271                --  If the inclusive size is too large, we try excluding
3272                --  the end-points (will be caught later if does not work).
3273
3274                else
3275                   Actual_Lo   := Loval_Excl_EP;
3276                   Actual_Hi   := Hival_Excl_EP;
3277                   Actual_Size := Size_Excl_EP;
3278                end if;
3279
3280             --  Case of size clause not given
3281
3282             else
3283                --  If we have a base type whose corresponding first subtype
3284                --  has an explicit size that is large enough to include our
3285                --  end-points, then do so. There is no point in working hard
3286                --  to get a base type whose size is smaller than the specified
3287                --  size of the first subtype.
3288
3289                First_Subt := First_Subtype (Typ);
3290
3291                if Has_Size_Clause (First_Subt)
3292                  and then Size_Incl_EP <= Esize (First_Subt)
3293                then
3294                   Actual_Size := Size_Incl_EP;
3295                   Actual_Lo   := Loval_Incl_EP;
3296                   Actual_Hi   := Hival_Incl_EP;
3297
3298                --  If excluding the end-points makes the size smaller and
3299                --  results in a size of 8,16,32,64, then we take the smaller
3300                --  size. For the 64 case, this is compulsory. For the other
3301                --  cases, it seems reasonable. We like to include end points
3302                --  if we can, but not at the expense of moving to the next
3303                --  natural boundary of size.
3304
3305                elsif Size_Incl_EP /= Size_Excl_EP
3306                  and then
3307                     (Size_Excl_EP = 8  or else
3308                      Size_Excl_EP = 16 or else
3309                      Size_Excl_EP = 32 or else
3310                      Size_Excl_EP = 64)
3311                then
3312                   Actual_Size := Size_Excl_EP;
3313                   Actual_Lo   := Loval_Excl_EP;
3314                   Actual_Hi   := Hival_Excl_EP;
3315
3316                --  Otherwise we can definitely include the end points
3317
3318                else
3319                   Actual_Size := Size_Incl_EP;
3320                   Actual_Lo   := Loval_Incl_EP;
3321                   Actual_Hi   := Hival_Incl_EP;
3322                end if;
3323
3324                --  One pathological case: normally we never fudge a low
3325                --  bound down, since it would seem to increase the size
3326                --  (if it has any effect), but for ranges containing a
3327                --  single value, or no values, the high bound can be
3328                --  small too large. Consider:
3329
3330                --    type t is delta 2.0**(-14)
3331                --      range 131072.0 .. 0;
3332
3333                --  That lower bound is *just* outside the range of 32
3334                --  bits, and does need fudging down in this case. Note
3335                --  that the bounds will always have crossed here, since
3336                --  the high bound will be fudged down if necessary, as
3337                --  in the case of:
3338
3339                --    type t is delta 2.0**(-14)
3340                --      range 131072.0 .. 131072.0;
3341
3342                --  So we can detect the situation by looking for crossed
3343                --  bounds, and if the bounds are crossed, and the low
3344                --  bound is greater than zero, we will always back it
3345                --  off by small, since this is completely harmless.
3346
3347                if Actual_Lo > Actual_Hi then
3348                   if UR_Is_Positive (Actual_Lo) then
3349                      Actual_Lo   := Loval_Incl_EP - Small;
3350                      Actual_Size := Fsize (Actual_Lo, Actual_Hi);
3351
3352                   --  And of course, we need to do exactly the same parallel
3353                   --  fudge for flat ranges in the negative region.
3354
3355                   elsif UR_Is_Negative (Actual_Hi) then
3356                      Actual_Hi := Hival_Incl_EP + Small;
3357                      Actual_Size := Fsize (Actual_Lo, Actual_Hi);
3358                   end if;
3359                end if;
3360             end if;
3361
3362             Set_Realval (Lo, Actual_Lo);
3363             Set_Realval (Hi, Actual_Hi);
3364          end Fudge;
3365
3366       --  For the decimal case, none of this fudging is required, since there
3367       --  are no end-point problems in the decimal case (the end-points are
3368       --  always included).
3369
3370       else
3371          Actual_Size := Fsize (Loval, Hival);
3372       end if;
3373
3374       --  At this stage, the actual size has been calculated and the proper
3375       --  required bounds are stored in the low and high bounds.
3376
3377       if Actual_Size > 64 then
3378          Error_Msg_Uint_1 := UI_From_Int (Actual_Size);
3379          Error_Msg_N
3380            ("size required (^) for type& too large, maximum is 64", Typ);
3381          Actual_Size := 64;
3382       end if;
3383
3384       --  Check size against explicit given size
3385
3386       if Has_Size_Clause (Typ) then
3387          if Actual_Size > RM_Size (Typ) then
3388             Error_Msg_Uint_1 := RM_Size (Typ);
3389             Error_Msg_Uint_2 := UI_From_Int (Actual_Size);
3390             Error_Msg_NE
3391               ("size given (^) for type& too small, minimum is ^",
3392                Size_Clause (Typ), Typ);
3393
3394          else
3395             Actual_Size := UI_To_Int (Esize (Typ));
3396          end if;
3397
3398       --  Increase size to next natural boundary if no size clause given
3399
3400       else
3401          if Actual_Size <= 8 then
3402             Actual_Size := 8;
3403          elsif Actual_Size <= 16 then
3404             Actual_Size := 16;
3405          elsif Actual_Size <= 32 then
3406             Actual_Size := 32;
3407          else
3408             Actual_Size := 64;
3409          end if;
3410
3411          Init_Esize (Typ, Actual_Size);
3412          Adjust_Esize_For_Alignment (Typ);
3413       end if;
3414
3415       --  If we have a base type, then expand the bounds so that they
3416       --  extend to the full width of the allocated size in bits, to
3417       --  avoid junk range checks on intermediate computations.
3418
3419       if Base_Type (Typ) = Typ then
3420          Set_Realval (Lo, -(Small * (Uint_2 ** (Actual_Size - 1))));
3421          Set_Realval (Hi,  (Small * (Uint_2 ** (Actual_Size - 1) - 1)));
3422       end if;
3423
3424       --  Final step is to reanalyze the bounds using the proper type
3425       --  and set the Corresponding_Integer_Value fields of the literals.
3426
3427       Set_Etype (Lo, Empty);
3428       Set_Analyzed (Lo, False);
3429       Analyze (Lo);
3430
3431       --  Resolve with universal fixed if the base type, and the base
3432       --  type if it is a subtype. Note we can't resolve the base type
3433       --  with itself, that would be a reference before definition.
3434
3435       if Typ = Btyp then
3436          Resolve (Lo, Universal_Fixed);
3437       else
3438          Resolve (Lo, Btyp);
3439       end if;
3440
3441       --  Set corresponding integer value for bound
3442
3443       Set_Corresponding_Integer_Value
3444         (Lo, UR_To_Uint (Realval (Lo) / Small));
3445
3446       --  Similar processing for high bound
3447
3448       Set_Etype (Hi, Empty);
3449       Set_Analyzed (Hi, False);
3450       Analyze (Hi);
3451
3452       if Typ = Btyp then
3453          Resolve (Hi, Universal_Fixed);
3454       else
3455          Resolve (Hi, Btyp);
3456       end if;
3457
3458       Set_Corresponding_Integer_Value
3459         (Hi, UR_To_Uint (Realval (Hi) / Small));
3460
3461       --  Set type of range to correspond to bounds
3462
3463       Set_Etype (Rng, Etype (Lo));
3464
3465       --  Set Esize to calculated size and also set RM_Size
3466
3467       Init_Esize (Typ, Actual_Size);
3468
3469       --  Set RM_Size if not already set. If already set, check value
3470
3471       declare
3472          Minsiz : constant Uint := UI_From_Int (Minimum_Size (Typ));
3473
3474       begin
3475          if RM_Size (Typ) /= Uint_0 then
3476             if RM_Size (Typ) < Minsiz then
3477                Error_Msg_Uint_1 := RM_Size (Typ);
3478                Error_Msg_Uint_2 := Minsiz;
3479                Error_Msg_NE
3480                  ("size given (^) for type& too small, minimum is ^",
3481                   Size_Clause (Typ), Typ);
3482             end if;
3483
3484          else
3485             Set_RM_Size (Typ, Minsiz);
3486          end if;
3487       end;
3488
3489    end Freeze_Fixed_Point_Type;
3490
3491    ------------------
3492    -- Freeze_Itype --
3493    ------------------
3494
3495    procedure Freeze_Itype (T : Entity_Id; N : Node_Id) is
3496       L : List_Id;
3497
3498    begin
3499       Set_Has_Delayed_Freeze (T);
3500       L := Freeze_Entity (T, Sloc (N));
3501
3502       if Is_Non_Empty_List (L) then
3503          Insert_Actions (N, L);
3504       end if;
3505    end Freeze_Itype;
3506
3507    --------------------------
3508    -- Freeze_Static_Object --
3509    --------------------------
3510
3511    procedure Freeze_Static_Object (E : Entity_Id) is
3512
3513       Cannot_Be_Static : exception;
3514       --  Exception raised if the type of a static object cannot be made
3515       --  static. This happens if the type depends on non-global objects.
3516
3517       procedure Ensure_Expression_Is_SA (N : Node_Id);
3518       --  Called to ensure that an expression used as part of a type
3519       --  definition is statically allocatable, which means that the type
3520       --  of the expression is statically allocatable, and the expression
3521       --  is either static, or a reference to a library level constant.
3522
3523       procedure Ensure_Type_Is_SA (Typ : Entity_Id);
3524       --  Called to mark a type as static, checking that it is possible
3525       --  to set the type as static. If it is not possible, then the
3526       --  exception Cannot_Be_Static is raised.
3527
3528       -----------------------------
3529       -- Ensure_Expression_Is_SA --
3530       -----------------------------
3531
3532       procedure Ensure_Expression_Is_SA (N : Node_Id) is
3533          Ent : Entity_Id;
3534
3535       begin
3536          Ensure_Type_Is_SA (Etype (N));
3537
3538          if Is_Static_Expression (N) then
3539             return;
3540
3541          elsif Nkind (N) = N_Identifier then
3542             Ent := Entity (N);
3543
3544             if Present (Ent)
3545               and then Ekind (Ent) = E_Constant
3546               and then Is_Library_Level_Entity (Ent)
3547             then
3548                return;
3549             end if;
3550          end if;
3551
3552          raise Cannot_Be_Static;
3553       end Ensure_Expression_Is_SA;
3554
3555       -----------------------
3556       -- Ensure_Type_Is_SA --
3557       -----------------------
3558
3559       procedure Ensure_Type_Is_SA (Typ : Entity_Id) is
3560          N : Node_Id;
3561          C : Entity_Id;
3562
3563       begin
3564          --  If type is library level, we are all set
3565
3566          if Is_Library_Level_Entity (Typ) then
3567             return;
3568          end if;
3569
3570          --  We are also OK if the type is already marked as statically
3571          --  allocated, which means we processed it before.
3572
3573          if Is_Statically_Allocated (Typ) then
3574             return;
3575          end if;
3576
3577          --  Mark type as statically allocated
3578
3579          Set_Is_Statically_Allocated (Typ);
3580
3581          --  Check that it is safe to statically allocate this type
3582
3583          if Is_Scalar_Type (Typ) or else Is_Real_Type (Typ) then
3584             Ensure_Expression_Is_SA (Type_Low_Bound (Typ));
3585             Ensure_Expression_Is_SA (Type_High_Bound (Typ));
3586
3587          elsif Is_Array_Type (Typ) then
3588             N := First_Index (Typ);
3589             while Present (N) loop
3590                Ensure_Type_Is_SA (Etype (N));
3591                Next_Index (N);
3592             end loop;
3593
3594             Ensure_Type_Is_SA (Component_Type (Typ));
3595
3596          elsif Is_Access_Type (Typ) then
3597             if Ekind (Designated_Type (Typ)) = E_Subprogram_Type then
3598
3599                declare
3600                   F : Entity_Id;
3601                   T : constant Entity_Id := Etype (Designated_Type (Typ));
3602
3603                begin
3604                   if T /= Standard_Void_Type then
3605                      Ensure_Type_Is_SA (T);
3606                   end if;
3607
3608                   F := First_Formal (Designated_Type (Typ));
3609
3610                   while Present (F) loop
3611                      Ensure_Type_Is_SA (Etype (F));
3612                      Next_Formal (F);
3613                   end loop;
3614                end;
3615
3616             else
3617                Ensure_Type_Is_SA (Designated_Type (Typ));
3618             end if;
3619
3620          elsif Is_Record_Type (Typ) then
3621             C := First_Entity (Typ);
3622
3623             while Present (C) loop
3624                if Ekind (C) = E_Discriminant
3625                  or else Ekind (C) = E_Component
3626                then
3627                   Ensure_Type_Is_SA (Etype (C));
3628
3629                elsif Is_Type (C) then
3630                   Ensure_Type_Is_SA (C);
3631                end if;
3632
3633                Next_Entity (C);
3634             end loop;
3635
3636          elsif Ekind (Typ) = E_Subprogram_Type then
3637             Ensure_Type_Is_SA (Etype (Typ));
3638
3639             C := First_Formal (Typ);
3640             while Present (C) loop
3641                Ensure_Type_Is_SA (Etype (C));
3642                Next_Formal (C);
3643             end loop;
3644
3645          else
3646             raise Cannot_Be_Static;
3647          end if;
3648       end Ensure_Type_Is_SA;
3649
3650    --  Start of processing for Freeze_Static_Object
3651
3652    begin
3653       Ensure_Type_Is_SA (Etype (E));
3654
3655    exception
3656       when Cannot_Be_Static =>
3657
3658          --  If the object that cannot be static is imported or exported,
3659          --  then we give an error message saying that this object cannot
3660          --  be imported or exported.
3661
3662          if Is_Imported (E) then
3663             Error_Msg_N
3664               ("& cannot be imported (local type is not constant)", E);
3665
3666          --  Otherwise must be exported, something is wrong if compiler
3667          --  is marking something as statically allocated which cannot be).
3668
3669          else pragma Assert (Is_Exported (E));
3670             Error_Msg_N
3671               ("& cannot be exported (local type is not constant)", E);
3672          end if;
3673    end Freeze_Static_Object;
3674
3675    -----------------------
3676    -- Freeze_Subprogram --
3677    -----------------------
3678
3679    procedure Freeze_Subprogram (E : Entity_Id) is
3680       Retype : Entity_Id;
3681       F      : Entity_Id;
3682
3683    begin
3684       --  Subprogram may not have an address clause unless it is imported
3685
3686       if Present (Address_Clause (E)) then
3687          if not Is_Imported (E) then
3688             Error_Msg_N
3689               ("address clause can only be given " &
3690                "for imported subprogram",
3691                Name (Address_Clause (E)));
3692          end if;
3693       end if;
3694
3695       --  For non-foreign convention subprograms, this is where we create
3696       --  the extra formals (for accessibility level and constrained bit
3697       --  information). We delay this till the freeze point precisely so
3698       --  that we know the convention!
3699
3700       if not Has_Foreign_Convention (E) then
3701          Create_Extra_Formals (E);
3702          Set_Mechanisms (E);
3703
3704          --  If this is convention Ada and a Valued_Procedure, that's odd
3705
3706          if Ekind (E) = E_Procedure
3707            and then Is_Valued_Procedure (E)
3708            and then Convention (E) = Convention_Ada
3709          then
3710             Error_Msg_N
3711               ("?Valued_Procedure has no effect for convention Ada", E);
3712             Set_Is_Valued_Procedure (E, False);
3713          end if;
3714
3715       --  Case of foreign convention
3716
3717       else
3718          Set_Mechanisms (E);
3719
3720          --  For foreign conventions, do not permit return of an
3721          --  unconstrained array.
3722
3723          --  Note: we *do* allow a return by descriptor for the VMS case,
3724          --  though here there is probably more to be done ???
3725
3726          if Ekind (E) = E_Function then
3727             Retype := Underlying_Type (Etype (E));
3728
3729             --  If no return type, probably some other error, e.g. a
3730             --  missing full declaration, so ignore.
3731
3732             if No (Retype) then
3733                null;
3734
3735             --  If the return type is generic, we have emitted a warning
3736             --  earlier on, and there is nothing else to check here.
3737             --  Specific instantiations may lead to erroneous behavior.
3738
3739             elsif Is_Generic_Type (Etype (E)) then
3740                null;
3741
3742             elsif Is_Array_Type (Retype)
3743               and then not Is_Constrained (Retype)
3744               and then Mechanism (E) not in Descriptor_Codes
3745             then
3746                Error_Msg_NE
3747                 ("convention for& does not permit returning " &
3748                   "unconstrained array type", E, E);
3749                return;
3750             end if;
3751          end if;
3752
3753          --  If any of the formals for an exported foreign convention
3754          --  subprogram have defaults, then emit an appropriate warning
3755          --  since this is odd (default cannot be used from non-Ada code)
3756
3757          if Is_Exported (E) then
3758             F := First_Formal (E);
3759             while Present (F) loop
3760                if Present (Default_Value (F)) then
3761                   Error_Msg_N
3762                     ("?parameter cannot be defaulted in non-Ada call",
3763                      Default_Value (F));
3764                end if;
3765
3766                Next_Formal (F);
3767             end loop;
3768          end if;
3769       end if;
3770
3771       --  For VMS, descriptor mechanisms for parameters are allowed only
3772       --  for imported subprograms.
3773
3774       if OpenVMS_On_Target then
3775          if not Is_Imported (E) then
3776             F := First_Formal (E);
3777             while Present (F) loop
3778                if Mechanism (F) in Descriptor_Codes then
3779                   Error_Msg_N
3780                     ("descriptor mechanism for parameter not permitted", F);
3781                   Error_Msg_N
3782                     ("\can only be used for imported subprogram", F);
3783                end if;
3784
3785                Next_Formal (F);
3786             end loop;
3787          end if;
3788       end if;
3789
3790    end Freeze_Subprogram;
3791
3792    -----------------------
3793    --  Is_Fully_Defined --
3794    -----------------------
3795
3796    --  Should this be in Sem_Util ???
3797
3798    function Is_Fully_Defined (T : Entity_Id) return Boolean is
3799    begin
3800       if Ekind (T) = E_Class_Wide_Type then
3801          return Is_Fully_Defined (Etype (T));
3802       else
3803          return not Is_Private_Type (T)
3804            or else Present (Full_View (Base_Type (T)));
3805       end if;
3806    end Is_Fully_Defined;
3807
3808    ---------------------------------
3809    -- Process_Default_Expressions --
3810    ---------------------------------
3811
3812    procedure Process_Default_Expressions
3813      (E     : Entity_Id;
3814       After : in out Node_Id)
3815    is
3816       Loc    : constant Source_Ptr := Sloc (E);
3817       Dbody  : Node_Id;
3818       Formal : Node_Id;
3819       Dcopy  : Node_Id;
3820       Dnam   : Entity_Id;
3821
3822    begin
3823       Set_Default_Expressions_Processed (E);
3824
3825       --  A subprogram instance and its associated anonymous subprogram
3826       --  share their signature. The default expression functions are defined
3827       --  in the wrapper packages for the anonymous subprogram, and should
3828       --  not be generated again for the instance.
3829
3830       if Is_Generic_Instance (E)
3831         and then Present (Alias (E))
3832         and then Default_Expressions_Processed (Alias (E))
3833       then
3834          return;
3835       end if;
3836
3837       Formal := First_Formal (E);
3838
3839       while Present (Formal) loop
3840          if Present (Default_Value (Formal)) then
3841
3842             --  We work with a copy of the default expression because we
3843             --  do not want to disturb the original, since this would mess
3844             --  up the conformance checking.
3845
3846             Dcopy := New_Copy_Tree (Default_Value (Formal));
3847
3848             --  The analysis of the expression may generate insert actions,
3849             --  which of course must not be executed. We wrap those actions
3850             --  in a procedure that is not called, and later on eliminated.
3851             --  The following cases have no side-effects, and are analyzed
3852             --  directly.
3853
3854             if Nkind (Dcopy) = N_Identifier
3855               or else Nkind (Dcopy) = N_Expanded_Name
3856               or else Nkind (Dcopy) = N_Integer_Literal
3857               or else (Nkind (Dcopy) = N_Real_Literal
3858                         and then not Vax_Float (Etype (Dcopy)))
3859               or else Nkind (Dcopy) = N_Character_Literal
3860               or else Nkind (Dcopy) = N_String_Literal
3861               or else Nkind (Dcopy) = N_Null
3862               or else (Nkind (Dcopy) = N_Attribute_Reference
3863                         and then
3864                        Attribute_Name (Dcopy) = Name_Null_Parameter)
3865
3866             then
3867
3868                --  If there is no default function, we must still do a full
3869                --  analyze call on the default value, to ensure that all
3870                --  error checks are performed, e.g. those associated with
3871                --  static evaluation. Note that this branch will always be
3872                --  taken if the analyzer is turned off (but we still need the
3873                --  error checks).
3874
3875                --  Note: the setting of parent here is to meet the requirement
3876                --  that we can only analyze the expression while attached to
3877                --  the tree. Really the requirement is that the parent chain
3878                --  be set, we don't actually need to be in the tree.
3879
3880                Set_Parent (Dcopy, Declaration_Node (Formal));
3881                Analyze (Dcopy);
3882
3883                --  Default expressions are resolved with their own type if the
3884                --  context is generic, to avoid anomalies with private types.
3885
3886                if Ekind (Scope (E)) = E_Generic_Package then
3887                   Resolve (Dcopy, Etype (Dcopy));
3888                else
3889                   Resolve (Dcopy, Etype (Formal));
3890                end if;
3891
3892                --  If that resolved expression will raise constraint error,
3893                --  then flag the default value as raising constraint error.
3894                --  This allows a proper error message on the calls.
3895
3896                if Raises_Constraint_Error (Dcopy) then
3897                   Set_Raises_Constraint_Error (Default_Value (Formal));
3898                end if;
3899
3900             --  If the default is a parameterless call, we use the name of
3901             --  the called function directly, and there is no body to build.
3902
3903             elsif Nkind (Dcopy) = N_Function_Call
3904               and then No (Parameter_Associations (Dcopy))
3905             then
3906                null;
3907
3908             --  Else construct and analyze the body of a wrapper procedure
3909             --  that contains an object declaration to hold the expression.
3910             --  Given that this is done only to complete the analysis, it
3911             --  simpler to build a procedure than a function which might
3912             --  involve secondary stack expansion.
3913
3914             else
3915                Dnam :=
3916                  Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
3917
3918                Dbody :=
3919                  Make_Subprogram_Body (Loc,
3920                    Specification =>
3921                      Make_Procedure_Specification (Loc,
3922                        Defining_Unit_Name => Dnam),
3923
3924                    Declarations => New_List (
3925                      Make_Object_Declaration (Loc,
3926                        Defining_Identifier =>
3927                          Make_Defining_Identifier (Loc,
3928                            New_Internal_Name ('T')),
3929                          Object_Definition =>
3930                            New_Occurrence_Of (Etype (Formal), Loc),
3931                          Expression => New_Copy_Tree (Dcopy))),
3932
3933                    Handled_Statement_Sequence =>
3934                      Make_Handled_Sequence_Of_Statements (Loc,
3935                        Statements => New_List));
3936
3937                Set_Scope (Dnam, Scope (E));
3938                Set_Assignment_OK (First (Declarations (Dbody)));
3939                Set_Is_Eliminated (Dnam);
3940                Insert_After (After, Dbody);
3941                Analyze (Dbody);
3942                After := Dbody;
3943             end if;
3944          end if;
3945
3946          Next_Formal (Formal);
3947       end loop;
3948
3949    end Process_Default_Expressions;
3950
3951    ----------------------------------------
3952    -- Set_Component_Alignment_If_Not_Set --
3953    ----------------------------------------
3954
3955    procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id) is
3956    begin
3957       --  Ignore if not base type, subtypes don't need anything
3958
3959       if Typ /= Base_Type (Typ) then
3960          return;
3961       end if;
3962
3963       --  Do not override existing representation
3964
3965       if Is_Packed (Typ) then
3966          return;
3967
3968       elsif Has_Specified_Layout (Typ) then
3969          return;
3970
3971       elsif Component_Alignment (Typ) /= Calign_Default then
3972          return;
3973
3974       else
3975          Set_Component_Alignment
3976            (Typ, Scope_Stack.Table
3977                   (Scope_Stack.Last).Component_Alignment_Default);
3978       end if;
3979    end Set_Component_Alignment_If_Not_Set;
3980
3981    ---------------------------
3982    -- Set_Debug_Info_Needed --
3983    ---------------------------
3984
3985    procedure Set_Debug_Info_Needed (T : Entity_Id) is
3986    begin
3987       if No (T)
3988         or else Needs_Debug_Info (T)
3989         or else Debug_Info_Off (T)
3990       then
3991          return;
3992       else
3993          Set_Needs_Debug_Info (T);
3994       end if;
3995
3996       if Is_Object (T) then
3997          Set_Debug_Info_Needed (Etype (T));
3998
3999       elsif Is_Type (T) then
4000          Set_Debug_Info_Needed (Etype (T));
4001
4002          if Is_Record_Type (T) then
4003             declare
4004                Ent : Entity_Id := First_Entity (T);
4005             begin
4006                while Present (Ent) loop
4007                   Set_Debug_Info_Needed (Ent);
4008                   Next_Entity (Ent);
4009                end loop;
4010             end;
4011
4012          elsif Is_Array_Type (T) then
4013             Set_Debug_Info_Needed (Component_Type (T));
4014
4015             declare
4016                Indx : Node_Id := First_Index (T);
4017             begin
4018                while Present (Indx) loop
4019                   Set_Debug_Info_Needed (Etype (Indx));
4020                   Indx := Next_Index (Indx);
4021                end loop;
4022             end;
4023
4024             if Is_Packed (T) then
4025                Set_Debug_Info_Needed (Packed_Array_Type (T));
4026             end if;
4027
4028          elsif Is_Access_Type (T) then
4029             Set_Debug_Info_Needed (Directly_Designated_Type (T));
4030
4031          elsif Is_Private_Type (T) then
4032             Set_Debug_Info_Needed (Full_View (T));
4033
4034          elsif Is_Protected_Type (T) then
4035             Set_Debug_Info_Needed (Corresponding_Record_Type (T));
4036          end if;
4037       end if;
4038
4039    end Set_Debug_Info_Needed;
4040
4041 end Freeze;