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