From fe960a3a19e47d7c2297a19758c914329c8c954e Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Fri, 7 Oct 2022 18:43:46 +0000 Subject: ada: Flag unsupported dispatching constructor calls gcc/ada/ * exp_intr.adb (Expand_Dispatching_Constructor_Call): Report an error on unsupported dispatching constructor calls and report a warning on calls that may fail at run time. gcc/testsuite/ * gnat.dg/abstract1.ads: Cleanup whitespaces. * gnat.dg/abstract1.adb: Likewise and add -gnatws to silence new warning. --- gcc/ada/exp_intr.adb | 44 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index bd987f0..cb9b5be 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -24,13 +24,16 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Aspects; use Aspects; with Checks; use Checks; 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_Atag; use Exp_Atag; +with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch11; use Exp_Ch11; with Exp_Code; use Exp_Code; @@ -277,6 +280,47 @@ package body Exp_Intr is Result_Typ : Entity_Id; begin + pragma Assert (Is_Class_Wide_Type (Etype (Entity (Name (N))))); + + -- Report case where we know that the generated code is wrong; that + -- is a dispatching constructor call whose controlling type has tasks + -- but its root type does not have tasks. In such case the constructor + -- subprogram of the root type does not have extra formals but the + -- constructor of the derivation must have extra formals. + + if not Global_No_Tasking + and then not No_Run_Time_Mode + and then Is_Build_In_Place_Function (Entity (Name (N))) + and then not Has_Task (Root_Type (Etype (Entity (Name (N))))) + and then not Has_Aspect (Root_Type (Etype (Entity (Name (N)))), + Aspect_No_Task_Parts) + then + -- Case 1: Explicit tag reference (which allows static check) + + if Nkind (Tag_Arg) = N_Identifier + and then Present (Entity (Tag_Arg)) + and then Is_Tag (Entity (Tag_Arg)) + then + if Has_Task (Related_Type (Entity (Tag_Arg))) then + Error_Msg_N ("unsupported dispatching constructor call", N); + Error_Msg_NE + ("\work around this problem by defining task component " + & "type& using access-to-task-type", + N, Related_Type (Entity (Tag_Arg))); + end if; + + -- Case 2: Dynamic tag which may fail at run time + + else + Error_Msg_N + ("unsupported dispatching constructor call if the type " + & "of the built object has task components??", N); + Error_Msg_N + ("\work around this problem by replacing task components " + & "with access-to-task-type components??", N); + end if; + end if; + -- Remove side effects from tag argument early, before rewriting -- the dispatching constructor call, as Remove_Side_Effects relies -- on Tag_Arg's Parent link properly attached to the tree (once the -- cgit v1.1