https://gcc.gnu.org/g:dc5689c9c077d6ae7fa7d4eff6293ccf5be67ac4
commit r17-742-gdc5689c9c077d6ae7fa7d4eff6293ccf5be67ac4 Author: Eric Botcazou <[email protected]> Date: Tue Jan 13 20:00:28 2026 +0100 ada: Fix early freezing of tagged type by expression function in nested package This addresses a long-standing issue in the implementation of expression functions of Ada 2012, pertaining to their interaction with the freezing of types that are referenced in their expression: when they are used as the completion of a function declaration, their expression causes these types to become frozen, but when they are stand-alone, it does not. The last rule is problematic for GNAT, because it goes against its freezing model devised for Ada 95, where types must always be frozen for code to be generated. Therefore the current implementation needs to resort to several kludges in order to implement it, but these are not bullet proof and do not always work when tagged types are involved. The new approach is to insert the generated body of stand-alone expression functions at the next freezing point, instead of at the end of the current package. This makes a difference for nested packages, which are precisely the problematic case. This requires the analysis and resolution performed on the body, potentially out of context now, to give identical results as the preanalysis and resolution performed on the expression in its context, which is achieved by treating the generated body as an inlined body. This approach requires a more complete implementation of the special rules for freezing expression functions, so the change overhauls it and plugs the most blatant loopholes of the current implementation. gcc/ada/ChangeLog: PR ada/93702 * contracts.adb (Analyze_Entry_Or_Subprogram_Contract): Call Freeze_Expr_Types_Before instead of Freeze_Expr_Types. (Process_Preconditions_For): Likewise. * exp_ch3.adb (Make_Controlling_Function_Wrappers): Do not set Was_Expression_Function flag on the generated bodies. * exp_ch6.adb (Expand_Call_Helper): Call Original_Node on the result of the call to Expression_Of_Expression_Function. * freeze.ads (Freeze_Expr_Types): Delete. (Freeze_Expr_Types_Before): New procedure declaration. * freeze.adb (Check_Expression_Function): Delete. (Freeze_And_Append): Add Do_Freeze_Profile formal parameter and pass it to Freeze_Entity. Remove call to Check_Expression_Function. (Freeze_Entity): Set Test_E consistently and freeze the expression of expression functions that are primitives of a tagged type. (Freeze_Profile): Adjust calls to Should_Freeze_Type. (In_Expanded_Body): Also return true for DIC procedures. (Freeze_Expression): Remove call to Check_Expression_Function. Freeze the expression of expression functions. (Freeze_Expr_Types): Add Result and Before formal parameters. Make a copy and preanalyze/resolve it only if Typ is present. (Freeze_Expr_Types.Explain_Error): New procedure. (Freeze_Expr_Types.Find_Incomplete_Constant): Likewise. (Freeze_Expr_Types.Check_And_Freeze_Type): Return immediately if the type is already frozen. Report errors on N instead of Node. If Before is False, append the freeze nodes to Result. (Freeze_Expr_Types.Freeze_Type_Refs): Call Find_Incomplete_Constant. (Freeze_Expr_Types_Before): New procedure. (Should_Freeze_Type): Remove formal parameter E and specific kludge for stand-alone expression functions. * ghost.ads (Mark_And_Set_Ghost_Body_Of_Expression_Function): New procedure declaration. * ghost.adb (Mark_And_Set_Ghost_Body_Of_Expression_Function): New procedure body. * rtsfind.adb (RTE): Preserve and reset the In_Inlined_Body flag. (RTE_Record_Component): Likewise. * sem_attr.adb (Resolve_Attribute) <Attribute_Access>: Just call Freeze_Expression to freeze the expression of prefixes that are expression functions and remove obsolete implementation. * sem_ch3.adb (Analyze_Declarations): Adjust commentary. (Check_Completion): Also skip stand-alone expressions functions. * sem_ch4.adb (Analyze_Case_Expression): Always analyze the choices. * sem_ch6.adb: Add with and use clauses for Sem_Ch7. (Analyze_Expression_Function): Call Freeze_Expr_Types_Before instead of Freeze_Expr_Types for expression functions that are completions. For stand-alone expression functions, set In_Private_Part on the entity if it is in the private part, propagate the results of the resolution of the specification of the the declaration to that of the body and insert the body at the next freezing point. (Analyze_Subprogram_Body_Helper): Remove the machinery for masking and unmasking unfrozen types. For a stand-alone expression function, call Mark_And_Set_Ghost_Body_Of_Expression_Function, remove obsolete code dealing with the freezing of the spec, set In_Inlined_Body to True, make the full view of the private types of its scope visible if this is not the current scope and it is in the private part, and avoid making the spec immediately visible. (Analyze_Subprogram_Specification): Fix typo. (New_Overloaded_Entity): Set Has_Completion on a [generic] package that conflicts with the entity to prevent a cascaded error. * sem_ch7.ads (Is_Private_Base_Type): New function declaration moved here from... * sem_ch7.adb (Is_Private_Base_Type): ...here. Remove. * sem_ch8.adb (Analyze_Subprogram_Renaming): Call Freeze_Expression to freeze the expression of expression functions, but only if the renaming comes from source. * sem_ch12.adb (Analyze_One_Association): Likewise, and remove the manual freezing for calls to them. * sem_res.adb (Resolve): Remove obsolete commentary. (Resolve_Call): Always freeze the expression of names that are expression functions. * sem_util.adb (Check_Fully_Declared): Add commentary and do not check types with private component declared outside of the current scope when it is a generic unit. (Expression_Of_Expression_Function): Return Expression directly. (Is_Inlinable_Expression_Function): Call Original_Node on the result of the call to Expression_Of_Expression_Function. Diff: --- gcc/ada/contracts.adb | 16 +- gcc/ada/exp_ch3.adb | 6 +- gcc/ada/exp_ch6.adb | 4 +- gcc/ada/freeze.adb | 477 +++++++++++++++++++++++--------------------------- gcc/ada/freeze.ads | 21 ++- gcc/ada/ghost.adb | 32 +++- gcc/ada/ghost.ads | 9 + gcc/ada/rtsfind.adb | 34 ++-- gcc/ada/sem_attr.adb | 73 ++------ gcc/ada/sem_ch12.adb | 32 ++-- gcc/ada/sem_ch3.adb | 15 +- gcc/ada/sem_ch4.adb | 2 +- gcc/ada/sem_ch6.adb | 314 ++++++++++++++++----------------- gcc/ada/sem_ch7.adb | 3 - gcc/ada/sem_ch7.ads | 4 +- gcc/ada/sem_ch8.adb | 16 +- gcc/ada/sem_res.adb | 23 +-- gcc/ada/sem_util.adb | 14 +- 18 files changed, 528 insertions(+), 567 deletions(-) diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 86871f9dea6b..301115f3c27d 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -753,13 +753,13 @@ package body Contracts is if Freeze_Types and then Present (Corresponding_Aspect (Prag)) then - Freeze_Expr_Types - (Def_Id => Subp_Id, - Typ => Standard_Boolean, + Freeze_Expr_Types_Before + (N => Bod, Expr => Expression (First (Pragma_Argument_Associations (Prag))), - N => Bod); + Def_Id => Subp_Id, + Typ => Standard_Boolean); end if; Analyze_Pre_Post_Condition_In_Decl_Part (Prag, Freeze_Id); @@ -3102,13 +3102,13 @@ package body Contracts is if Freeze_T and then Present (Corresponding_Aspect (Prag)) then - Freeze_Expr_Types - (Def_Id => Subp_Id, - Typ => Standard_Boolean, + Freeze_Expr_Types_Before + (N => Body_Decl, Expr => Expression (First (Pragma_Argument_Associations (Prag))), - N => Body_Decl); + Def_Id => Subp_Id, + Typ => Standard_Boolean); end if; Prepend_Pragma_To_Decls (Prag); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 1b7b4aae653c..d1956c1a1bee 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -11683,10 +11683,7 @@ package body Exp_Ch3 is Null_Record_Present => True); -- GNATprove will use expression of an expression function as an - -- implicit postcondition. GNAT will also benefit from expression - -- function to avoid premature freezing, but would struggle if we - -- added an expression function to freezing actions, so we create - -- the expanded form directly. + -- implicit postcondition. if GNATprove_Mode then Func_Body := @@ -11705,7 +11702,6 @@ package body Exp_Ch3 is Statements => New_List ( Make_Simple_Return_Statement (Loc, Expression => Ext_Aggr)))); - Set_Was_Expression_Function (Func_Body); end if; Append_To (Body_List, Func_Body); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 9a16229e3354..44925dac3c63 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5538,7 +5538,9 @@ package body Exp_Ch6 is elsif Is_Inlinable_Expression_Function (Subp) then Rewrite - (Call_Node, New_Copy (Expression_Of_Expression_Function (Subp))); + (Call_Node, + New_Copy + (Original_Node (Expression_Of_Expression_Function (Subp)))); Analyze (Call_Node); return; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 19f365117c2e..d989b2c27b05 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -121,17 +121,6 @@ package body Freeze is -- the flag if Debug_Info_Off is set. This procedure also ensures that -- subsidiary entities have the flag set as required. - procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id); - -- When an expression function is frozen by a use of it, the expression - -- itself is frozen. Check that the expression does not include references - -- to deferred constants without completion. We report this at the freeze - -- point of the function, to provide a better error message. - -- - -- In most cases the expression itself is frozen by the time the function - -- itself is frozen, because the formals will be frozen by then. However, - -- Attribute references to outer types are freeze points for those types; - -- this routine generates the required freeze nodes for them. - procedure Check_Strict_Alignment (E : Entity_Id); -- E is a base type. If E is tagged or has a component that is aliased -- or tagged or contains something this is aliased or tagged, set @@ -145,12 +134,13 @@ package body Freeze is -- effect if the entity E is not a discrete or fixed-point type. procedure Freeze_And_Append - (Ent : Entity_Id; - N : Node_Id; - Result : in out List_Id); + (Ent : Entity_Id; + N : Node_Id; + Result : in out List_Id; + Do_Freeze_Profile : Boolean := True); -- Freezes Ent using Freeze_Entity, and appends the resulting list of - -- nodes to Result, modifying Result from No_List if necessary. N has - -- the same usage as in Freeze_Entity. + -- nodes to Result, modifying Result from No_List if necessary. N and + -- Do_Freeze_Profile have the same usage as in Freeze_Entity. procedure Freeze_Enumeration_Type (Typ : Entity_Id); -- Freeze enumeration type. The Esize field is set as processing @@ -159,6 +149,17 @@ package body Freeze is -- that if a foreign convention is specified, and no specific size -- is given, then the size must be at least Integer'Size. + procedure Freeze_Expr_Types + (Expr : Node_Id; + N : Node_Id; + Def_Id : Entity_Id; + Result : in out List_Id; + Before : Boolean := False; + Typ : Entity_Id := Empty); + -- Same as Freeze_Expr_Types_Before if Before is True, but appends the + -- resulting list of nodes to Result if Before is False, modifying Result + -- from No_List if necessary. + procedure Freeze_Static_Object (E : Entity_Id); -- If an object is frozen which has Is_Statically_Allocated set, then -- all referenced types must also be marked with this flag. This routine @@ -207,16 +208,8 @@ package body Freeze is -- attribute definition clause occurs, then these two flags are reset in -- any case, so call will have no effect. - function Should_Freeze_Type - (Typ : Entity_Id; - E : Entity_Id; - N : Node_Id) return Boolean; - -- True if Typ should be frozen when the profile of E is being frozen at N. - - -- ??? Expression functions that are not completions shouldn't freeze types - -- but our current expansion and freezing model requires an early freezing - -- when the tag of Typ is needed or for an aggregate with a subtype of Typ, - -- so we return True in these cases. + function Should_Freeze_Type (Typ : Entity_Id; N : Node_Id) return Boolean; + -- True if Typ should be frozen when a profile is being frozen at N. procedure Undelay_Type (T : Entity_Id); -- T is a type of a component that we know to be an Itype. We don't want @@ -1416,78 +1409,6 @@ package body Freeze is end if; end Check_Debug_Info_Needed; - ------------------------------- - -- Check_Expression_Function -- - ------------------------------- - - procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id) is - function Find_Constant (Nod : Node_Id) return Traverse_Result; - -- Function to search for deferred constant - - ------------------- - -- Find_Constant -- - ------------------- - - function Find_Constant (Nod : Node_Id) return Traverse_Result is - begin - -- When a constant is initialized with the result of a dispatching - -- call, the constant declaration is rewritten as a renaming of the - -- displaced function result. This scenario is not a premature use of - -- a constant even though the Has_Completion flag is not set. - - if Is_Entity_Name (Nod) - and then Present (Entity (Nod)) - and then Ekind (Entity (Nod)) = E_Constant - and then Scope (Entity (Nod)) = Current_Scope - and then Nkind (Declaration_Node (Entity (Nod))) = - N_Object_Declaration - and then not Is_Imported (Entity (Nod)) - and then not Has_Completion (Entity (Nod)) - and then not (Present (Full_View (Entity (Nod))) - and then Has_Completion (Full_View (Entity (Nod)))) - then - Error_Msg_NE - ("premature use of& in call or instance", N, Entity (Nod)); - - elsif Nkind (Nod) = N_Attribute_Reference then - Analyze (Prefix (Nod)); - - if Is_Entity_Name (Prefix (Nod)) - and then Is_Type (Entity (Prefix (Nod))) - then - if Expander_Active then - Check_Fully_Declared (Entity (Prefix (Nod)), N); - end if; - - Freeze_Before (N, Entity (Prefix (Nod))); - end if; - end if; - - return OK; - end Find_Constant; - - procedure Check_Deferred is new Traverse_Proc (Find_Constant); - - -- Local variables - - Decl : Node_Id; - - -- Start of processing for Check_Expression_Function - - begin - Decl := Original_Node (Unit_Declaration_Node (Nam)); - - -- The subprogram body created for the expression function is not - -- itself a freeze point. - - if Scope (Nam) = Current_Scope - and then Nkind (Decl) = N_Expression_Function - and then Nkind (N) /= N_Subprogram_Body - then - Check_Deferred (Expression (Decl)); - end if; - end Check_Expression_Function; - -------------------------------- -- Check_Inherited_Conditions -- -------------------------------- @@ -2802,17 +2723,13 @@ package body Freeze is ----------------------- procedure Freeze_And_Append - (Ent : Entity_Id; - N : Node_Id; - Result : in out List_Id) + (Ent : Entity_Id; + N : Node_Id; + Result : in out List_Id; + Do_Freeze_Profile : Boolean := True) is - -- Freezing an Expression_Function does not freeze its profile: - -- the formals will have been frozen otherwise before the E_F - -- can be called. + L : constant List_Id := Freeze_Entity (Ent, N, Do_Freeze_Profile); - L : constant List_Id := - Freeze_Entity - (Ent, N, Do_Freeze_Profile => not Is_Expression_Function (Ent)); begin if Is_Non_Empty_List (L) then if Result = No_List then @@ -2841,10 +2758,6 @@ package body Freeze is Pack : constant Entity_Id := Scope (T); begin - if Ekind (T) = E_Function then - Check_Expression_Function (N, T); - end if; - if Is_Non_Empty_List (Freeze_Nodes) then -- If the entity is a type declared in an inner package, it may be @@ -2893,7 +2806,7 @@ package body Freeze is Result : List_Id := No_List; -- List of freezing actions, left at No_List if none - Test_E : Entity_Id := E; + Test_E : Entity_Id; -- A local temporary used to test if freezing is necessary for E, since -- its value can be set to something other than E in certain cases. For -- example, E cannot be used directly in cases such as when it is an @@ -4770,7 +4683,7 @@ package body Freeze is end if; if not From_Limited_With (F_Type) - and then Should_Freeze_Type (F_Type, E, N) + and then Should_Freeze_Type (F_Type, N) then Freeze_And_Append (F_Type, N, Result); end if; @@ -4942,7 +4855,7 @@ package body Freeze is Set_Etype (E, R_Type); end if; - if Should_Freeze_Type (R_Type, E, N) then + if Should_Freeze_Type (R_Type, N) then Freeze_And_Append (R_Type, N, Result); end if; @@ -6529,6 +6442,9 @@ package body Freeze is and then Is_Record_Type (Underlying_Type (Scope (E))) then Test_E := Underlying_Type (Scope (E)); + + else + Test_E := E; end if; -- Do not freeze if already frozen since we only need one freeze node @@ -8326,38 +8242,44 @@ package body Freeze is if Is_Type (E) then 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 - -- type itself is frozen, because the class-wide type refers to the - -- tagged type which generates the class. + -- When a tagged type is frozen, the corresponding class-wide type + -- is frozen as well (RM 13.14(15)). This must be done after the + -- tagged type itself is frozen, because the class-wide type refers + -- to the tagged type which generates the class. - -- For a tagged type, freeze explicitly those primitive operations - -- that are expression functions, which otherwise have no clear - -- freeze point: these have to be frozen before the dispatch table - -- for the type is built, and before any explicit call to the - -- primitive, which would otherwise be the freeze point for it. + -- When a tagged type is frozen, the primitive subprograms of the + -- type are frozen; for each such subprogram that is an expression + -- function, its expression causes freezing (RM 13.14(15.1)). - if Is_Tagged_Type (E) - and then not Is_Class_Wide_Type (E) - and then Present (Class_Wide_Type (E)) - then - Freeze_And_Append (Class_Wide_Type (E), N, Result); + -- Note that we explicitly freeze only expression functions here for + -- historical reasons; other primitive subprograms are frozen later, + -- by means of other freezing mechanisms. + if Is_Tagged_Type (E) and then not Is_Class_Wide_Type (E) then declare - Ops : constant Elist_Id := Primitive_Operations (E); + Ops : constant Elist_Id := Primitive_Operations (E); Elmt : Elmt_Id; Subp : Entity_Id; begin - if Ops /= No_Elist then + if Present (Class_Wide_Type (E)) then + Freeze_And_Append (Class_Wide_Type (E), N, Result); + end if; + + if Present (Ops) then Elmt := First_Elmt (Ops); while Present (Elmt) loop Subp := Node (Elmt); if Is_Expression_Function (Subp) then - Freeze_And_Append (Subp, N, Result); + Freeze_And_Append + (Subp, N, Result, Do_Freeze_Profile => False); + Freeze_Expr_Types + (Expr => Expression_Of_Expression_Function (Subp), + N => N, + Def_Id => Subp, + Result => Result); end if; - Next_Elmt (Elmt); end loop; end if; @@ -8616,6 +8538,13 @@ package body Freeze is then return True; + -- This is the body of a Default_Initial_Condition procedure + + elsif Present (Corresponding_Spec (P)) + and then Is_DIC_Procedure (Corresponding_Spec (P)) + then + return True; + -- This is the body of a helper/wrapper built for CW preconditions elsif Present (Corresponding_Spec (P)) @@ -8757,11 +8686,6 @@ package body Freeze is or else not Comes_From_Source (Entity (N))) then Nam := Entity (N); - - if Present (Nam) and then Ekind (Nam) = E_Function then - Check_Expression_Function (N, Nam); - end if; - else Nam := Empty; end if; @@ -9299,6 +9223,15 @@ package body Freeze is if Present (Nam) then Freeze_Before (P, Nam); + + -- Freeze types in expression function (RM 13.14(10.1, 10.2, 10.3)) + + if Is_Expression_Function (Nam) then + Freeze_Expr_Types_Before + (N => P, + Expr => Expression_Of_Expression_Function (Nam), + Def_Id => Nam); + end if; end if; -- Restore In_Spec_Expression flag @@ -9311,15 +9244,23 @@ package body Freeze is ----------------------- procedure Freeze_Expr_Types - (Def_Id : Entity_Id; - Typ : Entity_Id; - Expr : Node_Id; - N : Node_Id) + (Expr : Node_Id; + N : Node_Id; + Def_Id : Entity_Id; + Result : in out List_Id; + Before : Boolean := False; + Typ : Entity_Id := Empty) is function Cloned_Expression return Node_Id; -- Build a duplicate of the expression of the return statement that has -- no defining entities shared with the original expression. + procedure Explain_Error; + -- Output an explanation of the error as continuation messages + + procedure Find_Incomplete_Constant (Node : Node_Id); + -- Search for a deferred constant without completion + function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result; -- Freeze all types referenced in the subtree rooted at Node @@ -9377,6 +9318,71 @@ package body Freeze is return Dup_Expr; end Cloned_Expression; + ------------------- + -- Explain_Error -- + ------------------- + + procedure Explain_Error is + begin + Error_Msg_NE + ("\\because expression of function& is frozen here", N, Def_Id); + if Nkind (N) = N_Object_Declaration + and then Is_Dispatching_Operation (Def_Id) + then + declare + Typ : constant Entity_Id := + (if Present (Expression (N)) + then Etype (Expression (N)) + else Etype (Defining_Identifier (N))); + begin + if Present (Typ) then + Error_Msg_NE + ("\\as a primitive operation of type& frozen here", + N, Typ); + end if; + end; + end if; + if Nkind (N) /= N_Expression_Function then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Msg_NE ("\\expression function& is declared#", N, Def_Id); + end if; + end Explain_Error; + + ------------------------------ + -- Find_Incomplete_Constant -- + ------------------------------ + + procedure Find_Incomplete_Constant (Node : Node_Id) is + begin + -- When a constant is initialized with the result of a dispatching + -- call, the constant declaration is rewritten as a renaming of the + -- displaced function result. This scenario is not a premature use of + -- a constant even though the Has_Completion flag is not set. + + if Is_Entity_Name (Node) + and then Present (Entity (Node)) + and then Ekind (Entity (Node)) = E_Constant + and then Scope (Entity (Node)) = Current_Scope + and then Nkind (Declaration_Node (Entity (Node))) = + N_Object_Declaration + and then not Is_Imported (Entity (Node)) + and then not Has_Completion (Entity (Node)) + and then not + (Present (Full_View (Entity (Node))) + and then (Has_Completion (Full_View (Entity (Node))) + or else + Declaration_Node (Full_View (Entity (Node))) = N)) + then + Error_Msg_NE + ("deferred constant& is frozen before completion", + N, Entity (Node)); + + Explain_Error; + + Set_Is_Frozen (Entity (Node)); + end if; + end Find_Incomplete_Constant; + ---------------------- -- Freeze_Type_Refs -- ---------------------- @@ -9391,6 +9397,10 @@ package body Freeze is procedure Check_And_Freeze_Type (Typ : Entity_Id) is begin + if Is_Frozen (Typ) then + return; + end if; + -- Skip Itypes created by the preanalysis, and itypes whose -- scope is another type (i.e. component subtypes that depend -- on a discriminant), @@ -9406,17 +9416,22 @@ package body Freeze is -- whose compilation fails much later. Refine the error message if -- possible. - Check_Fully_Declared (Typ, Node); + Check_Fully_Declared (Typ, N); - if Error_Posted (Node) then + if Error_Posted (N) then if Has_Private_Component (Typ) and then not Is_Private_Type (Typ) then - Error_Msg_NE ("\type& has private component", Node, Typ); + Error_Msg_NE ("\\type& has private component", N, Typ); end if; - else + Explain_Error; + + elsif Before then Freeze_Before (N, Typ); + + else + Freeze_And_Append (Typ, N, Result); end if; end Check_And_Freeze_Type; @@ -9498,6 +9513,8 @@ package body Freeze is end; end if; + Find_Incomplete_Constant (Node); + -- No point in posting several errors on the same expression if Serious_Errors_Detected > 0 then @@ -9509,12 +9526,6 @@ package body Freeze is procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs); - -- Local variables - - Saved_First_Entity : constant Entity_Id := First_Entity (Def_Id); - Saved_Last_Entity : constant Entity_Id := Last_Entity (Def_Id); - Dup_Expr : constant Node_Id := Cloned_Expression; - -- Start of processing for Freeze_Expr_Types begin @@ -9531,31 +9542,65 @@ package body Freeze is -- And_Resolve for the sake of consistency with Analyze_Expression_ -- Function. - if Def_Id /= Current_Scope then - Push_Scope (Def_Id); - Install_Formals (Def_Id); - Preanalyze_And_Resolve_Spec_Expression (Dup_Expr, Typ); - End_Scope; - else - Preanalyze_And_Resolve_Spec_Expression (Dup_Expr, Typ); - end if; + if Present (Typ) then + declare + Saved_First_Entity : constant Entity_Id := First_Entity (Def_Id); + Saved_Last_Entity : constant Entity_Id := Last_Entity (Def_Id); + Dup_Expr : constant Node_Id := Cloned_Expression; + + begin + if Def_Id /= Current_Scope then + Push_Scope (Def_Id); + Install_Formals (Def_Id); + Preanalyze_And_Resolve_Spec_Expression (Dup_Expr, Typ); + End_Scope; + else + Preanalyze_And_Resolve_Spec_Expression (Dup_Expr, Typ); + end if; - -- Restore certain attributes of Def_Id since the preanalysis may - -- have introduced itypes to this scope, thus modifying attributes - -- First_Entity and Last_Entity. + -- Restore certain attributes of Def_Id since the preanalysis may + -- have introduced itypes to this scope, thus modifying attributes + -- First_Entity and Last_Entity. - Set_First_Entity (Def_Id, Saved_First_Entity); - Set_Last_Entity (Def_Id, Saved_Last_Entity); + Set_First_Entity (Def_Id, Saved_First_Entity); + Set_Last_Entity (Def_Id, Saved_Last_Entity); - if Present (Last_Entity (Def_Id)) then - Set_Next_Entity (Last_Entity (Def_Id), Empty); - end if; + if Present (Last_Entity (Def_Id)) then + Set_Next_Entity (Last_Entity (Def_Id), Empty); + end if; - -- Freeze all types referenced in the expression + -- Freeze all types referenced in the expression - Freeze_References (Dup_Expr); + Freeze_References (Dup_Expr); + end; + + else + Freeze_References (Expr); + end if; end Freeze_Expr_Types; + ------------------------------ + -- Freeze_Expr_Types_Before -- + ------------------------------ + + procedure Freeze_Expr_Types_Before + (N : Node_Id; + Expr : Node_Id; + Def_Id : Entity_Id; + Typ : Entity_Id := Empty) + is + Dummy : List_Id := No_List; + + begin + Freeze_Expr_Types + (Expr => Expr, + N => N, + Def_Id => Def_Id, + Result => Dummy, + Before => True, + Typ => Typ); + end Freeze_Expr_Types_Before; + ----------------------------- -- Freeze_Fixed_Point_Type -- ----------------------------- @@ -11047,101 +11092,11 @@ package body Freeze is -- Should_Freeze_Type -- ------------------------ - function Should_Freeze_Type - (Typ : Entity_Id; - E : Entity_Id; - N : Node_Id) return Boolean - is - Decl : constant Node_Id := - (if Ekind (E) = E_Subprogram_Type and then No (Parent (E)) - then Empty - else Original_Node (Unit_Declaration_Node (E))); - - function Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate - (N : Node_Id) return Traverse_Result; - -- Return Abandon if N is a dispatching call to a subprogram - -- declared in the same scope as Typ, or a tagged result that - -- needs specific expansion, or an aggregate whose type is Typ. - - function Check_Freezing is new - Traverse_Func (Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate); - -- Return Abandon if the input expression requires freezing Typ - - function Within_Simple_Return_Statement (N : Node_Id) return Boolean; - -- Determine whether N is the expression of a simple return statement, - -- or the dependent expression of a conditional expression which is - -- the expression of a simple return statement, including recursively. - - ------------------------------------------------------- - -- Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate -- - ------------------------------------------------------- - - function Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate - (N : Node_Id) return Traverse_Result - is - begin - if Nkind (N) = N_Function_Call - and then Present (Controlling_Argument (N)) - and then Scope (Entity (Original_Node (Name (N)))) = Scope (Typ) - then - return Abandon; - - -- The expansion done in Expand_Simple_Function_Return will assign - -- the tag to the result in this case. - - elsif Is_Conversion_Or_Reference_To_Formal (N) - and then Within_Simple_Return_Statement (N) - and then Etype (N) = Typ - and then Is_Tagged_Type (Typ) - and then not Is_Class_Wide_Type (Typ) - then - return Abandon; - - elsif Nkind (N) in N_Aggregate - | N_Delta_Aggregate - | N_Extension_Aggregate - and then Base_Type (Etype (N)) = Base_Type (Typ) - then - return Abandon; - - else - return OK; - end if; - end Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate; - - ------------------------------------ - -- Within_Simple_Return_Statement -- - ------------------------------------ - - function Within_Simple_Return_Statement (N : Node_Id) return Boolean is - Par : constant Node_Id := Parent (N); - - begin - if Nkind (Par) = N_Simple_Return_Statement then - return True; - - elsif Nkind (Par) = N_Case_Expression_Alternative then - return Within_Simple_Return_Statement (Parent (Par)); - - elsif Nkind (Par) = N_If_Expression - and then N /= First (Expressions (Par)) - then - return Within_Simple_Return_Statement (Par); - - else - return False; - end if; - end Within_Simple_Return_Statement; - - -- Start of processing for Should_Freeze_Type - + function Should_Freeze_Type (Typ : Entity_Id; N : Node_Id) return Boolean is begin return Within_Scope (Typ, Current_Scope) or else (Nkind (N) = N_Subprogram_Renaming_Declaration - and then Present (Corresponding_Formal_Spec (N))) - or else (Present (Decl) - and then Nkind (Decl) = N_Expression_Function - and then Check_Freezing (Expression (Decl)) = Abandon); + and then Present (Corresponding_Formal_Spec (N))); end Should_Freeze_Type; ------------------ diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads index fa4a22a04c11..995ff04187b4 100644 --- a/gcc/ada/freeze.ads +++ b/gcc/ada/freeze.ads @@ -226,16 +226,21 @@ package Freeze is -- so need to be similarly treated. Freeze_Expression takes care of -- determining the proper insertion point for generated freeze actions. - procedure Freeze_Expr_Types - (Def_Id : Entity_Id; - Typ : Entity_Id; + procedure Freeze_Expr_Types_Before + (N : Node_Id; Expr : Node_Id; - N : Node_Id); - -- N is the body constructed for an expression function that is a - -- completion, and Def_Id is the function being completed. + Def_Id : Entity_Id; + Typ : Entity_Id := Empty); -- This procedure freezes before N all the types referenced in Expr, - -- which is either the expression of the expression function, or - -- the expression in a pre/post aspect that applies to Def_Id; + -- which is either the expression of the expression function Def_Id, + -- or the expression in a pre/post aspect that applies to Def_Id. + + -- If Typ is present, it is the type used to preanalyze and resolve a + -- copy of Expr; if it is not, Expr is assumed to be already analyzed. + + -- Check that the expression does not include references to deferred + -- constants without completion. We report this at the freeze point of + -- the function, to provide a better error message. procedure Freeze_Fixed_Point_Type (Typ : Entity_Id); -- Freeze fixed point type. For fixed-point types, we have to defer diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index cf4774b8a27a..24534f121c1d 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -2021,7 +2021,7 @@ package body Ghost is Check_Ghost_Completion (Prev_Id => Spec_Id, Compl_Id => Body_Id); - -- Mark the body as its formals as Ghost + -- Mark the body and its formals as Ghost Mark_Ghost_Declaration_Or_Body (N, Policy, Level); @@ -2030,6 +2030,36 @@ package body Ghost is Install_Ghost_Region (Policy, N, Level); end Mark_And_Set_Ghost_Body; + ---------------------------------------------------- + -- Mark_And_Set_Ghost_Body_Of_Expression_Function -- + ---------------------------------------------------- + + procedure Mark_And_Set_Ghost_Body_Of_Expression_Function + (N : Node_Id; + Spec_Id : Entity_Id) + is + Level : constant Entity_Id := Ghost_Assertion_Level (Spec_Id); + + Policy : Name_Id; + + begin + if Is_Checked_Ghost_Entity (Spec_Id) then + Policy := Name_Check; + elsif Is_Ignored_Ghost_Entity (Spec_Id) then + Policy := Name_Ignore; + else + Policy := No_Name; + end if; + + -- Mark the body and its formals as Ghost + + Mark_Ghost_Declaration_Or_Body (N, Policy, Level); + + -- Install the appropriate Ghost region + + Install_Ghost_Region (Policy, N, Level); + end Mark_And_Set_Ghost_Body_Of_Expression_Function; + ----------------------------------- -- Mark_And_Set_Ghost_Completion -- ----------------------------------- diff --git a/gcc/ada/ghost.ads b/gcc/ada/ghost.ads index ac0334e43948..006dd0c4fbd8 100644 --- a/gcc/ada/ghost.ads +++ b/gcc/ada/ghost.ads @@ -181,6 +181,15 @@ package Ghost is -- Install the Ghost mode of the body. This routine starts a Ghost region -- and must be used with routine Restore_Ghost_Region. + procedure Mark_And_Set_Ghost_Body_Of_Expression_Function + (N : Node_Id; + Spec_Id : Entity_Id); + -- Mark the subprogram body N generated for an expression function Spec_Id + -- that is not a completion as Ghost when Spec_Id is a Ghost entity. + -- + -- Install the Ghost mode of the body. This routine starts a Ghost region + -- and must be used with routine Restore_Ghost_Region. + procedure Mark_And_Set_Ghost_Completion (N : Node_Id; Prev_Id : Entity_Id); diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index e760d567c3d9..2d72702c0e6f 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -1527,13 +1527,17 @@ package body Rtsfind is Lib_Unit : Node_Id; Pkg_Ent : Entity_Id; - Save_Front_End_Inlining : constant Boolean := Front_End_Inlining; + Saved_Front_End_Inlining : constant Boolean := Front_End_Inlining; -- This flag is used to disable front-end inlining when RTE is invoked. -- This prevents the analysis of other runtime bodies when a particular - -- spec is loaded through Rtsfind. This is both efficient, and prevents - -- spurious visibility conflicts between use-visible user entities, and + -- spec is loaded through Rtsfind. This is efficient, and also prevents + -- spurious visibility conflicts between use-visible user entities and -- entities in run-time packages. + Saved_In_Inlined_Body : constant Boolean := In_Inlined_Body; + -- This flag is used to preserve and reset In_Inlined_Body when RTE is + -- invoked. + -- Start of processing for RTE begin @@ -1556,6 +1560,7 @@ package body Rtsfind is end if; Front_End_Inlining := False; + In_Inlined_Body := False; -- Load unit if unit not previously loaded @@ -1630,7 +1635,9 @@ package body Rtsfind is end if; Maybe_Add_With (U); - Front_End_Inlining := Save_Front_End_Inlining; + + Front_End_Inlining := Saved_Front_End_Inlining; + In_Inlined_Body := Saved_In_Inlined_Body; return Check_CRT (E, RE_Table (E)); end RTE; @@ -1680,21 +1687,24 @@ package body Rtsfind is Lib_Unit : Node_Id; Pkg_Ent : Entity_Id; - -- The following flag is used to disable front-end inlining when + Saved_Front_End_Inlining : constant Boolean := Front_End_Inlining; + -- This flags is used to disable front-end inlining when -- RTE_Record_Component is invoked. This prevents the analysis of other -- runtime bodies when a particular spec is loaded through Rtsfind. This - -- is both efficient, and it prevents spurious visibility conflicts - -- between use-visible user entities, and entities in run-time packages. + -- is efficient, and also prevents spurious visibility conflicts between + -- use-visible user entities and entities in run-time packages. - Save_Front_End_Inlining : Boolean; + Saved_In_Inlined_Body : constant Boolean := In_Inlined_Body; + -- This flag is used to preserve and reset In_Inlined_Body when + -- RTE_Record_Component is invoked. begin -- Note: Contrary to subprogram RTE, there is no need to do any special -- management with package system.ads because it has no record type -- declarations. - Save_Front_End_Inlining := Front_End_Inlining; - Front_End_Inlining := False; + Front_End_Inlining := False; + In_Inlined_Body := False; -- Load unit if unit not previously loaded @@ -1733,7 +1743,9 @@ package body Rtsfind is Maybe_Add_With (U); - Front_End_Inlining := Save_Front_End_Inlining; + Front_End_Inlining := Saved_Front_End_Inlining; + In_Inlined_Body := Saved_In_Inlined_Body; + return Check_CRT (E, Found_E); end RTE_Record_Component; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 691667226925..1b9431964c3d 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -11707,8 +11707,16 @@ package body Sem_Attr is -- spec expressions). The profile of the subprogram is not -- frozen at this point. + -- Taking the 'Access of an expression function freezes its + -- expression (RM 13.14(10.3)). + if not Preanalysis_Active then - Freeze_Before (N, Entity (P), Do_Freeze_Profile => False); + if Is_Expression_Function (Entity (P)) then + Freeze_Expression (P); + else + Freeze_Before + (N, Entity (P), Do_Freeze_Profile => False); + end if; end if; -- If it is a type, there is nothing to resolve. @@ -11717,7 +11725,12 @@ package body Sem_Attr is elsif Is_Overloadable (Entity (P)) then if not Preanalysis_Active then - Freeze_Before (N, Entity (P), Do_Freeze_Profile => False); + if Is_Expression_Function (Entity (P)) then + Freeze_Expression (P); + else + Freeze_Before + (N, Entity (P), Do_Freeze_Profile => False); + end if; end if; -- Nothing to do if prefix is a type name @@ -12498,8 +12511,8 @@ package body Sem_Attr is Scop : constant Entity_Id := Scope (Subp_Id); Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); - Flag_Id : Entity_Id; - Subp_Body : Node_Id; + + Flag_Id : Entity_Id; -- If the access has been taken and the body of the subprogram -- has not been see yet, indirect calls must be protected with @@ -12552,58 +12565,6 @@ package body Sem_Attr is Set_Scope (Flag_Id, Scop); end if; - - -- Taking the 'Access of an expression function freezes its - -- expression (RM 13.14 10.3/3). This does not apply to an - -- expression function that acts as a completion because the - -- generated body is immediately analyzed and the expression - -- is automatically frozen. - - if Is_Expression_Function (Subp_Id) - and then Present (Corresponding_Body (Subp_Decl)) - then - Subp_Body := - Unit_Declaration_Node (Corresponding_Body (Subp_Decl)); - - -- The body has already been analyzed when the expression - -- function acts as a completion. - - if Analyzed (Subp_Body) then - null; - - -- Attribute 'Access may appear within the generated body - -- of the expression function subject to the attribute: - - -- function F is (... F'Access ...); - - -- If the expression function is on the scope stack, then - -- the body is currently being analyzed. Do not reanalyze - -- it because this will lead to infinite recursion. - - elsif In_Open_Scopes (Subp_Id) then - null; - - -- If reference to the expression function appears in an - -- inner scope, for example as an actual in an instance, - -- this is not a freeze point either. - - elsif Scope (Subp_Id) /= Current_Scope then - null; - - -- Dispatch tables are not a freeze point either - - elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion - and then Is_Dispatch_Table_Entity (Etype (Parent (N))) - then - null; - - -- Analyze the body of the expression function to freeze - -- the expression. - - else - Analyze (Subp_Body); - end if; - end if; end; end if; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index a1afb17bd779..402aa2164270 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -2438,14 +2438,30 @@ package body Sem_Ch12 is -- An instantiation freezes all generic actuals, except for incomplete -- types and subprograms that are not fully defined at the point of - -- instantiation. + -- instantiation. If one of them is an expression function, then the + -- instantiation also freezes its expression (RM 13.14(10.2)). declare - Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze); + Elmt : Elmt_Id; + Expr : Node_Id; begin + Elmt := First_Elmt (Actuals_To_Freeze); while Present (Elmt) loop - Freeze_Before (N, Node (Elmt)); + -- For technical reasons, we need an expression attached to the + -- tree to freeze the expression of an expression function, so + -- we manufacture one on the fly. + + if Is_Expression_Function (Node (Elmt)) then + Expr := New_Occurrence_Of (Node (Elmt), Sloc (N)); + Set_Comes_From_Source (Expr); + Set_Entity (Expr, Node (Elmt)); + Set_Parent (Expr, N); + Freeze_Expression (Expr); + else + Freeze_Before (N, Node (Elmt)); + end if; + Next_Elmt (Elmt); end loop; end; @@ -2569,16 +2585,6 @@ package body Sem_Ch12 is end if; end if; - -- If the object is a call to an expression function, this - -- is a freezing point for it. - - if Is_Entity_Name (Match) - and then Present (Entity (Match)) - and then Is_Expression_Function (Entity (Match)) - then - Append_Elmt (Entity (Match), Actuals_To_Freeze); - end if; - when N_Formal_Type_Declaration => if Assoc.Actual.Kind = Box_Actual then Process_Box_Actual (Assoc.Un_Formal); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index b26a6ca70ea0..e726abad4760 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2894,7 +2894,8 @@ package body Sem_Ch3 is -- generated bodies that have not been analyzed yet), freeze all -- types now. Note that in the latter case, the expander must take -- care to attach the bodies at a proper place in the tree so as to - -- not cause unwanted freezing at that point. + -- not cause unwanted freezing at that point. The exception is the + -- generated body of an expression function, which does not freeze. -- It is also necessary to check for a case where both an expression -- function is used and the current scope depends on an incomplete @@ -2941,11 +2942,6 @@ package body Sem_Ch3 is Adjust_Decl; - -- The generated body of an expression function does not freeze, - -- unless it is a completion, in which case only the expression - -- itself freezes. This is handled when the body itself is - -- analyzed (see Freeze_Expr_Types, sem_ch6.adb). - Freeze_All (Freeze_From, Decl); Freeze_From := Last_Entity (Current_Scope); end if; @@ -12575,6 +12571,10 @@ package body Sem_Ch3 is -- source (including the _Call primitive operation of RAS types, -- which has to have the flag Comes_From_Source for other purposes): -- we assume that the expander will provide the missing completion. + + -- Likewise for a stand-alone expression function, whose body may be + -- generated outside of the package. + -- In case of previous errors, other expansion actions that provide -- bodies for null procedures with not be invoked, so inhibit message -- in those cases. @@ -12600,6 +12600,9 @@ package body Sem_Ch3 is then null; + elsif Is_Expression_Function (E) then + null; + elsif Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit then diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 81b9458d5540..956b25fbdd0d 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1812,7 +1812,7 @@ package body Sem_Ch4 is and then Has_Static_Predicate_Aspect (Exp_Type) and then Preanalysis_Active then - null; + Analyze_Choices (Alternatives (N), Exp_Type); -- Call Analyze_Choices and Check_Choices to do the rest of the work diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 666627bee8e7..d898fb40997c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -62,6 +62,7 @@ with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; with Sem_Ch5; use Sem_Ch5; +with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Ch9; use Sem_Ch9; with Sem_Ch10; use Sem_Ch10; @@ -304,6 +305,8 @@ package body Sem_Ch6 is -- Local variables Asp : Node_Id; + F_Id : Node_Id; + F_Spec : Node_Id; New_Body : Node_Id; New_Spec : Node_Id; Orig_N : Node_Id := Empty; @@ -439,11 +442,11 @@ package body Sem_Ch6 is -- with the function body. Ghost_Context_Checks_Disabled := True; - Freeze_Expr_Types - (Def_Id => Def_Id, - Typ => Typ, + Freeze_Expr_Types_Before + (N => N, Expr => Expr, - N => N); + Def_Id => Def_Id, + Typ => Typ); Ghost_Context_Checks_Disabled := False; end if; @@ -529,9 +532,36 @@ package body Sem_Ch6 is Def_Id := Defining_Entity (N); Set_Is_Inlined (Def_Id); + Set_In_Private_Part (Def_Id, In_Private_Part (Scope (Def_Id))); Typ := Etype (Def_Id); + -- Propagate the results of the resolution of the specification of + -- the declaration to the specification of the body, so that it is + -- not done again and potentially out of context. + + Set_Result_Definition (New_Spec, New_Occurrence_Of (Typ, Loc)); + + F_Id := First_Formal (Def_Id); + F_Spec := First (Parameter_Specifications (New_Spec)); + while Present (F_Spec) loop + if Nkind (Parameter_Type (F_Spec)) = N_Access_Definition then + Set_Subtype_Mark + (Parameter_Type (F_Spec), + New_Occurrence_Of + (Directly_Designated_Type (Etype (F_Id)), Loc)); + elsif Null_Exclusion_Present (F_Spec) then + Set_Parameter_Type + (F_Spec, New_Occurrence_Of (Base_Type (Etype (F_Id)), Loc)); + else + Set_Parameter_Type + (F_Spec, New_Occurrence_Of (Etype (F_Id), Loc)); + end if; + + Next_Formal (F_Id); + Next (F_Spec); + end loop; + -- Establish the linkages between the spec and the body. These are -- used when the expression function acts as the prefix of attribute -- 'Access in order to freeze the original expression which has been @@ -550,7 +580,8 @@ package body Sem_Ch6 is Insert_After (N, New_Body); -- To prevent premature freeze action, insert the new body at the end - -- of the current declarations, or at the end of the package spec. + -- of the current declarative part or at the end of the specification + -- of the innermost package that is a library unit per RM 13.14(3/5). -- However, resolve usage names now, to prevent spurious visibility -- on later entities. Note that the function can now be called in -- the current declarative part, which will appear to be prior to the @@ -560,10 +591,19 @@ package body Sem_Ch6 is else declare - Decls : List_Id := List_Containing (N); - Par : constant Node_Id := Parent (Decls); + Decls : List_Id := List_Containing (N); + Par : Node_Id := Parent (Decls); begin + while Nkind (Par) = N_Package_Specification + and then not Is_Compilation_Unit (Defining_Entity (Par)) + and then not Is_Generic_Instance (Defining_Entity (Par)) + and then not Is_Generic_Unit (Defining_Entity (Par)) + loop + Decls := List_Containing (Parent (Par)); + Par := Parent (Decls); + end loop; + if Nkind (Par) = N_Package_Specification and then Decls = Visible_Declarations (Par) and then not Is_Empty_List (Private_Declarations (Par)) @@ -652,8 +692,7 @@ package body Sem_Ch6 is -- calls. Set_Expression - (Original_Node (Subprogram_Spec (Def_Id)), - Make_Expr_Copy); + (Original_Node (Subprogram_Spec (Def_Id)), Make_Expr_Copy); -- Mark static expression functions as inlined, to ensure -- that even calls with nonstatic actuals will be inlined. @@ -2384,7 +2423,6 @@ package body Sem_Ch6 is Conformant : Boolean; Desig_View : Entity_Id := Empty; Exch_Views : Elist_Id := No_Elist; - Mask_Types : Elist_Id := No_Elist; Prot_Typ : Entity_Id := Empty; Spec_Decl : Node_Id := Empty; Spec_Id : Entity_Id := Empty; @@ -2474,12 +2512,6 @@ package body Sem_Ch6 is -- Determine whether subprogram Subp_Id is a primitive of a concurrent -- type that implements an interface and has a private view. - function Mask_Unfrozen_Types (Spec_Id : Entity_Id) return Elist_Id; - -- N is the body generated for an expression function that is not a - -- completion and Spec_Id the defining entity of its spec. Mark all - -- the not-yet-frozen types referenced by the simple return statement - -- of the function as formally frozen. - procedure Move_Pragmas (From : Node_Id; To : Node_Id); -- Find all suitable source pragmas at the top of subprogram body -- From's declarations and move them after arbitrary node To. @@ -2496,9 +2528,6 @@ package body Sem_Ch6 is -- of an entity, we mark the entity as set in source to suppress any -- warning on the stylized use of function stubs with a dummy return. - procedure Unmask_Unfrozen_Types (Unmask_List : Elist_Id); - -- Undo the transformation done by Mask_Unfrozen_Types - procedure Verify_Overriding_Indicator; -- If there was a previous spec, the entity has been entered in the -- current scope previously. If the body itself carries an overriding @@ -3308,86 +3337,6 @@ package body Sem_Ch6 is return False; end Is_Private_Concurrent_Primitive; - ------------------------- - -- Mask_Unfrozen_Types -- - ------------------------- - - function Mask_Unfrozen_Types (Spec_Id : Entity_Id) return Elist_Id is - Result : Elist_Id := No_Elist; - - function Mask_Type_Refs (Node : Node_Id) return Traverse_Result; - -- Mask all types referenced in the subtree rooted at Node as - -- formally frozen. - - -------------------- - -- Mask_Type_Refs -- - -------------------- - - function Mask_Type_Refs (Node : Node_Id) return Traverse_Result is - procedure Mask_Type (Typ : Entity_Id); - -- Mask a given type as formally frozen when outside the current - -- scope, or else freeze the type. - - --------------- - -- Mask_Type -- - --------------- - - procedure Mask_Type (Typ : Entity_Id) is - begin - -- Skip Itypes created by the preanalysis - - if Is_Itype (Typ) - and then Scope_Within_Or_Same (Scope (Typ), Spec_Id) - then - return; - end if; - - if not Is_Frozen (Typ) then - if Scope (Typ) /= Current_Scope then - Set_Is_Frozen (Typ); - Append_New_Elmt (Typ, Result); - else - Freeze_Before (N, Typ); - end if; - end if; - end Mask_Type; - - -- Start of processing for Mask_Type_Refs - - begin - if Is_Entity_Name (Node) and then Present (Entity (Node)) then - Mask_Type (Etype (Entity (Node))); - - if Ekind (Entity (Node)) in E_Component | E_Discriminant then - Mask_Type (Scope (Entity (Node))); - end if; - - elsif Nkind (Node) in N_Aggregate | N_Null | N_Type_Conversion - and then Present (Etype (Node)) - then - Mask_Type (Etype (Node)); - end if; - - return OK; - end Mask_Type_Refs; - - procedure Mask_References is new Traverse_Proc (Mask_Type_Refs); - - -- Local variables - - Return_Stmt : constant Node_Id := - First (Statements (Handled_Statement_Sequence (N))); - - -- Start of processing for Mask_Unfrozen_Types - - begin - pragma Assert (Nkind (Return_Stmt) = N_Simple_Return_Statement); - - Mask_References (Expression (Return_Stmt)); - - return Result; - end Mask_Unfrozen_Types; - ------------------ -- Move_Pragmas -- ------------------ @@ -3490,20 +3439,6 @@ package body Sem_Ch6 is end if; end Set_Trivial_Subprogram; - --------------------------- - -- Unmask_Unfrozen_Types -- - --------------------------- - - procedure Unmask_Unfrozen_Types (Unmask_List : Elist_Id) is - Elmt : Elmt_Id := First_Elmt (Unmask_List); - - begin - while Present (Elmt) loop - Set_Is_Frozen (Node (Elmt), False); - Next_Elmt (Elmt); - end loop; - end Unmask_Unfrozen_Types; - --------------------------------- -- Verify_Overriding_Indicator -- --------------------------------- @@ -3605,6 +3540,8 @@ package body Sem_Ch6 is Ignore_SPARK_Mode_Pragmas_In_Instance; -- Save the Ghost and SPARK mode-related data to restore on exit + Saved_In_Inlined_Body : Boolean; + -- Start of processing for Analyze_Subprogram_Body_Helper begin @@ -3810,7 +3747,11 @@ package body Sem_Ch6 is -- the mode now to ensure that any nodes generated during analysis -- and expansion are properly marked as Ghost. - Mark_And_Set_Ghost_Body (N, Spec_Id); + if Is_Expression_Function (Spec_Id) then + Mark_And_Set_Ghost_Body_Of_Expression_Function (N, Spec_Id); + else + Mark_And_Set_Ghost_Body (N, Spec_Id); + end if; -- If the body completes the initial declaration of a compilation -- unit which is subject to pragma Elaboration_Checks, set the @@ -3889,51 +3830,25 @@ package body Sem_Ch6 is Compute_Returns_By_Ref (Spec_Id); end if; - -- In general, the spec will be frozen when we start analyzing the - -- body. However, for internally generated operations, such as - -- wrapper functions for inherited operations with controlling - -- results, the spec may not have been frozen by the time we expand - -- the freeze actions that include the bodies. In particular, extra - -- formals for accessibility or for return-in-place may need to be - -- generated. Freeze nodes, if any, are inserted before the current - -- body. These freeze actions are also needed in Compile_Only mode to - -- enable the proper back-end type annotations. - -- They are necessary in any case to ensure proper elaboration order - -- in gigi. - - if From_Expression_Function - and then not Has_Completion (Spec_Id) - and then Serious_Errors_Detected = 0 - and then (Expander_Active - or else Operating_Mode = Check_Semantics - or else Is_Ignored_Ghost_Entity_In_Codegen (Spec_Id)) - then - -- The body generated for an expression function that is not a - -- completion is a freeze point neither for the profile nor for - -- anything else. That's why, in order to prevent any freezing - -- during analysis, we need to mask types declared outside the - -- expression (and in an outer scope) that are not yet frozen. - -- This also needs to be done in the case of an ignored Ghost - -- expression function, where the expander isn't active. - - -- A further complication arises if the expression function is - -- a primitive operation of a tagged type: in that case the - -- function entity must be frozen before the dispatch table for - -- the type is constructed, so it will be frozen like other local - -- entities, at the end of the current scope. + -- In most cases the spec is frozen when we start analyzing the body. + -- However, for some internally generated operations such as wrapper + -- functions for inherited operations with a controlling result, and + -- for expression functions, it has not necessarily been frozen yet. + -- In particular, extra formals for accessibility or build-in-place + -- return purposes may still need to be generated. Freeze nodes are + -- inserted before the body, and are necessary to ensure the proper + -- elaboration order in the code generator. - if not Is_Dispatching_Operation (Spec_Id) then - Set_Is_Frozen (Spec_Id); - end if; + -- A further complication arises when the expression function is a + -- primitive operation of a tagged type: in that case the function + -- entity must be frozen before the dispatch table for the type is + -- built, but this freezing must not freeze the tagged type itself. - Mask_Types := Mask_Unfrozen_Types (Spec_Id); - - elsif not Is_Frozen (Spec_Id) - and then Serious_Errors_Detected = 0 - then + if not Is_Frozen (Spec_Id) and then Serious_Errors_Detected = 0 then Set_Has_Delayed_Freeze (Spec_Id); Create_Extra_Formals (Spec_Id, Related_Nod => N); - Freeze_Before (N, Spec_Id); + Freeze_Before (N, Spec_Id, + Do_Freeze_Profile => not Is_Dispatching_Operation (Spec_Id)); end if; end if; @@ -3996,7 +3911,7 @@ package body Sem_Ch6 is then Conformant := True; - -- Finally, a body generated for an expression function copies + -- The body generated for a stand-alone expression function copies -- the profile of the function and no check is needed either. elsif Is_Expression_Function (Spec_Id) then @@ -4122,13 +4037,57 @@ package body Sem_Ch6 is Build_Subprogram_Instance_Renamings (N, Current_Scope); end if; - Push_Scope (Spec_Id); + -- The body of a stand-alone expression function may be generated + -- out of context like an inlined body, so we set In_Inlined_Body + -- when analyzing it to bypass visibility constraints on the types + -- of operators (the constraints have already been checked during + -- the preanalysis of the expression but, unlike resolution per se + -- which is not redone, they are checked again to set the Etype). + + if Is_Expression_Function (Spec_Id) then + Saved_In_Inlined_Body := In_Inlined_Body; + In_Inlined_Body := True; + + -- Moreover, if the expression function was declared in the + -- private part of its package, we need to temporarily make + -- the full view of the private types visible. + + if Scope (Spec_Id) /= Current_Scope + and then In_Private_Part (Spec_Id) + then + declare + S : constant Entity_Id := Scope (Spec_Id); + + Ent : Entity_Id; + + begin + Ent := First_Entity (S); + while Present (Ent) + and then Ent /= First_Private_Entity (S) + loop + if Is_Private_Base_Type (Ent) + and then Present (Full_View (Ent)) + and then Comes_From_Source (Full_View (Ent)) + and then Scope (Full_View (Ent)) = Scope (Ent) + and then Ekind (Full_View (Ent)) /= E_Incomplete_Type + then + Exchange_Declarations (Ent); + end if; + + Next_Entity (Ent); + end loop; + end; + end if; -- Make sure that the subprogram is immediately visible. For -- child units that have no separate spec this is indispensable. -- Otherwise it is safe albeit redundant. - Set_Is_Immediately_Visible (Spec_Id); + else + Set_Is_Immediately_Visible (Spec_Id); + end if; + + Push_Scope (Spec_Id); end if; Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id); @@ -4749,6 +4708,34 @@ package body Sem_Ch6 is Update_Use_Clause_Chain; End_Scope; + -- Cleanup for the body of a stand-alone expression function + + if Present (Spec_Id) and then Is_Expression_Function (Spec_Id) then + In_Inlined_Body := Saved_In_Inlined_Body; + + if Scope (Spec_Id) /= Current_Scope + and then In_Private_Part (Spec_Id) + then + declare + S : constant Entity_Id := Scope (Spec_Id); + + Ent : Entity_Id; + + begin + Ent := First_Private_Entity (S); + while Present (Ent) loop + if Is_Private_Base_Type (Ent) + and then Present (Full_View (Ent)) + then + Exchange_Declarations (Ent); + end if; + + Next_Entity (Ent); + end loop; + end; + end if; + end if; + -- If we are compiling an entry wrapper, remove the enclosing -- synchronized object from the stack. @@ -5009,10 +4996,6 @@ package body Sem_Ch6 is Restore_Limited_Views (Exch_Views); end if; - if Present (Mask_Types) then - Unmask_Unfrozen_Types (Mask_Types); - end if; - if Present (Desig_View) then Set_Directly_Designated_Type (Etype (Spec_Id), Desig_View); end if; @@ -12539,6 +12522,13 @@ package body Sem_Ch6 is else Report_Conflict (S, E); + + -- Prevent cascaded error about missing body + + if Is_Package_Or_Generic_Package (E) then + Set_Has_Completion (E); + end if; + return; end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index b3905dc649e5..1f2fe1622ef4 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -136,9 +136,6 @@ package body Sem_Ch7 is -- one entity on its visibility chain, and recurses on the visible part if -- the entity is an inner package. - function Is_Private_Base_Type (E : Entity_Id) return Boolean; - -- True for a private type that is not a subtype - function Is_Visible_Dependent (Dep : Entity_Id) return Boolean; -- If the private dependent is a private type whose full view is derived -- from the parent type, its full properties are revealed only if we are in diff --git a/gcc/ada/sem_ch7.ads b/gcc/ada/sem_ch7.ads index 117fd44f5891..d21c40b1c270 100644 --- a/gcc/ada/sem_ch7.ads +++ b/gcc/ada/sem_ch7.ads @@ -42,7 +42,6 @@ package Sem_Ch7 is procedure Install_Visible_Declarations (P : Entity_Id); procedure Install_Private_Declarations (P : Entity_Id); - -- On entrance to a package body, make declarations in package spec -- immediately visible. -- @@ -52,6 +51,9 @@ package Sem_Ch7 is -- but is deferred until the compilation of the private part of the -- child for public child packages. + function Is_Private_Base_Type (E : Entity_Id) return Boolean; + -- True for a private type that is not a subtype + function Unit_Requires_Body (Pack_Id : Entity_Id; Do_Abstract_States : Boolean := False) return Boolean; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 2aa3021cfa62..66d4b355bbfb 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -3545,20 +3545,16 @@ package body Sem_Ch8 is Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec); end if; - -- AI12-0132: a renames-as-body freezes the expression of any - -- expression function that it renames. + -- RM 13.14(5.2/4): At the occurrence of a renames-as-body whose + -- name denotes an expression function, the return expression of + -- the expression function causes freezing. - if Is_Entity_Name (Nam) + if Comes_From_Source (N) + and then Is_Entity_Name (Nam) and then Is_Expression_Function (Entity (Nam)) and then not Inside_A_Generic then - Freeze_Expr_Types - (Def_Id => Entity (Nam), - Typ => Etype (Entity (Nam)), - Expr => - Expression - (Original_Node (Unit_Declaration_Node (Entity (Nam)))), - N => N); + Freeze_Expression (Nam); end if; -- Normal subprogram renaming (not renaming as body) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index afe82549995d..1da3ac8413ae 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3589,11 +3589,6 @@ package body Sem_Res is -- default expression mode (the Freeze_Expression routine tests this -- flag and only freezes static types if it is set). - -- Ada 2012 (AI05-177): The declaration of an expression function - -- does not cause freezing, but we never reach here in that case. - -- Here we are resolving the corresponding expanded body, so we do - -- need to perform normal freezing. - -- As elsewhere we do not emit freeze node within a generic. if not Inside_A_Generic then @@ -6659,28 +6654,22 @@ package body Sem_Res is -- conditions of subsequent functions or expression functions. Such -- calls do not freeze when they appear within generated bodies, -- (including the body of another expression function) which would - -- place the freeze node in the wrong scope. An expression function - -- is frozen in the usual fashion, by the appearance of a real body, - -- or at the end of a declarative part. However an implicit call to + -- place the freeze node in the wrong scope. But an implicit call to -- an expression function may appear when it is part of a default -- expression in a call to an initialization procedure, and must be -- frozen now, even if the body is inserted at a later point. - -- Otherwise, the call freezes the expression if expander is active, - -- for example as part of an object declaration. if Is_Entity_Name (Subp) and then not In_Spec_Expression and then not Is_Expression_Function_Or_Completion (Current_Scope) - and then not (Chars (Current_Scope) = Name_uWrapped_Statements - and then Is_Expression_Function_Or_Completion - (Scope (Current_Scope))) - and then - (not Is_Expression_Function_Or_Completion (Entity (Subp)) - or else Expander_Active) + and then not + (Chars (Current_Scope) = Name_uWrapped_Statements + and then + Is_Expression_Function_Or_Completion (Scope (Current_Scope))) then if Is_Expression_Function (Entity (Subp)) then - -- Force freeze of expression function in call + -- Force freezing of expression function in call Set_Comes_From_Source (Subp, True); Set_Must_Not_Freeze (Subp, False); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 223dad32d0cb..0bc88aacd6df 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2592,6 +2592,8 @@ package body Sem_Util is procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is begin + -- The immediate case is an incomplete type + if Ekind (T) = E_Incomplete_Type then -- Ada 2005 (AI-50217): If the type is available through a limited @@ -2610,10 +2612,15 @@ package body Sem_Util is ("premature usage of incomplete}", N, First_Subtype (T)); end if; - -- Need comments for these tests ??? + -- The other case is a type with a private component (including itself) + -- that has not yet received a full declaration. But we exclude formal + -- types, as well as references in generic units to entities declared + -- outside of them, and all references in spec expressions. elsif Has_Private_Component (T) and then not Is_Generic_Type (Root_Type (T)) + and then (not Is_Generic_Unit (Current_Scope) + or else Scope_Within_Or_Same (Scope (T), Current_Scope)) and then not In_Spec_Expression then -- Special case: if T is the anonymous type created for a single @@ -8589,7 +8596,7 @@ package body Sem_Util is Subp_Decl := Unit_Declaration_Node (Corresponding_Body (Subp_Decl)); end if; - return Original_Node (Expression (Original_Node (Subp_Decl))); + return Expression (Original_Node (Subp_Decl)); end Expression_Of_Expression_Function; ------------------------------- @@ -18812,7 +18819,8 @@ package body Sem_Util is and then Present (Subprogram_Body (Subp)) and then Was_Expression_Function (Subprogram_Body (Subp)) then - Return_Expr := Expression_Of_Expression_Function (Subp); + Return_Expr := + Original_Node (Expression_Of_Expression_Function (Subp)); -- The returned object must not have a qualified expression and its -- nominal subtype must be statically compatible with the result
