From aaeb3b3a867a793f3e08de6cd6ac76539907fef3 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 2 Mar 2015 12:07:34 +0100 Subject: [PATCH] [multiple changes] 2015-03-02 Hristian Kirtchev * sem_prag.adb (Ensure_Aggregate_Form): Ensure that the name denoted by the Chars of a pragma argument association has the proper Sloc when converted into an aggregate. 2015-03-02 Bob Duff * sem_ch6.adb (Check_Private_Overriding): Capture Incomplete_Or_Partial_View in a constant. This is cleaner and more efficient. 2015-03-02 Gary Dismukes * einfo.ads, exp_unst.ads: Minor reformatting. 2015-03-02 Ed Schonberg * a-strsea.adb (Find_Token): Ensure that the range of iteration does not perform any improper character access. This prevents erroneous access in the unusual case of an empty string target and a From parameter less than Source'First. 2015-03-02 Robert Dewar * elists.adb (List_Length): Fix incorrect result. From-SVN: r221111 --- gcc/ada/ChangeLog | 27 ++++++++++++++ gcc/ada/a-strsea.adb | 6 ++- gcc/ada/einfo.ads | 4 +- gcc/ada/elists.adb | 1 + gcc/ada/exp_unst.ads | 2 +- gcc/ada/sem_ch6.adb | 89 +++++++++++++++++++++++++------------------- gcc/ada/sem_prag.adb | 46 ++++++++++++----------- 7 files changed, 112 insertions(+), 63 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 01787e449bb..b1bab66e16e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2015-03-02 Hristian Kirtchev + + * sem_prag.adb (Ensure_Aggregate_Form): + Ensure that the name denoted by the Chars of a pragma argument + association has the proper Sloc when converted into an aggregate. + +2015-03-02 Bob Duff + + * sem_ch6.adb (Check_Private_Overriding): Capture + Incomplete_Or_Partial_View in a constant. This is cleaner and + more efficient. + +2015-03-02 Gary Dismukes + + * einfo.ads, exp_unst.ads: Minor reformatting. + +2015-03-02 Ed Schonberg + + * a-strsea.adb (Find_Token): Ensure that the range of iteration + does not perform any improper character access. This prevents + erroneous access in the unusual case of an empty string target + and a From parameter less than Source'First. + +2015-03-02 Robert Dewar + + * elists.adb (List_Length): Fix incorrect result. + 2015-03-02 Bob Duff * sem_ch6.adb (Check_Private_Overriding): Refine the legality diff --git a/gcc/ada/a-strsea.adb b/gcc/ada/a-strsea.adb index 42d57dfc283..df267c1d7f9 100644 --- a/gcc/ada/a-strsea.adb +++ b/gcc/ada/a-strsea.adb @@ -209,7 +209,11 @@ package body Ada.Strings.Search is raise Index_Error; end if; - for J in From .. Source'Last loop + -- If Source is the empty string, From may still be out of its + -- range. The following ensures that in all cases there is no + -- possible erroneous access to a non-existing character. + + for J in Integer'Max (From, Source'First) .. Source'Last loop if Belongs (Source (J), Set, Test) then First := J; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 08b5319ece6..316b6ad0e4e 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1999,7 +1999,7 @@ package Einfo is -- the case where we are unnesting nested subprograms (in which case it -- is also set for types and subtypes which are not static types, and -- that are referenced uplevel, as well as for subprograms that contain --- uplevel references or call other subprogram, see Exp_unst for details. +-- uplevel references or call other subprograms (Exp_Unst has details). -- Has_Visible_Refinement (Flag263) -- Defined in E_Abstract_State entities. Set when a state has at least @@ -2978,7 +2978,7 @@ package Einfo is -- type is known to be a static type (defined as a discrete type with -- static bounds, a record all of whose component types are static types, -- or an array, all of whose bounds are of a static type, and also have --- a component type that is a static type. See Set_Uplevel_Type for more +-- a component type that is a static type). See Set_Uplevel_Type for more -- information on how this flag is used. Note that if Is_Static_Type is -- True, then it is never the case that the Has_Uplevel_Reference flag is -- set for the same type. diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb index 4d332644b74..5b1f88cdd74 100644 --- a/gcc/ada/elists.adb +++ b/gcc/ada/elists.adb @@ -302,6 +302,7 @@ package body Elists is if No (Elmt) then return N; else + N := N + 1; Next_Elmt (Elmt); end if; end loop; diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads index 9e48a66d57f..8690a3547a8 100644 --- a/gcc/ada/exp_unst.ads +++ b/gcc/ada/exp_unst.ads @@ -195,7 +195,7 @@ package Exp_Unst is -- xxx is replaced by Tnn!(AREC1.xxx).all (where ! represents a call -- to unchecked conversion to convert the address to the access type -- and Tnn is a locally declared type that is "access all t", where t - -- is the type of the reference. + -- is the type of the reference). -- Note: the reason that we use Address as the component type in the -- declaration of AREC1T is that we may create this type before we see diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 39cd353ea5e..929b1c94155 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -8906,24 +8906,27 @@ package body Sem_Ch6 is procedure Check_Private_Overriding (T : Entity_Id) is - function Overrides_Visible_Function return Boolean; + function Overrides_Visible_Function + (Partial_View : Entity_Id) return Boolean; -- True if S overrides a function in the visible part. The -- overridden function could be explicitly or implicitly declared. - function Overrides_Visible_Function return Boolean is + function Overrides_Visible_Function + (Partial_View : Entity_Id) return Boolean + is begin if not Is_Overriding or else not Has_Homonym (S) then return False; end if; - if not Present (Incomplete_Or_Partial_View (T)) then + if not Present (Partial_View) then return True; end if; -- Search through all the homonyms H of S in the current -- package spec, and return True if we find one that matches. -- Note that Parent (H) will be the declaration of the - -- Incomplete_Or_Partial_View of T for a match. + -- partial view of T for a match. declare H : Entity_Id := S; @@ -8936,8 +8939,7 @@ package body Sem_Ch6 is (Parent (H), N_Private_Extension_Declaration, N_Private_Type_Declaration) - and then Defining_Identifier (Parent (H)) = - Incomplete_Or_Partial_View (T) + and then Defining_Identifier (Parent (H)) = Partial_View then return True; end if; @@ -8963,41 +8965,52 @@ package body Sem_Ch6 is Error_Msg_N ("abstract subprograms must be visible " & "(RM 3.9.3(10))!", S); - elsif Ekind (S) = E_Function - and then not Overrides_Visible_Function - then - -- Here, S is "function ... return T;" declared in the - -- private part, not overriding some visible operation. - -- That's illegal in the tagged case (but not if the - -- private type is untagged). + elsif Ekind (S) = E_Function then + declare + Partial_View : constant Entity_Id := + Incomplete_Or_Partial_View (T); - if ((Present (Incomplete_Or_Partial_View (T)) - and then Is_Tagged_Type (Incomplete_Or_Partial_View (T))) - or else (not Present (Incomplete_Or_Partial_View (T)) - and then Is_Tagged_Type (T))) - and then T = Base_Type (Etype (S)) - then - Error_Msg_N ("private function with tagged result must" - & " override visible-part function", S); - Error_Msg_N ("\move subprogram to the visible part" - & " (RM 3.9.3(10))", S); + begin + if not Overrides_Visible_Function (Partial_View) then - -- AI05-0073: extend this test to the case of a function - -- with a controlling access result. + -- Here, S is "function ... return T;" declared in + -- the private part, not overriding some visible + -- operation. That's illegal in the tagged case + -- (but not if the private type is untagged). - elsif Ekind (Etype (S)) = E_Anonymous_Access_Type - and then Is_Tagged_Type (Designated_Type (Etype (S))) - and then - not Is_Class_Wide_Type (Designated_Type (Etype (S))) - and then Ada_Version >= Ada_2012 - then - Error_Msg_N - ("private function with controlling access result " - & "must override visible-part function", S); - Error_Msg_N - ("\move subprogram to the visible part" - & " (RM 3.9.3(10))", S); - end if; + if ((Present (Partial_View) + and then Is_Tagged_Type (Partial_View)) + or else (not Present (Partial_View) + and then Is_Tagged_Type (T))) + and then T = Base_Type (Etype (S)) + then + Error_Msg_N + ("private function with tagged result must" + & " override visible-part function", S); + Error_Msg_N + ("\move subprogram to the visible part" + & " (RM 3.9.3(10))", S); + + -- AI05-0073: extend this test to the case of a + -- function with a controlling access result. + + elsif Ekind (Etype (S)) = E_Anonymous_Access_Type + and then Is_Tagged_Type (Designated_Type (Etype (S))) + and then + not Is_Class_Wide_Type + (Designated_Type (Etype (S))) + and then Ada_Version >= Ada_2012 + then + Error_Msg_N + ("private function with controlling access " + & "result must override visible-part function", + S); + Error_Msg_N + ("\move subprogram to the visible part" + & " (RM 3.9.3(10))", S); + end if; + end if; + end; end if; end if; end Check_Private_Overriding; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 04d73173453..2d84303ac0a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5222,21 +5222,32 @@ package body Sem_Prag is --------------------------- procedure Ensure_Aggregate_Form (Arg : Node_Id) is - Expr : constant Node_Id := Expression (Arg); - Loc : constant Source_Ptr := Sloc (Expr); - Comps : List_Id := No_List; - Exprs : List_Id := No_List; - Nam : Name_Id; - - CFSD : constant Boolean := Get_Comes_From_Source_Default; - -- Used to restore Comes_From_Source_Default + CFSD : constant Boolean := Get_Comes_From_Source_Default; + Expr : constant Node_Id := Expression (Arg); + Loc : constant Source_Ptr := Sloc (Expr); + Comps : List_Id := No_List; + Exprs : List_Id := No_List; + Nam : Name_Id := No_Name; + Nam_Loc : Source_Ptr; begin - if Nkind (Arg) = N_Aspect_Specification then - Nam := No_Name; - else - pragma Assert (Nkind (Arg) = N_Pragma_Argument_Association); - Nam := Chars (Arg); + -- The pragma argument is in positional form: + + -- pragma Depends (Nam => ...) + -- ^ + -- Chars field + + -- Note that the Sloc of the Chars field is the Sloc of the pragma + -- argument association. + + if Nkind (Arg) = N_Pragma_Argument_Association then + Nam := Chars (Arg); + Nam_Loc := Sloc (Arg); + + -- Remove the pragma argument name as this will be captured in the + -- aggregate. + + Set_Chars (Arg, No_Name); end if; -- The argument is already in aggregate form, but the presence of a @@ -5279,17 +5290,10 @@ package body Sem_Prag is else Comps := New_List ( Make_Component_Association (Loc, - Choices => New_List (Make_Identifier (Loc, Chars (Arg))), + Choices => New_List (Make_Identifier (Nam_Loc, Nam)), Expression => Relocate_Node (Expr))); end if; - -- Remove the pragma argument name as this information has been - -- captured in the aggregate. - - if Nkind (Arg) = N_Pragma_Argument_Association then - Set_Chars (Arg, No_Name); - end if; - Set_Expression (Arg, Make_Aggregate (Loc, Component_Associations => Comps,