From: Javier Miranda Date: Tue, 10 May 2022 17:18:30 +0000 (+0000) Subject: [Ada] Missing error on tagged type conversion X-Git-Tag: basepoints/gcc-14~5680 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=28add0a4c82f52631b434e1e126588cd3f5b7782;p=thirdparty%2Fgcc.git [Ada] Missing error on tagged type conversion 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. 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. --- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 8fbd2d5e2a5..3ff0afd1712 100644 --- 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