From 605d816615bf239b9ca6627b18b861b0ff12eac0 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Thu, 12 Dec 2019 10:02:00 +0000 Subject: [PATCH] [Ada] Constraint is ignored on constrained access record component 2019-12-12 Ed Schonberg gcc/ada/ * sem_ch3.adb (Constrain_Access): Remove obsolete comments and warning concerning component types of an access type whose designated type is a constrained record type. (Such constraints were previously ignored). Set scope of itype for component to the scope of the enclosing record. * sem_ch4.adb: Remove call to Set_Ekind. * sem_util.adb (Build_Actual_Subtype_Of_Component): Handle components whose type is an access to a constrained discriminant, where the constraints may be given by the discriminants of the enclosing type. New subprogram Build_Access_Record_Constraint. gcc/testsuite/ * gnat.dg/warn24.adb: Remove expected warning. From-SVN: r279281 --- gcc/ada/ChangeLog | 14 +++++ gcc/ada/sem_ch3.adb | 30 ++++++--- gcc/ada/sem_ch4.adb | 7 +-- gcc/ada/sem_util.adb | 105 ++++++++++++++++++++++++++++++- gcc/testsuite/ChangeLog | 4 ++ gcc/testsuite/gnat.dg/warn24.adb | 2 +- 6 files changed, 144 insertions(+), 18 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 73434302329..c71233d6cbf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2019-12-12 Ed Schonberg + + * sem_ch3.adb (Constrain_Access): Remove obsolete comments and + warning concerning component types of an access type whose + designated type is a constrained record type. (Such constraints + were previously ignored). Set scope of itype for component to + the scope of the enclosing record. + * sem_ch4.adb: Remove call to Set_Ekind. + * sem_util.adb (Build_Actual_Subtype_Of_Component): Handle + components whose type is an access to a constrained + discriminant, where the constraints may be given by the + discriminants of the enclosing type. New subprogram + Build_Access_Record_Constraint. + 2019-12-12 Justin Squirek * exp_ch6.adb (Expand_Call_Helper): Added null case for diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index b12f69b994c..bcee77978ac 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -12971,29 +12971,39 @@ package body Sem_Ch3 is or else Is_Incomplete_Or_Private_Type (Desig_Type)) and then not Is_Constrained (Desig_Type) then - -- ??? The following code is a temporary bypass to ignore a - -- discriminant constraint on access type if it is constraining - -- the current record. Avoid creating the implicit subtype of the - -- record we are currently compiling since right now, we cannot - -- handle these. For now, just return the access type itself. + -- If this is a constrained access definition for a record + -- component, we leave the type as an unconstrained access, + -- and mark the component so that its actual type is build + -- at a point of use (e.g an assignment statement). THis is + -- handled in sem_util, Build_Actual_Subtype_Of_Component. if Desig_Type = Current_Scope and then No (Def_Id) then - Error_Msg_Warn := SPARK_Mode /= On; - Error_Msg_N ("< Scope (Desig_Type)); Set_Ekind (Desig_Subtype, E_Record_Subtype); Def_Id := Entity (Subtype_Mark (S)); + -- We indicate that the component has a pet-object + -- constraint for uniform treatment at a point of use, + -- even though the constraint may be independent of + -- discriminants of enclosing type. + + if Nkind (Related_Nod) = N_Component_Declaration then + Set_Has_Per_Object_Constraint + (Defining_Identifier (Related_Nod)); + end if; + -- This call added to ensure that the constraint is analyzed -- (needed for a B test). Note that we still return early from - -- this procedure to avoid recursive processing. ??? + -- this procedure to avoid recursive processing. Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod, For_Access => True); return; + end if; -- Enforce rule that the constraint is illegal if there is an diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 313398a7921..08905393795 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4812,16 +4812,15 @@ package body Sem_Ch4 is Set_Etype (N, Etype (Comp)); else - -- Component type depends on discriminants. Enter the - -- main attributes of the subtype. + -- If discriminants were present in the component + -- declaration, they have been replaced by the + -- actual values in the prefix object. declare Subt : constant Entity_Id := Defining_Identifier (Act_Decl); - begin Set_Etype (Subt, Base_Type (Etype (Comp))); - Set_Ekind (Subt, Ekind (Etype (Comp))); Set_Etype (N, Subt); end; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c7dabdd6cfa..5d5c52014b8 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1187,18 +1187,28 @@ package body Sem_Util is is Loc : constant Source_Ptr := Sloc (N); P : constant Node_Id := Prefix (N); + D : Elmt_Id; Id : Node_Id; Index_Typ : Entity_Id; + Sel : Entity_Id := Empty; Desig_Typ : Entity_Id; -- This is either a copy of T, or if T is an access type, then it is -- the directly designated type of this access type. + function Build_Access_Record_Constraint (C : List_Id) return List_Id; + -- If the record component is a constrained access to the current + -- record, the subtype has not been constructed during analysis of + -- the enclosing record type (see Analyze_Access). In that case build + -- a constrainted access subtype after replacing references to the + -- enclosing discriminants by the corresponding discriminant values + -- of the prefix. + function Build_Actual_Array_Constraint return List_Id; -- If one or more of the bounds of the component depends on -- discriminants, build actual constraint using the discriminants - -- of the prefix. + -- of the prefx, as above. function Build_Actual_Record_Constraint return List_Id; -- Similar to previous one, for discriminated components constrained @@ -1286,10 +1296,53 @@ package body Sem_Util is return Constraints; end Build_Actual_Record_Constraint; + ------------------------------------ + -- Build_Access_Record_Constraint -- + ------------------------------------ + + function Build_Access_Record_Constraint (C : List_Id) return List_Id is + Constraints : constant List_Id := New_List; + D : Node_Id; + D_Val : Node_Id; + + begin + -- Retrieve the constraint from the compomnent declaration, because + -- the component subtype has not been constructed and the component + -- type is an unconstrained access. + + D := First (C); + while Present (D) loop + if Nkind (D) = N_Discriminant_Association + and then Denotes_Discriminant (Expression (D)) + then + D_Val := New_Copy_Tree (D); + Set_Expression (D_Val, + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (P), + Selector_Name => + New_Occurrence_Of (Entity (Expression (D)), Loc))); + + elsif Denotes_Discriminant (D) then + D_Val := Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (P), + Selector_Name => New_Occurrence_Of (Entity (D), Loc)); + + else + D_Val := New_Copy_Tree (D); + end if; + + Append (D_Val, Constraints); + Next (D); + end loop; + + return Constraints; + end Build_Access_Record_Constraint; + -- Start of processing for Build_Actual_Subtype_Of_Component begin - -- Why the test for Spec_Expression mode here??? + -- The subtype does not need to be created for a selected component + -- in a Spec_Expression, if In_Spec_Expression then return Empty; @@ -1314,19 +1367,33 @@ package body Sem_Util is Remove_Side_Effects (P); return Build_Actual_Subtype (T, N); end if; + else return Empty; end if; + + elsif Nkind (N) = N_Selected_Component then + -- THe entity of the selected compomnent allows us to retrieve + -- the original constraint from its component declaration. + + Sel := Entity (Selector_Name (N)); + if Nkind (Parent (Sel)) /= N_Component_Declaration then + return Empty; + end if; end if; - if Ekind (T) = E_Access_Subtype then + if Is_Access_Type (T) then Desig_Typ := Designated_Type (T); + else Desig_Typ := T; end if; if Ekind (Desig_Typ) = E_Array_Subtype then Id := First_Index (Desig_Typ); + + -- Check whether an index bound is constrained by a discriminant. + while Present (Id) loop Index_Typ := Underlying_Type (Etype (Id)); @@ -1345,6 +1412,7 @@ package body Sem_Util is elsif Is_Composite_Type (Desig_Typ) and then Has_Discriminants (Desig_Typ) + and then not Is_Empty_Elmt_List (Discriminant_Constraint (Desig_Typ)) and then not Has_Unknown_Discriminants (Desig_Typ) then if Is_Private_Type (Desig_Typ) @@ -1364,6 +1432,37 @@ package body Sem_Util is Next_Elmt (D); end loop; + + -- Special processing for an access record component that is + -- the target of an assignment. If the designated type is an + -- unconstrained discriminated record we create its actual + -- subtype now. + + elsif Ekind (T) = E_Access_Type + and then Present (Sel) + and then Has_Per_Object_Constraint (Sel) + and then Nkind (Parent (N)) = N_Assignment_Statement + and then N = Name (Parent (N)) + -- and then not Inside_Init_Proc + -- and then Has_Discriminants (Desig_Typ) + -- and then not Is_Constrained (Desig_Typ) + then + declare + S_Indic : constant Node_Id := + (Subtype_Indication + (Component_Definition (Parent (Sel)))); + Discs : List_Id; + begin + if Nkind (S_Indic) = N_Subtype_Indication then + Discs := Constraints (Constraint (S_Indic)); + + Remove_Side_Effects (P); + return Build_Component_Subtype + (Build_Access_Record_Constraint (Discs), Loc, T); + else + return Empty; + end if; + end; end if; -- If none of the above, the actual and nominal subtypes are the same diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 9174880af75..cde7d7279fe 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-12-12 Ed Schonberg + + * gnat.dg/warn24.adb: Remove expected warning. + 2019-12-12 Pierre-Marie de Rodat * gnat.dg/subp_inst_pkg.adb: Remove implicit anonymous access diff --git a/gcc/testsuite/gnat.dg/warn24.adb b/gcc/testsuite/gnat.dg/warn24.adb index e7c9f8a0466..c2a9e3aeb73 100644 --- a/gcc/testsuite/gnat.dg/warn24.adb +++ b/gcc/testsuite/gnat.dg/warn24.adb @@ -6,7 +6,7 @@ procedure Warn24 is type List_Acc is access List_D; type List_D (D : Boolean) is record - Next : List_Acc (D); -- { dg-warning "constraint is ignored on component that is access to current record" } + Next : List_Acc (D); end record; X : List_D (True); -- 2.30.2