diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 27 | ||||
| -rw-r--r-- | gcc/ada/errout.adb | 118 | ||||
| -rw-r--r-- | gcc/ada/errout.ads | 13 | ||||
| -rw-r--r-- | gcc/ada/erroutc.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/erroutc.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/errutil.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_intr.adb | 101 | ||||
| -rw-r--r-- | gcc/ada/exp_prag.adb | 33 | ||||
| -rw-r--r-- | gcc/ada/par-ch4.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_aggr.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 119 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 145 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 8 |
16 files changed, 372 insertions, 243 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 98e2678..7c9adb7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2017-09-08 Arnaud Charlet <charlet@adacore.com> + + * exp_intr.adb (Append_Entity_Name): Move to ... + * sem_util.ads, sem_util.adb: ... here to share it. + (Subprogram_Name): New subprogram, to compute the name of the enclosing + subprogram/entity. + * errutil.adb (Error_Msg): Fill new field Node. + * erroutc.ads (Subprogram_Name_Ptr): New. + (Error_Msg_Object): New field Node. + * erroutc.adb (dmsg, Output_Msg_Text): Take new field Node into account. + * errout.adb (Error_Msg): New variant with node id parameter. + Fill new parameter Node when emitting messages. Revert previous + changes for Include_Subprogram_In_Messages. + * sem_ch5.adb (Check_Unreachable_Code): Supply Node parameter when + generating warning message. + +2017-09-08 Ed Schonberg <schonberg@adacore.com> + + * par-ch4.adb (P_Iterated_Component_Association): Place construct + under -gnat2020 flag, given that it is a future feature of + the language. + * sem_aggr.adb (Resolve_Iterated_Component_Association): Mark + defining identifier as referenced to prevent spurious warnings: + corresponding loop is expanded into one or more loops whose + variable has the same name, and the expression uses those names + and not the original one. + 2017-09-08 Hristian Kirtchev <kirtchev@adacore.com> * sem_elab.adb (Check_A_Call): Do not consider diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 664d36e..ce99fd8 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -100,7 +100,8 @@ package body Errout is (Msg : String; Sptr : Source_Ptr; Optr : Source_Ptr; - Msg_Cont : Boolean); + Msg_Cont : Boolean; + Node : Node_Id); -- This is the low level routine used to post messages after dealing with -- the issue of messages placed on instantiations (which get broken up -- into separate calls in Error_Msg). Sptr is the location on which the @@ -111,7 +112,9 @@ package body Errout is -- copy. So typically we can see Optr pointing to the template location -- in an instantiation copy when Sptr points to the source location of -- the actual instantiation (i.e the line with the new). Msg_Cont is - -- set true if this is a continuation message. + -- set true if this is a continuation message. Node is the relevant + -- Node_Id for this message, to be used to compute the enclosing entity if + -- Opt.Include_Subprogram_In_Messages is set. function No_Warnings (N : Node_Or_Entity_Id) return Boolean; -- Determines if warnings should be suppressed for the given node @@ -303,6 +306,15 @@ package body Errout is -- referencing the generic declaration. procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is + begin + Error_Msg (Msg, Flag_Location, Empty); + end Error_Msg; + + procedure Error_Msg + (Msg : String; + Flag_Location : Source_Ptr; + N : Node_Id) + is Sindex : Source_File_Index; -- Source index for flag location @@ -310,8 +322,6 @@ package body Errout is -- Original location of Flag_Location (i.e. location in original -- template in instantiation case, otherwise unchanged). - Entity : Bounded_String; - begin -- Return if all errors are to be ignored @@ -338,18 +348,6 @@ package body Errout is Prescan_Message (Msg); Orig_Loc := Original_Location (Flag_Location); - if Include_Subprogram_In_Messages then - declare - Ent : constant Entity_Id := Current_Subprogram_Ptr.all; - begin - if Present (Ent) then - Append_Unqualified_Decoded (Entity, Chars (Ent)); - else - Append (Entity, "unknown subprogram"); - end if; - end; - end if; - -- If the current location is in an instantiation, the issue arises of -- whether to post the message on the template or the instantiation. @@ -419,14 +417,7 @@ package body Errout is -- Error_Msg_Internal to place the message in the requested location. if Instantiation (Sindex) = No_Location then - if Include_Subprogram_In_Messages then - Append (Entity, ": "); - Append (Entity, Msg); - Error_Msg_Internal (+Entity, Flag_Location, Flag_Location, False); - else - Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False); - end if; - + Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False, N); return; end if; @@ -521,23 +512,35 @@ package body Errout is if Inlined_Body (X) then if Is_Info_Msg then Error_Msg_Internal - ("info: in inlined body #", - Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + (Msg => "info: in inlined body #", + Sptr => Actual_Error_Loc, + Optr => Flag_Location, + Msg_Cont => Msg_Cont_Status, + Node => N); elsif Is_Warning_Msg then Error_Msg_Internal - (Warn_Insertion & "in inlined body #", - Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + (Msg => Warn_Insertion & "in inlined body #", + Sptr => Actual_Error_Loc, + Optr => Flag_Location, + Msg_Cont => Msg_Cont_Status, + Node => N); elsif Is_Style_Msg then Error_Msg_Internal - ("style: in inlined body #", - Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + (Msg => "style: in inlined body #", + Sptr => Actual_Error_Loc, + Optr => Flag_Location, + Msg_Cont => Msg_Cont_Status, + Node => N); else Error_Msg_Internal - ("error in inlined body #", - Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + (Msg => "error in inlined body #", + Sptr => Actual_Error_Loc, + Optr => Flag_Location, + Msg_Cont => Msg_Cont_Status, + Node => N); end if; -- Case of generic instantiation @@ -545,23 +548,35 @@ package body Errout is else if Is_Info_Msg then Error_Msg_Internal - ("info: in instantiation #", - Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + (Msg => "info: in instantiation #", + Sptr => Actual_Error_Loc, + Optr => Flag_Location, + Msg_Cont => Msg_Cont_Status, + Node => N); elsif Is_Warning_Msg then Error_Msg_Internal - (Warn_Insertion & "in instantiation #", - Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + (Msg => Warn_Insertion & "in instantiation #", + Sptr => Actual_Error_Loc, + Optr => Flag_Location, + Msg_Cont => Msg_Cont_Status, + Node => N); elsif Is_Style_Msg then Error_Msg_Internal - ("style: in instantiation #", - Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + (Msg => "style: in instantiation #", + Sptr => Actual_Error_Loc, + Optr => Flag_Location, + Msg_Cont => Msg_Cont_Status, + Node => N); else Error_Msg_Internal - ("instantiation error #", - Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + (Msg => "instantiation error #", + Sptr => Actual_Error_Loc, + Optr => Flag_Location, + Msg_Cont => Msg_Cont_Status, + Node => N); end if; end if; end if; @@ -576,15 +591,12 @@ package body Errout is -- Here we output the original message on the outer instantiation - if Include_Subprogram_In_Messages then - Append (Entity, ": "); - Append (Entity, Msg); - Error_Msg_Internal - (+Entity, Actual_Error_Loc, Flag_Location, Msg_Cont_Status); - else - Error_Msg_Internal - (Msg, Actual_Error_Loc, Flag_Location, Msg_Cont_Status); - end if; + Error_Msg_Internal + (Msg => Msg, + Sptr => Actual_Error_Loc, + Optr => Flag_Location, + Msg_Cont => Msg_Cont_Status, + Node => N); end; end Error_Msg; @@ -798,7 +810,8 @@ package body Errout is (Msg : String; Sptr : Source_Ptr; Optr : Source_Ptr; - Msg_Cont : Boolean) + Msg_Cont : Boolean; + Node : Node_Id) is Next_Msg : Error_Msg_Id; -- Pointer to next message at insertion point @@ -1080,7 +1093,8 @@ package body Errout is Serious => Is_Serious_Error, Uncond => Is_Unconditional_Msg, Msg_Cont => Continuation, - Deleted => False)); + Deleted => False, + Node => Node)); Cur_Msg := Errors.Last; -- Test if warning to be treated as error @@ -1369,7 +1383,7 @@ package body Errout is then Debug_Output (N); Error_Msg_Node_1 := E; - Error_Msg (Msg, Flag_Location); + Error_Msg (Msg, Flag_Location, N); else Last_Killed := True; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index ad33673..e9c4eb4 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -68,11 +68,6 @@ package Errout is -- error message tag. The -gnatw.d switch sets this flag True, -gnatw.D -- sets this flag False. - type Current_Subprogram_Type is access function return Entity_Id; - Current_Subprogram_Ptr : Current_Subprogram_Type := null; - -- Indirect call to Sem_Util.Current_Subprogram to break circular - -- dependency with the static elaboration model. - ----------------------------------- -- Suppression of Error Messages -- ----------------------------------- @@ -691,9 +686,13 @@ package Errout is -- Output list of messages, including messages giving number of detected -- errors and warnings. - procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr); + procedure Error_Msg + (Msg : String; Flag_Location : Source_Ptr); + procedure Error_Msg + (Msg : String; Flag_Location : Source_Ptr; N : Node_Id); -- Output a message at specified location. Can be called from the parser - -- or the semantic analyzer. + -- or the semantic analyzer. If N is set, points to the relevant node for + -- this message. procedure Error_Msg_S (Msg : String); -- Output a message at current scan pointer location. This routine can be diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 464c64e..f81d337 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -299,6 +299,7 @@ package body Erroutc is w (" Uncond = ", E.Uncond); w (" Msg_Cont = ", E.Msg_Cont); w (" Deleted = ", E.Deleted); + w (" Node = ", Int (E.Node)); Write_Eol; end dmsg; @@ -632,7 +633,22 @@ package body Erroutc is -- Postfix warning tag to message if needed if Tag /= "" and then Warning_Doc_Switch then - Txt := new String'(Text.all & ' ' & Tag); + if Include_Subprogram_In_Messages then + Txt := + new String' + (Subprogram_Name_Ptr (Errors.Table (E).Node) & + ": " & Text.all & ' ' & Tag); + else + Txt := new String'(Text.all & ' ' & Tag); + end if; + + elsif Include_Subprogram_In_Messages + and then (Errors.Table (E).Warn or else Errors.Table (E).Style) + then + Txt := + new String' + (Subprogram_Name_Ptr (Errors.Table (E).Node) & + ": " & Text.all); else Txt := Text; end if; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 9aa44e9..a8fc4f9 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -132,6 +132,11 @@ package Erroutc is -- output. This is used for internal processing for the case of an -- illegal instantiation. See Error_Msg routine for further details. + type Subprogram_Name_Type is access function (N : Node_Id) return String; + Subprogram_Name_Ptr : Subprogram_Name_Type; + -- Indirect call to Sem_Util.Subprogram_Name to break circular + -- dependency with the static elaboration model. + ---------------------------- -- Message ID Definitions -- ---------------------------- @@ -251,6 +256,11 @@ package Erroutc is Deleted : Boolean; -- If this flag is set, the message is not printed. This is used -- in the circuit for deleting duplicate/redundant error messages. + + Node : Node_Id; + -- If set, points to the node relevant for this message which will be + -- used to compute the enclosing subprogram name if + -- Opt.Include_Subprogram_In_Messages is set. end record; package Errors is new Table.Table ( diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index 498833a..ed7412a 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -220,7 +220,8 @@ package body Errutil is Serious => Is_Serious_Error, Uncond => Is_Unconditional_Msg, Msg_Cont => Continuation, - Deleted => False)); + Deleted => False, + Node => Empty)); Cur_Msg := Errors.Last; Prev_Msg := No_Error_Msg; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index d6d8069..6719f2e 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1204,7 +1204,7 @@ package body Exp_Disp is procedure Expand_Interface_Conversion (N : Node_Id) is function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id; - -- Return the underlying record type of Typ. + -- Return the underlying record type of Typ ---------------------------- -- Underlying_Record_Type -- diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index fde0617..1d3a321 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,7 +27,6 @@ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; with Elists; use Elists; -with Errout; use Errout; with Expander; use Expander; with Exp_Atag; use Exp_Atag; with Exp_Ch4; use Exp_Ch4; @@ -111,12 +110,6 @@ package body Exp_Intr is -- GNAT.Source_Info; see g-souinf.ads for documentation of these -- intrinsics. - procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id); - -- Recursive procedure to construct string for qualified name of enclosing - -- program unit. The qualification stops at an enclosing scope has no - -- source name (block or loop). If entity is a subprogram instance, skip - -- enclosing wrapper package. The name is appended to Buf. - --------------------- -- Add_Source_Info -- --------------------- @@ -189,98 +182,6 @@ package body Exp_Intr is end case; end Add_Source_Info; - ----------------------- - -- Append_Entity_Name -- - ----------------------- - - procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is - Temp : Bounded_String; - - procedure Inner (E : Entity_Id); - -- Inner recursive routine, keep outer routine nonrecursive to ease - -- debugging when we get strange results from this routine. - - ----------- - -- Inner -- - ----------- - - procedure Inner (E : Entity_Id) is - begin - -- If entity has an internal name, skip by it, and print its scope. - -- Note that we strip a final R from the name before the test; this - -- is needed for some cases of instantiations. - - declare - E_Name : Bounded_String; - - begin - Append (E_Name, Chars (E)); - - if E_Name.Chars (E_Name.Length) = 'R' then - E_Name.Length := E_Name.Length - 1; - end if; - - if Is_Internal_Name (E_Name) then - Inner (Scope (E)); - return; - end if; - end; - - -- Just print entity name if its scope is at the outer level - - if Scope (E) = Standard_Standard then - null; - - -- If scope comes from source, write scope and entity - - elsif Comes_From_Source (Scope (E)) then - Append_Entity_Name (Temp, Scope (E)); - Append (Temp, '.'); - - -- If in wrapper package skip past it - - elsif Is_Wrapper_Package (Scope (E)) then - Append_Entity_Name (Temp, Scope (Scope (E))); - Append (Temp, '.'); - - -- Otherwise nothing to output (happens in unnamed block statements) - - else - null; - end if; - - -- Output the name - - declare - E_Name : Bounded_String; - - begin - Append_Unqualified_Decoded (E_Name, Chars (E)); - - -- Remove trailing upper-case letters from the name (useful for - -- dealing with some cases of internal names generated in the case - -- of references from within a generic). - - while E_Name.Length > 1 - and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z' - loop - E_Name.Length := E_Name.Length - 1; - end loop; - - -- Adjust casing appropriately (gets name from source if possible) - - Adjust_Name_Case (E_Name, Sloc (E)); - Append (Temp, E_Name); - end; - end Inner; - - -- Start of processing for Append_Entity_Name - - begin - Inner (E); - Append (Buf, Temp); - end Append_Entity_Name; - --------------------------------- -- Expand_Binary_Operator_Call -- --------------------------------- diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index dbb9d3e..57f60cd 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -338,17 +338,22 @@ package body Exp_Prag is ------------------------------------------ procedure Replace_Discriminals_Of_Protected_Op (Expr : Node_Id) is - function Find_Corresponding_Discriminal (E : Entity_Id) - return Entity_Id; - -- Find the local entity that renames a discriminant of the - -- enclosing protected type, and has a matching name. + function Find_Corresponding_Discriminal + (E : Entity_Id) return Entity_Id; + -- Find the local entity that renames a discriminant of the enclosing + -- protected type, and has a matching name. + + function Replace_Discr_Ref (N : Node_Id) return Traverse_Result; + -- Replace a reference to a discriminant of the original protected + -- type by the local renaming declaration of the discriminant of + -- the target object. ------------------------------------ - -- find_Corresponding_Discriminal -- + -- Find_Corresponding_Discriminal -- ------------------------------------ - function Find_Corresponding_Discriminal (E : Entity_Id) - return Entity_Id + function Find_Corresponding_Discriminal + (E : Entity_Id) return Entity_Id is R : Entity_Id; @@ -369,35 +374,35 @@ package body Exp_Prag is return Empty; end Find_Corresponding_Discriminal; - function Replace_Discr_Ref (N : Node_Id) return Traverse_Result; - -- Replace a reference to a discriminant of the original protected - -- type by the local renaming declaration of the discriminant of - -- the target object. - ----------------------- -- Replace_Discr_Ref -- ----------------------- - function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is + function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is R : Entity_Id; begin if Is_Entity_Name (N) - and then Present (Discriminal_Link (Entity (N))) + and then Present (Discriminal_Link (Entity (N))) then R := Find_Corresponding_Discriminal (Entity (N)); Rewrite (N, New_Occurrence_Of (R, Sloc (N))); end if; + return OK; end Replace_Discr_Ref; procedure Replace_Discriminant_References is new Traverse_Proc (Replace_Discr_Ref); + -- Start of processing for Replace_Discriminals_Of_Protected_Op + begin Replace_Discriminant_References (Expr); end Replace_Discriminals_Of_Protected_Op; + -- Start of processing for Expand_Pragma_Check + begin -- Nothing to do if pragma is ignored diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 2844b4e..fd0373e 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -3317,6 +3317,12 @@ package body Ch4 is Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List); TF_Arrow; Set_Expression (Assoc_Node, P_Expression); + + if Ada_Version < Ada_2020 then + Error_Msg_SC ("Iterated component is an Ada 2020 extension"); + Error_Msg_SC ("\compile with -gnatX"); + end if; + return Assoc_Node; end P_Iterated_Component_Association; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index a726904..7a37bdd 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1694,13 +1694,16 @@ package body Sem_Aggr is -- may have several choices, each one leading to a loop, so we create -- this variable only once to prevent homonyms in this scope. -- The expression has to be analyzed once the index variable is - -- directly visible. + -- directly visible. Mark the variable as referenced to prevent + -- spurious warnings, given that subsequent uses of its name in the + -- expression will reference the internal (synonym) loop variable. if No (Scope (Id)) then Enter_Name (Id); Set_Etype (Id, Index_Typ); Set_Ekind (Id, E_Variable); Set_Scope (Id, Ent); + Set_Referenced (Id); end if; Push_Scope (Ent); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 64c5dc7..135ecd8 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -3745,7 +3745,8 @@ package body Sem_Ch5 is Check_SPARK_05_Restriction ("unreachable code is not allowed", Error_Node); else - Error_Msg ("??unreachable code!", Sloc (Error_Node)); + Error_Msg + ("??unreachable code!", Sloc (Error_Node), Error_Node); end if; end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 37459f8..3c6f363 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -343,7 +343,6 @@ package body Sem_Ch6 is ---------------------- function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is - procedure Check_And_Freeze_Type (Typ : Entity_Id); -- Check that Typ is fully declared and freeze it if so @@ -371,8 +370,7 @@ package body Sem_Ch6 is if Has_Private_Component (Typ) and then not Is_Private_Type (Typ) then - Error_Msg_NE - ("\type& has private component", Node, Typ); + Error_Msg_NE ("\type& has private component", Node, Typ); end if; else diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 1f4eb1b..b013755a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -29,65 +29,66 @@ -- to complete the syntax checks. Certain pragmas are handled partially or -- completely by the parser (see Par.Prag for further details). -with Aspects; use Aspects; -with Atree; use Atree; -with Casing; use Casing; -with Checks; use Checks; -with Contracts; use Contracts; -with Csets; use Csets; -with Debug; use Debug; -with Einfo; use Einfo; -with Elists; use Elists; -with Errout; use Errout; -with Exp_Dist; use Exp_Dist; -with Exp_Util; use Exp_Util; -with Freeze; use Freeze; -with Ghost; use Ghost; -with Gnatvsn; use Gnatvsn; -with Lib; use Lib; -with Lib.Writ; use Lib.Writ; -with Lib.Xref; use Lib.Xref; -with Namet.Sp; use Namet.Sp; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Output; use Output; -with Par_SCO; use Par_SCO; -with Restrict; use Restrict; -with Rident; use Rident; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Ch3; use Sem_Ch3; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch8; use Sem_Ch8; -with Sem_Ch12; use Sem_Ch12; -with Sem_Ch13; use Sem_Ch13; -with Sem_Disp; use Sem_Disp; -with Sem_Dist; use Sem_Dist; -with Sem_Elim; use Sem_Elim; -with Sem_Eval; use Sem_Eval; -with Sem_Intr; use Sem_Intr; -with Sem_Mech; use Sem_Mech; -with Sem_Res; use Sem_Res; -with Sem_Type; use Sem_Type; -with Sem_Util; use Sem_Util; -with Sem_Warn; use Sem_Warn; -with Stand; use Stand; -with Sinfo; use Sinfo; -with Sinfo.CN; use Sinfo.CN; -with Sinput; use Sinput; -with Stringt; use Stringt; -with Stylesw; use Stylesw; -with System.Case_Util; +with Aspects; use Aspects; +with Atree; use Atree; +with Casing; use Casing; +with Checks; use Checks; +with Contracts; use Contracts; +with Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Dist; use Exp_Dist; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Ghost; use Ghost; +with Gnatvsn; use Gnatvsn; +with Lib; use Lib; +with Lib.Writ; use Lib.Writ; +with Lib.Xref; use Lib.Xref; +with Namet.Sp; use Namet.Sp; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Output; use Output; +with Par_SCO; use Par_SCO; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Elim; use Sem_Elim; +with Sem_Eval; use Sem_Eval; +with Sem_Intr; use Sem_Intr; +with Sem_Mech; use Sem_Mech; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.CN; use Sinfo.CN; +with Sinput; use Sinput; +with Stringt; use Stringt; +with Stylesw; use Stylesw; with Table; -with Targparm; use Targparm; -with Tbuild; use Tbuild; +with Targparm; use Targparm; +with Tbuild; use Tbuild; with Ttypes; -with Uintp; use Uintp; -with Uname; use Uname; -with Urealp; use Urealp; -with Validsw; use Validsw; -with Warnsw; use Warnsw; +with Uintp; use Uintp; +with Uname; use Uname; +with Urealp; use Urealp; +with Validsw; use Validsw; +with Warnsw; use Warnsw; + +with System.Case_Util; package body Sem_Prag is @@ -17924,8 +17925,8 @@ package body Sem_Prag is Name_Increases) then declare - Name : String := - Get_Name_String (Chars (Variant)); + Name : String := Get_Name_String (Chars (Variant)); + begin -- It is a common mistake to write "Increasing" for -- "Increases" or "Decreasing" for "Decreases". Recognize diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a153e9a..5e74d20 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -32,6 +32,7 @@ with Checks; use Checks; with Debug; use Debug; with Elists; use Elists; with Errout; use Errout; +with Erroutc; use Erroutc; with Exp_Ch11; use Exp_Ch11; with Exp_Disp; use Exp_Disp; with Exp_Util; use Exp_Util; @@ -137,6 +138,10 @@ package body Sem_Util is -- becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is -- eliminated. + function Subprogram_Name (N : Node_Id) return String; + -- Return the fully qualified name of the enclosing subprogram for the + -- given node N. + ------------------------------ -- Abstract_Interface_List -- ------------------------------ @@ -572,6 +577,98 @@ package body Sem_Util is end case; end All_Composite_Constraints_Static; + ------------------------ + -- Append_Entity_Name -- + ------------------------ + + procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is + Temp : Bounded_String; + + procedure Inner (E : Entity_Id); + -- Inner recursive routine, keep outer routine nonrecursive to ease + -- debugging when we get strange results from this routine. + + ----------- + -- Inner -- + ----------- + + procedure Inner (E : Entity_Id) is + begin + -- If entity has an internal name, skip by it, and print its scope. + -- Note that we strip a final R from the name before the test; this + -- is needed for some cases of instantiations. + + declare + E_Name : Bounded_String; + + begin + Append (E_Name, Chars (E)); + + if E_Name.Chars (E_Name.Length) = 'R' then + E_Name.Length := E_Name.Length - 1; + end if; + + if Is_Internal_Name (E_Name) then + Inner (Scope (E)); + return; + end if; + end; + + -- Just print entity name if its scope is at the outer level + + if Scope (E) = Standard_Standard then + null; + + -- If scope comes from source, write scope and entity + + elsif Comes_From_Source (Scope (E)) then + Append_Entity_Name (Temp, Scope (E)); + Append (Temp, '.'); + + -- If in wrapper package skip past it + + elsif Is_Wrapper_Package (Scope (E)) then + Append_Entity_Name (Temp, Scope (Scope (E))); + Append (Temp, '.'); + + -- Otherwise nothing to output (happens in unnamed block statements) + + else + null; + end if; + + -- Output the name + + declare + E_Name : Bounded_String; + + begin + Append_Unqualified_Decoded (E_Name, Chars (E)); + + -- Remove trailing upper-case letters from the name (useful for + -- dealing with some cases of internal names generated in the case + -- of references from within a generic). + + while E_Name.Length > 1 + and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z' + loop + E_Name.Length := E_Name.Length - 1; + end loop; + + -- Adjust casing appropriately (gets name from source if possible) + + Adjust_Name_Case (E_Name, Sloc (E)); + Append (Temp, E_Name); + end; + end Inner; + + -- Start of processing for Append_Entity_Name + + begin + Inner (E); + Append (Buf, Temp); + end Append_Entity_Name; + --------------------------------- -- Append_Inherited_Subprogram -- --------------------------------- @@ -21663,11 +21760,12 @@ package body Sem_Util is -- Set_Rep_Info -- ------------------ - procedure Set_Rep_Info (T1, T2 : Entity_Id) is + procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id) is begin Set_Is_Atomic (T1, Is_Atomic (T2)); Set_Is_Independent (T1, Is_Independent (T2)); Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2)); + if Is_Base_Type (T1) then Set_Is_Volatile (T1, Is_Volatile (T2)); end if; @@ -21855,6 +21953,49 @@ package body Sem_Util is end if; end Subprogram_Access_Level; + --------------------- + -- Subprogram_Name -- + --------------------- + + function Subprogram_Name (N : Node_Id) return String is + Buf : Bounded_String; + Ent : Node_Id := N; + + begin + while Present (Ent) loop + case Nkind (Ent) is + when N_Subprogram_Body => + Ent := Defining_Unit_Name (Specification (Ent)); + exit; + + when N_Package_Body + | N_Package_Specification + | N_Subprogram_Specification + => + Ent := Defining_Unit_Name (Ent); + exit; + + when N_Protected_Body + | N_Protected_Type_Declaration + | N_Task_Body + => + exit; + + when others => + null; + end case; + + Ent := Parent (Ent); + end loop; + + if No (Ent) then + return "unknown subprogram"; + end if; + + Append_Entity_Name (Buf, Ent); + return +Buf; + end Subprogram_Name; + ------------------------------- -- Support_Atomic_Primitives -- ------------------------------- @@ -23188,5 +23329,5 @@ package body Sem_Util is end Yields_Universal_Type; begin - Errout.Current_Subprogram_Ptr := Current_Subprogram'Access; + Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access; end Sem_Util; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index d0c3a26..7279c63 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -105,6 +105,12 @@ package Sem_Util is -- irrelevant. Also called for array aggregates, but only named notation, -- because those are the only dynamic cases. + procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id); + -- Recursive procedure to construct string for qualified name of enclosing + -- program unit. The qualification stops at an enclosing scope has no + -- source name (block or loop). If entity is a subprogram instance, skip + -- enclosing wrapper package. The name is appended to Buf. + procedure Append_Inherited_Subprogram (S : Entity_Id); -- If the parent of the operation is declared in the visible part of -- the current scope, the inherited operation is visible even though the @@ -2473,7 +2479,7 @@ package Sem_Util is -- (Referenced_As_LHS if Out_Param is False, Referenced_As_Out_Parameter -- if Out_Param is True) is set True, and the other flag set False. - procedure Set_Rep_Info (T1, T2 : Entity_Id); + procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id); pragma Inline (Set_Rep_Info); -- Copies the Is_Atomic, Is_Independent and Is_Volatile_Full_Access flags -- from sub(type) entity T2 to (sub)type entity T1, as well as Is_Volatile |