X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Ffreeze.adb;h=15bd6e075e3adfe2bc9e6735612a57831160ad55;hb=c0a208a52ba10b65d217c635ddddf7a07ea51ebd;hp=e0810029314a046d9ad3e7794635460fd5a48e7b;hpb=b2603bc099601ce4cb49e46ddfcd560795cf7f43;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index e0810029314..15bd6e075e3 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6,18 +6,17 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- You should have received a copy of the GNU General Public License along -- --- with this program; see file COPYING3. If not see -- --- . -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -36,12 +35,14 @@ with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; with Exp_Tss; use Exp_Tss; with Layout; use Layout; +with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Restrict; use Restrict; with Rident; use Rident; +with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; @@ -100,10 +101,11 @@ package body Freeze is procedure Freeze_And_Append (Ent : Entity_Id; - Loc : Source_Ptr; + N : Node_Id; Result : in out List_Id); -- Freezes Ent using Freeze_Entity, and appends the resulting list of - -- nodes to Result, modifying Result from No_List if necessary. + -- nodes to Result, modifying Result from No_List if necessary. N has + -- the same usage as in Freeze_Entity. procedure Freeze_Enumeration_Type (Typ : Entity_Id); -- Freeze enumeration type. The Esize field is set as processing @@ -137,20 +139,20 @@ package body Freeze is procedure Process_Default_Expressions (E : Entity_Id; After : in out Node_Id); - -- This procedure is called for each subprogram to complete processing - -- of default expressions at the point where all types are known to be - -- frozen. The expressions must be analyzed in full, to make sure that - -- all error processing is done (they have only been pre-analyzed). If - -- the expression is not an entity or literal, its analysis may generate - -- code which must not be executed. In that case we build a function - -- body to hold that code. This wrapper function serves no other purpose - -- (it used to be called to evaluate the default, but now the default is - -- inlined at each point of call). + -- This procedure is called for each subprogram to complete processing of + -- default expressions at the point where all types are known to be frozen. + -- The expressions must be analyzed in full, to make sure that all error + -- processing is done (they have only been pre-analyzed). If the expression + -- is not an entity or literal, its analysis may generate code which must + -- not be executed. In that case we build a function body to hold that + -- code. This wrapper function serves no other purpose (it used to be + -- called to evaluate the default, but now the default is inlined at each + -- point of call). procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id); - -- Typ is a record or array type that is being frozen. This routine - -- sets the default component alignment from the scope stack values - -- if the alignment is otherwise not specified. + -- Typ is a record or array type that is being frozen. This routine sets + -- the default component alignment from the scope stack values if the + -- alignment is otherwise not specified. procedure Check_Debug_Info_Needed (T : Entity_Id); -- As each entity is frozen, this routine is called to deal with the @@ -161,9 +163,9 @@ package body Freeze is -- subsidiary entities have the flag set as required. procedure Undelay_Type (T : Entity_Id); - -- T is a type of a component that we know to be an Itype. - -- We don't want this to have a Freeze_Node, so ensure it doesn't. - -- Do the same for any Full_View or Corresponding_Record_Type. + -- T is a type of a component that we know to be an Itype. We don't want + -- this to have a Freeze_Node, so ensure it doesn't. Do the same for any + -- Full_View or Corresponding_Record_Type. procedure Warn_Overlay (Expr : Node_Id; @@ -203,12 +205,64 @@ package body Freeze is New_S : Entity_Id; After : in out Node_Id) is - Body_Node : constant Node_Id := Build_Renamed_Body (Decl, New_S); + Body_Decl : constant Node_Id := Unit_Declaration_Node (New_S); + Ent : constant Entity_Id := Defining_Entity (Decl); + Body_Node : Node_Id; + Renamed_Subp : Entity_Id; + begin - Insert_After (After, Body_Node); - Mark_Rewrite_Insertion (Body_Node); - Analyze (Body_Node); - After := Body_Node; + -- If the renamed subprogram is intrinsic, there is no need for a + -- wrapper body: we set the alias that will be called and expanded which + -- completes the declaration. This transformation is only legal if the + -- renamed entity has already been elaborated. + + -- Note that it is legal for a renaming_as_body to rename an intrinsic + -- subprogram, as long as the renaming occurs before the new entity + -- is frozen. See RM 8.5.4 (5). + + if Nkind (Body_Decl) = N_Subprogram_Renaming_Declaration + and then Is_Entity_Name (Name (Body_Decl)) + then + Renamed_Subp := Entity (Name (Body_Decl)); + else + Renamed_Subp := Empty; + end if; + + if Present (Renamed_Subp) + and then Is_Intrinsic_Subprogram (Renamed_Subp) + and then + (not In_Same_Source_Unit (Renamed_Subp, Ent) + or else Sloc (Renamed_Subp) < Sloc (Ent)) + + -- We can make the renaming entity intrinsic if the renamed function + -- has an interface name, or if it is one of the shift/rotate + -- operations known to the compiler. + + and then (Present (Interface_Name (Renamed_Subp)) + or else Chars (Renamed_Subp) = Name_Rotate_Left + or else Chars (Renamed_Subp) = Name_Rotate_Right + or else Chars (Renamed_Subp) = Name_Shift_Left + or else Chars (Renamed_Subp) = Name_Shift_Right + or else Chars (Renamed_Subp) = Name_Shift_Right_Arithmetic) + then + Set_Interface_Name (Ent, Interface_Name (Renamed_Subp)); + + if Present (Alias (Renamed_Subp)) then + Set_Alias (Ent, Alias (Renamed_Subp)); + else + Set_Alias (Ent, Renamed_Subp); + end if; + + Set_Is_Intrinsic_Subprogram (Ent); + Set_Has_Completion (Ent); + + else + Body_Node := Build_Renamed_Body (Decl, New_S); + Insert_After (After, Body_Node); + Mark_Rewrite_Insertion (Body_Node); + Analyze (Body_Node); + After := Body_Node; + end if; end Build_And_Analyze_Renamed_Body; ------------------------ @@ -220,12 +274,12 @@ package body Freeze is New_S : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (New_S); - -- We use for the source location of the renamed body, the location - -- of the spec entity. It might seem more natural to use the location - -- of the renaming declaration itself, but that would be wrong, since - -- then the body we create would look as though it was created far - -- too late, and this could cause problems with elaboration order - -- analysis, particularly in connection with instantiations. + -- We use for the source location of the renamed body, the location of + -- the spec entity. It might seem more natural to use the location of + -- the renaming declaration itself, but that would be wrong, since then + -- the body we create would look as though it was created far too late, + -- and this could cause problems with elaboration order analysis, + -- particularly in connection with instantiations. N : constant Node_Id := Unit_Declaration_Node (New_S); Nam : constant Node_Id := Name (N); @@ -301,19 +355,20 @@ package body Freeze is Call_Name := New_Copy (Name (N)); end if; - -- The original name may have been overloaded, but - -- is fully resolved now. + -- Original name may have been overloaded, but is fully resolved now Set_Is_Overloaded (Call_Name, False); end if; -- For simple renamings, subsequent calls can be expanded directly as - -- called to the renamed entity. The body must be generated in any case - -- for calls they may appear elsewhere. + -- calls to the renamed entity. The body must be generated in any case + -- for calls that may appear elsewhere. This is not done in the case + -- where the subprogram is an instantiation because the actual proper + -- body has not been built yet. - if (Ekind (Old_S) = E_Function - or else Ekind (Old_S) = E_Procedure) + if Ekind_In (Old_S, E_Function, E_Procedure) and then Nkind (Decl) = N_Subprogram_Declaration + and then not Is_Generic_Instance (Old_S) then Set_Body_To_Inline (Decl, Old_S); end if; @@ -331,7 +386,6 @@ package body Freeze is Form_Type : constant Entity_Id := Etype (First_Formal (Old_S)); begin - -- The controlling formal may be an access parameter, or the -- actual may be an access value, so adjust accordingly. @@ -380,10 +434,8 @@ package body Freeze is if Present (Formal) then O_Formal := First_Formal (Old_S); Param_Spec := First (Parameter_Specifications (Spec)); - while Present (Formal) loop if Is_Entry (Old_S) then - if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then @@ -446,7 +498,6 @@ package body Freeze is Make_Defining_Identifier (Loc, Chars => Chars (New_S))); Param_Spec := First (Parameter_Specifications (Spec)); - while Present (Param_Spec) loop Set_Defining_Identifier (Param_Spec, Make_Defining_Identifier (Loc, @@ -497,49 +548,7 @@ package body Freeze is if Present (Addr) then Expr := Expression (Addr); - -- If we have no initialization of any kind, then we don't need to - -- place any restrictions on the address clause, because the object - -- will be elaborated after the address clause is evaluated. This - -- happens if the declaration has no initial expression, or the type - -- has no implicit initialization, or the object is imported. - - -- The same holds for all initialized scalar types and all access - -- types. Packed bit arrays of size up to 64 are represented using a - -- modular type with an initialization (to zero) and can be processed - -- like other initialized scalar types. - - -- If the type is controlled, code to attach the object to a - -- finalization chain is generated at the point of declaration, - -- and therefore the elaboration of the object cannot be delayed: - -- the address expression must be a constant. - - if (No (Expression (Decl)) - and then not Needs_Finalization (Typ) - and then - (not Has_Non_Null_Base_Init_Proc (Typ) - or else Is_Imported (E))) - - or else - (Present (Expression (Decl)) - and then Is_Scalar_Type (Typ)) - - or else - Is_Access_Type (Typ) - - or else - (Is_Bit_Packed_Array (Typ) - and then - Is_Modular_Integer_Type (Packed_Array_Type (Typ))) - then - null; - - -- Otherwise, we require the address clause to be constant because - -- the call to the initialization procedure (or the attach code) has - -- to happen at the point of the declaration. - -- Actually the IP call has been moved to the freeze actions - -- anyway, so maybe we can relax this restriction??? - - else + if Needs_Constant_Address (Decl, Typ) then Check_Constant_Address_Clause (Expr, E); -- Has_Delayed_Freeze was set on E when the address clause was @@ -551,7 +560,36 @@ package body Freeze is end if; end if; - if not Error_Posted (Expr) + -- If Rep_Clauses are to be ignored, remove address clause from + -- list attached to entity, because it may be illegal for gigi, + -- for example by breaking order of elaboration.. + + if Ignore_Rep_Clauses then + declare + Rep : Node_Id; + + begin + Rep := First_Rep_Item (E); + + if Rep = Addr then + Set_First_Rep_Item (E, Next_Rep_Item (Addr)); + + else + while Present (Rep) + and then Next_Rep_Item (Rep) /= Addr + loop + Rep := Next_Rep_Item (Rep); + end loop; + end if; + + if Present (Rep) then + Set_Next_Rep_Item (Rep, Next_Rep_Item (Addr)); + end if; + end; + + Rewrite (Addr, Make_Null_Statement (Sloc (E))); + + elsif not Error_Posted (Expr) and then not Needs_Finalization (Typ) then Warn_Overlay (Expr, Typ, Name (Addr)); @@ -568,7 +606,7 @@ package body Freeze is procedure Set_Small_Size (T : Entity_Id; S : Uint); -- Sets the compile time known size (32 bits or less) in the Esize -- field, of T checking for a size clause that was given which attempts - -- to give a smaller size. + -- to give a smaller size, and also checking for an alignment clause. function Size_Known (T : Entity_Id) return Boolean; -- Recursive function that does all the work @@ -589,27 +627,20 @@ package body Freeze is if S > 32 then return; + -- Check for bad size clause given + elsif Has_Size_Clause (T) then if RM_Size (T) < S then Error_Msg_Uint_1 := S; Error_Msg_NE ("size for& too small, minimum allowed is ^", Size_Clause (T), T); - - elsif Unknown_Esize (T) then - Set_Esize (T, S); end if; - -- Set sizes if not set already - - else - if Unknown_Esize (T) then - Set_Esize (T, S); - end if; + -- Set size if not set already - if Unknown_RM_Size (T) then - Set_RM_Size (T, S); - end if; + elsif Unknown_RM_Size (T) then + Set_RM_Size (T, S); end if; end Set_Small_Size; @@ -740,7 +771,7 @@ package body Freeze is return False; -- A subtype of a variant record must not have non-static - -- discriminanted components. + -- discriminated components. elsif T /= Base_Type (T) and then not Static_Discriminated_Components (T) @@ -780,7 +811,7 @@ package body Freeze is and then Present (Parent (T)) and then Nkind (Parent (T)) = N_Full_Type_Declaration and then Nkind (Type_Definition (Parent (T))) = - N_Record_Definition + N_Record_Definition and then not Null_Present (Type_Definition (Parent (T))) and then Present (Variant_Part (Component_List (Type_Definition (Parent (T))))) @@ -792,9 +823,8 @@ package body Freeze is if not Is_Constrained (T) and then - No (Discriminant_Default_Value - (First_Discriminant (T))) - and then Unknown_Esize (T) + No (Discriminant_Default_Value (First_Discriminant (T))) + and then Unknown_RM_Size (T) then return False; end if; @@ -890,12 +920,12 @@ package body Freeze is if Is_Elementary_Type (Ctyp) or else (Is_Array_Type (Ctyp) - and then Present (Packed_Array_Type (Ctyp)) - and then Is_Modular_Integer_Type - (Packed_Array_Type (Ctyp))) + and then Present (Packed_Array_Type (Ctyp)) + and then Is_Modular_Integer_Type + (Packed_Array_Type (Ctyp))) then - -- If RM_Size is known and static, then we can - -- keep accumulating the packed size. + -- If RM_Size is known and static, then we can keep + -- accumulating the packed size. if Known_Static_RM_Size (Ctyp) then @@ -1016,7 +1046,6 @@ package body Freeze is end if; Comp := First_Component (E); - while Present (Comp) loop if not Is_Type (Comp) and then (Strict_Alignment (Etype (Comp)) @@ -1047,7 +1076,9 @@ package body Freeze is -- Do not attempt to analyze case where range was in error - if Error_Posted (Scalar_Range (E)) then + if No (Scalar_Range (E)) + or else Error_Posted (Scalar_Range (E)) + then return; end if; @@ -1136,10 +1167,7 @@ package body Freeze is if Nkind_In (Par, N_Object_Declaration, N_Assignment_Statement) and then Comes_From_Source (Par) then - Temp := - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')); - + Temp := Make_Temporary (Loc, 'T', E); New_N := Make_Object_Declaration (Loc, Defining_Identifier => Temp, @@ -1168,7 +1196,6 @@ package body Freeze is -- as they are generated. procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is - Loc : constant Source_Ptr := Sloc (After); E : Entity_Id; Decl : Node_Id; @@ -1182,10 +1209,7 @@ package body Freeze is -- Freeze_All_Ent -- -------------------- - procedure Freeze_All_Ent - (From : Entity_Id; - After : in out Node_Id) - is + procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id) is E : Entity_Id; Flist : List_Id; Lastn : Node_Id; @@ -1239,6 +1263,13 @@ package body Freeze is End_Package_Scope (E); + if Is_Generic_Instance (E) + and then Has_Delayed_Freeze (E) + then + Set_Has_Delayed_Freeze (E, False); + Expand_N_Package_Declaration (Unit_Declaration_Node (E)); + end if; + elsif Ekind (E) in Task_Kind and then (Nkind (Parent (E)) = N_Task_Type_Declaration @@ -1267,15 +1298,14 @@ package body Freeze is Subp : Entity_Id; begin - Prim := First_Elmt (Prim_List); - + Prim := First_Elmt (Prim_List); while Present (Prim) loop Subp := Node (Prim); if Comes_From_Source (Subp) and then not Is_Frozen (Subp) then - Flist := Freeze_Entity (Subp, Loc); + Flist := Freeze_Entity (Subp, After); Process_Flist; end if; @@ -1285,13 +1315,37 @@ package body Freeze is end if; if not Is_Frozen (E) then - Flist := Freeze_Entity (E, Loc); + Flist := Freeze_Entity (E, After); Process_Flist; + + -- If already frozen, and there are delayed aspects, this is where + -- we do the visibility check for these aspects (see Sem_Ch13 spec + -- for a description of how we handle aspect visibility). + + elsif Has_Delayed_Aspects (E) then + declare + Ritem : Node_Id; + + begin + Ritem := First_Rep_Item (E); + while Present (Ritem) loop + if Nkind (Ritem) = N_Aspect_Specification + and then Entity (Ritem) = E + and then Is_Delayed_Aspect (Ritem) + then + Check_Aspect_At_End_Of_Declarations (Ritem); + end if; + + Ritem := Next_Rep_Item (Ritem); + end loop; + end; end if; -- If an incomplete type is still not frozen, this may be a -- premature freezing because of a body declaration that follows. - -- Indicate where the freezing took place. + -- Indicate where the freezing took place. Freezing will happen + -- if the body comes from source, but not if it is internally + -- generated, for example as the body of a type invariant. -- If the freezing is caused by the end of the current declarative -- part, it is a Taft Amendment type, and there is no error. @@ -1303,14 +1357,23 @@ package body Freeze is Bod : constant Node_Id := Next (After); begin - if (Nkind (Bod) = N_Subprogram_Body - or else Nkind (Bod) = N_Entry_Body - or else Nkind (Bod) = N_Package_Body - or else Nkind (Bod) = N_Protected_Body - or else Nkind (Bod) = N_Task_Body + -- The presence of a body freezes all entities previously + -- declared in the current list of declarations, but this + -- does not apply if the body does not come from source. + -- A type invariant is transformed into a subprogram body + -- which is placed at the end of the private part of the + -- current package, but this body does not freeze incomplete + -- types that may be declared in this private part. + + if (Nkind_In (Bod, N_Subprogram_Body, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Task_Body) or else Nkind (Bod) in N_Body_Stub) - and then - List_Containing (After) = List_Containing (Parent (E)) + and then + List_Containing (After) = List_Containing (Parent (E)) + and then Comes_From_Source (Bod) then Error_Msg_Sloc := Sloc (Next (After)); Error_Msg_NE @@ -1334,6 +1397,9 @@ package body Freeze is -- point at which such functions are constructed (after all types that -- might be used in such expressions have been frozen). + -- For subprograms that are renaming_as_body, we create the wrapper + -- bodies as needed. + -- We also add finalization chains to access types whose designated -- types are controlled. This is normally done when freezing the type, -- but this misses recursive type definitions where the later members @@ -1353,7 +1419,11 @@ package body Freeze is Decl := Unit_Declaration_Node (E); if Nkind (Decl) = N_Subprogram_Renaming_Declaration then - Build_And_Analyze_Renamed_Body (Decl, E, After); + if Error_Posted (Decl) then + Set_Has_Completion (E); + else + Build_And_Analyze_Renamed_Body (Decl, E, After); + end if; elsif Nkind (Decl) = N_Subprogram_Declaration and then Present (Corresponding_Body (Decl)) @@ -1374,11 +1444,10 @@ package body Freeze is then declare Ent : Entity_Id; + begin Ent := First_Entity (E); - while Present (Ent) loop - if Is_Entry (Ent) and then not Default_Expressions_Processed (Ent) then @@ -1389,13 +1458,24 @@ package body Freeze is end loop; end; + -- We add finalization masters to access types whose designated types + -- require finalization. This is normally done when freezing the + -- type, but this misses recursive type definitions where the later + -- members of the recursion introduce controlled components (such as + -- can happen when incomplete types are involved), as well cases + -- where a component type is private and the controlled full type + -- occurs after the access type is frozen. Cases that don't need a + -- finalization master are generic formal types (the actual type will + -- have it) and types with Java and CIL conventions, since those are + -- used for API bindings. (Are there any other cases that should be + -- excluded here???) + elsif Is_Access_Type (E) and then Comes_From_Source (E) - and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type + and then not Is_Generic_Type (E) and then Needs_Finalization (Designated_Type (E)) - and then No (Associated_Final_Chain (E)) then - Build_Final_List (Parent (E), E); + Build_Finalization_Master (E); end if; Next_Entity (E); @@ -1408,10 +1488,10 @@ package body Freeze is procedure Freeze_And_Append (Ent : Entity_Id; - Loc : Source_Ptr; + N : Node_Id; Result : in out List_Id) is - L : constant List_Id := Freeze_Entity (Ent, Loc); + L : constant List_Id := Freeze_Entity (Ent, N); begin if Is_Non_Empty_List (L) then if Result = No_List then @@ -1427,7 +1507,7 @@ package body Freeze is ------------------- procedure Freeze_Before (N : Node_Id; T : Entity_Id) is - Freeze_Nodes : constant List_Id := Freeze_Entity (T, Sloc (N)); + Freeze_Nodes : constant List_Id := Freeze_Entity (T, N); begin if Is_Non_Empty_List (Freeze_Nodes) then Insert_Actions (N, Freeze_Nodes); @@ -1438,18 +1518,24 @@ package body Freeze is -- Freeze_Entity -- ------------------- - function Freeze_Entity (E : Entity_Id; Loc : Source_Ptr) return List_Id is + function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (N); Test_E : Entity_Id := E; Comp : Entity_Id; F_Node : Node_Id; - Result : List_Id; Indx : Node_Id; Formal : Entity_Id; Atype : Entity_Id; + Result : List_Id := No_List; + -- List of freezing actions, left at No_List if none + Has_Default_Initialization : Boolean := False; -- This flag gets set to true for a variable with default initialization + procedure Add_To_Result (N : Node_Id); + -- N is a freezing action to be appended to the Result + procedure Check_Current_Instance (Comp_Decl : Node_Id); -- Check that an Access or Unchecked_Access attribute with a prefix -- which is the current instance type can only be applied when the type @@ -1468,6 +1554,19 @@ package body Freeze is -- Freeze each component, handle some representation clauses, and freeze -- primitive operations if this is a tagged type. + ------------------- + -- Add_To_Result -- + ------------------- + + procedure Add_To_Result (N : Node_Id) is + begin + if No (Result) then + Result := New_List (N); + else + Append (N, Result); + end if; + end Add_To_Result; + ---------------------------- -- After_Last_Declaration -- ---------------------------- @@ -1494,14 +1593,93 @@ package body Freeze is procedure Check_Current_Instance (Comp_Decl : Node_Id) is - Rec_Type : constant Entity_Id := - Scope (Defining_Identifier (Comp_Decl)); - - Decl : constant Node_Id := Parent (Rec_Type); + function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean; + -- Determine whether Typ is compatible with the rules for aliased + -- views of types as defined in RM 3.10 in the various dialects. function Process (N : Node_Id) return Traverse_Result; -- Process routine to apply check to given node + ----------------------------- + -- Is_Aliased_View_Of_Type -- + ----------------------------- + + function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean is + Typ_Decl : constant Node_Id := Parent (Typ); + + begin + -- Common case + + if Nkind (Typ_Decl) = N_Full_Type_Declaration + and then Limited_Present (Type_Definition (Typ_Decl)) + then + return True; + + -- The following paragraphs describe what a legal aliased view of + -- a type is in the various dialects of Ada. + + -- Ada 95 + + -- The current instance of a limited type, and a formal parameter + -- or generic formal object of a tagged type. + + -- Ada 95 limited type + -- * Type with reserved word "limited" + -- * A protected or task type + -- * A composite type with limited component + + elsif Ada_Version <= Ada_95 then + return Is_Limited_Type (Typ); + + -- Ada 2005 + + -- The current instance of a limited tagged type, a protected + -- type, a task type, or a type that has the reserved word + -- "limited" in its full definition ... a formal parameter or + -- generic formal object of a tagged type. + + -- Ada 2005 limited type + -- * Type with reserved word "limited", "synchronized", "task" + -- or "protected" + -- * A composite type with limited component + -- * A derived type whose parent is a non-interface limited type + + elsif Ada_Version = Ada_2005 then + return + (Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ)) + or else + (Is_Derived_Type (Typ) + and then not Is_Interface (Etype (Typ)) + and then Is_Limited_Type (Etype (Typ))); + + -- Ada 2012 and beyond + + -- The current instance of an immutably limited type ... a formal + -- parameter or generic formal object of a tagged type. + + -- Ada 2012 limited type + -- * Type with reserved word "limited", "synchronized", "task" + -- or "protected" + -- * A composite type with limited component + -- * A derived type whose parent is a non-interface limited type + -- * An incomplete view + + -- Ada 2012 immutably limited type + -- * Explicitly limited record type + -- * Record extension with "limited" present + -- * Non-formal limited private type that is either tagged + -- or has at least one access discriminant with a default + -- expression + -- * Task type, protected type or synchronized interface + -- * Type derived from immutably limited type + + else + return + Is_Immutably_Limited_Type (Typ) + or else Is_Incomplete_Type (Typ); + end if; + end Is_Aliased_View_Of_Type; + ------------- -- Process -- ------------- @@ -1530,24 +1708,15 @@ package body Freeze is procedure Traverse is new Traverse_Proc (Process); - -- Start of processing for Check_Current_Instance + -- Local variables - begin - -- In Ada95, the (imprecise) rule is that the current instance of a - -- limited type is aliased. In Ada2005, limitedness must be explicit: - -- either a tagged type, or a limited record. - - if Is_Limited_Type (Rec_Type) - and then (Ada_Version < Ada_05 or else Is_Tagged_Type (Rec_Type)) - then - return; + Rec_Type : constant Entity_Id := + Scope (Defining_Identifier (Comp_Decl)); - elsif Nkind (Decl) = N_Full_Type_Declaration - and then Limited_Present (Type_Definition (Decl)) - then - return; + -- Start of processing for Check_Current_Instance - else + begin + if not Is_Aliased_View_Of_Type (Rec_Type) then Traverse (Comp_Decl); end if; end Check_Current_Instance; @@ -1563,6 +1732,7 @@ package body Freeze is if Nkind (Decl) = N_Full_Type_Declaration then declare Tdef : constant Node_Id := Type_Definition (Decl); + begin if Nkind (Tdef) = N_Modular_Type_Definition then declare @@ -1709,12 +1879,7 @@ package body Freeze is then IR := Make_Itype_Reference (Sloc (Comp)); Set_Itype (IR, Desig); - - if No (Result) then - Result := New_List (IR); - else - Append (IR, Result); - end if; + Add_To_Result (IR); end if; elsif Ekind (Typ) = E_Anonymous_Access_Subprogram_Type @@ -1727,47 +1892,13 @@ package body Freeze is -- Start of processing for Freeze_Record_Type begin - -- If this is a subtype of a controlled type, declared without a - -- constraint, the _controller may not appear in the component list - -- if the parent was not frozen at the point of subtype declaration. - -- Inherit the _controller component now. - - if Rec /= Base_Type (Rec) - and then Has_Controlled_Component (Rec) - then - if Nkind (Parent (Rec)) = N_Subtype_Declaration - and then Is_Entity_Name (Subtype_Indication (Parent (Rec))) - then - Set_First_Entity (Rec, First_Entity (Base_Type (Rec))); - - -- If this is an internal type without a declaration, as for - -- record component, the base type may not yet be frozen, and its - -- controller has not been created. Add an explicit freeze node - -- for the itype, so it will be frozen after the base type. This - -- freeze node is used to communicate with the expander, in order - -- to create the controller for the enclosing record, and it is - -- deleted afterwards (see exp_ch3). It must not be created when - -- expansion is off, because it might appear in the wrong context - -- for the back end. - - elsif Is_Itype (Rec) - and then Has_Delayed_Freeze (Base_Type (Rec)) - and then - Nkind (Associated_Node_For_Itype (Rec)) = - N_Component_Declaration - and then Expander_Active - then - Ensure_Freeze_Node (Rec); - end if; - end if; - -- Freeze components and embedded subtypes Comp := First_Entity (Rec); Prev := Empty; while Present (Comp) loop - -- First handle the (real) component case + -- First handle the component case if Ekind (Comp) = E_Component or else Ekind (Comp) = E_Discriminant @@ -1791,7 +1922,7 @@ package body Freeze is Undelay_Type (Etype (Comp)); end if; - Freeze_And_Append (Etype (Comp), Loc, Result); + Freeze_And_Append (Etype (Comp), N, Result); -- Check for error of component clause given for variable -- sized type. We have to delay this test till this point, @@ -1799,12 +1930,18 @@ package body Freeze is -- if it is variable length. We omit this test in a generic -- context, it will be applied at instantiation time. + -- We also omit this test in CodePeer mode, since we do not + -- have sufficient info on size and representation clauses. + if Present (CC) then Placed_Component := True; if Inside_A_Generic then null; + elsif CodePeer_Mode then + null; + elsif not Size_Known_At_Compile_Time (Underlying_Type (Etype (Comp))) @@ -1838,129 +1975,12 @@ package body Freeze is Component_Name (Component_Clause (Comp))); end if; end if; - - -- If component clause is present, then deal with the non- - -- default bit order case for Ada 95 mode. The required - -- processing for Ada 2005 mode is handled separately after - -- processing all components. - - -- We only do this processing for the base type, and in - -- fact that's important, since otherwise if there are - -- record subtypes, we could reverse the bits once for - -- each subtype, which would be incorrect. - - if Present (CC) - and then Reverse_Bit_Order (Rec) - and then Ekind (E) = E_Record_Type - and then Ada_Version <= Ada_95 - then - declare - CFB : constant Uint := Component_Bit_Offset (Comp); - CSZ : constant Uint := Esize (Comp); - CLC : constant Node_Id := Component_Clause (Comp); - Pos : constant Node_Id := Position (CLC); - FB : constant Node_Id := First_Bit (CLC); - - Storage_Unit_Offset : constant Uint := - CFB / System_Storage_Unit; - - Start_Bit : constant Uint := - CFB mod System_Storage_Unit; - - begin - -- Cases where field goes over storage unit boundary - - if Start_Bit + CSZ > System_Storage_Unit then - - -- Allow multi-byte field but generate warning - - if Start_Bit mod System_Storage_Unit = 0 - and then CSZ mod System_Storage_Unit = 0 - then - Error_Msg_N - ("multi-byte field specified with non-standard" - & " Bit_Order?", CLC); - - if Bytes_Big_Endian then - Error_Msg_N - ("bytes are not reversed " - & "(component is big-endian)?", CLC); - else - Error_Msg_N - ("bytes are not reversed " - & "(component is little-endian)?", CLC); - end if; - - -- Do not allow non-contiguous field - - else - Error_Msg_N - ("attempt to specify non-contiguous field " - & "not permitted", CLC); - Error_Msg_N - ("\caused by non-standard Bit_Order " - & "specified", CLC); - Error_Msg_N - ("\consider possibility of using " - & "Ada 2005 mode here", CLC); - end if; - - -- Case where field fits in one storage unit - - else - -- Give warning if suspicious component clause - - if Intval (FB) >= System_Storage_Unit - and then Warn_On_Reverse_Bit_Order - then - Error_Msg_N - ("?Bit_Order clause does not affect " & - "byte ordering", Pos); - Error_Msg_Uint_1 := - Intval (Pos) + Intval (FB) / - System_Storage_Unit; - Error_Msg_N - ("?position normalized to ^ before bit " & - "order interpreted", Pos); - end if; - - -- Here is where we fix up the Component_Bit_Offset - -- value to account for the reverse bit order. - -- Some examples of what needs to be done are: - - -- First_Bit .. Last_Bit Component_Bit_Offset - -- old new old new - - -- 0 .. 0 7 .. 7 0 7 - -- 0 .. 1 6 .. 7 0 6 - -- 0 .. 2 5 .. 7 0 5 - -- 0 .. 7 0 .. 7 0 4 - - -- 1 .. 1 6 .. 6 1 6 - -- 1 .. 4 3 .. 6 1 3 - -- 4 .. 7 0 .. 3 4 0 - - -- The general rule is that the first bit is - -- is obtained by subtracting the old ending bit - -- from storage_unit - 1. - - Set_Component_Bit_Offset - (Comp, - (Storage_Unit_Offset * System_Storage_Unit) + - (System_Storage_Unit - 1) - - (Start_Bit + CSZ - 1)); - - Set_Normalized_First_Bit - (Comp, - Component_Bit_Offset (Comp) mod - System_Storage_Unit); - end if; - end; - end if; end; end if; - -- Gather data for possible Implicit_Packing later + -- Gather data for possible Implicit_Packing later. Note that at + -- this stage we might be dealing with a real component, or with + -- an implicit subtype declaration. if not Is_Scalar_Type (Etype (Comp)) then All_Scalar_Components := False; @@ -1973,12 +1993,12 @@ package body Freeze is -- If the component is an Itype with Delayed_Freeze and is either -- a record or array subtype and its base type has not yet been - -- frozen, we must remove this from the entity list of this - -- record and put it on the entity list of the scope of its base - -- type. Note that we know that this is not the type of a - -- component since we cleared Has_Delayed_Freeze for it in the - -- previous loop. Thus this must be the Designated_Type of an - -- access type, which is the type of a component. + -- frozen, we must remove this from the entity list of this record + -- and put it on the entity list of the scope of its base type. + -- Note that we know that this is not the type of a component + -- since we cleared Has_Delayed_Freeze for it in the previous + -- loop. Thus this must be the Designated_Type of an access type, + -- which is the type of a component. if Is_Itype (Comp) and then Is_Type (Scope (Comp)) @@ -2067,13 +2087,13 @@ package body Freeze is then if Is_Entity_Name (Expression (Alloc)) then Freeze_And_Append - (Entity (Expression (Alloc)), Loc, Result); + (Entity (Expression (Alloc)), N, Result); elsif Nkind (Expression (Alloc)) = N_Subtype_Indication then Freeze_And_Append (Entity (Subtype_Mark (Expression (Alloc))), - Loc, Result); + N, Result); end if; elsif Is_Itype (Designated_Type (Etype (Comp))) then @@ -2081,7 +2101,7 @@ package body Freeze is else Freeze_And_Append - (Designated_Type (Etype (Comp)), Loc, Result); + (Designated_Type (Etype (Comp)), N, Result); end if; end if; end; @@ -2102,37 +2122,45 @@ package body Freeze is then Freeze_And_Append (Designated_Type - (Component_Type (Etype (Comp))), Loc, Result); + (Component_Type (Etype (Comp))), N, Result); end if; Prev := Comp; Next_Entity (Comp); end loop; - -- Deal with pragma Bit_Order + -- Deal with Bit_Order aspect specifying a non-default bit order if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then if not Placed_Component then ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order); - Error_Msg_N - ("?Bit_Order specification has no effect", ADC); + Error_Msg_N ("?Bit_Order specification has no effect", ADC); Error_Msg_N ("\?since no component clauses were specified", ADC); - -- Here is where we do Ada 2005 processing for bit order (the Ada - -- 95 case was already taken care of above). + -- Here is where we do the processing for reversed bit order - elsif Ada_Version >= Ada_05 then + else Adjust_Record_For_Reverse_Bit_Order (Rec); end if; end if; + -- Complete error checking on record representation clause (e.g. + -- overlap of components). This is called after adjusting the + -- record for reverse bit order. + + declare + RRC : constant Node_Id := Get_Record_Representation_Clause (Rec); + begin + if Present (RRC) then + Check_Record_Representation_Clause (RRC); + end if; + end; + -- Set OK_To_Reorder_Components depending on debug flags - if Rec = Base_Type (Rec) - and then Convention (Rec) = Convention_Ada - then + if Is_Base_Type (Rec) and then Convention (Rec) = Convention_Ada then if (Has_Discriminants (Rec) and then Debug_Flag_Dot_V) or else (not Has_Discriminants (Rec) and then Debug_Flag_Dot_R) @@ -2163,7 +2191,7 @@ package body Freeze is -- Give warning if redundant constructs warnings on if Warn_On_Redundant_Constructs then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?pragma Pack has no effect, no unplaced components", Get_Rep_Pragma (Rec, Name_Pack)); end if; @@ -2179,34 +2207,38 @@ package body Freeze is if Ekind (Rec) = E_Record_Type then if Present (Corresponding_Remote_Type (Rec)) then - Freeze_And_Append - (Corresponding_Remote_Type (Rec), Loc, Result); + Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result); end if; Comp := First_Component (Rec); while Present (Comp) loop - if Has_Controlled_Component (Etype (Comp)) - or else (Chars (Comp) /= Name_uParent - and then Is_Controlled (Etype (Comp))) - or else (Is_Protected_Type (Etype (Comp)) - and then Present - (Corresponding_Record_Type (Etype (Comp))) - and then Has_Controlled_Component - (Corresponding_Record_Type (Etype (Comp)))) + + -- Do not set Has_Controlled_Component on a class-wide + -- equivalent type. See Make_CW_Equivalent_Type. + + if not Is_Class_Wide_Equivalent_Type (Rec) + and then (Has_Controlled_Component (Etype (Comp)) + or else (Chars (Comp) /= Name_uParent + and then Is_Controlled (Etype (Comp))) + or else (Is_Protected_Type (Etype (Comp)) + and then Present + (Corresponding_Record_Type + (Etype (Comp))) + and then Has_Controlled_Component + (Corresponding_Record_Type + (Etype (Comp))))) then Set_Has_Controlled_Component (Rec); - exit; end if; if Has_Unchecked_Union (Etype (Comp)) then Set_Has_Unchecked_Union (Rec); end if; - if Has_Per_Object_Constraint (Comp) then - - -- Scan component declaration for likely misuses of current - -- instance, either in a constraint or a default expression. + -- Scan component declaration for likely misuses of current + -- instance, either in a constraint or a default expression. + if Has_Per_Object_Constraint (Comp) then Check_Current_Instance (Parent (Comp)); end if; @@ -2224,7 +2256,6 @@ package body Freeze is if Is_First_Subtype (Rec) then Comp := First_Component (Rec); - while Present (Comp) loop if Present (Component_Clause (Comp)) and then (Is_Fixed_Point_Type (Etype (Comp)) @@ -2302,17 +2333,20 @@ package body Freeze is -- less than the sum of the object sizes (no point in packing if -- this is not the case). - and then Esize (Rec) < Scalar_Component_Total_Esize + and then RM_Size (Rec) < Scalar_Component_Total_Esize -- And the total RM size cannot be greater than the specified size -- since otherwise packing will not get us where we have to be! - and then Esize (Rec) >= Scalar_Component_Total_RM_Size + and then RM_Size (Rec) >= Scalar_Component_Total_RM_Size - -- Never do implicit packing in CodePeer mode since we don't do - -- any packing ever in this mode (why not???) + -- Never do implicit packing in CodePeer or Alfa modes since + -- we don't do any packing in these modes, since this generates + -- over-complex code that confuses static analysis, and in + -- general, neither CodePeer not GNATprove care about the + -- internal representation of objects. - and then not CodePeer_Mode + and then not (CodePeer_Mode or Alfa_Mode) then -- If implicit packing enabled, do it @@ -2325,9 +2359,9 @@ package body Freeze is declare Sz : constant Node_Id := Size_Clause (Rec); begin - Error_Msg_NE -- CODEFIX + Error_Msg_NE -- CODEFIX ("size given for& too small", Sz, Rec); - Error_Msg_N -- CODEFIX + Error_Msg_N -- CODEFIX ("\use explicit pragma Pack " & "or use pragma Implicit_Packing", Sz); end; @@ -2362,6 +2396,16 @@ package body Freeze is elsif Inside_A_Generic and then External_Ref_In_Generic (Test_E) then return No_List; + -- AI05-0213: A formal incomplete type does not freeze the actual. In + -- the instance, the same applies to the subtype renaming the actual. + + elsif Is_Private_Type (E) + and then Is_Generic_Actual_Type (E) + and then No (Full_View (Base_Type (E))) + and then Ada_Version >= Ada_2012 + then + return No_List; + -- Do not freeze a global entity within an inner scope created during -- expansion. A call to subprogram E within some internal procedure -- (a stream attribute for example) might require freezing E, but the @@ -2381,9 +2425,10 @@ package body Freeze is and then Ekind (Test_E) /= E_Constant then declare - S : Entity_Id := Current_Scope; + S : Entity_Id; begin + S := Current_Scope; while Present (S) loop if Is_Overloadable (S) then if Comes_From_Source (S) @@ -2414,9 +2459,10 @@ package body Freeze is and then Present (Scope (Test_E)) then declare - S : Entity_Id := Scope (Test_E); + S : Entity_Id; begin + S := Scope (Test_E); while Present (S) loop if Is_Generic_Instance (S) then exit; @@ -2431,9 +2477,43 @@ package body Freeze is end; end if; + -- Deal with delayed aspect specifications. The analysis of the aspect + -- is required to be delayed to the freeze point, so we evaluate the + -- pragma or attribute definition clause in the tree at this point. + + if Has_Delayed_Aspects (E) then + declare + Ritem : Node_Id; + Aitem : Node_Id; + + begin + -- Look for aspect specification entries for this entity + + Ritem := First_Rep_Item (E); + while Present (Ritem) loop + if Nkind (Ritem) = N_Aspect_Specification + and then Entity (Ritem) = E + and then Is_Delayed_Aspect (Ritem) + and then Scope (E) = Current_Scope + then + Aitem := Aspect_Rep_Item (Ritem); + + -- Skip if this is an aspect with no corresponding pragma + -- or attribute definition node (such as Default_Value). + + if Present (Aitem) then + Set_Parent (Aitem, Ritem); + Analyze (Aitem); + end if; + end if; + + Next_Rep_Item (Ritem); + end loop; + end; + end if; + -- Here to freeze the entity - Result := No_List; Set_Is_Frozen (E); -- Case of entity being frozen is other than a type @@ -2445,8 +2525,8 @@ package body Freeze is -- Skip this if the entity is stubbed, since we don't need a name -- for any stubbed routine. For the case on intrinsics, if no -- external name is specified, then calls will be handled in - -- Exp_Intr.Expand_Intrinsic_Call, and no name is needed; if - -- an external name is provided, then Expand_Intrinsic_Call leaves + -- Exp_Intr.Expand_Intrinsic_Call, and no name is needed. If an + -- external name is provided, then Expand_Intrinsic_Call leaves -- calls in place for expansion by GIGI. if (Is_Imported (E) or else Is_Exported (E)) @@ -2467,8 +2547,7 @@ package body Freeze is and then Nkind (Parent (E)) = N_Object_Declaration and then Present (Expression (Parent (E))) and then Nkind (Expression (Parent (E))) = N_Aggregate - and then - Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E)) + and then Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E)) then null; end if; @@ -2492,7 +2571,19 @@ package body Freeze is Formal := First_Formal (E); while Present (Formal) loop F_Type := Etype (Formal); - Freeze_And_Append (F_Type, Loc, Result); + + -- AI05-0151 : incomplete types can appear in a profile. + -- By the time the entity is frozen, the full view must + -- be available, unless it is a limited view. + + if Is_Incomplete_Type (F_Type) + and then Present (Full_View (F_Type)) + then + F_Type := Full_View (F_Type); + Set_Etype (Formal, F_Type); + end if; + + Freeze_And_Append (F_Type, N, Result); if Is_Private_Type (F_Type) and then Is_Private_Type (Base_Type (F_Type)) @@ -2556,8 +2647,7 @@ package body Freeze is and then not Has_Size_Clause (F_Type) and then VM_Target = No_VM then - Error_Msg_N - ("& is an 8-bit Ada Boolean?", Formal); + Error_Msg_N ("& is an 8-bit Ada Boolean?", Formal); Error_Msg_N ("\use appropriate corresponding type in C " & "(e.g. char)?", Formal); @@ -2602,6 +2692,11 @@ package body Freeze is and then Is_Array_Type (F_Type) and then not Is_Constrained (F_Type) and then Warn_On_Export_Import + + -- Exclude VM case, since both .NET and JVM can handle + -- unconstrained arrays without a problem. + + and then VM_Target = No_VM then Error_Msg_Qual_Level := 1; @@ -2644,7 +2739,7 @@ package body Freeze is if Is_Itype (Etype (Formal)) and then Ekind (F_Type) = E_Subprogram_Type then - Freeze_And_Append (F_Type, Loc, Result); + Freeze_And_Append (F_Type, N, Result); end if; end if; @@ -2658,7 +2753,18 @@ package body Freeze is -- Freeze return type R_Type := Etype (E); - Freeze_And_Append (R_Type, Loc, Result); + + -- AI05-0151: the return type may have been incomplete + -- at the point of declaration. + + if Ekind (R_Type) = E_Incomplete_Type + and then Present (Full_View (R_Type)) + then + R_Type := Full_View (R_Type); + Set_Etype (E, R_Type); + end if; + + Freeze_And_Append (R_Type, N, Result); -- Check suspicious return type for C function @@ -2732,7 +2838,7 @@ package body Freeze is end if; end if; - -- Give warning for suspicous return of a result of an + -- Give warning for suspicious return of a result of an -- unconstrained array type in a foreign convention -- function. @@ -2744,7 +2850,8 @@ package body Freeze is and then not Is_Constrained (R_Type) -- Exclude imported routines, the warning does not - -- belong on the import, but on the routine definition. + -- belong on the import, but rather on the routine + -- definition. and then not Is_Imported (E) @@ -2771,7 +2878,7 @@ package body Freeze is -- Must freeze its parent first if it is a derived subprogram if Present (Alias (E)) then - Freeze_And_Append (Alias (E), Loc, Result); + Freeze_And_Append (Alias (E), N, Result); end if; -- We don't freeze internal subprograms, because we don't normally @@ -2795,7 +2902,7 @@ package body Freeze is if Present (Etype (E)) and then Ekind (E) /= E_Generic_Function then - Freeze_And_Append (Etype (E), Loc, Result); + Freeze_And_Append (Etype (E), N, Result); end if; -- Special processing for objects created by object declaration @@ -2807,7 +2914,7 @@ package body Freeze is -- Note: we inhibit this check for objects that do not come -- from source because there is at least one case (the - -- expansion of x'class'input where x is abstract) where we + -- expansion of x'Class'Input where x is abstract) where we -- legitimately generate an abstract object. if Is_Abstract_Type (Etype (E)) @@ -2819,7 +2926,8 @@ package body Freeze is Object_Definition (Parent (E))); if Is_CPP_Class (Etype (E)) then - Error_Msg_NE ("\} may need a cpp_constructor", + Error_Msg_NE + ("\} may need a cpp_constructor", Object_Definition (Parent (E)), Etype (E)); end if; end if; @@ -2855,7 +2963,7 @@ package body Freeze is ((Has_Non_Null_Base_Init_Proc (Etype (E)) and then not No_Initialization (Declaration_Node (E)) and then not Is_Value_Type (Etype (E)) - and then not Suppress_Init_Proc (Etype (E))) + and then not Initialization_Suppressed (Etype (E))) or else (Needs_Simple_Initialization (Etype (E)) and then not Is_Internal (E))) @@ -2988,7 +3096,7 @@ package body Freeze is else -- We used to check here that a full type must have preelaborable -- initialization if it completes a private type specified with - -- pragma Preelaborable_Intialization, but that missed cases where + -- pragma Preelaborable_Initialization, but that missed cases where -- the types occur within a generic package, since the freezing -- that occurs within a containing scope generally skips traversal -- of a generic unit's declarations (those will be frozen within @@ -3001,8 +3109,13 @@ package body Freeze is -- nable and used in subsequent checks, so might as well try to -- compute it. + -- In Ada 2012, Freeze_Entities is also used in the front end to + -- trigger the analysis of aspect expressions, so in this case we + -- want to continue the freezing process. + if Present (Scope (E)) and then Is_Generic_Unit (Scope (E)) + and then not Has_Predicates (E) then Check_Compile_Time_Size (E); return No_List; @@ -3043,16 +3156,16 @@ package body Freeze is -- action that causes stuff to be inherited). if Present (Size_Clause (E)) - and then Known_Static_Esize (E) + and then Known_Static_RM_Size (E) and then not Is_Packed (E) and then not Has_Pragma_Pack (E) and then Number_Dimensions (E) = 1 and then not Has_Component_Size_Clause (E) - and then Known_Static_Esize (Ctyp) + and then Known_Static_RM_Size (Ctyp) and then not Is_Limited_Composite (E) and then not Is_Packed (Root_Type (E)) and then not Has_Component_Size_Clause (Root_Type (E)) - and then not CodePeer_Mode + and then not (CodePeer_Mode or Alfa_Mode) then Get_Index_Bounds (First_Index (E), Lo, Hi); @@ -3099,7 +3212,7 @@ package body Freeze is else Error_Msg_NE ("size given for& too small", SZ, E); - Error_Msg_N + Error_Msg_N -- CODEFIX ("\use explicit pragma Pack " & "or use pragma Implicit_Packing", SZ); end if; @@ -3124,25 +3237,38 @@ package body Freeze is end if; -- If ancestor subtype present, freeze that first. Note that this - -- will also get the base type frozen. + -- will also get the base type frozen. Need RM reference ??? Atype := Ancestor_Subtype (E); if Present (Atype) then - Freeze_And_Append (Atype, Loc, Result); + Freeze_And_Append (Atype, N, Result); + + -- No ancestor subtype present + + else + -- See if we have a nearest ancestor that has a predicate. + -- That catches the case of derived type with a predicate. + -- Need RM reference here ??? - -- Otherwise freeze the base type of the entity before freezing - -- the entity itself (RM 13.14(15)). + Atype := Nearest_Ancestor (E); - elsif E /= Base_Type (E) then - Freeze_And_Append (Base_Type (E), Loc, Result); + if Present (Atype) and then Has_Predicates (Atype) then + Freeze_And_Append (Atype, N, Result); + end if; + + -- Freeze base type before freezing the entity (RM 13.14(15)) + + if E /= Base_Type (E) then + Freeze_And_Append (Base_Type (E), N, Result); + end if; end if; -- For a derived type, freeze its parent type first (RM 13.14(15)) elsif Is_Derived_Type (E) then - Freeze_And_Append (Etype (E), Loc, Result); - Freeze_And_Append (First_Subtype (Etype (E)), Loc, Result); + Freeze_And_Append (Etype (E), N, Result); + Freeze_And_Append (First_Subtype (Etype (E)), N, Result); end if; -- For array type, freeze index types and component type first @@ -3150,18 +3276,20 @@ package body Freeze is if Is_Array_Type (E) then declare - Ctyp : constant Entity_Id := Component_Type (E); + FS : constant Entity_Id := First_Subtype (E); + Ctyp : constant Entity_Id := Component_Type (E); + Clause : Entity_Id; Non_Standard_Enum : Boolean := False; -- Set true if any of the index types is an enumeration type -- with a non-standard representation. begin - Freeze_And_Append (Ctyp, Loc, Result); + Freeze_And_Append (Ctyp, N, Result); Indx := First_Index (E); while Present (Indx) loop - Freeze_And_Append (Etype (Indx), Loc, Result); + Freeze_And_Append (Etype (Indx), N, Result); if Is_Enumeration_Type (Etype (Indx)) and then Has_Non_Standard_Rep (Etype (Indx)) @@ -3203,8 +3331,8 @@ package body Freeze is begin if (Is_Packed (E) or else Has_Pragma_Pack (E)) - and then not Has_Atomic_Components (E) and then Known_Static_RM_Size (Ctyp) + and then not Has_Component_Size_Clause (E) then Csiz := UI_Max (RM_Size (Ctyp), 1); @@ -3266,6 +3394,7 @@ package body Freeze is if Present (Comp_Size_C) and then Has_Pragma_Pack (Ent) + and then Warn_On_Redundant_Constructs then Error_Msg_Sloc := Sloc (Comp_Size_C); Error_Msg_NE @@ -3274,6 +3403,8 @@ package body Freeze is Error_Msg_N ("\?explicit component size given#!", Pack_Pragma); + Set_Is_Packed (Base_Type (Ent), False); + Set_Is_Bit_Packed_Array (Base_Type (Ent), False); end if; -- Set component size if not already set by a @@ -3330,19 +3461,151 @@ package body Freeze is -- a representation characteristic, and this -- request may be ignored. - Set_Is_Packed (Base_Type (E), False); + Set_Is_Packed (Base_Type (E), False); + Set_Is_Bit_Packed_Array (Base_Type (E), False); + + if Known_Static_Esize (Component_Type (E)) + and then Esize (Component_Type (E)) = Csiz + then + Set_Has_Non_Standard_Rep + (Base_Type (E), False); + end if; - -- In all other cases, packing is indeed needed + -- In all other cases, packing is indeed needed else - Set_Has_Non_Standard_Rep (Base_Type (E)); - Set_Is_Bit_Packed_Array (Base_Type (E)); - Set_Is_Packed (Base_Type (E)); + Set_Has_Non_Standard_Rep (Base_Type (E), True); + Set_Is_Bit_Packed_Array (Base_Type (E), True); + Set_Is_Packed (Base_Type (E), True); end if; end; end if; end; + -- Check for Atomic_Components or Aliased with unsuitable + -- packing or explicit component size clause given. + + if (Has_Atomic_Components (E) + or else Has_Aliased_Components (E)) + and then (Has_Component_Size_Clause (E) + or else Is_Packed (E)) + then + Alias_Atomic_Check : declare + + procedure Complain_CS (T : String); + -- Outputs error messages for incorrect CS clause or + -- pragma Pack for aliased or atomic components (T is + -- "aliased" or "atomic"); + + ----------------- + -- Complain_CS -- + ----------------- + + procedure Complain_CS (T : String) is + begin + if Has_Component_Size_Clause (E) then + Clause := + Get_Attribute_Definition_Clause + (FS, Attribute_Component_Size); + + if Known_Static_Esize (Ctyp) then + Error_Msg_N + ("incorrect component size for " + & T & " components", Clause); + Error_Msg_Uint_1 := Esize (Ctyp); + Error_Msg_N + ("\only allowed value is^", Clause); + + else + Error_Msg_N + ("component size cannot be given for " + & T & " components", Clause); + end if; + + else + Error_Msg_N + ("cannot pack " & T & " components", + Get_Rep_Pragma (FS, Name_Pack)); + end if; + + return; + end Complain_CS; + + -- Start of processing for Alias_Atomic_Check + + begin + + -- If object size of component type isn't known, we + -- cannot be sure so we defer to the back end. + + if not Known_Static_Esize (Ctyp) then + null; + + -- Case where component size has no effect. First + -- check for object size of component type multiple + -- of the storage unit size. + + elsif Esize (Ctyp) mod System_Storage_Unit = 0 + + -- OK in both packing case and component size case + -- if RM size is known and static and the same as + -- the object size. + + and then + ((Known_Static_RM_Size (Ctyp) + and then Esize (Ctyp) = RM_Size (Ctyp)) + + -- Or if we have an explicit component size + -- clause and the component size and object size + -- are equal. + + or else + (Has_Component_Size_Clause (E) + and then Component_Size (E) = Esize (Ctyp))) + then + null; + + elsif Has_Aliased_Components (E) + or else Is_Aliased (Ctyp) + then + Complain_CS ("aliased"); + + elsif Has_Atomic_Components (E) + or else Is_Atomic (Ctyp) + then + Complain_CS ("atomic"); + end if; + end Alias_Atomic_Check; + end if; + + -- Warn for case of atomic type + + Clause := Get_Rep_Pragma (FS, Name_Atomic); + + if Present (Clause) + and then not Addressable (Component_Size (FS)) + then + Error_Msg_NE + ("non-atomic components of type& may not be " + & "accessible by separate tasks?", Clause, E); + + if Has_Component_Size_Clause (E) then + Error_Msg_Sloc := + Sloc + (Get_Attribute_Definition_Clause + (FS, Attribute_Component_Size)); + Error_Msg_N + ("\because of component size clause#?", + Clause); + + elsif Has_Pragma_Pack (E) then + Error_Msg_Sloc := + Sloc (Get_Rep_Pragma (FS, Name_Pack)); + Error_Msg_N + ("\because of pragma Pack#?", Clause); + end if; + end if; + -- Processing that is done only for subtypes else @@ -3377,9 +3640,9 @@ package body Freeze is end; end if; - -- If any of the index types was an enumeration type with - -- a non-standard rep clause, then we indicate that the - -- array type is always packed (even if it is not bit packed). + -- If any of the index types was an enumeration type with a + -- non-standard rep clause, then we indicate that the array + -- type is always packed (even if it is not bit packed). if Non_Standard_Enum then Set_Has_Non_Standard_Rep (Base_Type (E)); @@ -3397,7 +3660,7 @@ package body Freeze is and then Ekind (E) /= E_String_Literal_Subtype then Create_Packed_Array_Type (E); - Freeze_And_Append (Packed_Array_Type (E), Loc, Result); + Freeze_And_Append (Packed_Array_Type (E), N, Result); -- Size information of packed array type is copied to the -- array type, since this is really the representation. But @@ -3440,7 +3703,7 @@ package body Freeze is -- frozen as well (RM 13.14(15)) elsif Is_Class_Wide_Type (E) then - Freeze_And_Append (Root_Type (E), Loc, Result); + Freeze_And_Append (Root_Type (E), N, Result); -- If the base type of the class-wide type is still incomplete, -- the class-wide remains unfrozen as well. This is legal when @@ -3466,11 +3729,7 @@ package body Freeze is begin Set_Itype (Ref, E); - if No (Result) then - Result := New_List (Ref); - else - Append (Ref, Result); - end if; + Add_To_Result (Ref); end; end if; @@ -3480,7 +3739,7 @@ package body Freeze is if Ekind (E) = E_Class_Wide_Subtype and then Present (Equivalent_Type (E)) then - Freeze_And_Append (Equivalent_Type (E), Loc, Result); + Freeze_And_Append (Equivalent_Type (E), N, Result); end if; -- For a record (sub)type, freeze all the component types (RM @@ -3504,13 +3763,13 @@ package body Freeze is elsif Is_Concurrent_Type (E) then if Present (Corresponding_Record_Type (E)) then Freeze_And_Append - (Corresponding_Record_Type (E), Loc, Result); + (Corresponding_Record_Type (E), N, Result); end if; Comp := First_Entity (E); while Present (Comp) loop if Is_Type (Comp) then - Freeze_And_Append (Comp, Loc, Result); + Freeze_And_Append (Comp, N, Result); elsif (Ekind (Comp)) /= E_Function then if Is_Itype (Etype (Comp)) @@ -3519,7 +3778,7 @@ package body Freeze is Undelay_Type (Etype (Comp)); end if; - Freeze_And_Append (Etype (Comp), Loc, Result); + Freeze_And_Append (Etype (Comp), N, Result); end if; Next_Entity (Comp); @@ -3552,7 +3811,7 @@ package body Freeze is -- package Pkg is -- type T is tagged private; -- type DT is new T with private; - -- procedure Prim (X : in out T; Y : in out DT'class); + -- procedure Prim (X : in out T; Y : in out DT'Class); -- private -- type T is tagged null record; -- Obj : T; @@ -3577,7 +3836,6 @@ package body Freeze is -- processing is required if Is_Frozen (Full_View (E)) then - Set_Has_Delayed_Freeze (E, False); Set_Freeze_Node (E, Empty); Check_Debug_Info_Needed (E); @@ -3594,10 +3852,10 @@ package body Freeze is and then Present (Underlying_Full_View (Full)) then Freeze_And_Append - (Underlying_Full_View (Full), Loc, Result); + (Underlying_Full_View (Full), N, Result); end if; - Freeze_And_Append (Full, Loc, Result); + Freeze_And_Append (Full, N, Result); if Has_Delayed_Freeze (E) then F_Node := Freeze_Node (Full); @@ -3668,7 +3926,6 @@ package body Freeze is elsif Ekind (E) = E_Subprogram_Type then Formal := First_Formal (E); - while Present (Formal) loop if Ekind (Etype (Formal)) = E_Incomplete_Type and then No (Full_View (Etype (Formal))) @@ -3676,13 +3933,17 @@ package body Freeze is then if Is_Tagged_Type (Etype (Formal)) then null; - else + + -- AI05-151: Incomplete types are allowed in access to + -- subprogram specifications. + + elsif Ada_Version < Ada_2012 then Error_Msg_NE ("invalid use of incomplete type&", E, Etype (Formal)); end if; end if; - Freeze_And_Append (Etype (Formal), Loc, Result); + Freeze_And_Append (Etype (Formal), N, Result); Next_Formal (Formal); end loop; @@ -3694,7 +3955,7 @@ package body Freeze is elsif Is_Access_Protected_Subprogram_Type (E) then if Present (Equivalent_Type (E)) then - Freeze_And_Append (Equivalent_Type (E), Loc, Result); + Freeze_And_Append (Equivalent_Type (E), N, Result); end if; end if; @@ -3716,9 +3977,7 @@ package body Freeze is -- these till the freeze-point since we need the small and range -- values. We only do these checks for base types - if Is_Ordinary_Fixed_Point_Type (E) - and then E = Base_Type (E) - then + if Is_Ordinary_Fixed_Point_Type (E) and then Is_Base_Type (E) then if Small_Value (E) < Ureal_2_M_80 then Error_Msg_Name_1 := Name_Small; Error_Msg_N @@ -3757,6 +4016,28 @@ package body Freeze is elsif Is_Access_Type (E) then + -- If a pragma Default_Storage_Pool applies, and this type has no + -- Storage_Pool or Storage_Size clause (which must have occurred + -- before the freezing point), then use the default. This applies + -- only to base types. + + if Present (Default_Pool) + and then Is_Base_Type (E) + and then not Has_Storage_Size_Clause (E) + and then No (Associated_Storage_Pool (E)) + then + -- Case of pragma Default_Storage_Pool (null) + + if Nkind (Default_Pool) = N_Null then + Set_No_Pool_Assigned (E); + + -- Case of pragma Default_Storage_Pool (storage_pool_NAME) + + else + Set_Associated_Storage_Pool (E, Entity (Default_Pool)); + end if; + end if; + -- Check restriction for standard storage pool if No (Associated_Storage_Pool (E)) then @@ -3767,12 +4048,12 @@ package body Freeze is -- error in Ada 2005 if there is no pool (see AI-366). if Is_Pure_Unit_Access_Type (E) - and then (Ada_Version < Ada_05 + and then (Ada_Version < Ada_2005 or else not No_Pool_Assigned (E)) then Error_Msg_N ("named access type not allowed in pure unit", E); - if Ada_Version >= Ada_05 then + if Ada_Version >= Ada_2005 then Error_Msg_N ("\would be legal if Storage_Size of 0 given?", E); @@ -3811,6 +4092,7 @@ package body Freeze is declare Prim_List : constant Elist_Id := Primitive_Operations (E); Prim : Elmt_Id; + begin Prim := First_Elmt (Prim_List); while Present (Prim) loop @@ -3822,6 +4104,276 @@ package body Freeze is end loop; end; end if; + + -- If the type is a simple storage pool type, then this is where + -- we attempt to locate and validate its Allocate, Deallocate, and + -- Storage_Size operations (the first is required, and the latter + -- two are optional). We also verify that the full type for a + -- private type is allowed to be a simple storage pool type. + + if Present (Get_Rep_Pragma (E, Name_Simple_Storage_Pool_Type)) + and then (Is_Base_Type (E) or else Has_Private_Declaration (E)) + then + -- If the type is marked Has_Private_Declaration, then this is + -- a full type for a private type that was specified with the + -- pragma Simple_Storage_Pool_Type, and here we ensure that the + -- pragma is allowed for the full type (for example, it can't + -- be an array type, or a nonlimited record type). + + if Has_Private_Declaration (E) then + if (not Is_Record_Type (E) + or else not Is_Immutably_Limited_Type (E)) + and then not Is_Private_Type (E) + then + Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type; + Error_Msg_N + ("pragma% can only apply to full type that is an " & + "explicitly limited type", E); + end if; + end if; + + Validate_Simple_Pool_Ops : declare + Pool_Type : Entity_Id renames E; + Address_Type : constant Entity_Id := RTE (RE_Address); + Stg_Cnt_Type : constant Entity_Id := RTE (RE_Storage_Count); + + procedure Validate_Simple_Pool_Op_Formal + (Pool_Op : Entity_Id; + Pool_Op_Formal : in out Entity_Id; + Expected_Mode : Formal_Kind; + Expected_Type : Entity_Id; + Formal_Name : String; + OK_Formal : in out Boolean); + -- Validate one formal Pool_Op_Formal of the candidate pool + -- operation Pool_Op. The formal must be of Expected_Type + -- and have mode Expected_Mode. OK_Formal will be set to + -- False if the formal doesn't match. If OK_Formal is False + -- on entry, then the formal will effectively be ignored + -- (because validation of the pool op has already failed). + -- Upon return, Pool_Op_Formal will be updated to the next + -- formal, if any. + + procedure Validate_Simple_Pool_Operation (Op_Name : Name_Id); + -- Search for and validate a simple pool operation with the + -- name Op_Name. If the name is Allocate, then there must be + -- exactly one such primitive operation for the simple pool + -- type. If the name is Deallocate or Storage_Size, then + -- there can be at most one such primitive operation. The + -- profile of the located primitive must conform to what + -- is expected for each operation. + + ------------------------------------ + -- Validate_Simple_Pool_Op_Formal -- + ------------------------------------ + + procedure Validate_Simple_Pool_Op_Formal + (Pool_Op : Entity_Id; + Pool_Op_Formal : in out Entity_Id; + Expected_Mode : Formal_Kind; + Expected_Type : Entity_Id; + Formal_Name : String; + OK_Formal : in out Boolean) + is + begin + -- If OK_Formal is False on entry, then simply ignore + -- the formal, because an earlier formal has already + -- been flagged. + + if not OK_Formal then + return; + + -- If no formal is passed in, then issue an error for a + -- missing formal. + + elsif not Present (Pool_Op_Formal) then + Error_Msg_NE + ("simple storage pool op missing formal " & + Formal_Name & " of type&", Pool_Op, Expected_Type); + OK_Formal := False; + + return; + end if; + + if Etype (Pool_Op_Formal) /= Expected_Type then + + -- If the pool type was expected for this formal, then + -- this will not be considered a candidate operation + -- for the simple pool, so we unset OK_Formal so that + -- the op and any later formals will be ignored. + + if Expected_Type = Pool_Type then + OK_Formal := False; + + return; + + else + Error_Msg_NE + ("wrong type for formal " & Formal_Name & + " of simple storage pool op; expected type&", + Pool_Op_Formal, Expected_Type); + end if; + end if; + + -- Issue error if formal's mode is not the expected one + + if Ekind (Pool_Op_Formal) /= Expected_Mode then + Error_Msg_N + ("wrong mode for formal of simple storage pool op", + Pool_Op_Formal); + end if; + + -- Advance to the next formal + + Next_Formal (Pool_Op_Formal); + end Validate_Simple_Pool_Op_Formal; + + ------------------------------------ + -- Validate_Simple_Pool_Operation -- + ------------------------------------ + + procedure Validate_Simple_Pool_Operation + (Op_Name : Name_Id) + is + Op : Entity_Id; + Found_Op : Entity_Id := Empty; + Formal : Entity_Id; + Is_OK : Boolean; + + begin + pragma Assert + (Op_Name = Name_Allocate + or else Op_Name = Name_Deallocate + or else Op_Name = Name_Storage_Size); + + Error_Msg_Name_1 := Op_Name; + + -- For each homonym declared immediately in the scope + -- of the simple storage pool type, determine whether + -- the homonym is an operation of the pool type, and, + -- if so, check that its profile is as expected for + -- a simple pool operation of that name. + + Op := Get_Name_Entity_Id (Op_Name); + while Present (Op) loop + if Ekind_In (Op, E_Function, E_Procedure) + and then Scope (Op) = Current_Scope + then + Formal := First_Entity (Op); + + Is_OK := True; + + -- The first parameter must be of the pool type + -- in order for the operation to qualify. + + if Op_Name = Name_Storage_Size then + Validate_Simple_Pool_Op_Formal + (Op, Formal, E_In_Parameter, Pool_Type, + "Pool", Is_OK); + else + Validate_Simple_Pool_Op_Formal + (Op, Formal, E_In_Out_Parameter, Pool_Type, + "Pool", Is_OK); + end if; + + -- If another operation with this name has already + -- been located for the type, then flag an error, + -- since we only allow the type to have a single + -- such primitive. + + if Present (Found_Op) and then Is_OK then + Error_Msg_NE + ("only one % operation allowed for " & + "simple storage pool type&", Op, Pool_Type); + end if; + + -- In the case of Allocate and Deallocate, a formal + -- of type System.Address is required. + + if Op_Name = Name_Allocate then + Validate_Simple_Pool_Op_Formal + (Op, Formal, E_Out_Parameter, + Address_Type, "Storage_Address", Is_OK); + elsif Op_Name = Name_Deallocate then + Validate_Simple_Pool_Op_Formal + (Op, Formal, E_In_Parameter, + Address_Type, "Storage_Address", Is_OK); + end if; + + -- In the case of Allocate and Deallocate, formals + -- of type Storage_Count are required as the third + -- and fourth parameters. + + if Op_Name /= Name_Storage_Size then + Validate_Simple_Pool_Op_Formal + (Op, Formal, E_In_Parameter, + Stg_Cnt_Type, "Size_In_Storage_Units", Is_OK); + Validate_Simple_Pool_Op_Formal + (Op, Formal, E_In_Parameter, + Stg_Cnt_Type, "Alignment", Is_OK); + end if; + + -- If no mismatched formals have been found (Is_OK) + -- and no excess formals are present, then this + -- operation has been validated, so record it. + + if not Present (Formal) and then Is_OK then + Found_Op := Op; + end if; + end if; + + Op := Homonym (Op); + end loop; + + -- There must be a valid Allocate operation for the type, + -- so issue an error if none was found. + + if Op_Name = Name_Allocate + and then not Present (Found_Op) + then + Error_Msg_N ("missing % operation for simple " & + "storage pool type", Pool_Type); + + elsif Present (Found_Op) then + + -- Simple pool operations can't be abstract + + if Is_Abstract_Subprogram (Found_Op) then + Error_Msg_N + ("simple storage pool operation must not be " & + "abstract", Found_Op); + end if; + + -- The Storage_Size operation must be a function with + -- Storage_Count as its result type. + + if Op_Name = Name_Storage_Size then + if Ekind (Found_Op) = E_Procedure then + Error_Msg_N + ("% operation must be a function", Found_Op); + + elsif Etype (Found_Op) /= Stg_Cnt_Type then + Error_Msg_NE + ("wrong result type for%, expected type&", + Found_Op, Stg_Cnt_Type); + end if; + + -- Allocate and Deallocate must be procedures + + elsif Ekind (Found_Op) = E_Function then + Error_Msg_N + ("% operation must be a procedure", Found_Op); + end if; + end if; + end Validate_Simple_Pool_Operation; + + -- Start of processing for Validate_Simple_Pool_Ops + + begin + Validate_Simple_Pool_Operation (Name_Allocate); + Validate_Simple_Pool_Operation (Name_Deallocate); + Validate_Simple_Pool_Operation (Name_Storage_Size); + end Validate_Simple_Pool_Ops; + end if; end if; -- Now that all types from which E may depend are frozen, see if the @@ -3851,14 +4403,16 @@ package body Freeze is end if; end if; - -- Remaining process is to set/verify the representation information, - -- in particular the size and alignment values. This processing is - -- not required for generic types, since generic types do not play - -- any part in code generation, and so the size and alignment values - -- for such types are irrelevant. + -- Now we set/verify the representation information, in particular + -- the size and alignment values. This processing is not required for + -- generic types, since generic types do not play any part in code + -- generation, and so the size and alignment values for such types + -- are irrelevant. Ditto for types declared within a generic unit, + -- which may have components that depend on generic parameters, and + -- that will be recreated in an instance. - if Is_Generic_Type (E) then - return Result; + if Inside_A_Generic then + null; -- Otherwise we call the layout procedure @@ -3866,6 +4420,51 @@ package body Freeze is Layout_Type (E); end if; + -- If this is an access to subprogram whose designated type is itself + -- a subprogram type, the return type of this anonymous subprogram + -- type must be decorated as well. + + if Ekind (E) = E_Anonymous_Access_Subprogram_Type + and then Ekind (Designated_Type (E)) = E_Subprogram_Type + then + Layout_Type (Etype (Designated_Type (E))); + end if; + + -- If the type has a Defaut_Value/Default_Component_Value aspect, + -- this is where we analye the expression (after the type is frozen, + -- since in the case of Default_Value, we are analyzing with the + -- type itself, and we treat Default_Component_Value similarly for + -- the sake of uniformity. + + if Is_First_Subtype (E) and then Has_Default_Aspect (E) then + declare + Nam : Name_Id; + Exp : Node_Id; + Typ : Entity_Id; + + begin + if Is_Scalar_Type (E) then + Nam := Name_Default_Value; + Typ := E; + Exp := Default_Aspect_Value (Typ); + else + Nam := Name_Default_Component_Value; + Typ := Component_Type (E); + Exp := Default_Aspect_Component_Value (E); + end if; + + Analyze_And_Resolve (Exp, Typ); + + if Etype (Exp) /= Any_Type then + if not Is_Static_Expression (Exp) then + Error_Msg_Name_1 := Nam; + Flag_Non_Static_Expr + ("aspect% requires static expression", Exp); + end if; + end if; + end; + end if; + -- End of freeze processing for type entities end if; @@ -3893,12 +4492,7 @@ package body Freeze is end if; Set_Entity (F_Node, E); - - if Result = No_List then - Result := New_List (F_Node); - else - Append (F_Node, Result); - end if; + Add_To_Result (F_Node); -- A final pass over record types with discriminants. If the type -- has an incomplete declaration, there may be constrained access @@ -3918,7 +4512,6 @@ package body Freeze is begin Comp := First_Component (E); - while Present (Comp) loop Typ := Etype (Comp); @@ -3944,7 +4537,7 @@ package body Freeze is -- since obviously the first subtype depends on its own base type. if Is_Type (E) then - Freeze_And_Append (First_Subtype (E), Loc, Result); + Freeze_And_Append (First_Subtype (E), N, Result); -- If we just froze a tagged non-class wide record, then freeze the -- corresponding class-wide type. This must be done after the tagged @@ -3955,7 +4548,7 @@ package body Freeze is and then not Is_Class_Wide_Type (E) and then Present (Class_Wide_Type (E)) then - Freeze_And_Append (Class_Wide_Type (E), Loc, Result); + Freeze_And_Append (Class_Wide_Type (E), N, Result); end if; end if; @@ -3977,6 +4570,8 @@ package body Freeze is -- subprogram in main unit, generate descriptor if we are in -- Propagate_Exceptions mode. + -- This is very odd code, it makes a null result, why ??? + elsif Propagate_Exceptions and then Is_Imported (E) and then not Is_Intrinsic_Subprogram (E) @@ -4000,7 +4595,8 @@ package body Freeze is -- By default, if no size clause is present, an enumeration type with -- Convention C is assumed to interface to a C enum, and has integer -- size. This applies to types. For subtypes, verify that its base - -- type has no size clause either. + -- type has no size clause either. Treat other foreign conventions + -- in the same way, and also make sure alignment is set right. if Has_Foreign_Convention (Typ) and then not Has_Size_Clause (Typ) @@ -4008,6 +4604,7 @@ package body Freeze is and then Esize (Typ) < Standard_Integer_Size then Init_Esize (Typ, Standard_Integer_Size); + Set_Alignment (Typ, Alignment (Standard_Integer)); else -- If the enumeration type interfaces to C, and it has a size clause @@ -4108,13 +4705,23 @@ package body Freeze is -- If expression is non-static, then it does not freeze in a default -- expression, see section "Handling of Default Expressions" in the - -- spec of package Sem for further details. Note that we have to - -- make sure that we actually have a real expression (if we have - -- a subtype indication, we can't test Is_Static_Expression!) + -- spec of package Sem for further details. Note that we have to make + -- sure that we actually have a real expression (if we have a subtype + -- indication, we can't test Is_Static_Expression!) However, we exclude + -- the case of the prefix of an attribute of a static scalar subtype + -- from this early return, because static subtype attributes should + -- always cause freezing, even in default expressions, but the attribute + -- may not have been marked as static yet (because in Resolve_Attribute, + -- the call to Eval_Attribute follows the call of Freeze_Expression on + -- the prefix). if In_Spec_Exp and then Nkind (N) in N_Subexpr and then not Is_Static_Expression (N) + and then (Nkind (Parent (N)) /= N_Attribute_Reference + or else not (Is_Entity_Name (N) + and then Is_Type (Entity (N)) + and then Is_Static_Subtype (Entity (N)))) then return; end if; @@ -4223,8 +4830,8 @@ package body Freeze is -- exiting from the loop when it is appropriate to insert the freeze -- node before the current node P. - -- Also checks som special exceptions to the freezing rules. These cases - -- result in a direct return, bypassing the freeze action. + -- Also checks some special exceptions to the freezing rules. These + -- cases result in a direct return, bypassing the freeze action. P := N; loop @@ -4377,31 +4984,34 @@ package body Freeze is -- is a statement or declaration and we can insert the freeze node -- before it. - when N_Package_Specification | + when N_Block_Statement | + N_Entry_Body | N_Package_Body | - N_Subprogram_Body | - N_Task_Body | + N_Package_Specification | N_Protected_Body | - N_Entry_Body | - N_Block_Statement => exit; + N_Subprogram_Body | + N_Task_Body => exit; -- The expander is allowed to define types in any statements list, -- so any of the following parent nodes also mark a freezing point -- if the actual node is in a list of statements or declarations. - when N_Exception_Handler | - N_If_Statement | - N_Elsif_Part | + when N_Abortable_Part | + N_Accept_Alternative | + N_And_Then | N_Case_Statement_Alternative | N_Compilation_Unit_Aux | - N_Selective_Accept | - N_Accept_Alternative | - N_Delay_Alternative | N_Conditional_Entry_Call | + N_Delay_Alternative | + N_Elsif_Part | N_Entry_Call_Alternative | - N_Triggering_Alternative | - N_Abortable_Part | - N_Freeze_Entity => + N_Exception_Handler | + N_Extended_Return_Statement | + N_Freeze_Entity | + N_If_Statement | + N_Or_Else | + N_Selective_Accept | + N_Triggering_Alternative => exit when Is_List_Member (P); @@ -4459,38 +5069,42 @@ package body Freeze is or else Ekind (Current_Scope) = E_Void then declare - Loc : constant Source_Ptr := Sloc (Current_Scope); - Freeze_Nodes : List_Id := No_List; - Pos : Int := Scope_Stack.Last; + N : constant Node_Id := Current_Scope; + Freeze_Nodes : List_Id := No_List; + Pos : Int := Scope_Stack.Last; begin if Present (Desig_Typ) then - Freeze_And_Append (Desig_Typ, Loc, Freeze_Nodes); + Freeze_And_Append (Desig_Typ, N, Freeze_Nodes); end if; if Present (Typ) then - Freeze_And_Append (Typ, Loc, Freeze_Nodes); + Freeze_And_Append (Typ, N, Freeze_Nodes); end if; if Present (Nam) then - Freeze_And_Append (Nam, Loc, Freeze_Nodes); + Freeze_And_Append (Nam, N, Freeze_Nodes); end if; -- The current scope may be that of a constrained component of -- an enclosing record declaration, which is above the current -- scope in the scope stack. + -- If the expression is within a top-level pragma, as for a pre- + -- condition on a library-level subprogram, nothing to do. - if Is_Record_Type (Scope (Current_Scope)) then + if not Is_Compilation_Unit (Current_Scope) + and then Is_Record_Type (Scope (Current_Scope)) + then Pos := Pos - 1; end if; if Is_Non_Empty_List (Freeze_Nodes) then if No (Scope_Stack.Table (Pos).Pending_Freeze_Actions) then Scope_Stack.Table (Pos).Pending_Freeze_Actions := - Freeze_Nodes; + Freeze_Nodes; else - Append_List (Freeze_Nodes, Scope_Stack.Table - (Pos).Pending_Freeze_Actions); + Append_List (Freeze_Nodes, + Scope_Stack.Table (Pos).Pending_Freeze_Actions); end if; end if; end; @@ -4800,11 +5414,7 @@ package body Freeze is -- natural boundary of size. elsif Size_Incl_EP /= Size_Excl_EP - and then - (Size_Excl_EP = 8 or else - Size_Excl_EP = 16 or else - Size_Excl_EP = 32 or else - Size_Excl_EP = 64) + and then Addressable (Size_Excl_EP) then Actual_Size := Size_Excl_EP; Actual_Lo := Loval_Excl_EP; @@ -4994,7 +5604,7 @@ package body Freeze is begin Set_Has_Delayed_Freeze (T); - L := Freeze_Entity (T, Sloc (N)); + L := Freeze_Entity (T, N); if Is_Non_Empty_List (L) then Insert_Actions (N, L); @@ -5103,7 +5713,6 @@ package body Freeze is end if; F := First_Formal (Designated_Type (Typ)); - while Present (F) loop Ensure_Type_Is_SA (Etype (F)); Next_Formal (F); @@ -5155,10 +5764,16 @@ package body Freeze is -- issue an error message saying that this object cannot be imported -- or exported. If it has an address clause it is an overlay in the -- current partition and the static requirement is not relevant. + -- Do not issue any error message when ignoring rep clauses. - if Is_Imported (E) and then No (Address_Clause (E)) then - Error_Msg_N - ("& cannot be imported (local type is not constant)", E); + if Ignore_Rep_Clauses then + null; + + elsif Is_Imported (E) then + if No (Address_Clause (E)) then + Error_Msg_N + ("& cannot be imported (local type is not constant)", E); + end if; -- Otherwise must be exported, something is wrong if compiler -- is marking something as statically allocated which cannot be). @@ -5261,13 +5876,13 @@ package body Freeze is and then Mechanism (E) not in Descriptor_Codes - -- Check appropriate warning is enabled (should we check for - -- Warnings (Off) on specific entities here, probably so???) + -- Check appropriate warning is enabled (should we check for + -- Warnings (Off) on specific entities here, probably so???) and then Warn_On_Export_Import - -- Exclude the VM case, since return of unconstrained arrays - -- is properly handled in both the JVM and .NET cases. + -- Exclude the VM case, since return of unconstrained arrays + -- is properly handled in both the JVM and .NET cases. and then VM_Target = No_VM then @@ -5381,7 +5996,6 @@ package body Freeze is begin Comp := First_Component (T); - while Present (Comp) loop if not Is_Fully_Defined (Etype (Comp)) then return False; @@ -5392,6 +6006,26 @@ package body Freeze is return True; end; + -- For the designated type of an access to subprogram, all types in + -- the profile must be fully defined. + + elsif Ekind (T) = E_Subprogram_Type then + declare + F : Entity_Id; + + begin + F := First_Formal (T); + while Present (F) loop + if not Is_Fully_Defined (Etype (F)) then + return False; + end if; + + Next_Formal (F); + end loop; + + return Is_Fully_Defined (Etype (T)); + end; + else return not Is_Private_Type (T) or else Present (Full_View (Base_Type (T))); @@ -5502,8 +6136,7 @@ package body Freeze is -- involve secondary stack expansion. else - Dnam := - Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + Dnam := Make_Temporary (Loc, 'D'); Dbody := Make_Subprogram_Body (Loc, @@ -5513,16 +6146,14 @@ package body Freeze is Declarations => New_List ( Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')), - Object_Definition => - New_Occurrence_Of (Etype (Formal), Loc), - Expression => New_Copy_Tree (Dcopy))), + Defining_Identifier => Make_Temporary (Loc, 'T'), + Object_Definition => + New_Occurrence_Of (Etype (Formal), Loc), + Expression => New_Copy_Tree (Dcopy))), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List)); + Statements => Empty_List)); Set_Scope (Dnam, Scope (E)); Set_Assignment_OK (First (Declarations (Dbody))); @@ -5638,18 +6269,21 @@ package body Freeze is -- We only give the warning for non-imported entities of a type for -- which a non-null base init proc is defined, or for objects of access - -- types with implicit null initialization, or when Initialize_Scalars + -- types with implicit null initialization, or when Normalize_Scalars -- applies and the type is scalar or a string type (the latter being -- tested for because predefined String types are initialized by inline - -- code rather than by an init_proc). + -- code rather than by an init_proc). Note that we do not give the + -- warning for Initialize_Scalars, since we suppressed initialization + -- in this case. Also, do not warn if Suppress_Initialization is set. if Present (Expr) and then not Is_Imported (Ent) + and then not Initialization_Suppressed (Typ) and then (Has_Non_Null_Base_Init_Proc (Typ) - or else Is_Access_Type (Typ) - or else (Init_Or_Norm_Scalars - and then (Is_Scalar_Type (Typ) - or else Is_String_Type (Typ)))) + or else Is_Access_Type (Typ) + or else (Normalize_Scalars + and then (Is_Scalar_Type (Typ) + or else Is_String_Type (Typ)))) then if Nkind (Expr) = N_Attribute_Reference and then Is_Entity_Name (Prefix (Expr)) @@ -5712,7 +6346,6 @@ package body Freeze is begin Comp := First_Component (Typ); - while Present (Comp) loop if Nkind (Parent (Comp)) = N_Component_Declaration and then Present (Expression (Parent (Comp)))