From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wr1-x42f.google.com (mail-wr1-x42f.google.com [IPv6:2a00:1450:4864:20::42f]) by sourceware.org (Postfix) with ESMTPS id 4A0A33857BA5 for ; Wed, 6 Jul 2022 13:31:29 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 4A0A33857BA5 Received: by mail-wr1-x42f.google.com with SMTP id cl1so22110516wrb.4 for ; Wed, 06 Jul 2022 06:31:29 -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=E4MM4cA9IcFaRDkonJhi9rpF4teYzVl/AyT2nQJStGY=; b=AUvOHWiorgUxKz9AgTUMBoX56IrZmHwfo2D39m/akKe+TgIkC9IE9VHzSW7za5cxH5 XXEer/li+YlUmnT3pKZb3Jug2pSud7rct5CMckt9JRuQ4tqTGu2lOd9HqpccoqU1kwyz 1DOJv+GxMcCawdiobuGekTBhCIt5S+zsTAvsPXlBvtlkC/FwsIDejJtzRwbHTqJItzdK BQcp1Ok0DDW+aaYzfFnIpOqW20frpYXrXXx8DGC3Vo1HrYn2q05t5ih3+BIVGtIUgkY/ F9OXSzuorxD4sobNtB2wTvJmkm7h60psm/nINkzg/84E/Q+X7vhlIasOWIT7C4XxyHml zelQ== X-Gm-Message-State: AJIora/lYPF8kjF6FBUryUJT0q82/MXkEj6mgRasVY9AMryjGOQsYtMc CJzwmz6tmqhh7XDF6RznRP38/QI3WiiYeg== X-Google-Smtp-Source: AGRyM1s3ll7/NPMCKaRjBdUH+6xzgh8XllF5zMX1+yT6nQOkMXLV3quXcrlFFpBH0WX9D0zSwDFz1w== X-Received: by 2002:a5d:6d0a:0:b0:21d:6f28:5ead with SMTP id e10-20020a5d6d0a000000b0021d6f285eadmr10364041wrq.95.1657114288068; Wed, 06 Jul 2022 06:31:28 -0700 (PDT) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id t5-20020a1c4605000000b0039db31f6372sm22403903wma.2.2022.07.06.06.31.27 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 06 Jul 2022 06:31:27 -0700 (PDT) Date: Wed, 6 Jul 2022 13:31:27 +0000 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Missing error on tagged type conversion Message-ID: <20220706133127.GA2204572@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="vkogqOf2sHV7VnPd" Content-Disposition: inline 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, 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-List-Received-Date: Wed, 06 Jul 2022 13:31:32 -0000 --vkogqOf2sHV7VnPd Content-Type: text/plain; charset=us-ascii Content-Disposition: inline The compiler does not report an error on a type conversion to/from a tagged type whose parent type is an interface type and there is no relationship between the source and target types. This bug has been dormant since January/2016. This patch also improves the text of errors reported on interface type conversions suggesting how to fix these errors. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_res.adb (Resolve_Type_Conversion): Code cleanup since the previous static check has been moved to Valid_Tagged_Conversion. (Valid_Tagged_Conversion): Fix the code checking conversion to/from interface types since incorrectly returns True when the parent type of the operand type (or the target type) is an interface type; add missing static checks on interface type conversions. --vkogqOf2sHV7VnPd Content-Type: text/x-diff; charset=us-ascii Content-Disposition: attachment; filename="patch.diff" diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -31,6 +31,7 @@ with Debug_A; use Debug_A; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; +with Elists; use Elists; with Errout; use Errout; with Expander; use Expander; with Exp_Ch6; use Exp_Ch6; @@ -12308,26 +12309,7 @@ package body Sem_Res is -- Conversion to interface type elsif Is_Interface (Target) then - - -- Handle subtypes - - if Ekind (Opnd) in E_Protected_Subtype | E_Task_Subtype then - Opnd := Etype (Opnd); - end if; - - if Is_Class_Wide_Type (Opnd) - or else Interface_Present_In_Ancestor - (Typ => Opnd, - Iface => Target) - then - Expand_Interface_Conversion (N); - else - Error_Msg_Name_1 := Chars (Etype (Target)); - Error_Msg_Name_2 := Chars (Opnd); - Error_Msg_N - ("wrong interface conversion (% is not a progenitor " - & "of %)", N); - end if; + Expand_Interface_Conversion (N); end if; end; end if; @@ -13621,29 +13603,115 @@ package body Sem_Res is Conversion_Check (False, "downward conversion of tagged objects not allowed"); - -- Ada 2005 (AI-251): The conversion to/from interface types is - -- always valid. The types involved may be class-wide (sub)types. + -- Ada 2005 (AI-251): A conversion is valid if the operand and target + -- types are both class-wide types and the specific type associated + -- with at least one of them is an interface type (RM 4.6 (23.1/2)); + -- at run-time a check will verify the validity of this interface + -- type conversion. - elsif Is_Interface (Etype (Base_Type (Target_Type))) - or else Is_Interface (Etype (Base_Type (Opnd_Type))) + elsif Is_Class_Wide_Type (Target_Type) + and then Is_Class_Wide_Type (Opnd_Type) + and then (Is_Interface (Target_Type) + or else Is_Interface (Opnd_Type)) then return True; - -- If the operand is a class-wide type obtained through a limited_ - -- with clause, and the context includes the nonlimited view, use - -- it to determine whether the conversion is legal. + -- Report errors + + elsif Is_Class_Wide_Type (Target_Type) + and then Is_Interface (Target_Type) + and then not Is_Interface (Opnd_Type) + and then not Interface_Present_In_Ancestor + (Typ => Opnd_Type, + Iface => Target_Type) + then + Error_Msg_Name_1 := Chars (Etype (Target_Type)); + Error_Msg_Name_2 := Chars (Opnd_Type); + Conversion_Error_N + ("wrong interface conversion (% is not a progenitor " + & "of %)", N); + return False; elsif Is_Class_Wide_Type (Opnd_Type) - and then From_Limited_With (Opnd_Type) - and then Present (Non_Limited_View (Etype (Opnd_Type))) - and then Is_Interface (Non_Limited_View (Etype (Opnd_Type))) + and then Is_Interface (Opnd_Type) + and then not Is_Interface (Target_Type) + and then not Interface_Present_In_Ancestor + (Typ => Target_Type, + Iface => Opnd_Type) then - return True; + Error_Msg_Name_1 := Chars (Etype (Opnd_Type)); + Error_Msg_Name_2 := Chars (Target_Type); + Conversion_Error_N + ("wrong interface conversion (% is not a progenitor " + & "of %)", N); - elsif Is_Access_Type (Opnd_Type) - and then Is_Interface (Directly_Designated_Type (Opnd_Type)) + -- Search for interface types shared between the target type and + -- the operand interface type to complete the text of the error + -- since the source of this error is a missing type conversion + -- to such interface type. + + if Has_Interfaces (Target_Type) then + declare + Operand_Ifaces_List : Elist_Id; + Operand_Iface_Elmt : Elmt_Id; + Target_Ifaces_List : Elist_Id; + Target_Iface_Elmt : Elmt_Id; + First_Candidate : Boolean := True; + + begin + Collect_Interfaces (Base_Type (Target_Type), + Target_Ifaces_List); + Collect_Interfaces (Root_Type (Base_Type (Opnd_Type)), + Operand_Ifaces_List); + + Operand_Iface_Elmt := First_Elmt (Operand_Ifaces_List); + while Present (Operand_Iface_Elmt) loop + Target_Iface_Elmt := First_Elmt (Target_Ifaces_List); + while Present (Target_Iface_Elmt) loop + if Node (Operand_Iface_Elmt) + = Node (Target_Iface_Elmt) + then + Error_Msg_Name_1 := + Chars (Node (Target_Iface_Elmt)); + + if First_Candidate then + First_Candidate := False; + Conversion_Error_N + ("\must convert to `%''Class` before downward " + & "conversion", Operand); + else + Conversion_Error_N + ("\or must convert to `%''Class` before " + & "downward conversion", Operand); + end if; + end if; + + Next_Elmt (Target_Iface_Elmt); + end loop; + + Next_Elmt (Operand_Iface_Elmt); + end loop; + end; + end if; + + return False; + + elsif not Is_Class_Wide_Type (Target_Type) + and then Is_Interface (Target_Type) then - return True; + Conversion_Error_N + ("wrong use of interface type in tagged conversion", N); + Conversion_Error_N + ("\add ''Class to the target interface type", N); + return False; + + elsif not Is_Class_Wide_Type (Opnd_Type) + and then Is_Interface (Opnd_Type) + then + Conversion_Error_N + ("must convert to class-wide interface type before downward " + & "conversion", Operand); + return False; else Conversion_Error_NE --vkogqOf2sHV7VnPd--