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