diff options
| -rw-r--r-- | gcc/ada/par-ch3.adb | 26 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 106 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/sprint.adb | 10 |
4 files changed, 145 insertions, 7 deletions
diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index a54577e..9065f4b 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -1480,6 +1480,32 @@ package body Ch3 is Done := False; return; + -- AI12-0275: Object renaming declaration without subtype_mark or + -- access_definition + + elsif Token = Tok_Renames then + if Ada_Version < Ada_2020 then + Error_Msg_SC + ("object renaming without subtype is an Ada 202x feature"); + Error_Msg_SC ("\compile with -gnatX"); + end if; + + Scan; -- past renames + + Decl_Node := + New_Node (N_Object_Renaming_Declaration, Ident_Sloc); + Set_Name (Decl_Node, P_Name); + Set_Defining_Identifier (Decl_Node, Idents (1)); + + P_Aspect_Specifications (Decl_Node, Semicolon => False); + + T_Semicolon; + + Append (Decl_Node, Decls); + Done := False; + + return; + -- Otherwise we have an error situation else diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 76f696b..4a730fc 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -906,10 +906,108 @@ package body Sem_Ch8 is Find_Type (Subtype_Mark (N)); end if; - elsif Present (Subtype_Mark (N)) then - Find_Type (Subtype_Mark (N)); - T := Entity (Subtype_Mark (N)); - Analyze (Nam); + elsif Present (Subtype_Mark (N)) + or else not Present (Access_Definition (N)) + then + if Present (Subtype_Mark (N)) then + Find_Type (Subtype_Mark (N)); + T := Entity (Subtype_Mark (N)); + Analyze (Nam); + + -- AI12-0275: Case of object renaming without a subtype_mark + + else + Analyze (Nam); + + -- Normal case of no overloading in object name + + if not Is_Overloaded (Nam) then + + -- Catch error cases (such as attempting to rename a procedure + -- or package) using the shorthand form. + + if No (Etype (Nam)) + or else Etype (Nam) = Standard_Void_Type + then + Error_Msg_N ("object name expected in renaming", Nam); + + Set_Ekind (Id, E_Variable); + Set_Etype (Id, Any_Type); + + return; + + else + T := Etype (Nam); + end if; + + -- Case of overloaded name, which will be illegal if there's more + -- than one acceptable interpretation (such as overloaded function + -- calls). + + else + declare + I : Interp_Index; + I1 : Interp_Index; + It : Interp; + It1 : Interp; + Nam1 : Entity_Id; + + begin + -- More than one candidate interpretation is available + + -- Remove procedure calls, which syntactically cannot appear + -- in this context, but which cannot be removed by type + -- checking, because the context does not impose a type. + + Get_First_Interp (Nam, I, It); + while Present (It.Typ) loop + if It.Typ = Standard_Void_Type then + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + + Get_First_Interp (Nam, I, It); + I1 := I; + It1 := It; + + -- If there's no type present, we have an error case (such + -- as overloaded procedures named in the object renaming). + + if No (It.Typ) then + Error_Msg_N ("object name expected in renaming", Nam); + + Set_Ekind (Id, E_Variable); + Set_Etype (Id, Any_Type); + + return; + end if; + + Get_Next_Interp (I, It); + + if Present (It.Typ) then + Nam1 := It1.Nam; + It1 := Disambiguate (Nam, I1, I, Any_Type); + + if It1 = No_Interp then + Error_Msg_N ("ambiguous name in object renaming", Nam); + + Error_Msg_Sloc := Sloc (It.Nam); + Error_Msg_N ("\\possible interpretation#!", Nam); + + Error_Msg_Sloc := Sloc (Nam1); + Error_Msg_N ("\\possible interpretation#!", Nam); + + return; + end if; + end if; + + Set_Etype (Nam, It1.Typ); + T := It1.Typ; + end; + end if; + end if; -- The object renaming declaration may become Ghost if it renames a -- Ghost entity. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index dff9f81..49594e4 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -11726,7 +11726,6 @@ package body Sem_Util is when N_Component_Definition | N_Formal_Object_Declaration - | N_Object_Renaming_Declaration => if Present (Subtype_Mark (N)) then return Null_Exclusion_Present (N); @@ -11734,6 +11733,15 @@ package body Sem_Util is return Null_Exclusion_Present (Access_Definition (N)); end if; + when N_Object_Renaming_Declaration => + if Present (Subtype_Mark (N)) then + return Null_Exclusion_Present (N); + elsif Present (Access_Definition (N)) then + return Null_Exclusion_Present (Access_Definition (N)); + else + return False; -- Case of no subtype in renaming (AI12-0275) + end if; + when N_Discriminant_Specification => if Nkind (Discriminant_Type (N)) = N_Access_Definition then return Null_Exclusion_Present (Discriminant_Type (N)); diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 51f0bf4..f177981 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -2441,14 +2441,15 @@ package body Sprint is Write_Indent; Set_Debug_Sloc; Sprint_Node (Defining_Identifier (Node)); - Write_Str (" : "); -- Ada 2005 (AI-230): Access renamings if Present (Access_Definition (Node)) then + Write_Str (" : "); Sprint_Node (Access_Definition (Node)); elsif Present (Subtype_Mark (Node)) then + Write_Str (" : "); -- Ada 2005 (AI-423): Object renaming with a null exclusion @@ -2458,8 +2459,13 @@ package body Sprint is Sprint_Node (Subtype_Mark (Node)); + -- AI12-0275: Object_Renaming_Declaration without explicit subtype + + elsif Ada_Version >= Ada_2020 then + null; + else - Write_Str (" ??? "); + Write_Str (" : ??? "); end if; Write_Str_With_Col_Check (" renames "); |