From patchwork Thu Aug 8 14:29:45 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 1970587 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=Zbmb60iz; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4WfqJx56P6z1ybS for ; Fri, 9 Aug 2024 00:33:05 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 059FB385F018 for ; Thu, 8 Aug 2024 14:33:04 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x330.google.com (mail-wm1-x330.google.com [IPv6:2a00:1450:4864:20::330]) by sourceware.org (Postfix) with ESMTPS id 4EEC8385E82D for ; Thu, 8 Aug 2024 14:30:37 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 4EEC8385E82D Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 4EEC8385E82D Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::330 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723127439; cv=none; b=tEc931fmOh2WENVj8C/VgFjz1XinLLLz1jtQKmIOf9c23XJBDBt4IJRxs0p7yDr8l9lFIH0ejS6JT4Kq/NxhO2MenMoXQc0J0dhZfCKwcA+CnUE8Jjqxeu3RDuzPVFAJeeylIiqk2bqlc7yC72/Cgi1dKsIU9dWdz5gFDaY818Y= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723127439; c=relaxed/simple; bh=vuwG2A4HjC7k/9vxDwYxLJzHkBcHl85p2iGYSb5ImiE=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=O/0wYFj5iWMUzQi1Y4ovupflLL9+V9ICk2Qf7nrxR3xVLMpF4d6jiiyTDUMCRadSjbRkh9opvX7QOyMk65syZEfid15S6zopcBbWpGHGw2Ol03kKoQkabbCYg/XsXt00ZpqTlu/QffikF8TK0aAZvH2V71B9B92MpGdqPbqwh4o= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x330.google.com with SMTP id 5b1f17b1804b1-428178fc07eso6897795e9.3 for ; Thu, 08 Aug 2024 07:30:37 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1723127436; x=1723732236; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=UUs57jvsIAQVoTSNniagnaYmsY53hQEYEAneOMskhj8=; b=Zbmb60izicyezj+WfpnU7O0pojlRMy9l6R3FIpCW5hocrlfIgYyliI2dbI8Md07Bgq FSHoOL8ChYUA8whpJaT4OV9ceAG4HVIqC9k3KgMKMpxFO+ZVuTq+nb6Li9RuQwWFHJV7 OPeG042Mfv8Q5qzFlAYwGS63dpuR8+YFz1DD368e2p3d/HBJ0y/6ishNKhhDw1Kk1rYI 0pClNHnopfGm9Mn9tJSJZ1bR7WubNu2mH3Gj1UReegJfJMKfUdEzkxGd7NpcuqbdNjTY 08VaxWJ5yKtsSSXGcaKhdkJnWETQvz0OjWh/niJYSpASaoEZRULHuTSrXDxnXL8MKtAw L1Lg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1723127436; x=1723732236; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=UUs57jvsIAQVoTSNniagnaYmsY53hQEYEAneOMskhj8=; b=iEvKHOmnSoSpZP19NARuFb9WqfZOzLdC6kt131Rz/97n/wolCZGq/JwelE679NyPMp 7shuUg/q+RH+hT1PeI5LbfXJI5+4IcIfHTYwSAuRUP8HCELTv/w11uazmRBj2fz82chB ccae2pSEDDDbdI5zpWty+pcm4j3pchlgABIas0mNJ8vq1mEcZNDnXbU/ydJGtcEZRFqf Qbqx2BtWpnU6sbxeIvtQn1jeQWKaxt8Bmwm6P5su+CWdbA805UhJTFE9LWMU5/Lq2Kpu LN6TCPlotg+5sU2F7tuJuMt7HzlluUJIIk3L4koT2Yivd0M8VOXQKmMGt8kOf/RIAfzO o5qg== X-Gm-Message-State: AOJu0YxQTE4G9hYOdCLUv9lKEZl8EwrCM19oMMmiYI3JcpHHHdSopeEA OIDVuk21csCF+9CQw4N6OvNW+d4BwnDiuYRH7CqUebzV7yz9Todmytc2WLpNGmC9F4KFxLL/QmB /cA== X-Google-Smtp-Source: AGHT+IGyXHX97z8hExhh0l/5wgb9NbSACqMyTChKH6e88JhohSt8mgLrpeg6t4wSHMurHRTOhkLTxw== X-Received: by 2002:a05:600c:190c:b0:426:6e86:f82 with SMTP id 5b1f17b1804b1-4290af13f11mr19436285e9.22.1723127435573; Thu, 08 Aug 2024 07:30:35 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id 5b1f17b1804b1-4290c72d6c8sm25992015e9.9.2024.08.08.07.30.34 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 08 Aug 2024 07:30:35 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Justin Squirek Subject: [COMMITTED 3/6] ada: Futher refinements to mutably tagged types Date: Thu, 8 Aug 2024 16:29:45 +0200 Message-ID: <20240808142948.807190-3-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240808142948.807190-1-poulhies@adacore.com> References: <20240808142948.807190-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP 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.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Justin Squirek This patch further enhances the mutably tagged type implementation by fixing several oversights relating to generic instantiations, attributes, and type conversions. gcc/ada/ * exp_put_image.adb (Append_Component_Attr): Obtain the mutably tagged type for the component type. * mutably_tagged.adb (Make_Mutably_Tagged_Conversion): Add more cases to avoid conversion generation. * sem_attr.adb (Check_Put_Image_Attribute): Add mutably tagged type conversion. * sem_ch12.adb (Analyze_One_Association): Add rewrite for formal type declarations which are mutably tagged type to their equivalent type. (Instantiate_Type): Add condition to obtain class wide equivalent types. (Validate_Private_Type_Instance): Add check for class wide equivalent types which are considered "definite". * sem_util.adb (Is_Variable): Add condition to handle selected components of view conversions. Add missing check for selected components. (Is_View_Conversion): Add condition to handle class wide equivalent types. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_put_image.adb | 25 ++++++++++++++----------- gcc/ada/mutably_tagged.adb | 21 ++++++++++++++------- gcc/ada/sem_attr.adb | 7 +++++++ gcc/ada/sem_ch12.adb | 25 +++++++++++++++++++++++-- gcc/ada/sem_util.adb | 14 +++++++++++++- 5 files changed, 71 insertions(+), 21 deletions(-) diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index bf14eded93e..217c38a30e7 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -32,6 +32,7 @@ with Einfo.Utils; use Einfo.Utils; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Lib; use Lib; +with Mutably_Tagged; use Mutably_Tagged; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -402,9 +403,9 @@ package body Exp_Put_Image is end; end Build_Elementary_Put_Image_Call; - ------------------------------------- + --------------------------------- -- Build_String_Put_Image_Call -- - ------------------------------------- + --------------------------------- function Build_String_Put_Image_Call (N : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); @@ -485,9 +486,9 @@ package body Exp_Put_Image is Relocate_Node (Sink))); end Build_Protected_Put_Image_Call; - ------------------------------------ + ------------------------------- -- Build_Task_Put_Image_Call -- - ------------------------------------ + ------------------------------- -- For "Task_Type'Put_Image (S, Task_Object)", build: -- @@ -650,12 +651,14 @@ package body Exp_Put_Image is return Result; end Make_Component_List_Attributes; - -------------------------------- + --------------------------- -- Append_Component_Attr -- - -------------------------------- + --------------------------- procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id) is - Component_Typ : constant Entity_Id := Put_Image_Base_Type (Etype (C)); + Component_Typ : constant Entity_Id := + Put_Image_Base_Type + (Get_Corresponding_Mutably_Tagged_Type_If_Present (Etype (C))); begin if Ekind (C) /= E_Void then Append_To (Clist, @@ -936,9 +939,9 @@ package body Exp_Put_Image is Build_Put_Image_Proc (Loc, Btyp, Decl, Pnam, Stms); end Build_Record_Put_Image_Procedure; - ------------------------------- + ----------------------------- -- Build_Put_Image_Profile -- - ------------------------------- + ----------------------------- function Build_Put_Image_Profile (Loc : Source_Ptr; Typ : Entity_Id) return List_Id @@ -983,9 +986,9 @@ package body Exp_Put_Image is Statements => Stms)); end Build_Put_Image_Proc; - ------------------------------------ + ---------------------------------- -- Build_Unknown_Put_Image_Call -- - ------------------------------------ + ---------------------------------- function Build_Unknown_Put_Image_Call (N : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); diff --git a/gcc/ada/mutably_tagged.adb b/gcc/ada/mutably_tagged.adb index 34b032f08c8..495cdd0fcfb 100644 --- a/gcc/ada/mutably_tagged.adb +++ b/gcc/ada/mutably_tagged.adb @@ -272,15 +272,22 @@ package body Mutably_Tagged is if Force -- Otherwise, don't make the conversion when N is on the left-hand - -- side of the assignment, is already part of an unchecked conversion, - -- or is part of a renaming. + -- side of the assignment, in cases where we need the actual type + -- such as a subtype or object renaming declaration, or a generic or + -- parameter specification. + + -- Additionally, prevent generation of the conversion if N is already + -- part of an unchecked conversion or a part of a selected component. or else (not Known_To_Be_Assigned (N, Only_LHS => True) - and then (No (Parent (N)) - or else Nkind (Parent (N)) - not in N_Selected_Component - | N_Unchecked_Type_Conversion - | N_Object_Renaming_Declaration)) + and then (No (Parent (N)) + or else Nkind (Parent (N)) + not in N_Selected_Component + | N_Subtype_Declaration + | N_Parameter_Specification + | N_Generic_Association + | N_Unchecked_Type_Conversion + | N_Object_Renaming_Declaration)) then -- Exclude the case where we have a 'Size so that we get the proper -- size of the class-wide equivalent type. Are there other cases ??? diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index a5c90e3f36d..994a45becdc 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -2682,6 +2682,13 @@ package body Sem_Attr is E1); end if; + -- Generate a conversion from a class-wide equivalent type (if + -- present) to the relevant actual type E2. + + if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (E2)) then + Make_Mutably_Tagged_Conversion (E2); + end if; + -- Check that the second argument is of the right type Analyze (E2); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 0f8792c3a82..bc0d34e871d 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -2419,9 +2419,9 @@ package body Sem_Ch12 is -- but there is "others => <>". Add a copy of the declaration of the -- generic formal to the Result_Renamings. - --------------------- + ------------------------ -- Process_Box_Actual -- - --------------------- + ------------------------ procedure Process_Box_Actual (Formal : Node_Id) is pragma Assert (Assoc.Actual.Kind = Box_Actual); @@ -2535,6 +2535,19 @@ package body Sem_Ch12 is else Analyze (Match); + + -- Rewrite mutably tagged types to be their class-wide + -- equivalent type. + + if Ekind (Etype (Match)) /= E_Void + and then Is_Mutably_Tagged_Type (Etype (Match)) + then + Rewrite (Match, New_Occurrence_Of + (Class_Wide_Equivalent_Type + (Etype (Match)), Sloc (Match))); + Analyze (Match); + end if; + Append_List (Instantiate_Type (Assoc.Un_Formal, Match, Assoc.An_Formal, @@ -14928,6 +14941,7 @@ package body Sem_Ch12 is elsif not Is_Definite_Subtype (Act_T) and then Is_Definite_Subtype (A_Gen_T) + and then No (Class_Wide_Equivalent_Type (Act_T)) and then Ada_Version >= Ada_95 then Error_Msg_NE @@ -14957,6 +14971,13 @@ package body Sem_Ch12 is Act_T := Entity (Actual); + -- Obtain the class-wide equivalent type and use it for the + -- instantiation instead of a mutably tagged type. + + if Present (Class_Wide_Equivalent_Type (Act_T)) then + Act_T := Class_Wide_Equivalent_Type (Act_T); + end if; + -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed -- as a generic actual parameter if the corresponding formal type -- does not have a known_discriminant_part, or is a formal derived diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 7b575c09c30..3f956098c6d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -21052,6 +21052,16 @@ package body Sem_Util is if Nkind (N) in N_Subexpr and then Assignment_OK (N) then return True; + -- It is possible that N is a selected component of a view conversion, + -- and in that case get the expression of the conversion and test + -- whether it is indeed a variable. + + elsif Nkind (N) = N_Selected_Component + and then Is_View_Conversion (Ultimate_Prefix (N)) + and then Is_Variable (Expression (Ultimate_Prefix (N))) + then + return True; + -- Normally we go to the original node, but there is one exception where -- we use the rewritten node, namely when it is an explicit dereference. -- The generated code may rewrite a prefix which is an access type with @@ -21205,7 +21215,9 @@ package body Sem_Util is and then Nkind (Unqual_Conv (N)) in N_Has_Etype then if Is_Tagged_Type (Etype (N)) - and then Is_Tagged_Type (Etype (Unqual_Conv (N))) + and then (Is_Tagged_Type (Etype (Unqual_Conv (N))) + or else Is_Class_Wide_Equivalent_Type + (Etype (Unqual_Conv (N)))) then return True;