From patchwork Thu Jun 17 14:33:11 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1493578 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Received: from sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4G5Pz92J3Cz9sSs for ; Fri, 18 Jun 2021 00:47:17 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 8043E399BC14 for ; Thu, 17 Jun 2021 14:47:14 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from rock.gnat.com (rock.gnat.com [205.232.38.15]) by sourceware.org (Postfix) with ESMTPS id BC5A03951874 for ; Thu, 17 Jun 2021 14:33:15 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org BC5A03951874 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 745E0116AF6; Thu, 17 Jun 2021 10:33:11 -0400 (EDT) X-Virus-Scanned: Debian amavisd-new at gnat.com Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id JHw0q6HR9LKG; Thu, 17 Jun 2021 10:33:11 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 5E68A56049; Thu, 17 Jun 2021 10:33:11 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 5D7CDA3; Thu, 17 Jun 2021 10:33:11 -0400 (EDT) Date: Thu, 17 Jun 2021 10:33:11 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Subject: [Ada] Warn on 'in out' param containing access in predefined private type Message-ID: <20210617143311.GA10630@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-Spam-Status: No, score=-11.7 required=5.0 tests=BAYES_00, GIT_PATCH_0, KAM_DMARC_STATUS, LIKELY_SPAM_BODY, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: Bob Duff Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" Normally the warnings: warning: formal parameter "..." is not modified warning: mode could be "in" instead of "in out" are disabled if the type contains components of an access type. This patch enables such warnings if the only such components are in internal private types. Tested on x86_64-pc-linux-gnu, committed on trunk 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. diff --git a/gcc/ada/libgnat/g-rewdat.adb b/gcc/ada/libgnat/g-rewdat.adb --- 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 --- 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 --- 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 --- 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 --- 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 --- 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