From 4892e31daceb8ab230768a15eb0a01b814e8bbfd Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Thu, 11 Mar 2021 17:20:41 -0500 Subject: [PATCH] [Ada] Warn on 'in out' param containing access in predefined private type gcc/ada/ * sem_util.adb, sem_util.ads (Has_Access_Values): New formal Include_Internal to indicate whether internal types should be included. * sem_warn.adb (Check_References): Change E_Out_Parameter to Formal_Kind, to match the comment about Spec_Entity. Pass Include_Internal => False to Has_Access_Values, so that we warn on types with access values that happen to be in internal types, such as Unbounded_String. * sem_attr.adb (Attribute_Has_Access_Values): Pass Include_Internal => True to Has_Access_Values, to preserve existing behavior. * libgnat/g-rewdat.adb (Do_Output): Change B from 'in out' to 'in', to avoid warning enabled by the change to sem_warn.adb. * libgnat/s-objrea.adb (Check_Read_Offset): Change S from 'in out' to 'in', to avoid warning enabled by the change to sem_warn.adb. --- gcc/ada/libgnat/g-rewdat.adb | 4 ++-- gcc/ada/libgnat/s-objrea.adb | 4 ++-- gcc/ada/sem_attr.adb | 4 +++- gcc/ada/sem_util.adb | 14 +++++++++++--- gcc/ada/sem_util.ads | 6 +++++- gcc/ada/sem_warn.adb | 11 +++++++---- 6 files changed, 30 insertions(+), 13 deletions(-) diff --git a/gcc/ada/libgnat/g-rewdat.adb b/gcc/ada/libgnat/g-rewdat.adb index c257afa4c4f8..3b4a0d02b413 100644 --- a/gcc/ada/libgnat/g-rewdat.adb +++ b/gcc/ada/libgnat/g-rewdat.adb @@ -37,7 +37,7 @@ package body GNAT.Rewrite_Data is subtype SEO is Stream_Element_Offset; procedure Do_Output - (B : in out Buffer; + (B : Buffer; Data : Stream_Element_Array; Output : not null access procedure (Data : Stream_Element_Array)); -- Do the actual output. This ensures that we properly send the data @@ -81,7 +81,7 @@ package body GNAT.Rewrite_Data is --------------- procedure Do_Output - (B : in out Buffer; + (B : Buffer; Data : Stream_Element_Array; Output : not null access procedure (Data : Stream_Element_Array)) is diff --git a/gcc/ada/libgnat/s-objrea.adb b/gcc/ada/libgnat/s-objrea.adb index 50be05a17920..b5ca32fdbc9b 100644 --- a/gcc/ada/libgnat/s-objrea.adb +++ b/gcc/ada/libgnat/s-objrea.adb @@ -47,7 +47,7 @@ package body System.Object_Reader is function Trim_Trailing_Nuls (Str : String) return String; -- Return a copy of a string with any trailing NUL characters truncated - procedure Check_Read_Offset (S : in out Mapped_Stream; Size : uint32); + procedure Check_Read_Offset (S : Mapped_Stream; Size : uint32); -- Check that the SIZE bytes at the current offset are still in the stream ------------------------------------- @@ -1931,7 +1931,7 @@ package body System.Object_Reader is return To_String_Ptr_Len (Read (S)); end Read; - procedure Check_Read_Offset (S : in out Mapped_Stream; Size : uint32) is + procedure Check_Read_Offset (S : Mapped_Stream; Size : uint32) is begin if S.Off + Offset (Size) > Offset (Last (S.Region)) then raise IO_Error with "could not read from object file"; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 63b0f09ea5d4..07ce4883fd4e 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -8830,7 +8830,9 @@ package body Sem_Attr is when Attribute_Has_Access_Values => Rewrite (N, New_Occurrence_Of - (Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc)); + (Boolean_Literals + (Has_Access_Values (P_Root_Type, Include_Internal => True)), + Loc)); Analyze_And_Resolve (N, Standard_Boolean); ----------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b71efde85676..47b6a93e1503 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -11539,7 +11539,9 @@ package body Sem_Util is -- Has_Access_Values -- ----------------------- - function Has_Access_Values (T : Entity_Id) return Boolean is + function Has_Access_Values + (T : Entity_Id; Include_Internal : Boolean) return Boolean + is Typ : constant Entity_Id := Underlying_Type (T); begin @@ -11552,11 +11554,17 @@ package body Sem_Util is if No (Typ) then return False; + elsif not Include_Internal + and then T /= Typ + and then In_Internal_Unit (Typ) + then + return False; + elsif Is_Access_Type (Typ) then return True; elsif Is_Array_Type (Typ) then - return Has_Access_Values (Component_Type (Typ)); + return Has_Access_Values (Component_Type (Typ), Include_Internal); elsif Is_Record_Type (Typ) then declare @@ -11571,7 +11579,7 @@ package body Sem_Util is -- Check for access component, tag field does not count, even -- though it is implemented internally using an access type. - if Has_Access_Values (Etype (Comp)) + if Has_Access_Values (Etype (Comp), Include_Internal) and then Chars (Comp) /= Name_uTag then return True; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b8ad3820185d..1d4bd1689681 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1312,7 +1312,8 @@ package Sem_Util is -- limited, packed array and other implementation types. If Include_PAT -- is False, don't look inside packed array types. - function Has_Access_Values (T : Entity_Id) return Boolean; + function Has_Access_Values + (T : Entity_Id; Include_Internal : Boolean) return Boolean; -- Returns true if type or subtype T is an access type, or has a component -- (at any recursive level) that is an access type. This is a conservative -- predicate, if it is not known whether or not T contains access values @@ -1320,6 +1321,9 @@ package Sem_Util is -- Note that tagged types return False. Even though the tag is implemented -- as an access type internally, this function tests only for access types -- known to the programmer. See also Has_Tagged_Component. + -- + -- If Include_Internal is False, we return False for internal private types + -- whose full type contains access types. function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean; -- Returns True if Typ has one or more anonymous access discriminants diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 728927433dab..e85f49301756 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1182,7 +1182,7 @@ package body Sem_Warn is -- First gather any Unset_Reference indication for E1. In the -- case of a parameter, it is the Spec_Entity that is relevant. - if Ekind (E1) = E_Out_Parameter + if Ekind (E1) in Formal_Kind and then Present (Spec_Entity (E1)) then UR := Unset_Reference (Spec_Entity (E1)); @@ -1354,10 +1354,13 @@ package body Sem_Warn is -- Suppress warning if composite type contains any access -- component, since the logical effect of modifying a -- parameter may be achieved by modifying a referenced - -- object. + -- object. This rationale does not apply to internal + -- private types, so we warn even if a component is of + -- something like Unbounded_String. elsif Is_Composite_Type (E1T) - and then Has_Access_Values (E1T) + and then Has_Access_Values + (E1T, Include_Internal => False) then null; @@ -3090,7 +3093,7 @@ package body Sem_Warn is -- Here we generate the warning else - -- If -gnatwk is set then output message that we could be IN + -- If -gnatwk is set then output message that it could be IN if not Is_Trivial_Subprogram (Scope (E1)) then if Warn_On_Constant then -- 2.47.2