From 84be0369c8d3a6c94f46906d901d2c5426fb9174 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 17 Nov 2020 03:39:04 -0500 Subject: [PATCH] [Ada] Remove discriminant checks processing in gigi gcc/ada/ * sem_ch4.adb (Analyze_Selected_Component): Request a compile time error replacement in Apply_Compile_Time_Constraint_Error in case of an invalid field. * sem_ch3.adb (Create_Constrained_Components): Take advantage of Gather_Components also in the case of a record extension and also constrain records in the case of compile time known discriminant values, as already done in gigi. * sem_util.ads, sem_util.adb (Gather_Components): New parameter Allow_Compile_Time to allow compile time known (but non static) discriminant values, needed by Create_Constrained_Components, and new parameter Include_Interface_Tag. (Is_Dependent_Component_Of_Mutable_Object): Use Original_Node to perform check on the original tree. (Is_Object_Reference): Likewise. Only call Original_Node when relevant via a new function Safe_Prefix. (Is_Static_Discriminant_Component, In_Check_Node): New. (Is_Actual_Out_Or_In_Out_Parameter): New. * exp_ch4.adb (Expand_N_Selected_Component): Remove no longer needed code preventing evaluating statically discriminants in more cases. * exp_ch5.adb (Expand_N_Loop_Statement): Simplify expansion of loops with an N_Raise_xxx_Error node to avoid confusing the code generator. (Make_Component_List_Assign): Try to find a constrained type to extract discriminant values from, so that the case statement built gets an opportunity to be folded by Expand_N_Case_Statement. (Expand_Assign_Record): Update comments, code cleanups. * sem_attr.adb (Analyze_Attribute): Perform most of the analysis on the original prefix node to deal properly with a prefix rewritten as a N_Raise_xxx_Error. * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Handle properly a discrete subtype definition being rewritten as N_Raise_xxx_Error. * sem_ch8.adb (Analyze_Object_Renaming): Handle N_Raise_xxx_Error nodes as part of the expression being renamed. * sem_eval.ads, sem_eval.adb (Fold, Eval_Selected_Component): New. (Compile_Time_Known_Value, Expr_Value, Expr_Rep_Value): Evaluate static discriminant component values. * sem_res.adb (Resolve_Selected_Component): Call Eval_Selected_Component. --- gcc/ada/exp_ch4.adb | 12 +---- gcc/ada/exp_ch5.adb | 59 ++++++++++++++-------- gcc/ada/sem_attr.adb | 25 ++++++--- gcc/ada/sem_ch3.adb | 69 +++++++++++++------------ gcc/ada/sem_ch4.adb | 2 +- gcc/ada/sem_ch5.adb | 5 +- gcc/ada/sem_ch8.adb | 32 +++++++++++- gcc/ada/sem_eval.adb | 69 +++++++++++++++++++++++++ gcc/ada/sem_eval.ads | 5 ++ gcc/ada/sem_res.adb | 46 +++++++++-------- gcc/ada/sem_util.adb | 118 +++++++++++++++++++++++++++++++++++-------- gcc/ada/sem_util.ads | 32 ++++++++++-- 12 files changed, 353 insertions(+), 121 deletions(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e376648a4a5..04bd1fe0dba 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -11162,7 +11162,7 @@ package body Exp_Ch4 is -- because the selected component may be a reference to the -- object being initialized, whose discriminant is not yet -- set. This only happens in complex cases involving changes - -- or representation. + -- of representation. if Disc = Entity (Selector_Name (N)) and then (Is_Entity_Name (Dval) @@ -11174,15 +11174,7 @@ package body Exp_Ch4 is -- constrained by an outer discriminant, which cannot -- be optimized away. - if Denotes_Discriminant - (Dval, Check_Concurrent => True) - then - exit Discr_Loop; - - elsif Nkind (Original_Node (Dval)) = N_Selected_Component - and then - Denotes_Discriminant - (Selector_Name (Original_Node (Dval)), True) + if Denotes_Discriminant (Dval, Check_Concurrent => True) then exit Discr_Loop; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 307acaae61a..4cae2ee8d3f 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1623,14 +1623,27 @@ package body Exp_Ch5 is CI : constant List_Id := Component_Items (CL); VP : constant Node_Id := Variant_Part (CL); - Alts : List_Id; - DC : Node_Id; - DCH : List_Id; - Expr : Node_Id; - Result : List_Id; - V : Node_Id; + Constrained_Typ : Entity_Id; + Alts : List_Id; + DC : Node_Id; + DCH : List_Id; + Expr : Node_Id; + Result : List_Id; + V : Node_Id; begin + -- Try to find a constrained type to extract discriminant values + -- from, so that the case statement built below gets an + -- opportunity to be folded by Expand_N_Case_Statement. + + if U_U or else Is_Constrained (Etype (Rhs)) then + Constrained_Typ := Etype (Rhs); + elsif Is_Constrained (Etype (Expression (N))) then + Constrained_Typ := Etype (Expression (N)); + else + Constrained_Typ := Empty; + end if; + Result := Make_Field_Assigns (CI); if Present (VP) then @@ -1652,17 +1665,12 @@ package body Exp_Ch5 is Next_Non_Pragma (V); end loop; - -- If we have an Unchecked_Union, use the value of the inferred - -- discriminant of the variant part expression as the switch - -- for the case statement. The case statement may later be - -- folded. - - if U_U then + if Present (Constrained_Typ) then Expr := New_Copy (Get_Discriminant_Value ( Entity (Name (VP)), - Etype (Rhs), - Discriminant_Constraint (Etype (Rhs)))); + Constrained_Typ, + Discriminant_Constraint (Constrained_Typ))); else Expr := Make_Selected_Component (Loc, @@ -1786,9 +1794,10 @@ package body Exp_Ch5 is -- Start of processing for Expand_Assign_Record begin - -- Note that we use the base types for this processing. This results - -- in some extra work in the constrained case, but the change of - -- representation case is so unusual that it is not worth the effort. + -- Note that we need to use the base types for this processing in + -- order to retrieve the Type_Definition. In the constrained case, + -- we filter out the non relevant fields in + -- Make_Component_List_Assign. -- First copy the discriminants. This is done unconditionally. It -- is required in the unconstrained left side case, and also in the @@ -1824,7 +1833,7 @@ package body Exp_Ch5 is CF := F; end if; - if Is_Unchecked_Union (Base_Type (R_Typ)) then + if Is_Unchecked_Union (R_Typ) then -- Within an initialization procedure this is the -- assignment to an unchecked union component, in which @@ -1916,8 +1925,8 @@ package body Exp_Ch5 is Insert_Actions (N, Make_Component_List_Assign (Component_List (RDef), True)); else - Insert_Actions - (N, Make_Component_List_Assign (Component_List (RDef))); + Insert_Actions (N, + Make_Component_List_Assign (Component_List (RDef))); end if; Rewrite (N, Make_Null_Statement (Loc)); @@ -4681,6 +4690,16 @@ package body Exp_Ch5 is New_Id : Entity_Id; begin + -- If Discrete_Subtype_Definition has been rewritten as an + -- N_Raise_xxx_Error, rewrite the whole loop as a raise node to + -- avoid confusing the code generator down the line. + + if Nkind (Discrete_Subtype_Definition (LPS)) in N_Raise_xxx_Error + then + Rewrite (N, Discrete_Subtype_Definition (LPS)); + return; + end if; + if Present (Iterator_Filter (LPS)) then pragma Assert (Ada_Version >= Ada_2020); Set_Statements (N, diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 0bef709e9e6..e4537e45553 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -227,9 +227,11 @@ package body Sem_Attr is procedure Analyze_Attribute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Aname : constant Name_Id := Attribute_Name (N); - P : constant Node_Id := Prefix (N); Exprs : constant List_Id := Expressions (N); Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname); + P_Old : constant Node_Id := Prefix (N); + + P : Node_Id := P_Old; E1 : Node_Id; E2 : Node_Id; @@ -1836,7 +1838,7 @@ package body Sem_Attr is -- Case of an expression - Resolve (P); + Resolve (P_Old); if Is_Access_Type (P_Type) then @@ -1852,12 +1854,12 @@ package body Sem_Attr is Freeze_Before (N, Designated_Type (P_Type)); end if; - Rewrite (P, - Make_Explicit_Dereference (Sloc (P), - Prefix => Relocate_Node (P))); + Rewrite (P_Old, + Make_Explicit_Dereference (Sloc (P_Old), + Prefix => Relocate_Node (P_Old))); - Analyze_And_Resolve (P); - P_Type := Etype (P); + Analyze_And_Resolve (P_Old); + P_Type := Etype (P_Old); if P_Type = Any_Type then raise Bad_Attribute; @@ -3102,6 +3104,15 @@ package body Sem_Attr is end if; end if; + -- If the prefix was rewritten as a raise node, then rewrite N as a + -- raise node, to avoid creating inconsistent trees. We still need to + -- perform legality checks on the original tree. + + if Nkind (P) in N_Raise_xxx_Error then + Rewrite (N, Relocate_Node (P)); + P := Original_Node (P_Old); + end if; + -- Remaining processing depends on attribute case Attr_Id is diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index a51dd54aff5..c01bce132c0 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -14619,11 +14619,13 @@ package body Sem_Ch3 is Comp_List : constant Elist_Id := New_Elmt_List; Parent_Type : constant Entity_Id := Etype (Typ); Assoc_List : constant List_Id := New_List; - Discr_Val : Elmt_Id; - Errors : Boolean; - New_C : Entity_Id; - Old_C : Entity_Id; - Is_Static : Boolean := True; + + Discr_Val : Elmt_Id; + Errors : Boolean; + New_C : Entity_Id; + Old_C : Entity_Id; + Is_Static : Boolean := True; + Is_Compile_Time_Known : Boolean := True; procedure Collect_Fixed_Components (Typ : Entity_Id); -- Collect parent type components that do not appear in a variant part @@ -14773,7 +14775,11 @@ package body Sem_Ch3 is while Present (Discr_Val) loop if not Is_OK_Static_Expression (Node (Discr_Val)) then Is_Static := False; - exit; + + if not Compile_Time_Known_Value (Node (Discr_Val)) then + Is_Compile_Time_Known := False; + exit; + end if; end if; Next_Elmt (Discr_Val); @@ -14871,19 +14877,18 @@ package body Sem_Ch3 is end if; end Add_Discriminants; - if Is_Static + if Is_Compile_Time_Known and then Is_Variant_Record (Typ) then Collect_Fixed_Components (Typ); - - Gather_Components ( - Typ, - Component_List (Type_Definition (Parent (Typ))), - Governed_By => Assoc_List, - Into => Comp_List, - Report_Errors => Errors); - pragma Assert (not Errors - or else Serious_Errors_Detected > 0); + Gather_Components + (Typ, + Component_List (Type_Definition (Parent (Typ))), + Governed_By => Assoc_List, + Into => Comp_List, + Report_Errors => Errors, + Allow_Compile_Time => True); + pragma Assert (not Errors or else Serious_Errors_Detected > 0); Create_All_Components; @@ -14891,7 +14896,7 @@ package body Sem_Ch3 is -- with constraints, we retrieve the record definition of the parent -- type to select the components of the proper variant. - elsif Is_Static + elsif Is_Compile_Time_Known and then Is_Tagged_Type (Typ) and then Nkind (Parent (Typ)) = N_Full_Type_Declaration and then @@ -14899,13 +14904,13 @@ package body Sem_Ch3 is and then Is_Variant_Record (Parent_Type) then Collect_Fixed_Components (Typ); - Gather_Components (Typ, Component_List (Type_Definition (Parent (Parent_Type))), - Governed_By => Assoc_List, - Into => Comp_List, - Report_Errors => Errors); + Governed_By => Assoc_List, + Into => Comp_List, + Report_Errors => Errors, + Allow_Compile_Time => True); -- Note: previously there was a check at this point that no errors -- were detected. As a consequence of AI05-220 there may be an error @@ -14913,21 +14918,19 @@ package body Sem_Ch3 is -- static constraint. -- If the tagged derivation has a type extension, collect all the - -- new components therein. + -- new relevant components therein via Gather_Components. if Present (Record_Extension_Part (Type_Definition (Parent (Typ)))) then - Old_C := First_Component (Typ); - while Present (Old_C) loop - if Original_Record_Component (Old_C) = Old_C - and then Chars (Old_C) /= Name_uTag - and then Chars (Old_C) /= Name_uParent - then - Append_Elmt (Old_C, Comp_List); - end if; - - Next_Component (Old_C); - end loop; + Gather_Components + (Typ, + Component_List + (Record_Extension_Part (Type_Definition (Parent (Typ)))), + Governed_By => Assoc_List, + Into => Comp_List, + Report_Errors => Errors, + Allow_Compile_Time => True, + Include_Interface_Tag => True); end if; Create_All_Components; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 01d70b00684..7a8c261ee4f 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -5455,7 +5455,7 @@ package body Sem_Ch4 is Apply_Compile_Time_Constraint_Error (N, "component not present in }??", CE_Discriminant_Check_Failed, - Ent => Prefix_Type, Rep => False); + Ent => Prefix_Type); Set_Raises_Constraint_Error (N); return; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index d344ad16e3e..0b1db8510c4 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -3097,7 +3097,10 @@ package body Sem_Ch5 is Check_Predicate_Use (Entity (Subtype_Mark (DS))); end if; - Make_Index (DS, N); + if Nkind (DS) not in N_Raise_xxx_Error then + Make_Index (DS, N); + end if; + Set_Ekind (Id, E_Loop_Parameter); -- A quantified expression which appears in a pre- or post-condition may diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 8ec86fc9b1c..899464f961b 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -772,6 +772,31 @@ package body Sem_Ch8 is -- Obtain the name of the object from node Nod which is being renamed by -- the object renaming declaration N. + function Find_Raise_Node (N : Node_Id) return Traverse_Result; + -- Process one node in search for N_Raise_xxx_Error nodes. + -- Return Abandon if found, OK otherwise. + + --------------------- + -- Find_Raise_Node -- + --------------------- + + function Find_Raise_Node (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) in N_Raise_xxx_Error then + return Abandon; + else + return OK; + end if; + end Find_Raise_Node; + + ------------------------ + -- No_Raise_xxx_Error -- + ------------------------ + + function No_Raise_xxx_Error is new Traverse_Func (Find_Raise_Node); + -- Traverse tree to look for a N_Raise_xxx_Error node and returns + -- Abandon if so and OK if none found. + ------------------------------ -- Check_Constrained_Object -- ------------------------------ @@ -1454,9 +1479,12 @@ package body Sem_Ch8 is then Error_Msg_N ("incompatible types in renaming", Nam); - -- AI12-0383: Names that denote values can be renamed + -- AI12-0383: Names that denote values can be renamed. + -- Ignore (accept) N_Raise_xxx_Error nodes in this context. - elsif Ada_Version < Ada_2020 then + elsif Ada_Version < Ada_2020 + and then No_Raise_xxx_Error (Nam) = OK + then Error_Msg_N ("value in renaming requires -gnat2020", Nam); end if; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 1a832f767cd..8d47589df73 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -43,6 +43,7 @@ with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Elab; use Sem_Elab; @@ -1855,6 +1856,12 @@ package body Sem_Eval is N_Character_Literal | N_Real_Literal | N_String_Literal | N_Null then return True; + + -- Evaluate static discriminants, to eliminate dead paths and + -- redundant discriminant checks. + + elsif Is_Static_Discriminant_Component (Op) then + return True; end if; end if; @@ -3818,6 +3825,24 @@ package body Sem_Eval is Warn_On_Known_Condition (N); end Eval_Relational_Op; + ----------------------------- + -- Eval_Selected_Component -- + ----------------------------- + + procedure Eval_Selected_Component (N : Node_Id) is + begin + -- If an attribute reference or a LHS, nothing to do. + -- Also do not fold if N is an [in] out subprogram parameter. + -- Fold will perform the other relevant tests. + + if Nkind (Parent (N)) /= N_Attribute_Reference + and then Is_LHS (N) = No + and then not Is_Actual_Out_Or_In_Out_Parameter (N) + then + Fold (N); + end if; + end Eval_Selected_Component; + ---------------- -- Eval_Shift -- ---------------- @@ -4487,6 +4512,15 @@ package body Sem_Eval is elsif Kind = N_Unchecked_Type_Conversion then return Expr_Rep_Value (Expression (N)); + -- Static discriminant value + + elsif Is_Static_Discriminant_Component (N) then + return Expr_Rep_Value + (Get_Discriminant_Value + (Entity (Selector_Name (N)), + Etype (Prefix (N)), + Discriminant_Constraint (Etype (Prefix (N))))); + else raise Program_Error; end if; @@ -4574,6 +4608,15 @@ package body Sem_Eval is elsif Kind = N_Unchecked_Type_Conversion then Val := Expr_Value (Expression (N)); + -- Static discriminant value + + elsif Is_Static_Discriminant_Component (N) then + Val := Expr_Value + (Get_Discriminant_Value + (Entity (Selector_Name (N)), + Etype (Prefix (N)), + Discriminant_Constraint (Etype (Prefix (N))))); + else raise Program_Error; end if; @@ -4801,6 +4844,32 @@ package body Sem_Eval is end if; end Flag_Non_Static_Expr; + ---------- + -- Fold -- + ---------- + + procedure Fold (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + begin + -- If not known at compile time or if already a literal, nothing to do + + if Nkind (N) in N_Numeric_Or_String_Literal + or else not Compile_Time_Known_Value (N) + then + null; + + elsif Is_Discrete_Type (Typ) then + Fold_Uint (N, Expr_Value (N), Static => Is_Static_Expression (N)); + + elsif Is_Real_Type (Typ) then + Fold_Ureal (N, Expr_Value_R (N), Static => Is_Static_Expression (N)); + + elsif Is_String_Type (Typ) then + Fold_Str + (N, Strval (Expr_Value_S (N)), Static => Is_Static_Expression (N)); + end if; + end Fold; + ---------------- -- Fold_Dummy -- ---------------- diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 76e4bdf5d65..972cee646d7 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -330,6 +330,7 @@ package Sem_Eval is procedure Eval_Op_Not (N : Node_Id); procedure Eval_Real_Literal (N : Node_Id); procedure Eval_Relational_Op (N : Node_Id); + procedure Eval_Selected_Component (N : Node_Id); procedure Eval_Shift (N : Node_Id); procedure Eval_Short_Circuit (N : Node_Id); procedure Eval_Slice (N : Node_Id); @@ -387,6 +388,10 @@ package Sem_Eval is -- The call has no effect if Raises_Constraint_Error (N) is True, since -- there is no point in folding if we have an error. + procedure Fold (N : Node_Id); + -- Rewrite N with the relevant value if Compile_Time_Known_Value (N) is + -- True, otherwise a no-op. + function Is_In_Range (N : Node_Id; Typ : Entity_Id; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index bb4ddab6d85..4077ae1b256 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -10891,30 +10891,34 @@ package body Sem_Res is Set_Etype (N, Base_Type (Typ)); end if; - -- Note: No Eval processing is required, because the prefix is of a - -- record type, or protected type, and neither can possibly be static. + -- Eval_Selected_Component may e.g. fold statically known discriminants. - -- If the record type is atomic and the component is not, then this is - -- worth a warning before Ada 2020, since we have a situation where the - -- access to the component may cause extra read/writes of the atomic - -- object, or partial word accesses, both of which may be unexpected. + Eval_Selected_Component (N); - if Nkind (N) = N_Selected_Component - and then Is_Atomic_Ref_With_Address (N) - and then not Is_Atomic (Entity (S)) - and then not Is_Atomic (Etype (Entity (S))) - and then Ada_Version < Ada_2020 - then - Error_Msg_N - ("??access to non-atomic component of atomic record", - Prefix (N)); - Error_Msg_N - ("\??may cause unexpected accesses to atomic object", - Prefix (N)); - end if; + if Nkind (N) = N_Selected_Component then - Resolve_Implicit_Dereference (Prefix (N)); - Analyze_Dimension (N); + -- If the record type is atomic and the component is not, then this + -- is worth a warning before Ada 2020, since we have a situation + -- where the access to the component may cause extra read/writes of + -- the atomic object, or partial word accesses, both of which may be + -- unexpected. + + if Is_Atomic_Ref_With_Address (N) + and then not Is_Atomic (Entity (S)) + and then not Is_Atomic (Etype (Entity (S))) + and then Ada_Version < Ada_2020 + then + Error_Msg_N + ("??access to non-atomic component of atomic record", + Prefix (N)); + Error_Msg_N + ("\??may cause unexpected accesses to atomic object", + Prefix (N)); + end if; + + Resolve_Implicit_Dereference (Prefix (N)); + Analyze_Dimension (N); + end if; end Resolve_Selected_Component; ------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 90e746f746a..20ec9075a51 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -9896,11 +9896,13 @@ package body Sem_Util is ----------------------- procedure Gather_Components - (Typ : Entity_Id; - Comp_List : Node_Id; - Governed_By : List_Id; - Into : Elist_Id; - Report_Errors : out Boolean) + (Typ : Entity_Id; + Comp_List : Node_Id; + Governed_By : List_Id; + Into : Elist_Id; + Report_Errors : out Boolean; + Allow_Compile_Time : Boolean := False; + Include_Interface_Tag : Boolean := False) is Assoc : Node_Id; Variant : Node_Id; @@ -9932,15 +9934,20 @@ package body Sem_Util is while Present (Comp_Item) loop - -- Skip the tag of a tagged record, the interface tags, as well - -- as all items that are not user components (anonymous types, - -- rep clauses, Parent field, controller field). + -- Skip the tag of a tagged record, as well as all items that are not + -- user components (anonymous types, rep clauses, Parent field, + -- controller field). if Nkind (Comp_Item) = N_Component_Declaration then declare Comp : constant Entity_Id := Defining_Identifier (Comp_Item); begin - if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then + if not (Is_Tag (Comp) + and then not + (Include_Interface_Tag + and then Etype (Comp) = RTE (RE_Interface_Tag))) + and then Chars (Comp) /= Name_uParent + then Append_Elmt (Comp, Into); end if; end; @@ -10049,7 +10056,11 @@ package body Sem_Util is end loop Find_Constraint; Discrim_Value := Expression (Assoc); - if Is_OK_Static_Expression (Discrim_Value) then + + if Is_OK_Static_Expression (Discrim_Value) + or else (Allow_Compile_Time + and then Compile_Time_Known_Value (Discrim_Value)) + then Discrim_Value_Status := Static_Expr; else if Ada_Version >= Ada_2020 then @@ -10228,7 +10239,8 @@ package body Sem_Util is end if; Gather_Components - (Typ, Component_List (Variant), Governed_By, Into, Report_Errors); + (Typ, Component_List (Variant), Governed_By, Into, + Report_Errors, Allow_Compile_Time); end if; end Gather_Components; @@ -13861,6 +13873,24 @@ package body Sem_Util is and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag)); end In_Assertion_Expression_Pragma; + ------------------- + -- In_Check_Node -- + ------------------- + + function In_Check_Node (N : Node_Id) return Boolean is + Node : Node_Id := Parent (N); + begin + while Present (Node) loop + if Nkind (Node) in N_Raise_xxx_Error then + return True; + end if; + + Node := Parent (Node); + end loop; + + return False; + end In_Check_Node; + ------------------------------- -- In_Generic_Formal_Package -- ------------------------------- @@ -15210,6 +15240,19 @@ package body Sem_Util is return Present (Formal) and then Ekind (Formal) = E_In_Out_Parameter; end Is_Actual_In_Out_Parameter; + --------------------------------------- + -- Is_Actual_Out_Or_In_Out_Parameter -- + --------------------------------------- + + function Is_Actual_Out_Or_In_Out_Parameter (N : Node_Id) return Boolean is + Formal : Entity_Id; + Call : Node_Id; + begin + Find_Actual (N, Formal, Call); + return Present (Formal) + and then Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter; + end Is_Actual_Out_Or_In_Out_Parameter; + ------------------------- -- Is_Actual_Parameter -- ------------------------- @@ -16312,7 +16355,7 @@ package body Sem_Util is P_Aliased : Boolean := False; Comp : Entity_Id; - Deref : Node_Id := Object; + Deref : Node_Id := Original_Node (Object); -- Dereference node, in something like X.all.Y(2) -- Start of processing for Is_Dependent_Component_Of_Mutable_Object @@ -16323,11 +16366,9 @@ package body Sem_Util is while Nkind (Deref) in N_Indexed_Component | N_Selected_Component | N_Slice loop - Deref := Prefix (Deref); + Deref := Original_Node (Prefix (Deref)); end loop; - Deref := Original_Node (Deref); - -- If the prefix is a qualified expression of a variable, then function -- Is_Variable will return False for that because a qualified expression -- denotes a constant view, so we need to get the name being qualified @@ -16503,14 +16544,16 @@ package body Sem_Util is elsif Nkind (Object) = N_Indexed_Component or else Nkind (Object) = N_Slice then - return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); + return Is_Dependent_Component_Of_Mutable_Object + (Original_Node (Prefix (Object))); -- A type conversion that Is_Variable is a view conversion: -- go back to the denoted object. elsif Nkind (Object) = N_Type_Conversion then return - Is_Dependent_Component_Of_Mutable_Object (Expression (Object)); + Is_Dependent_Component_Of_Mutable_Object + (Original_Node (Expression (Object))); end if; end if; @@ -18296,6 +18339,23 @@ package body Sem_Util is ------------------------- function Is_Object_Reference (N : Node_Id) return Boolean is + function Safe_Prefix (N : Node_Id) return Node_Id; + -- Return Prefix (N) unless it has been rewritten as an + -- N_Raise_xxx_Error node, in which case return its original node. + + ----------------- + -- Safe_Prefix -- + ----------------- + + function Safe_Prefix (N : Node_Id) return Node_Id is + begin + if Nkind (Prefix (N)) in N_Raise_xxx_Error then + return Original_Node (Prefix (N)); + else + return Prefix (N); + end if; + end Safe_Prefix; + begin -- AI12-0068: Note that a current instance reference in a type or -- subtype's aspect_specification is considered a value, not an object @@ -18311,8 +18371,8 @@ package body Sem_Util is | N_Slice => return - Is_Object_Reference (Prefix (N)) - or else Is_Access_Type (Etype (Prefix (N))); + Is_Object_Reference (Safe_Prefix (N)) + or else Is_Access_Type (Etype (Safe_Prefix (N))); -- In Ada 95, a function call is a constant object; a procedure -- call is not. @@ -18340,8 +18400,8 @@ package body Sem_Util is return Is_Object_Reference (Selector_Name (N)) and then - (Is_Object_Reference (Prefix (N)) - or else Is_Access_Type (Etype (Prefix (N)))); + (Is_Object_Reference (Safe_Prefix (N)) + or else Is_Access_Type (Etype (Safe_Prefix (N)))); -- An explicit dereference denotes an object, except that a -- conditional expression gets turned into an explicit dereference @@ -19954,6 +20014,22 @@ package body Sem_Util is or else Nkind (N) = N_Procedure_Call_Statement; end Is_Statement; + -------------------------------------- + -- Is_Static_Discriminant_Component -- + -------------------------------------- + + function Is_Static_Discriminant_Component (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Selected_Component + and then not Is_In_Discriminant_Check (N) + and then Present (Etype (Prefix (N))) + and then Ekind (Etype (Prefix (N))) = E_Record_Subtype + and then Has_Static_Discriminants (Etype (Prefix (N))) + and then Present (Entity (Selector_Name (N))) + and then Ekind (Entity (Selector_Name (N))) = E_Discriminant + and then not In_Check_Node (N); + end Is_Static_Discriminant_Component; + ------------------------ -- Is_Static_Function -- ------------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 60ed0e8f941..65601800495 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1049,11 +1049,13 @@ package Sem_Util is -- be installed on the scope stack to prevent spurious visibility errors. procedure Gather_Components - (Typ : Entity_Id; - Comp_List : Node_Id; - Governed_By : List_Id; - Into : Elist_Id; - Report_Errors : out Boolean); + (Typ : Entity_Id; + Comp_List : Node_Id; + Governed_By : List_Id; + Into : Elist_Id; + Report_Errors : out Boolean; + Allow_Compile_Time : Boolean := False; + Include_Interface_Tag : Boolean := False); -- The purpose of this procedure is to gather the valid components in a -- record type according to the values of its discriminants, in order to -- validate the components of a record aggregate. @@ -1076,6 +1078,12 @@ package Sem_Util is -- Report_Errors is set to True if the values of the discriminants are -- non-static. -- + -- Allow_Compile_Time if set to True, allows compile time known values in + -- Governed_By expressions in addition to static expressions. + -- + -- Include_Interface_Tag if set to True, gather any interface tag + -- component, otherwise exclude them. + -- -- This procedure is also used when building a record subtype. If the -- discriminant constraint of the subtype is static, the components of the -- subtype are only those of the variants selected by the values of the @@ -1542,6 +1550,9 @@ package Sem_Util is -- Returns True if node N appears within a pragma that acts as an assertion -- expression. See Sem_Prag for the list of qualifying pragmas. + function In_Check_Node (N : Node_Id) return Boolean; + -- Return True if N is part of a N_Raise_xxx_Error node + function In_Generic_Formal_Package (E : Entity_Id) return Boolean; -- Returns True if entity E is inside a generic formal package @@ -1696,6 +1707,10 @@ package Sem_Util is function Is_Actual_Out_Parameter (N : Node_Id) return Boolean; -- Determines if N is an actual parameter of out mode in a subprogram call + function Is_Actual_Out_Or_In_Out_Parameter (N : Node_Id) return Boolean; + -- Determines if N is an actual parameter of out or in out mode in a + -- subprogram call. + function Is_Actual_Parameter (N : Node_Id) return Boolean; -- Determines if N is an actual parameter in a subprogram call @@ -2236,6 +2251,13 @@ package Sem_Util is -- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo). -- Note that a label is *not* a statement, and will return False. + function Is_Static_Discriminant_Component (N : Node_Id) return Boolean; + -- Return True if N is guaranteed to a selected component containing a + -- statically known discriminant. + -- Note that this routine takes a conservative view and may return False + -- in some cases where N would match the criteria. In other words this + -- routine should be used to simplify or optimize the expanded code. + function Is_Static_Function (Subp : Entity_Id) return Boolean; -- Determine whether subprogram Subp denotes a static function, -- which is a function with the aspect Static with value True. -- 2.30.2