From eb1091dd34ee60aa96a513c09ef1d70f40a6a38f Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Fri, 29 Apr 2022 14:55:38 -0700 Subject: [PATCH] [Ada] Missing discriminant checks when accessing variant field In some cases, the compiler would incorrectly fail to generate discriminant checks when accessing fields declared in a variant part. Correct some such cases; detect the remaining cases and flag them as unsupported. The formerly-problematic cases that are now handled correctly involve component references occurring in a predicate expression (e.g., the expression of a Dynamic_Predicate aspect specification) for a type declaration (not for a subtype declaration). The cases which are now flagged as unsupported involve expression functions declared before the discriminated type in question has been frozen. gcc/ada/ * exp_ch3.ads: Replace visible Build_Discr_Checking_Funcs (which did not need to be visible - it was not referenced outside this package) with Build_Or_Copy_Discr_Checking_Funcs. * exp_ch3.adb: Refactor existing code into 3 procedures - Build_Discr_Checking_Funcs, Copy_Discr_Checking_Funcs, and Build_Or_Copy_Discr_Checking_Funcs. This refactoring is intended to be semantics-preserving. * exp_ch4.adb (Expand_N_Selected_Component): Detect case where a call should be generated to the Discriminant_Checking_Func for the component in question, but that subprogram does not yet exist. * sem_ch13.adb (Freeze_Entity_Checks): Immediately before calling Build_Predicate_Function, add a call to Exp_Ch3.Build_Or_Copy_Discr_Checking_Funcs in order to ensure that Discriminant_Checking_Func attributes are already set when Build_Predicate_Function is called. * sem_ch6.adb (Analyze_Expression_Function): If the expression of a static expression function has been transformed into an N_Raise_xxx_Error node, then we need to copy the original expression in order to check the requirement that the expression must be a potentially static expression. We also want to set aside a copy the untransformed expression for later use in checking calls to the expression function via Inline_Static_Function_Call. So introduce a new function, Make_Expr_Copy, for use in these situations. * sem_res.adb (Preanalyze_And_Resolve): When analyzing certain expressions (e.g., a default parameter expression in a subprogram declaration) we want to suppress checks. However, we do not want to suppress checks for the expression of an expression function. --- gcc/ada/exp_ch3.adb | 88 ++++++++++++++++++++++++++++++++-------------------- gcc/ada/exp_ch3.ads | 13 +++++--- gcc/ada/exp_ch4.adb | 11 +++++++ gcc/ada/sem_ch13.adb | 11 ++++++- gcc/ada/sem_ch6.adb | 68 +++++++++++++++++++++++----------------- gcc/ada/sem_res.adb | 6 +++- 6 files changed, 128 insertions(+), 69 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 87a84b4..03ff925 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -106,6 +106,13 @@ package body Exp_Ch3 is -- types with discriminants. Otherwise new identifiers are created, -- with the source names of the discriminants. + procedure Build_Discr_Checking_Funcs (N : Node_Id); + -- For each variant component, builds a function which checks whether + -- the component name is consistent with the current discriminants + -- and sets the component's Dcheck_Function attribute to refer to it. + -- N is the full type declaration node; the discriminant checking + -- functions are inserted after this node. + function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id; -- This function builds a static aggregate that can serve as the initial -- value for an array type whose bounds are static, and whose component @@ -152,6 +159,12 @@ package body Exp_Ch3 is -- needed after an initialization. Typ is the component type, and Proc_Id -- the initialization procedure for the enclosing composite type. + procedure Copy_Discr_Checking_Funcs (N : Node_Id); + -- For a derived untagged type, copy the attributes that were set + -- for the components of the parent type onto the components of the + -- derived type. No new subprograms are constructed. + -- N is the full type declaration node, as for Build_Discr_Checking_Funcs. + procedure Expand_Freeze_Array_Type (N : Node_Id); -- Freeze an array type. Deals with building the initialization procedure, -- creating the packed array type for a packed array and also with the @@ -1219,6 +1232,25 @@ package body Exp_Ch3 is end if; end Build_Discr_Checking_Funcs; + ---------------------------------------- + -- Build_Or_Copy_Discr_Checking_Funcs -- + ---------------------------------------- + + procedure Build_Or_Copy_Discr_Checking_Funcs (N : Node_Id) is + Typ : constant Entity_Id := Defining_Identifier (N); + begin + if Is_Unchecked_Union (Typ) or else not Has_Discriminants (Typ) then + null; + elsif not Is_Derived_Type (Typ) + or else Has_New_Non_Standard_Rep (Typ) + or else Is_Tagged_Type (Typ) + then + Build_Discr_Checking_Funcs (N); + else + Copy_Discr_Checking_Funcs (N); + end if; + end Build_Or_Copy_Discr_Checking_Funcs; + -------------------------------- -- Build_Discriminant_Formals -- -------------------------------- @@ -4842,6 +4874,27 @@ package body Exp_Ch3 is end if; end Clean_Task_Names; + ------------------------------- + -- Copy_Discr_Checking_Funcs -- + ------------------------------- + + procedure Copy_Discr_Checking_Funcs (N : Node_Id) is + Typ : constant Entity_Id := Defining_Identifier (N); + Comp : Entity_Id := First_Component (Typ); + Old_Comp : Entity_Id := First_Component + (Base_Type (Underlying_Type (Etype (Typ)))); + begin + while Present (Comp) loop + if Chars (Comp) = Chars (Old_Comp) then + Set_Discriminant_Checking_Func + (Comp, Discriminant_Checking_Func (Old_Comp)); + end if; + + Next_Component (Old_Comp); + Next_Component (Comp); + end loop; + end Copy_Discr_Checking_Funcs; + ---------------------------------------- -- Ensure_Activation_Chain_And_Master -- ---------------------------------------- @@ -5527,40 +5580,7 @@ package body Exp_Ch3 is -- we copy explicitly the discriminant checking functions from the -- parent into the components of the derived type. - if not Is_Derived_Type (Typ) - or else Has_New_Non_Standard_Rep (Typ) - or else Is_Tagged_Type (Typ) - then - Build_Discr_Checking_Funcs (Typ_Decl); - - elsif Is_Derived_Type (Typ) - and then not Is_Tagged_Type (Typ) - - -- If we have a derived Unchecked_Union, we do not inherit the - -- discriminant checking functions from the parent type since the - -- discriminants are non existent. - - and then not Is_Unchecked_Union (Typ) - and then Has_Discriminants (Typ) - then - declare - Old_Comp : Entity_Id; - - begin - Old_Comp := - First_Component (Base_Type (Underlying_Type (Etype (Typ)))); - Comp := First_Component (Typ); - while Present (Comp) loop - if Chars (Comp) = Chars (Old_Comp) then - Set_Discriminant_Checking_Func - (Comp, Discriminant_Checking_Func (Old_Comp)); - end if; - - Next_Component (Old_Comp); - Next_Component (Comp); - end loop; - end; - end if; + Build_Or_Copy_Discr_Checking_Funcs (Typ_Decl); if Is_Derived_Type (Typ) and then Is_Limited_Type (Typ) diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 23fecfd..ca8a550 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -56,10 +56,15 @@ package Exp_Ch3 is -- checks on the relevant aspects. The wrapper body could be simplified to -- a null body when expansion is disabled ??? - procedure Build_Discr_Checking_Funcs (N : Node_Id); - -- Builds function which checks whether the component name is consistent - -- with the current discriminants. N is the full type declaration node, - -- and the discriminant checking functions are inserted after this node. + procedure Build_Or_Copy_Discr_Checking_Funcs (N : Node_Id); + -- For each variant component, builds a function that checks whether + -- the component name is consistent with the current discriminants + -- and sets the component's Dcheck_Function attribute to refer to it. + -- N is the full type declaration node; the discriminant checking + -- functions are inserted after this node. + -- In the case of a derived untagged type, copy the attributes that were + -- set for the components of the parent type onto the components of the + -- derived type; no new subprograms are constructed in this case. function Build_Initialization_Call (Loc : Source_Ptr; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 3b4d521..140789a 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -46,6 +46,7 @@ with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Inline; use Inline; +with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -11008,6 +11009,16 @@ package body Exp_Ch4 is -- actually performed. else + if (not Is_Unchecked_Union + (Implementation_Base_Type (Etype (Prefix (N))))) + and then not Is_Predefined_Unit (Get_Source_Unit (N)) + then + Error_Msg_N + ("sorry - unable to generate discriminant check for" & + " reference to variant component &", + Selector_Name (N)); + end if; + Set_Do_Discriminant_Check (N, False); end if; end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index fdc767e..57ff450 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -33,6 +33,7 @@ with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Errout; use Errout; +with Exp_Ch3; use Exp_Ch3; with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; @@ -13138,12 +13139,20 @@ package body Sem_Ch13 is end if; end; + -- Before we build a predicate function, ensure that discriminant + -- checking functions are available. The predicate function might + -- need to call these functions if the predicate references + -- any components declared in a variant part. + if Ekind (E) = E_Record_Type and then Has_Discriminants (E) then + Build_Or_Copy_Discr_Checking_Funcs (Parent (E)); + end if; + Build_Predicate_Function (E, N); end if; -- If type has delayed aspects, this is where we do the preanalysis at -- the freeze point, as part of the consistent visibility check. Note - -- that this must be done after calling Build_Predicate_Functions or + -- that this must be done after calling Build_Predicate_Function or -- Build_Invariant_Procedure since these subprograms fix occurrences of -- the subtype name in the saved expression so that they will not cause -- trouble in the preanalysis. diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 8ca2974..5a3692c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -570,42 +570,52 @@ package body Sem_Ch6 is -- RM in 4.9(3.2/5-3.4/5) and we flag an error. if Is_Static_Function (Def_Id) then - if not Is_Static_Expression (Expr) then - declare - Exp_Copy : constant Node_Id := New_Copy_Tree (Expr); - begin - Set_Checking_Potentially_Static_Expression (True); + declare + -- If a potentially static expr like "Parameter / 0" + -- is transformed into "(raise Constraint_Error)", then we + -- need to copy the Original_Node. + function Make_Expr_Copy return Node_Id is + (New_Copy_Tree (if Expr in N_Raise_xxx_Error_Id + then Original_Node (Expr) + else Expr)); + begin + if not Is_Static_Expression (Expr) then + declare + Exp_Copy : constant Node_Id := Make_Expr_Copy; + begin + Set_Checking_Potentially_Static_Expression (True); - Preanalyze_Formal_Expression (Exp_Copy, Typ); + Preanalyze_Formal_Expression (Exp_Copy, Typ); - if not Is_Static_Expression (Exp_Copy) then - Error_Msg_N - ("static expression function requires " - & "potentially static expression", Expr); - end if; + if not Is_Static_Expression (Exp_Copy) then + Error_Msg_N + ("static expression function requires " + & "potentially static expression", Expr); + end if; - Set_Checking_Potentially_Static_Expression (False); - end; - end if; + Set_Checking_Potentially_Static_Expression (False); + end; + end if; - -- We also make an additional copy of the expression and - -- replace the expression of the expression function with - -- this copy, because the currently present expression is - -- now associated with the body created for the static - -- expression function, which will later be analyzed and - -- possibly rewritten, and we need to have the separate - -- unanalyzed copy available for use with later static - -- calls. + -- We also make an additional copy of the expression and + -- replace the expression of the expression function with + -- this copy, because the currently present expression is + -- now associated with the body created for the static + -- expression function, which will later be analyzed and + -- possibly rewritten, and we need to have the separate + -- unanalyzed copy available for use with later static + -- calls. - Set_Expression - (Original_Node (Subprogram_Spec (Def_Id)), - New_Copy_Tree (Expr)); + Set_Expression + (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. + -- Mark static expression functions as inlined, to ensure + -- that even calls with nonstatic actuals will be inlined. - Set_Has_Pragma_Inline (Def_Id); - Set_Is_Inlined (Def_Id); + Set_Has_Pragma_Inline (Def_Id); + Set_Is_Inlined (Def_Id); + end; end if; end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 4ffb64c..ad6d467 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2060,7 +2060,11 @@ package body Sem_Res is -- case of Ada 2012 constructs such as quantified expressions, which are -- expanded in two separate steps. - if GNATprove_Mode then + -- We also do not want to suppress checks if we are not dealing + -- with a default expression. One such case that is known to reach + -- this point is the expression of an expression function. + + if GNATprove_Mode or Nkind (Parent (N)) = N_Simple_Return_Statement then Analyze_And_Resolve (N, T); else Analyze_And_Resolve (N, T, Suppress => All_Checks); -- 2.7.4