From patchwork Mon Jul 4 07:50:19 2022 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: 55669 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 1945E3834E5E for ; Mon, 4 Jul 2022 07:51:36 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 1945E3834E5E DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1656921096; bh=VYzmgY5muqTPDX/kucVikRxCuD0Fg2J/IY2dscoIwAI=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=XqqyWS9oWeKAWqtyBMzXpSzDftgHmvl72hLRxR51EyJ9KH9IvtGZLiDQOvbkkTPOm GFFxWepmPoGw47aTkc5jIXBR9zgvJg+cL6cKldmzsLsPJBc93pioyLII8ENb0EiHzt bzMNciYrLXNmV60Pt9QikLqXtAKdJBGk8sPdnL0M= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-ej1-x62c.google.com (mail-ej1-x62c.google.com [IPv6:2a00:1450:4864:20::62c]) by sourceware.org (Postfix) with ESMTPS id 51A3D385415C for ; Mon, 4 Jul 2022 07:50:21 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 51A3D385415C Received: by mail-ej1-x62c.google.com with SMTP id fw3so15210123ejc.10 for ; Mon, 04 Jul 2022 00:50:21 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:date:from:to:cc:subject:message-id:mime-version :content-disposition; bh=VYzmgY5muqTPDX/kucVikRxCuD0Fg2J/IY2dscoIwAI=; b=autUSg+dIAvaJPtX20wW5SGG/FtU/GMK1qycojSs3LrCLQk3ni++4LMIumdWijmG0L 05HXlq3PSLpmU3KEFa5NXikFs1p9s9ST8x1IIm6qjsC4aUuAs61aSybjWl2Ehhu4L8zd yFQB9QSF2FMPhcbxuD7IWUDUbxfM44oNcxrPp+qXf6w/RC9AZ4bCySTxjTy/FU6IoWEF YSP3MvkaiRF0Os5gqs5SlpSL3nplkvfKeXNvhS1MI29MfqjFuTnuZA9fgLBnfpcx60iv LWjm1vCESiBm6wUNXcWpSLYaPXKfR3m6E1dkREw8UwNrZatp9wF9RK2mlHv9ivQZF7oO /WyA== X-Gm-Message-State: AJIora91YUlX2lPCPXH3waNhWCFFASBPojZQezQgTPg9lK6voC4qkRdv Q1n48Nx9dYueQ9GnHhKWjP8Xa0JpUSTk6A== X-Google-Smtp-Source: AGRyM1tgJeAKQ7+HOILgY3IArtmIc4J43vx5blpgNvkZneNJ4slb6RSgtFS9FaN1OXw0yXTi7+H4JA== X-Received: by 2002:a17:906:5a4e:b0:72a:605a:57c3 with SMTP id my14-20020a1709065a4e00b0072a605a57c3mr21385994ejc.301.1656921020959; Mon, 04 Jul 2022 00:50:20 -0700 (PDT) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id t4-20020a17090605c400b00706242d297fsm13676890ejt.212.2022.07.04.00.50.20 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Jul 2022 00:50:20 -0700 (PDT) Date: Mon, 4 Jul 2022 07:50:19 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Tech debt: Remove code duplication Message-ID: <20220704075019.GA99232@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-13.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) 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: , X-Patchwork-Original-From: Pierre-Marie de Rodat via Gcc-patches From: Pierre-Marie de Rodat Reply-To: Pierre-Marie de Rodat Cc: Justin Squirek Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch corrects removes some code duplication within the GNAT compiler. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_util.adb (Remove_Side_Effects): Combine identical branches. * sem_attr.adb (Analyze_Attribute): Combine identical cases Attribute_Has_Same_Storage and Attribute_Overlaps_Storage. * sem_prag.adb (Check_Role): Combine E_Out_Parameter case with general case for parameters. * sem_util.adb (Accessibility_Level): Combine identical branches. * sprint.adb (Sprint_Node_Actual): Combine cases for N_Real_Range_Specification and N_Signed_Integer_Type_Definition. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -12017,31 +12017,23 @@ package body Exp_Util is -- renaming is handled by the front end, as the back end may balk at -- the nonstandard representation (see Evaluation_Required in Exp_Ch8). - elsif Nkind (Exp) in N_Indexed_Component | N_Selected_Component - and then Has_Non_Standard_Rep (Etype (Prefix (Exp))) - then - Def_Id := Build_Temporary (Loc, 'R', Exp); - Res := New_Occurrence_Of (Def_Id, Loc); - - Insert_Action (Exp, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Def_Id, - Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc), - Name => Relocate_Node (Exp))); + elsif (Nkind (Exp) in N_Indexed_Component | N_Selected_Component + and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))) - -- For an expression that denotes a name, we can use a renaming scheme. - -- This is needed for correctness in the case of a volatile object of - -- a nonvolatile type because the Make_Reference call of the "default" - -- approach would generate an illegal access value (an access value - -- cannot designate such an object - see Analyze_Reference). + -- For an expression that denotes a name, we can use a renaming + -- scheme. This is needed for correctness in the case of a volatile + -- object of a nonvolatile type because the Make_Reference call of the + -- "default" approach would generate an illegal access value (an + -- access value cannot designate such an object - see + -- Analyze_Reference). - elsif Is_Name_Reference (Exp) + or else (Is_Name_Reference (Exp) - -- We skip using this scheme if we have an object of a volatile - -- type and we do not have Name_Req set true (see comments for - -- Side_Effect_Free). + -- We skip using this scheme if we have an object of a volatile + -- type and we do not have Name_Req set true (see comments for + -- Side_Effect_Free). - and then (Name_Req or else not Treat_As_Volatile (Exp_Type)) + and then (Name_Req or else not Treat_As_Volatile (Exp_Type))) then Def_Id := Build_Temporary (Loc, 'R', Exp); Res := New_Occurrence_Of (Def_Id, Loc); 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 @@ -4451,7 +4451,9 @@ package body Sem_Attr is -- Has_Same_Storage -- ---------------------- - when Attribute_Has_Same_Storage => + when Attribute_Has_Same_Storage + | Attribute_Overlaps_Storage + => Check_E1; -- The arguments must be objects of any type @@ -5563,21 +5565,6 @@ package body Sem_Attr is end if; end Old; - ---------------------- - -- Overlaps_Storage -- - ---------------------- - - when Attribute_Overlaps_Storage => - Check_E1; - - -- Both arguments must be objects of any type - - Analyze_And_Resolve (P); - Analyze_And_Resolve (E1); - Check_Object_Reference (P); - Check_Object_Reference (E1); - Set_Etype (N, Standard_Boolean); - ------------ -- Output -- ------------ diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1361,36 +1361,15 @@ package body Sem_Prag is when E_Generic_In_Out_Parameter | E_In_Out_Parameter + | E_Out_Parameter | E_Variable => - -- When pragma Global is present it determines the mode of - -- the object. - - if Global_Seen then - - -- A variable has mode IN when its type is unconstrained - -- or tagged because array bounds, discriminants or tags - -- can be read. - - Item_Is_Input := - Appears_In (Subp_Inputs, Item_Id) - or else Is_Unconstrained_Or_Tagged_Item (Item_Id); - - Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); - - -- Otherwise the variable has a default IN OUT mode - - else - Item_Is_Input := True; - Item_Is_Output := True; - end if; - - when E_Out_Parameter => - -- An OUT parameter of the related subprogram; it cannot -- appear in Global. - if Scope (Item_Id) = Spec_Id then + if Adjusted_Kind = E_Out_Parameter + and then Scope (Item_Id) = Spec_Id + then -- The parameter has mode IN if its type is unconstrained -- or tagged because array bounds, discriminants or tags @@ -1401,8 +1380,8 @@ package body Sem_Prag is Item_Is_Output := True; - -- An OUT parameter of an enclosing subprogram; it can - -- appear in Global and behaves as a read-write variable. + -- A parameter of an enclosing subprogram; it can appear + -- in Global and behaves as a read-write variable. else -- When pragma Global is present it determines the mode @@ -1411,8 +1390,8 @@ package body Sem_Prag is if Global_Seen then -- A variable has mode IN when its type is - -- unconstrained or tagged because array - -- bounds, discriminants or tags can be read. + -- unconstrained or tagged because array bounds, + -- discriminants, or tags can be read. Item_Is_Input := Appears_In (Subp_Inputs, Item_Id) 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 @@ -798,44 +798,30 @@ package body Sem_Util is -- in effect we treat discriminant components as regular -- components. - elsif Nkind (E) = N_Selected_Component - and then Ekind (Etype (E)) = E_Anonymous_Access_Type - and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type - and then (not (Nkind (Selector_Name (E)) in N_Has_Entity - and then Ekind (Entity (Selector_Name (E))) - = E_Discriminant) - - -- The alternative accessibility models both treat - -- discriminants as regular components. - - or else (No_Dynamic_Accessibility_Checks_Enabled (E) - and then Allow_Alt_Model)) - then - -- When restriction No_Dynamic_Accessibility_Checks is active - -- and -gnatd_b set, the level is that of the designated type. - - if Allow_Alt_Model - and then No_Dynamic_Accessibility_Checks_Enabled (E) - and then Debug_Flag_Underscore_B - then - return Make_Level_Literal - (Typ_Access_Level (Etype (E))); - end if; + elsif + (Nkind (E) = N_Selected_Component + and then Ekind (Etype (E)) = E_Anonymous_Access_Type + and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type + and then (not (Nkind (Selector_Name (E)) in N_Has_Entity + and then Ekind (Entity (Selector_Name (E))) + = E_Discriminant) - -- Otherwise proceed normally + -- The alternative accessibility models both treat + -- discriminants as regular components. - return Make_Level_Literal - (Typ_Access_Level (Etype (Prefix (E)))); + or else (No_Dynamic_Accessibility_Checks_Enabled (E) + and then Allow_Alt_Model))) - -- Similar to the previous case - arrays featuring components of - -- anonymous access components get their corresponding level from - -- their containing type's declaration. + -- Arrays featuring components of anonymous access components + -- get their corresponding level from their containing type's + -- declaration. - elsif Nkind (E) = N_Indexed_Component - and then Ekind (Etype (E)) = E_Anonymous_Access_Type - and then Ekind (Etype (Pre)) in Array_Kind - and then Ekind (Component_Type (Base_Type (Etype (Pre)))) - = E_Anonymous_Access_Type + or else + (Nkind (E) = N_Indexed_Component + and then Ekind (Etype (E)) = E_Anonymous_Access_Type + and then Ekind (Etype (Pre)) in Array_Kind + and then Ekind (Component_Type (Base_Type (Etype (Pre)))) + = E_Anonymous_Access_Type) then -- When restriction No_Dynamic_Accessibility_Checks is active -- and -gnatd_b set, the level is that of the designated type. diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -3132,7 +3132,9 @@ package body Sprint is when N_Real_Literal => Write_Ureal_With_Col_Check_Sloc (Realval (Node)); - when N_Real_Range_Specification => + when N_Real_Range_Specification + | N_Signed_Integer_Type_Definition + => Write_Str_With_Col_Check_Sloc ("range "); Sprint_Node (Low_Bound (Node)); Write_Str (" .. "); @@ -3248,12 +3250,6 @@ package body Sprint is Write_Indent_Str ("end select;"); - when N_Signed_Integer_Type_Definition => - Write_Str_With_Col_Check_Sloc ("range "); - Sprint_Node (Low_Bound (Node)); - Write_Str (" .. "); - Sprint_Node (High_Bound (Node)); - when N_Single_Protected_Declaration => Write_Indent_Str_Sloc ("protected "); Write_Id (Defining_Identifier (Node));