From 4edcee5b2bf6ca2c0f7dcf5edcbe6daf715fc26a Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 19 Mar 2021 03:54:38 -0400 Subject: [PATCH] [Ada] Premature freezing of types gcc/ada/ * exp_ch4.adb (Expand_N_Quantified_Expression): Ensure the type of the name of a "for of" loop is frozen. * exp_disp.adb (Check_Premature_Freezing): Complete condition to take into account a private type completed by another private type now that the freezing rule are better implemented. * freeze.adb (Freeze_Entity.Freeze_Profile): Do not perform an early freeze on types if not in the proper scope. Special case expression functions that requires access to the dispatch table. (Should_Freeze_Type): New. * sem_ch13.adb (Resolve_Aspect_Expressions): Prevent assert failure in case of an invalid tree (previous errors detected). * sem_res.adb (Resolve): Remove kludge related to entities causing incorrect premature freezing. * sem_util.adb (Ensure_Minimum_Decoration): Add protection against non base types. --- gcc/ada/exp_ch4.adb | 13 ++++--- gcc/ada/exp_disp.adb | 2 ++ gcc/ada/freeze.adb | 83 ++++++++++++++++++++++++++++++++++++++++---- gcc/ada/sem_ch13.adb | 6 +++- gcc/ada/sem_res.adb | 7 ++-- gcc/ada/sem_util.adb | 1 + 6 files changed, 96 insertions(+), 16 deletions(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 1d04a0613ca1..9c585e74e508 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -10851,10 +10851,11 @@ package body Exp_Ch4 is Var : Entity_Id; begin - -- Ensure that the bound variable is properly frozen. We must do - -- this before expansion because the expression is about to be - -- converted into a loop, and resulting freeze nodes may end up - -- in the wrong place in the tree. + -- Ensure that the bound variable as well as the type of Name of the + -- Iter_Spec if present are properly frozen. We must do this before + -- expansion because the expression is about to be converted into a + -- loop, and resulting freeze nodes may end up in the wrong place in the + -- tree. if Present (Iter_Spec) then Var := Defining_Identifier (Iter_Spec); @@ -10869,6 +10870,10 @@ package body Exp_Ch4 is P := Parent (P); end loop; + if Present (Iter_Spec) then + Freeze_Before (P, Etype (Name (Iter_Spec))); + end if; + Freeze_Before (P, Etype (Var)); end; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index eb6b352bef9b..a2ea7c6e88ac 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -4052,6 +4052,7 @@ package body Exp_Disp is if Present (N) and then Is_Private_Type (Typ) and then No (Full_View (Typ)) + and then not Has_Private_Declaration (Typ) and then not Is_Generic_Type (Typ) and then not Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) @@ -4070,6 +4071,7 @@ package body Exp_Disp is if not Is_Tagged_Type (Typ) and then Present (Comp) and then not Is_Frozen (Comp) + and then not Has_Private_Declaration (Comp) and then not Is_Actual_For_Formal_Incomplete_Type (Comp) then Error_Msg_Sloc := Sloc (Subp); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index b539e59ae4ce..9bb273205732 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -186,6 +186,72 @@ package body Freeze is -- the designated type. Otherwise freezing the access type does not freeze -- the designated type. + function Should_Freeze_Type (Typ : Entity_Id; E : Entity_Id) return Boolean; + -- If Typ is in the current scope or in an instantiation, then return True. + -- ???Expression functions (represented by E) shouldn't freeze types in + -- general, but our current expansion and freezing model requires an early + -- freezing when the dispatch table is needed or when building an aggregate + -- with a subtype of Typ, so return True also in this case. + -- Note that expression function completions do freeze and are + -- handled in Sem_Ch6.Analyze_Expression_Function. + + ------------------------ + -- Should_Freeze_Type -- + ------------------------ + + function Should_Freeze_Type + (Typ : Entity_Id; E : Entity_Id) return Boolean + is + function Is_Dispatching_Call_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 an aggregate whose type + -- is Typ. + + -------------------------------------- + -- Is_Dispatching_Call_Or_Aggregate -- + -------------------------------------- + + function Is_Dispatching_Call_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; + elsif Nkind (N) = N_Aggregate + and then Base_Type (Etype (N)) = Base_Type (Typ) + then + return Abandon; + else + return OK; + end if; + end Is_Dispatching_Call_Or_Aggregate; + + ------------------------- + -- Need_Dispatch_Table -- + ------------------------- + + function Need_Dispatch_Table is new + Traverse_Func (Is_Dispatching_Call_Or_Aggregate); + -- Return Abandon if the input expression requires access to + -- Typ's dispatch table. + + Decl : constant Node_Id := + (if No (E) then E else Original_Node (Unit_Declaration_Node (E))); + + -- Start of processing for Should_Freeze_Type + + begin + return Within_Scope (Typ, Current_Scope) + or else In_Instance + or else (Present (Decl) + and then Nkind (Decl) = N_Expression_Function + and then Need_Dispatch_Table (Expression (Decl)) = Abandon); + end Should_Freeze_Type; + procedure Process_Default_Expressions (E : Entity_Id; After : in out Node_Id); @@ -4006,7 +4072,9 @@ package body Freeze is Set_Etype (Formal, F_Type); end if; - if not From_Limited_With (F_Type) then + if not From_Limited_With (F_Type) + and then Should_Freeze_Type (F_Type, E) + then Freeze_And_Append (F_Type, N, Result); end if; @@ -4183,7 +4251,9 @@ package body Freeze is Set_Etype (E, R_Type); end if; - Freeze_And_Append (R_Type, N, Result); + if Should_Freeze_Type (R_Type, E) then + Freeze_And_Append (R_Type, N, Result); + end if; -- Check suspicious return type for C function @@ -5951,11 +6021,12 @@ package body Freeze is -- Here for other than a subprogram or type else - -- If entity has a type, and it is not a generic unit, then freeze - -- it first (RM 13.14(10)). + -- If entity has a type declared in the current scope, and it is + -- not a generic unit, then freeze it first. if Present (Etype (E)) and then Ekind (E) /= E_Generic_Function + and then Within_Scope (Etype (E), Current_Scope) then Freeze_And_Append (Etype (E), N, Result); @@ -7783,7 +7854,7 @@ package body Freeze is -- 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 ??? + -- ignore the freeze request in this case. if No (Parent_P) then return; @@ -8043,7 +8114,7 @@ package body Freeze is end case; -- We fall through the case if we did not yet find the proper - -- place in the free for inserting the freeze node, so climb. + -- place in the tree for inserting the freeze node, so climb. P := Parent_P; end loop; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 22eb168d4134..062aa50017a4 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -15106,7 +15106,11 @@ package body Sem_Ch13 is begin Assoc := First (Component_Associations (Expr)); while Present (Assoc) loop - Find_Direct_Name (Expression (Assoc)); + if Nkind (Expression (Assoc)) in N_Has_Entity + then + Find_Direct_Name (Expression (Assoc)); + end if; + Next (Assoc); end loop; end; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 720f170ff734..be0945325fd5 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3391,12 +3391,9 @@ package body Sem_Res is -- 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. We make - -- an exception for entities that are expressions, only to detect - -- misuses of deferred constants and preserve the output of various - -- tests. + -- As elsewhere we do not emit freeze node within a generic. - if not Inside_A_Generic or else Is_Entity_Name (N) then + if not Inside_A_Generic then Freeze_Expression (N); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 9849071fe0dd..cfbbae0e2d54 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -26744,6 +26744,7 @@ package body Sem_Util is if Present (Typ) and then not Is_Frozen (Typ) + and then Is_Base_Type (Typ) and then (Is_Record_Type (Typ) or else Is_Concurrent_Type (Typ) or else Is_Incomplete_Or_Private_Type (Typ)) -- 2.47.2