From: Eric Botcazou Date: Thu, 6 Nov 2025 19:42:13 +0000 (+0100) Subject: Ada: Fix function call in object notation incorrectly rejected X-Git-Url: http://git.ipfire.org/gitweb.cgi?a=commitdiff_plain;h=3dbca5ff67b830c2f0d512f048d0f334212a3191;p=thirdparty%2Fgcc.git Ada: Fix function call in object notation incorrectly rejected This happens in the name of a procedure call, again when there is an implicit dereference in this name, and the fix to apply to Find_Selected_Component is again straightforward: --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -8524,9 +8524,7 @@ package body Sem_Ch8 is -- Error if the prefix is procedure or entry, as is P.X if Ekind (P_Name) /= E_Function - and then - (not Is_Overloaded (P) - or else Nkind (Parent (N)) = N_Procedure_Call_Statement) + and then not Is_Overloaded (P) then -- Prefix may mention a package that is hidden by a local -- declaration: let the user know. Scan the full homonym But this also changes the diagnostics in illegal cases because they are not uniform in the procedure, so the change also factors them out so as to make them uniform, which slightly improves them in the end. gcc/ada/ PR ada/113352 * sem_ch4.adb (Diagnose_Call): Tweak error message. * sem_ch8.adb (Find_Selected_Component): Remove bypass for calls to procedures in the overloaded overloadable case. Factor out the diagnostics code and invoke it uniformly in this case. gcc/testsuite/ * gnat.dg/prefix3.adb: New test. * gnat.dg/prefix3_pkg.ads: New helper. * gnat.dg/prefix3_pkg.adb: Likewise. --- diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 5704bf142c8..54df44d954b 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -7147,7 +7147,7 @@ package body Sem_Ch4 is and then N = Prefix (Parent (N)) then Error_Msg_N -- CODEFIX - ("\period should probably be semicolon", Parent (N)); + ("\period is probably a typographical error", Parent (N)); end if; end if; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 18418e92a1e..11f2b19b0b0 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -8510,92 +8510,104 @@ package body Sem_Ch8 is end; end if; + -- Case of the enclosing construct + if In_Open_Scopes (P_Name) then Set_Entity (P, P_Name); Set_Is_Overloaded (P, False); Find_Expanded_Name (N); + -- If no interpretation as an expanded name is possible, then it + -- must be a selected component of a record returned by a function + -- call. Reformat the prefix as a function call and analyze it. + else - -- If no interpretation as an expanded name is possible, it - -- must be a selected component of a record returned by a - -- function call. Reformat prefix as a function call, the rest - -- is done by type resolution. + declare + procedure Diagnose_Call; + -- Try and give useful diagnostics on error - -- Error if the prefix is procedure or entry, as is P.X + ------------------- + -- Diagnose_Call -- + ------------------- - if Ekind (P_Name) /= E_Function - and then - (not Is_Overloaded (P) - or else Nkind (Parent (N)) = N_Procedure_Call_Statement) - then - -- Prefix may mention a package that is hidden by a local - -- declaration: let the user know. Scan the full homonym - -- chain, the candidate package may be anywhere on it. + procedure Diagnose_Call is + Ent : Entity_Id; - if Present (Homonym (Current_Entity (P_Name))) then - P_Name := Current_Entity (P_Name); + begin + -- Prefix may mention a package that is hidden by a local + -- declaration: let the user know. Scan the full homonym + -- chain, the candidate package may be anywhere on it. + + Ent := Current_Entity (P_Name); - while Present (P_Name) loop - exit when Ekind (P_Name) = E_Package; - P_Name := Homonym (P_Name); + while Present (Ent) loop + exit when Ekind (Ent) = E_Package; + Ent := Homonym (Ent); end loop; - if Present (P_Name) then - if not Is_Reference_In_Subunit then - Error_Msg_Sloc := Sloc (Entity (Prefix (N))); - Error_Msg_NE - ("package& is hidden by declaration#", N, P_Name); - end if; + if Present (Ent) and then not Is_Reference_In_Subunit then + Error_Msg_Sloc := Sloc (P_Name); + Error_Msg_NE + ("\package& is hidden by declaration#", N, Ent); + end if; - Set_Entity (Prefix (N), P_Name); - Find_Expanded_Name (N); - return; + -- Format node as expanded name, to avoid cascaded errors - else - P_Name := Entity (Prefix (N)); - end if; - end if; + Change_Selected_Component_To_Expanded_Name (N); + Set_Entity (N, Any_Id); + Set_Etype (N, Any_Type); + end Diagnose_Call; - Error_Msg_NE - ("invalid prefix in selected component&", N, P_Name); - Change_Selected_Component_To_Expanded_Name (N); - Set_Entity (N, Any_Id); - Set_Etype (N, Any_Type); + begin + -- Error if the prefix is procedure or entry, as in P.X - -- Here we have a function call, so do the reformatting + if Ekind (P_Name) /= E_Function + and then not Is_Overloaded (P) + then + Error_Msg_NE + ("invalid prefix& in selected component", N, P_Name); + Diagnose_Call; + return; - else - Nam := New_Copy (P); - Save_Interps (P, Nam); + -- Here we may have a function call, so do the reformatting - -- We use Replace here because this is one of those cases - -- where the parser has missclassified the node, and we fix - -- things up and then do the semantic analysis on the fixed - -- up node. Normally we do this using one of the Sinfo.CN - -- routines, but this is too tricky for that. + else + Nam := New_Copy (P); + Save_Interps (P, Nam); - -- Note that using Rewrite would be wrong, because we would - -- have a tree where the original node is unanalyzed. + -- We use Replace here because this is one of those cases + -- where the parser has misclassified the node and we fix + -- things up and then do semantic analysis on the fixed + -- up node. Normally we do this using one of the Sinfo.CN + -- routines, but this is too tricky for that. - Replace (P, - Make_Function_Call (Sloc (P), Name => Nam)); + -- Note that using Rewrite would be wrong, since we would + -- have a tree where the original node is unanalyzed. - -- Now analyze the reformatted node + Replace (P, Make_Function_Call (Sloc (P), Name => Nam)); - Analyze_Call (P); + -- Now analyze the reformatted node - -- If the prefix is illegal after this transformation, there - -- may be visibility errors on the prefix. The safest is to - -- treat the selected component as an error. + Analyze_Call (P); - if Error_Posted (P) then - Set_Etype (N, Any_Type); - return; + -- If the prefix is illegal after this transformation, + -- there may be a visibility error on the prefix. The + -- safest is to treat the selected component as an error. - else - Analyze_Selected_Component (N); + if Error_Posted (P) then + Diagnose_Call; + return; + + else + Analyze_Selected_Component (N); + + if Error_Posted (N) then + Diagnose_Call; + return; + end if; + end if; end if; - end if; + end; end if; -- Remaining cases generate various error messages diff --git a/gcc/testsuite/gnat.dg/prefix3.adb b/gcc/testsuite/gnat.dg/prefix3.adb new file mode 100644 index 00000000000..904cc0312c0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/prefix3.adb @@ -0,0 +1,8 @@ +-- { dg-do compile } + +with Prefix3_Pkg; + +procedure Prefix3 is +begin + Prefix3_Pkg.Handler.Log ("Hello"); +end; diff --git a/gcc/testsuite/gnat.dg/prefix3_pkg.adb b/gcc/testsuite/gnat.dg/prefix3_pkg.adb new file mode 100644 index 00000000000..3c1e7b547fc --- /dev/null +++ b/gcc/testsuite/gnat.dg/prefix3_pkg.adb @@ -0,0 +1,16 @@ +package body Prefix3_Pkg is + + My_Handler : aliased Logging := (Output => Ada.Text_IO.Current_Output); + + My_Generic_Handler : Logging_Class := My_Handler'Access; + + procedure Log (Handler : Logging; Msg : String) is + begin + Ada.Text_IO.Put_Line (Handler.Output.all, Msg); + end Log; + + function Handler return Logging_Class is (My_Generic_Handler); + + procedure Handler (To : Logging_Class) is null; + +end Prefix3_Pkg; diff --git a/gcc/testsuite/gnat.dg/prefix3_pkg.ads b/gcc/testsuite/gnat.dg/prefix3_pkg.ads new file mode 100644 index 00000000000..9011748f3f8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/prefix3_pkg.ads @@ -0,0 +1,16 @@ +with Ada.Text_IO; + +package Prefix3_Pkg is + + type Logging is tagged record + Output : Ada.Text_IO.File_Access; + end record; + + procedure Log (Handler : Logging; Msg : String); + + type Logging_Class is access all Logging'Class; + + function Handler return Logging_Class; + procedure Handler (To : Logging_Class); + +end Prefix3_Pkg;