From: Ed Schonberg Date: Fri, 6 Jan 2017 11:03:36 +0000 (+0000) Subject: exp_ch5.adb (Get_Default_Iterator): For a derived type... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=6eca51ce090586d67fe01897c848bb224142549f;p=gcc.git exp_ch5.adb (Get_Default_Iterator): For a derived type... 2017-01-06 Ed Schonberg * exp_ch5.adb (Get_Default_Iterator): For a derived type, the alias of the inherited op is the parent iterator, no need to examine dispatch table positions which might not be established yet if type is not frozen. * sem_disp.adb (Check_Controlling_Formals): The formal of a predicate function may be a subtype of a tagged type. * sem_ch3.adb (Complete_Private_Subtype): Adjust inheritance of representation items for the completion of a type extension where a predicate applies to the partial view. * checks.ads, checks.adb (Apply_Predicate_Check): Add optional parameter that designates function whose actual receives a predicate check, to improve warning message when the check will lead to infinite recursion. * sem_res.adb (Resolve_Actuals): Pass additional parameter to Apply_Predicate_Check. From-SVN: r244132 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ee3603d6116..e5f4d17b70b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,21 @@ +2017-01-06 Ed Schonberg + + * exp_ch5.adb (Get_Default_Iterator): For a derived type, the + alias of the inherited op is the parent iterator, no need to + examine dispatch table positions which might not be established + yet if type is not frozen. + * sem_disp.adb (Check_Controlling_Formals): The formal of a + predicate function may be a subtype of a tagged type. + * sem_ch3.adb (Complete_Private_Subtype): Adjust inheritance + of representation items for the completion of a type extension + where a predicate applies to the partial view. + * checks.ads, checks.adb (Apply_Predicate_Check): Add optional + parameter that designates function whose actual receives a + predicate check, to improve warning message when the check will + lead to infinite recursion. + * sem_res.adb (Resolve_Actuals): Pass additional parameter to + Apply_Predicate_Check. + 2017-01-06 Tristan Gingold * s-rident.ads (Profile_Info): Remove No_Entry_Queue from diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index d91d64b0ffb..83703b6cb9a 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2605,7 +2605,11 @@ package body Checks is -- Apply_Predicate_Check -- --------------------------- - procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id) is + procedure Apply_Predicate_Check + (N : Node_Id; + Typ : Entity_Id; + Fun : Entity_Id := Empty) + is S : Entity_Id; begin @@ -2633,11 +2637,18 @@ package body Checks is -- is likely to be a common error, and thus deserves a warning. elsif Present (S) and then S = Predicate_Function (Typ) then - Error_Msg_N - ("predicate check includes a function call that " - & "requires a predicate check??", Parent (N)); + Error_Msg_NE + ("predicate check includes a call to& that " + & "requires a predicate check??", Parent (N), Fun); Error_Msg_N ("\this will result in infinite recursion??", Parent (N)); + + if Is_First_Subtype (Typ) then + Error_Msg_NE + ("\use an explicit subtype of& to carry the predicate", + Parent (N), Typ); + end if; + Insert_Action (N, Make_Raise_Storage_Error (Sloc (N), Reason => SE_Infinite_Recursion)); diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 2d7d203b0e5..ff513e667b4 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -255,9 +255,14 @@ package Checks is -- verify the proper initialization of scalars in parameters and function -- results. - procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id); - -- N is an expression to which a predicate check may need to be applied - -- for Typ, if Typ has a predicate function. + procedure Apply_Predicate_Check + (N : Node_Id; + Typ : Entity_Id; + Fun : Entity_Id := Empty); + -- N is an expression to which a predicate check may need to be applied for + -- Typ, if Typ has a predicate function. When N is an actual in a call, Fun + -- is the function being called, which is used to generate a better warning + -- if the call leads to an infinite recursion. procedure Apply_Type_Conversion_Checks (N : Node_Id); -- N is an N_Type_Conversion node. A type conversion actually involves diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 4e09e99b8f0..ac7699d98ae 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -3769,14 +3769,17 @@ package body Exp_Ch5 is elsif Is_Derived_Type (T) then -- The default iterator must be a primitive operation of the - -- type, at the same dispatch slot position. + -- type, at the same dispatch slot position. The DT position + -- may not be established if type is not frozen yet. Prim := First_Elmt (Primitive_Operations (T)); while Present (Prim) loop Op := Node (Prim); - if Chars (Op) = Chars (Iter) - and then DT_Position (Op) = DT_Position (Iter) + if Alias (Op) = Iter + or else (Chars (Op) = Chars (Iter) + and then Present (DTC_Entity (Op)) + and then DT_Position (Op) = DT_Position (Iter)) then return Op; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 5e659fdb2f9..d00a31c406a 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -11947,9 +11947,11 @@ package body Sem_Ch3 is Append : Boolean; Item : Node_Id; Next_Item : Node_Id; + Priv_Item : Node_Id; begin Item := First_Rep_Item (Full); + Priv_Item := First_Rep_Item (Priv); -- If no existing rep items on full type, we can just link directly -- to the list of items on the private type, if any exist.. Same if @@ -11960,14 +11962,24 @@ package body Sem_Ch3 is or else Entity (Item) = Full_Base) and then Present (First_Rep_Item (Priv)) then - Set_First_Rep_Item (Full, First_Rep_Item (Priv)); + Set_First_Rep_Item (Full, Priv_Item); -- Otherwise, search to the end of items currently linked to the full -- subtype and append the private items to the end. However, if Priv -- and Full already have the same list of rep items, then the append -- is not done, as that would create a circularity. + -- + -- The partial view may have a predicate and the rep item lists of + -- both views agree when inherited from the same ancestor. In that + -- case, simply propagate the list from one view to the other. + -- A more complex analysis needed here ??? + + elsif Present (Priv_Item) + and then Item = Next_Rep_Item (Priv_Item) + then + Set_First_Rep_Item (Full, Priv_Item); - elsif Item /= First_Rep_Item (Priv) then + elsif Item /= Priv_Item then Append := True; loop Next_Item := Next_Rep_Item (Item); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 8aee9a05b92..f621fa5e189 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -234,7 +234,13 @@ package body Sem_Disp is Formal); end if; - elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) then + -- Within a predicate function, the formal may be a subtype + -- of a tagged type, given that the predicate is expressed + -- in terms of the subtype. + + elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) + and then not Is_Predicate_Function (Subp) + then Error_Msg_N ("parameter subtype does not match controlling type", Formal); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 86691d9e9a5..f174ad9497e 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4265,10 +4265,12 @@ package body Sem_Res is -- Apply predicate tests except in certain special cases. Note -- that it might be more consistent to apply these only when -- expansion is active (in Exp_Ch6.Expand_Actuals), as we do - -- for the outbound predicate tests ??? + -- for the outbound predicate tests ??? In any case indicate + -- the function being called, for better warnings if the call + -- leads to an infinite recursion. if Predicate_Tests_On_Arguments (Nam) then - Apply_Predicate_Check (A, F_Typ); + Apply_Predicate_Check (A, F_Typ, Nam); end if; -- Apply required constraint checks