From: Javier Miranda Date: Tue, 17 Jul 2018 08:07:52 +0000 (+0000) Subject: [Ada] Crash processing abstract state aspect of a package X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=e4d29736249cc9c5e62b0f8b3ecfed1a93b6d73d;p=gcc.git [Ada] Crash processing abstract state aspect of a package The compiler may crash processing an aspect Part_Of used in a package spec which has also an Initial_Condition aspect. After this patch the following test compiles fine. package P with SPARK_Mode => On, Abstract_State => (Count_State), Initial_Condition => (Get_Count = 0) -- Test is type Count_Type is range 0 .. 16; function Get_Count return Count_Type; procedure Dummy; private C: Count_Type := 0 with Part_Of => Count_State; -- Test function Get_Count return Count_Type is (C); end P; package body P with SPARK_Mode => On, Refined_State => (Count_State => C) is procedure Dummy is null; end P; Command: gcc -c p.adb 2018-07-17 Javier Miranda gcc/ada/ * exp_ch13.adb (Expand_N_Freeze_Entity): Handle subtype declared for an iterator. * freeze.adb (Freeze_Expression): Handle freeze of an entity defined outside of a subprogram body. This case was previously handled during preanalysis; the frozen entities were remembered and left pending until we continued freezeing entities outside of the subprogram. Now, when climbing the parents chain to locate the correct placement for the freezeing node, we check if the entity can be frozen and only when no enclosing node is marked as Must_Not_Freeze the entity is frozen. * sem_ch3.ads (Preanalyze_Default_Expression): Declaration moved to the package body. * sem_ch3.adb (Preanalyze_Default_Expression): Code adjusted to invoke the new subprogram Preanalyze_With_Freezing_And_Resolve. * sem_ch6.adb (Preanalyze_Formal_Expression): New subprogram. (Analyze_Expression_Function, Process_Formals): Invoke Preanalyze_Formal_Expression instead of Preanalyze_Spec_Expression since the analysis of the formals may freeze entities. (Analyze_Subprogram_Body_Helper): Skip building the body of the class-wide clone for eliminated subprograms. * sem_res.ads, sem_res.adb (Preanalyze_And_Resolve): New subprogram. Its code is basically the previous version of this routine but extended with an additional parameter which is used to specify if during preanalysis we are allowed to freeze entities. If the new parameter is True then the subtree root node is marked as Must_Not_Freeze and no entities are frozen during preanalysis. (Preanalyze_And_Resolve): Invokes the internal version of Preanalyze_And_Resolve without entity freezing. (Preanalyze_With_Freezing_And_Resolve): Invokes the internal version of Prenalyze_And_Resolve with freezing enabled. From-SVN: r262785 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d9d4f24653f..a2075223678 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,35 @@ +2018-07-17 Javier Miranda + + * exp_ch13.adb (Expand_N_Freeze_Entity): Handle subtype declared for an + iterator. + * freeze.adb (Freeze_Expression): Handle freeze of an entity defined + outside of a subprogram body. This case was previously handled during + preanalysis; the frozen entities were remembered and left pending until + we continued freezeing entities outside of the subprogram. Now, when + climbing the parents chain to locate the correct placement for the + freezeing node, we check if the entity can be frozen and only when no + enclosing node is marked as Must_Not_Freeze the entity is frozen. + * sem_ch3.ads (Preanalyze_Default_Expression): Declaration moved to the + package body. + * sem_ch3.adb (Preanalyze_Default_Expression): Code adjusted to invoke + the new subprogram Preanalyze_With_Freezing_And_Resolve. + * sem_ch6.adb (Preanalyze_Formal_Expression): New subprogram. + (Analyze_Expression_Function, Process_Formals): Invoke + Preanalyze_Formal_Expression instead of Preanalyze_Spec_Expression + since the analysis of the formals may freeze entities. + (Analyze_Subprogram_Body_Helper): Skip building the body of the + class-wide clone for eliminated subprograms. + * sem_res.ads, sem_res.adb (Preanalyze_And_Resolve): New subprogram. + Its code is basically the previous version of this routine but extended + with an additional parameter which is used to specify if during + preanalysis we are allowed to freeze entities. If the new parameter is + True then the subtree root node is marked as Must_Not_Freeze and no + entities are frozen during preanalysis. + (Preanalyze_And_Resolve): Invokes the internal version of + Preanalyze_And_Resolve without entity freezing. + (Preanalyze_With_Freezing_And_Resolve): Invokes the internal version of + Prenalyze_And_Resolve with freezing enabled. + 2018-07-17 Piotr Trojanek * einfo.ads, libgnat/g-comlin.ads: Minor change "ie" to "i.e." in docs diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 89be3513253..70e9327704c 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -470,6 +470,11 @@ package body Exp_Ch13 is and then Ekind (E_Scope) not in Concurrent_Kind then E_Scope := Scope (E_Scope); + + -- The entity may be a subtype declared for an iterator. + + elsif Ekind (E_Scope) = E_Loop then + E_Scope := Scope (E_Scope); end if; -- Remember that we are processing a freezing entity and its freezing diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 3f0350a3682..691d6a5fe6c 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6936,20 +6936,6 @@ package body Freeze is ----------------------- procedure Freeze_Expression (N : Node_Id) is - In_Spec_Exp : constant Boolean := In_Spec_Expression; - Typ : Entity_Id; - Nam : Entity_Id; - Desig_Typ : Entity_Id; - P : Node_Id; - Parent_P : Node_Id; - - Freeze_Outside : Boolean := False; - -- This flag is set true if the entity must be frozen outside the - -- current subprogram. This happens in the case of expander generated - -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do - -- not freeze all entities like other bodies, but which nevertheless - -- may reference entities that have to be frozen before the body and - -- obviously cannot be frozen inside the body. function Find_Aggregate_Component_Desig_Type return Entity_Id; -- If the expression is an array aggregate, the type of the component @@ -7038,6 +7024,29 @@ package body Freeze is end if; end In_Expanded_Body; + -- Local variables + + In_Spec_Exp : constant Boolean := In_Spec_Expression; + Typ : Entity_Id; + Nam : Entity_Id; + Desig_Typ : Entity_Id; + P : Node_Id; + Parent_P : Node_Id; + + Freeze_Outside : Boolean := False; + -- This flag is set true if the entity must be frozen outside the + -- current subprogram. This happens in the case of expander generated + -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do + -- not freeze all entities like other bodies, but which nevertheless + -- may reference entities that have to be frozen before the body and + -- obviously cannot be frozen inside the body. + + Freeze_Outside_Subp : Entity_Id := Empty; + -- This entity is set if we are inside a subprogram body and the frozen + -- entity is defined in the enclosing scope of this subprogram. In such + -- case we must skip the subprogram body when climbing the parents chain + -- to locate the correct placement for the freezing node. + -- Start of processing for Freeze_Expression begin @@ -7181,253 +7190,333 @@ package body Freeze is return; end if; - -- Examine the enclosing context by climbing the parent chain. The - -- traversal serves two purposes - to detect scenarios where freezeing - -- is not needed and to find the proper insertion point for the freeze - -- nodes. Although somewhat similar to Insert_Actions, this traversal - -- is freezing semantics-sensitive. Inserting freeze nodes blindly in - -- the tree may result in types being frozen too early. + -- Check if we are inside a subprogram body and the frozen entity is + -- defined in the enclosing scope of this subprogram. In such case we + -- must skip the subprogram when climbing the parents chain to locate + -- the correct placement for the freezing node. + + -- This is not needed for default expressions and other spec expressions + -- in generic units since the Move_Freeze_Nodes mechanism (sem_ch12.adb) + -- takes care of placing them at the proper place, after the generic + -- unit. + + if Present (Nam) + and then Scope (Nam) /= Current_Scope + and then not (In_Spec_Exp and then Inside_A_Generic) + then + declare + S : Entity_Id := Current_Scope; + + begin + while Present (S) + and then In_Same_Source_Unit (Nam, S) + loop + if Scope (S) = Scope (Nam) then + if Is_Subprogram (S) and then Has_Completion (S) then + Freeze_Outside_Subp := S; + end if; + + exit; + end if; + + S := Scope (S); + end loop; + end; + end if; + + -- Examine the enclosing context by climbing the parent chain. + + -- If we identified that we must freeze the entity outside of a given + -- subprogram then we just climb up to that subprogram checking if some + -- enclosing node is marked as Must_Not_Freeze (since in such case we + -- must not freeze yet this entity). P := N; - loop - Parent_P := Parent (P); - -- If we don't have a parent, then we are not in a well-formed tree. - -- This is an unusual case, but there are some legitimate situations - -- in which this occurs, notably when the expressions in the range of - -- a type declaration are resolved. We simply ignore the freeze - -- request in this case. Is this right ??? + if Present (Freeze_Outside_Subp) then + loop + -- Do not freeze the current expression if another expression in + -- the chain of parents must not be frozen. - if No (Parent_P) then - return; - end if; + if Nkind (P) in N_Subexpr and then Must_Not_Freeze (P) then + return; + end if; - -- See if we have got to an appropriate point in the tree + Parent_P := Parent (P); - case Nkind (Parent_P) is + -- If we don't have a parent, then we are not in a well-formed + -- tree. This is an unusual case, but there are some legitimate + -- situations in which this occurs, notably when the expressions + -- in the range of a type declaration are resolved. We simply + -- ignore the freeze request in this case. - -- A special test for the exception of (RM 13.14(8)) for the case - -- of per-object expressions (RM 3.8(18)) occurring in component - -- definition or a discrete subtype definition. Note that we test - -- for a component declaration which includes both cases we are - -- interested in, and furthermore the tree does not have explicit - -- nodes for either of these two constructs. + if No (Parent_P) then + return; + end if; - when N_Component_Declaration => + exit when Nkind (Parent_P) = N_Subprogram_Body + and then Unique_Defining_Entity (Parent_P) = Freeze_Outside_Subp; - -- The case we want to test for here is an identifier that is - -- a per-object expression, this is either a discriminant that - -- appears in a context other than the component declaration - -- or it is a reference to the type of the enclosing construct. + P := Parent_P; + end loop; - -- For either of these cases, we skip the freezing + -- Otherwise the traversal serves two purposes - to detect scenarios + -- where freezeing is not needed and to find the proper insertion point + -- for the freeze nodes. Although somewhat similar to Insert_Actions, + -- this traversal is freezing semantics-sensitive. Inserting freeze + -- nodes blindly in the tree may result in types being frozen too early. - if not In_Spec_Expression - and then Nkind (N) = N_Identifier - and then (Present (Entity (N))) - then - -- We recognize the discriminant case by just looking for - -- a reference to a discriminant. It can only be one for - -- the enclosing construct. Skip freezing in this case. + else + loop + -- Do not freeze the current expression if another expression in + -- the chain of parents must not be frozen. - if Ekind (Entity (N)) = E_Discriminant then - return; + if Nkind (P) in N_Subexpr and then Must_Not_Freeze (P) then + return; + end if; - -- For the case of a reference to the enclosing record, - -- (or task or protected type), we look for a type that - -- matches the current scope. + Parent_P := Parent (P); - elsif Entity (N) = Current_Scope then - return; - end if; - end if; + -- If we don't have a parent, then we are not in a well-formed + -- tree. This is an unusual case, but there are some legitimate + -- situations in which this occurs, notably when the expressions + -- in the range of a type declaration are resolved. We simply + -- ignore the freeze request in this case. Is this right ??? - -- If we have an enumeration literal that appears as the choice in - -- the aggregate of an enumeration representation clause, then - -- freezing does not occur (RM 13.14(10)). + if No (Parent_P) then + return; + end if; - when N_Enumeration_Representation_Clause => + -- See if we have got to an appropriate point in the tree - -- The case we are looking for is an enumeration literal + case Nkind (Parent_P) is - if (Nkind (N) = N_Identifier or Nkind (N) = N_Character_Literal) - and then Is_Enumeration_Type (Etype (N)) - then - -- If enumeration literal appears directly as the choice, - -- do not freeze (this is the normal non-overloaded case) + -- A special test for the exception of (RM 13.14(8)) for the + -- case of per-object expressions (RM 3.8(18)) occurring in + -- component definition or a discrete subtype definition. Note + -- that we test for a component declaration which includes both + -- cases we are interested in, and furthermore the tree does + -- not have explicit nodes for either of these two constructs. + + when N_Component_Declaration => + + -- The case we want to test for here is an identifier that + -- is a per-object expression, this is either a discriminant + -- that appears in a context other than the component + -- declaration or it is a reference to the type of the + -- enclosing construct. - if Nkind (Parent (N)) = N_Component_Association - and then First (Choices (Parent (N))) = N + -- For either of these cases, we skip the freezing + + if not In_Spec_Expression + and then Nkind (N) = N_Identifier + and then (Present (Entity (N))) then - return; + -- We recognize the discriminant case by just looking for + -- a reference to a discriminant. It can only be one for + -- the enclosing construct. Skip freezing in this case. - -- If enumeration literal appears as the name of function - -- which is the choice, then also do not freeze. This - -- happens in the overloaded literal case, where the - -- enumeration literal is temporarily changed to a function - -- call for overloading analysis purposes. + if Ekind (Entity (N)) = E_Discriminant then + return; - elsif Nkind (Parent (N)) = N_Function_Call - and then - Nkind (Parent (Parent (N))) = N_Component_Association - and then - First (Choices (Parent (Parent (N)))) = Parent (N) + -- For the case of a reference to the enclosing record, + -- (or task or protected type), we look for a type that + -- matches the current scope. + + elsif Entity (N) = Current_Scope then + return; + end if; + end if; + + -- If we have an enumeration literal that appears as the choice + -- in the aggregate of an enumeration representation clause, + -- then freezing does not occur (RM 13.14(10)). + + when N_Enumeration_Representation_Clause => + + -- The case we are looking for is an enumeration literal + + if Nkind_In (N, N_Identifier, N_Character_Literal) + and then Is_Enumeration_Type (Etype (N)) then - return; + -- If enumeration literal appears directly as the choice, + -- do not freeze (this is the normal non-overloaded case) + + if Nkind (Parent (N)) = N_Component_Association + and then First (Choices (Parent (N))) = N + then + return; + + -- If enumeration literal appears as the name of function + -- which is the choice, then also do not freeze. This + -- happens in the overloaded literal case, where the + -- enumeration literal is temporarily changed to a + -- function call for overloading analysis purposes. + + elsif Nkind (Parent (N)) = N_Function_Call + and then + Nkind (Parent (Parent (N))) = N_Component_Association + and then + First (Choices (Parent (Parent (N)))) = Parent (N) + then + return; + end if; end if; - end if; - -- Normally if the parent is a handled sequence of statements, - -- then the current node must be a statement, and that is an - -- appropriate place to insert a freeze node. + -- Normally if the parent is a handled sequence of statements, + -- then the current node must be a statement, and that is an + -- appropriate place to insert a freeze node. - when N_Handled_Sequence_Of_Statements => + when N_Handled_Sequence_Of_Statements => - -- An exception occurs when the sequence of statements is for - -- an expander generated body that did not do the usual freeze - -- all operation. In this case we usually want to freeze - -- outside this body, not inside it, and we skip past the - -- subprogram body that we are inside. + -- An exception occurs when the sequence of statements is + -- for an expander generated body that did not do the usual + -- freeze all operation. In this case we usually want to + -- freeze outside this body, not inside it, and we skip + -- past the subprogram body that we are inside. - if In_Expanded_Body (Parent_P) then - declare - Subp : constant Node_Id := Parent (Parent_P); - Spec : Entity_Id; + if In_Expanded_Body (Parent_P) then + declare + Subp : constant Node_Id := Parent (Parent_P); + Spec : Entity_Id; - begin - -- Freeze the entity only when it is declared inside the - -- body of the expander generated procedure. This case - -- is recognized by the scope of the entity or its type, - -- which is either the spec for some enclosing body, or - -- (in the case of init_procs, for which there are no - -- separate specs) the current scope. - - if Nkind (Subp) = N_Subprogram_Body then - Spec := Corresponding_Spec (Subp); - - if (Present (Typ) and then Scope (Typ) = Spec) - or else - (Present (Nam) and then Scope (Nam) = Spec) - then - exit; + begin + -- Freeze the entity only when it is declared inside + -- the body of the expander generated procedure. + -- This case is recognized by the scope of the entity + -- or its type, which is either the spec for some + -- enclosing body, or (in the case of init_procs, + -- for which there are no separate specs) the current + -- scope. + + if Nkind (Subp) = N_Subprogram_Body then + Spec := Corresponding_Spec (Subp); + + if (Present (Typ) and then Scope (Typ) = Spec) + or else + (Present (Nam) and then Scope (Nam) = Spec) + then + exit; - elsif Present (Typ) - and then Scope (Typ) = Current_Scope - and then Defining_Entity (Subp) = Current_Scope - then - exit; + elsif Present (Typ) + and then Scope (Typ) = Current_Scope + and then Defining_Entity (Subp) = Current_Scope + then + exit; + end if; end if; - end if; - -- An expression function may act as a completion of - -- a function declaration. As such, it can reference - -- entities declared between the two views: + -- An expression function may act as a completion of + -- a function declaration. As such, it can reference + -- entities declared between the two views: - -- Hidden []; -- 1 - -- function F return ...; - -- private - -- function Hidden return ...; - -- function F return ... is (Hidden); -- 2 + -- Hidden []; -- 1 + -- function F return ...; + -- private + -- function Hidden return ...; + -- function F return ... is (Hidden); -- 2 - -- Refering to the example above, freezing the expression - -- of F (2) would place Hidden's freeze node (1) in the - -- wrong place. Avoid explicit freezing and let the usual - -- scenarios do the job - for example, reaching the end - -- of the private declarations, or a call to F. + -- Refering to the example above, freezing the + -- expression of F (2) would place Hidden's freeze + -- node (1) in the wrong place. Avoid explicit + -- freezing and let the usual scenarios do the job + -- (for example, reaching the end of the private + -- declarations, or a call to F.) - if Nkind (Original_Node (Subp)) = - N_Expression_Function - then - null; + if Nkind (Original_Node (Subp)) = N_Expression_Function + then + null; - -- Freeze outside the body + -- Freeze outside the body - else - Parent_P := Parent (Parent_P); - Freeze_Outside := True; - end if; - end; + else + Parent_P := Parent (Parent_P); + Freeze_Outside := True; + end if; + end; - -- Here if normal case where we are in handled statement - -- sequence and want to do the insertion right there. + -- Here if normal case where we are in handled statement + -- sequence and want to do the insertion right there. - else - exit; - end if; + else + exit; + end if; - -- If parent is a body or a spec or a block, then the current node - -- is a statement or declaration and we can insert the freeze node - -- before it. - - when N_Block_Statement - | N_Entry_Body - | N_Package_Body - | N_Package_Specification - | N_Protected_Body - | 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_Abortable_Part - | N_Accept_Alternative - | N_And_Then - | N_Case_Statement_Alternative - | N_Compilation_Unit_Aux - | N_Conditional_Entry_Call - | N_Delay_Alternative - | N_Elsif_Part - | N_Entry_Call_Alternative - | 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); - - -- Freeze nodes produced by an expression coming from the Actions - -- list of a N_Expression_With_Actions node must remain within the - -- Actions list. Inserting the freeze nodes further up the tree - -- may lead to use before declaration issues in the case of array - -- types. - - when N_Expression_With_Actions => - if Is_List_Member (P) - and then List_Containing (P) = Actions (Parent_P) - then + -- If parent is a body or a spec or a block, then the current + -- node is a statement or declaration and we can insert the + -- freeze node before it. + + when N_Block_Statement + | N_Entry_Body + | N_Package_Body + | N_Package_Specification + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body + => exit; - end if; - -- Note: N_Loop_Statement is a special case. A type that appears - -- in the source can never be frozen in a loop (this occurs only - -- because of a loop expanded by the expander), so we keep on - -- going. Otherwise we terminate the search. Same is true of any - -- entity which comes from source. (if they have predefined type, - -- that type does not appear to come from source, but the entity - -- should not be frozen here). + -- 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_Abortable_Part + | N_Accept_Alternative + | N_And_Then + | N_Case_Statement_Alternative + | N_Compilation_Unit_Aux + | N_Conditional_Entry_Call + | N_Delay_Alternative + | N_Elsif_Part + | N_Entry_Call_Alternative + | 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); + + -- Freeze nodes produced by an expression coming from the + -- Actions list of a N_Expression_With_Actions node must remain + -- within the Actions list. Inserting the freeze nodes further + -- up the tree may lead to use before declaration issues in the + -- case of array types. + + when N_Expression_With_Actions => + if Is_List_Member (P) + and then List_Containing (P) = Actions (Parent_P) + then + exit; + end if; - when N_Loop_Statement => - exit when not Comes_From_Source (Etype (N)) - and then (No (Nam) or else not Comes_From_Source (Nam)); + -- Note: N_Loop_Statement is a special case. A type that + -- appears in the source can never be frozen in a loop (this + -- occurs only because of a loop expanded by the expander), so + -- we keep on going. Otherwise we terminate the search. Same + -- is true of any entity which comes from source. (if they + -- have predefined type, that type does not appear to come + -- from source, but the entity should not be frozen here). - -- For all other cases, keep looking at parents + when N_Loop_Statement => + exit when not Comes_From_Source (Etype (N)) + and then (No (Nam) or else not Comes_From_Source (Nam)); - when others => - null; - end case; + -- For all other cases, keep looking at parents - -- We fall through the case if we did not yet find the proper - -- place in the free for inserting the freeze node, so climb. + when others => + null; + end case; - P := Parent_P; - end loop; + -- We fall through the case if we did not yet find the proper + -- place in the free for inserting the freeze node, so climb. + + P := Parent_P; + end loop; + end if; -- If the expression appears in a record or an initialization procedure, -- the freeze nodes are collected and attached to the current scope, to diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index fce4992cff0..ad9d7e14d1b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -605,6 +605,10 @@ package body Sem_Ch3 is -- Create a new ordinary fixed point type, and apply the constraint to -- obtain subtype of it. + procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id); + -- Wrapper on Preanalyze_Spec_Expression for default expressions, so that + -- In_Default_Expr can be properly adjusted. + procedure Prepare_Private_Subtype_Completion (Id : Entity_Id; Related_Nod : Node_Id); @@ -19818,11 +19822,14 @@ package body Sem_Ch3 is ----------------------------------- procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is - Save_In_Default_Expr : constant Boolean := In_Default_Expr; + Save_In_Default_Expr : constant Boolean := In_Default_Expr; + Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; begin - In_Default_Expr := True; - Preanalyze_Spec_Expression (N, T); - In_Default_Expr := Save_In_Default_Expr; + In_Default_Expr := True; + In_Spec_Expression := True; + Preanalyze_With_Freezing_And_Resolve (N, T); + In_Default_Expr := Save_In_Default_Expr; + In_Spec_Expression := Save_In_Spec_Expression; end Preanalyze_Default_Expression; -------------------------------- diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 2e16917280b..c82ab860e77 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -250,10 +250,6 @@ package Sem_Ch3 is -- Wrapper on Preanalyze_Spec_Expression for assertion expressions, so that -- In_Assertion_Expr can be properly adjusted. - procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id); - -- Wrapper on Preanalyze_Spec_Expression for default expressions, so that - -- In_Default_Expr can be properly adjusted. - procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id); -- Process some semantic actions when the full view of a private type is -- encountered and analyzed. The first action is to create the full views diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 304e35c18c5..08717bf0a23 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -206,6 +206,10 @@ package body Sem_Ch6 is -- Create the declaration for an inequality operator that is implicitly -- created by a user-defined equality operator that yields a boolean. + procedure Preanalyze_Formal_Expression (N : Node_Id; T : Entity_Id); + -- Preanalysis of default expressions of subprogram formals. N is the + -- expression to be analyzed and T is the expected type. + procedure Set_Formal_Validity (Formal_Id : Entity_Id); -- Formal_Id is an formal parameter entity. This procedure deals with -- setting the proper validity status for this entity, which depends on @@ -761,7 +765,7 @@ package body Sem_Ch6 is if not Inside_A_Generic then Push_Scope (Def_Id); Install_Formals (Def_Id); - Preanalyze_Spec_Expression (Expr, Typ); + Preanalyze_Formal_Expression (Expr, Typ); Check_Limited_Return (Original_Node (N), Expr, Typ); End_Scope; end if; @@ -3862,12 +3866,14 @@ package body Sem_Ch6 is -- If the subprogram has a class-wide clone, build its body as a copy -- of the original body, and rewrite body of original subprogram as a -- wrapper that calls the clone. If N is a stub, this construction will - -- take place when the proper body is analyzed. + -- take place when the proper body is analyzed. No action needed if this + -- subprogram has been eliminated. if Present (Spec_Id) and then Present (Class_Wide_Clone (Spec_Id)) and then (Comes_From_Source (N) or else Was_Expression_Function (N)) and then Nkind (N) /= N_Subprogram_Body_Stub + and then not (Expander_Active and then Is_Eliminated (Spec_Id)) then Build_Class_Wide_Clone_Body (Spec_Id, N); @@ -11333,6 +11339,18 @@ package body Sem_Ch6 is end if; end New_Overloaded_Entity; + ---------------------------------- + -- Preanalyze_Formal_Expression -- + ---------------------------------- + + procedure Preanalyze_Formal_Expression (N : Node_Id; T : Entity_Id) is + Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; + begin + In_Spec_Expression := True; + Preanalyze_With_Freezing_And_Resolve (N, T); + In_Spec_Expression := Save_In_Spec_Expression; + end Preanalyze_Formal_Expression; + --------------------- -- Process_Formals -- --------------------- @@ -11625,7 +11643,7 @@ package body Sem_Ch6 is -- Do the special preanalysis of the expression (see section on -- "Handling of Default Expressions" in the spec of package Sem). - Preanalyze_Spec_Expression (Default, Formal_Type); + Preanalyze_Formal_Expression (Default, Formal_Type); -- An access to constant cannot be the default for -- an access parameter that is an access to variable. diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index b2cac71ce9f..6bcfc389db8 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -142,6 +142,12 @@ package body Sem_Res is -- a call, so such an operator is not treated as predefined by this -- predicate. + procedure Preanalyze_And_Resolve + (N : Node_Id; + T : Entity_Id; + With_Freezing : Boolean); + -- Subsidiary of public versions of Preanalyze_And_Resolve. + procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id); -- If a default expression in entry call N depends on the discriminants -- of the task, it must be replaced with a reference to the discriminant @@ -1660,10 +1666,21 @@ package body Sem_Res is -- Preanalyze_And_Resolve -- ---------------------------- - procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is - Save_Full_Analysis : constant Boolean := Full_Analysis; + procedure Preanalyze_And_Resolve + (N : Node_Id; + T : Entity_Id; + With_Freezing : Boolean) + is + Save_Full_Analysis : constant Boolean := Full_Analysis; + Save_Must_Not_Freeze : constant Boolean := Must_Not_Freeze (N); begin + pragma Assert (Nkind (N) in N_Subexpr); + + if not With_Freezing then + Set_Must_Not_Freeze (N); + end if; + Full_Analysis := False; Expander_Mode_Save_And_Set (False); @@ -1690,6 +1707,16 @@ package body Sem_Res is Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; + Set_Must_Not_Freeze (N, Save_Must_Not_Freeze); + end Preanalyze_And_Resolve; + + ---------------------------- + -- Preanalyze_And_Resolve -- + ---------------------------- + + procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is + begin + Preanalyze_And_Resolve (N, T, With_Freezing => False); end Preanalyze_And_Resolve; -- Version without context type @@ -1708,6 +1735,16 @@ package body Sem_Res is Full_Analysis := Save_Full_Analysis; end Preanalyze_And_Resolve; + ------------------------------------------ + -- Preanalyze_With_Freezing_And_Resolve -- + ------------------------------------------ + + procedure Preanalyze_With_Freezing_And_Resolve (N : Node_Id; T : Entity_Id) + is + begin + Preanalyze_And_Resolve (N, T, With_Freezing => True); + end Preanalyze_With_Freezing_And_Resolve; + ---------------------------------- -- Replace_Actual_Discriminants -- ---------------------------------- diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads index 58c8b5ebaa6..aeb758df466 100644 --- a/gcc/ada/sem_res.ads +++ b/gcc/ada/sem_res.ads @@ -93,6 +93,9 @@ package Sem_Res is procedure Preanalyze_And_Resolve (N : Node_Id); -- Same, but use type of node because context does not impose a single type + procedure Preanalyze_With_Freezing_And_Resolve (N : Node_Id; T : Entity_Id); + -- Same, but perform freezing of static expressions of N or its children. + procedure Resolve (N : Node_Id; Typ : Entity_Id); procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id); -- Top-level type-checking procedure, called in a complete context. The