diff options
Diffstat (limited to 'gcc/ada/errout.adb')
| -rw-r--r-- | gcc/ada/errout.adb | 942 |
1 files changed, 813 insertions, 129 deletions
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index cc291c6..0122304 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2021, 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- -- @@ -29,25 +29,29 @@ -- environment, and that in particular, no disallowed table expansion is -- allowed to occur. -with Atree; use Atree; -with Casing; use Casing; -with Csets; use Csets; -with Debug; use Debug; -with Einfo; use Einfo; -with Erroutc; use Erroutc; -with Gnatvsn; use Gnatvsn; -with Lib; use Lib; -with Opt; use Opt; -with Nlists; use Nlists; -with Output; use Output; -with Scans; use Scans; -with Sem_Aux; use Sem_Aux; -with Sinput; use Sinput; -with Sinfo; use Sinfo; -with Snames; use Snames; -with Stand; use Stand; -with Stylesw; use Stylesw; -with Uname; use Uname; +with Atree; use Atree; +with Casing; use Casing; +with Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Einfo.Entities; use Einfo.Entities; +with Einfo.Utils; use Einfo.Utils; +with Erroutc; use Erroutc; +with Gnatvsn; use Gnatvsn; +with Lib; use Lib; +with Opt; use Opt; +with Nlists; use Nlists; +with Output; use Output; +with Scans; use Scans; +with Sem_Aux; use Sem_Aux; +with Sinput; use Sinput; +with Sinfo; use Sinfo; +with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo.Utils; use Sinfo.Utils; +with Snames; use Snames; +with Stand; use Stand; +with Stylesw; use Stylesw; +with Uname; use Uname; package body Errout is @@ -98,8 +102,8 @@ package body Errout is procedure Error_Msg_Internal (Msg : String; - Sptr : Source_Ptr; - Optr : Source_Ptr; + Span : Source_Span; + Opan : Source_Span; Msg_Cont : Boolean; Node : Node_Id); -- This is the low level routine used to post messages after dealing with @@ -126,6 +130,11 @@ package body Errout is -- or if it refers to an Etype that has an error posted on it, or if -- it references an Entity that has an error posted on it. + procedure Output_JSON_Message (Error_Id : Error_Msg_Id); + -- Output error message Error_Id and any subsequent continuation message + -- using a JSON format similar to the one GCC uses when passed + -- -fdiagnostics-format=json. + procedure Output_Source_Line (L : Physical_Line_Number; Sfile : Source_File_Index; @@ -218,7 +227,7 @@ package body Errout is Err_Id : Error_Msg_Id := Error_Id; begin - Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr); + Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr.Ptr); Errors.Table (Error_Id).Text := new String'(Msg_Buffer (1 .. Msglen)); -- If in immediate error message mode, output modified error message now @@ -300,14 +309,19 @@ package body Errout is --------------- -- Error_Msg posts a flag at the given location, except that if the - -- Flag_Location points within a generic template and corresponds to an - -- instantiation of this generic template, then the actual message will be - -- posted on the generic instantiation, along with additional messages - -- referencing the generic declaration. + -- Flag_Location/Flag_Span points within a generic template and corresponds + -- to an instantiation of this generic template, then the actual message + -- will be posted on the generic instantiation, along with additional + -- messages referencing the generic declaration. procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is begin - Error_Msg (Msg, Flag_Location, Current_Node); + Error_Msg (Msg, To_Span (Flag_Location), Current_Node); + end Error_Msg; + + procedure Error_Msg (Msg : String; Flag_Span : Source_Span) is + begin + Error_Msg (Msg, Flag_Span, Current_Node); end Error_Msg; procedure Error_Msg @@ -318,7 +332,7 @@ package body Errout is Save_Is_Compile_Time_Msg : constant Boolean := Is_Compile_Time_Msg; begin Is_Compile_Time_Msg := Is_Compile_Time_Pragma; - Error_Msg (Msg, Flag_Location, Current_Node); + Error_Msg (Msg, To_Span (Flag_Location), Current_Node); Is_Compile_Time_Msg := Save_Is_Compile_Time_Msg; end Error_Msg; @@ -327,6 +341,17 @@ package body Errout is Flag_Location : Source_Ptr; N : Node_Id) is + begin + Error_Msg (Msg, To_Span (Flag_Location), N); + end Error_Msg; + + procedure Error_Msg + (Msg : String; + Flag_Span : Source_Span; + N : Node_Id) + is + Flag_Location : constant Source_Ptr := Flag_Span.Ptr; + Sindex : Source_File_Index; -- Source index for flag location @@ -429,7 +454,7 @@ package body Errout is -- Error_Msg_Internal to place the message in the requested location. if Instantiation (Sindex) = No_Location then - Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False, N); + Error_Msg_Internal (Msg, Flag_Span, Flag_Span, False, N); return; end if; @@ -525,32 +550,32 @@ package body Errout is if Is_Info_Msg then Error_Msg_Internal (Msg => "info: in inlined body #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); elsif Is_Warning_Msg then Error_Msg_Internal (Msg => Warn_Insertion & "in inlined body #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); elsif Is_Style_Msg then Error_Msg_Internal (Msg => "style: in inlined body #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); else Error_Msg_Internal (Msg => "error in inlined body #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); end if; @@ -561,32 +586,32 @@ package body Errout is if Is_Info_Msg then Error_Msg_Internal (Msg => "info: in instantiation #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); elsif Is_Warning_Msg then Error_Msg_Internal (Msg => Warn_Insertion & "in instantiation #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); elsif Is_Style_Msg then Error_Msg_Internal (Msg => "style: in instantiation #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); else Error_Msg_Internal (Msg => "instantiation error #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); end if; @@ -605,8 +630,8 @@ package body Errout is Error_Msg_Internal (Msg => Msg, - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); end; @@ -650,22 +675,22 @@ package body Errout is end Error_Msg_Ada_2012_Feature; -------------------------------- - -- Error_Msg_Ada_2020_Feature -- + -- Error_Msg_Ada_2022_Feature -- -------------------------------- - procedure Error_Msg_Ada_2020_Feature (Feature : String; Loc : Source_Ptr) is + procedure Error_Msg_Ada_2022_Feature (Feature : String; Loc : Source_Ptr) is begin - if Ada_Version < Ada_2020 then - Error_Msg (Feature & " is an Ada 2020 feature", Loc); + if Ada_Version < Ada_2022 then + Error_Msg (Feature & " is an Ada 2022 feature", Loc); if No (Ada_Version_Pragma) then - Error_Msg ("\unit must be compiled with -gnat2020 switch", Loc); + Error_Msg ("\unit must be compiled with -gnat2022 switch", Loc); else Error_Msg_Sloc := Sloc (Ada_Version_Pragma); Error_Msg ("\incompatible with Ada version set#", Loc); end if; end if; - end Error_Msg_Ada_2020_Feature; + end Error_Msg_Ada_2022_Feature; ------------------ -- Error_Msg_AP -- @@ -834,8 +859,13 @@ package body Errout is ----------------- procedure Error_Msg_F (Msg : String; N : Node_Id) is + Fst, Lst : Node_Id; begin - Error_Msg_NEL (Msg, N, N, Sloc (First_Node (N))); + First_And_Last_Nodes (N, Fst, Lst); + Error_Msg_NEL (Msg, N, N, + To_Span (Ptr => Sloc (Fst), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst))); end Error_Msg_F; ------------------ @@ -847,21 +877,42 @@ package body Errout is N : Node_Id; E : Node_Or_Entity_Id) is + Fst, Lst : Node_Id; begin - Error_Msg_NEL (Msg, N, E, Sloc (First_Node (N))); + First_And_Last_Nodes (N, Fst, Lst); + Error_Msg_NEL (Msg, N, E, + To_Span (Ptr => Sloc (Fst), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst))); end Error_Msg_FE; + ------------------------------ + -- Error_Msg_GNAT_Extension -- + ------------------------------ + + procedure Error_Msg_GNAT_Extension (Extension : String) is + Loc : constant Source_Ptr := Token_Ptr; + begin + if not Extensions_Allowed then + Error_Msg (Extension & " is a 'G'N'A'T specific extension", Loc); + Error_Msg ("\unit must be compiled with -gnatX switch", Loc); + end if; + end Error_Msg_GNAT_Extension; + ------------------------ -- Error_Msg_Internal -- ------------------------ procedure Error_Msg_Internal (Msg : String; - Sptr : Source_Ptr; - Optr : Source_Ptr; + Span : Source_Span; + Opan : Source_Span; Msg_Cont : Boolean; Node : Node_Id) is + Sptr : constant Source_Ptr := Span.Ptr; + Optr : constant Source_Ptr := Opan.Ptr; + Next_Msg : Error_Msg_Id; -- Pointer to next message at insertion point @@ -923,6 +974,11 @@ package body Errout is -- Start of processing for Error_Msg_Internal begin + -- Detect common mistake of prefixing or suffing the message with a + -- space character. + + pragma Assert (Msg (Msg'First) /= ' ' and then Msg (Msg'Last) /= ' '); + if Raise_Exception_On_Error /= 0 then raise Error_Msg_Exception; end if; @@ -989,7 +1045,7 @@ package body Errout is if In_Extended_Main_Source_Unit (Sptr) then null; - -- If the main unit has not been read yet. the warning must be on + -- If the main unit has not been read yet. The warning must be on -- a configuration file: gnat.adc or user-defined. This means we -- are not parsing the main unit yet, so skip following checks. @@ -1136,7 +1192,7 @@ package body Errout is ((Text => new String'(Msg_Buffer (1 .. Msglen)), Next => No_Error_Msg, Prev => No_Error_Msg, - Sptr => Sptr, + Sptr => Span, Optr => Optr, Insertion_Sloc => (if Has_Insertion_Line then Error_Msg_Sloc else No_Location), @@ -1196,9 +1252,9 @@ package body Errout is if Last_Error_Msg /= No_Error_Msg and then Errors.Table (Cur_Msg).Sfile = Errors.Table (Last_Error_Msg).Sfile - and then (Sptr > Errors.Table (Last_Error_Msg).Sptr + and then (Sptr > Errors.Table (Last_Error_Msg).Sptr.Ptr or else - (Sptr = Errors.Table (Last_Error_Msg).Sptr + (Sptr = Errors.Table (Last_Error_Msg).Sptr.Ptr and then Optr > Errors.Table (Last_Error_Msg).Optr)) then @@ -1216,8 +1272,8 @@ package body Errout is if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile then - exit when Sptr < Errors.Table (Next_Msg).Sptr - or else (Sptr = Errors.Table (Next_Msg).Sptr + exit when Sptr < Errors.Table (Next_Msg).Sptr.Ptr + or else (Sptr = Errors.Table (Next_Msg).Sptr.Ptr and then Optr < Errors.Table (Next_Msg).Optr); end if; @@ -1364,8 +1420,13 @@ package body Errout is ----------------- procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is + Fst, Lst : Node_Id; begin - Error_Msg_NEL (Msg, N, N, Sloc (N)); + First_And_Last_Nodes (N, Fst, Lst); + Error_Msg_NEL (Msg, N, N, + To_Span (Ptr => Sloc (N), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst))); end Error_Msg_N; ------------------ @@ -1377,8 +1438,13 @@ package body Errout is N : Node_Or_Entity_Id; E : Node_Or_Entity_Id) is + Fst, Lst : Node_Id; begin - Error_Msg_NEL (Msg, N, E, Sloc (N)); + First_And_Last_Nodes (N, Fst, Lst); + Error_Msg_NEL (Msg, N, E, + To_Span (Ptr => Sloc (N), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst))); end Error_Msg_NE; ------------------- @@ -1391,6 +1457,22 @@ package body Errout is E : Node_Or_Entity_Id; Flag_Location : Source_Ptr) is + Fst, Lst : Node_Id; + begin + First_And_Last_Nodes (N, Fst, Lst); + Error_Msg_NEL + (Msg, N, E, + To_Span (Ptr => Flag_Location, + First => Source_Ptr'Min (Flag_Location, First_Sloc (Fst)), + Last => Source_Ptr'Max (Flag_Location, Last_Sloc (Lst)))); + end Error_Msg_NEL; + + procedure Error_Msg_NEL + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id; + Flag_Span : Source_Span) + is begin if Special_Msg_Delete (Msg, N, E) then return; @@ -1443,7 +1525,7 @@ package body Errout is then Debug_Output (N); Error_Msg_Node_1 := E; - Error_Msg (Msg, Flag_Location, N); + Error_Msg (Msg, Flag_Span, N); else Last_Killed := True; @@ -1463,12 +1545,17 @@ package body Errout is Msg : String; N : Node_Or_Entity_Id) is + Fst, Lst : Node_Id; begin if Eflag and then In_Extended_Main_Source_Unit (N) and then Comes_From_Source (N) then - Error_Msg_NEL (Msg, N, N, Sloc (N)); + First_And_Last_Nodes (N, Fst, Lst); + Error_Msg_NEL (Msg, N, N, + To_Span (Ptr => Sloc (N), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst))); end if; end Error_Msg_NW; @@ -1563,7 +1650,7 @@ package body Errout is F := Nxt; while F /= No_Error_Msg - and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr + and then Errors.Table (F).Sptr.Ptr = Errors.Table (Cur).Sptr.Ptr loop Check_Duplicate_Message (Cur, F); F := Errors.Table (F).Next; @@ -1583,8 +1670,8 @@ package body Errout is begin if (CE.Warn and not CE.Deleted) and then - (Warning_Specifically_Suppressed (CE.Sptr, CE.Text, Tag) /= - No_String + (Warning_Specifically_Suppressed (CE.Sptr.Ptr, CE.Text, Tag) + /= No_String or else Warning_Specifically_Suppressed (CE.Optr, CE.Text, Tag) /= No_String) @@ -1630,23 +1717,40 @@ package body Errout is ---------------- function First_Node (C : Node_Id) return Node_Id is + Fst, Lst : Node_Id; + begin + First_And_Last_Nodes (C, Fst, Lst); + return Fst; + end First_Node; + + -------------------------- + -- First_And_Last_Nodes -- + -------------------------- + + procedure First_And_Last_Nodes + (C : Node_Id; + First_Node, Last_Node : out Node_Id) + is Orig : constant Node_Id := Original_Node (C); Loc : constant Source_Ptr := Sloc (Orig); Sfile : constant Source_File_Index := Get_Source_File_Index (Loc); Earliest : Node_Id; + Latest : Node_Id; Eloc : Source_Ptr; + Lloc : Source_Ptr; - function Test_Earlier (N : Node_Id) return Traverse_Result; + function Test_First_And_Last (N : Node_Id) return Traverse_Result; -- Function applied to every node in the construct - procedure Search_Tree_First is new Traverse_Proc (Test_Earlier); + procedure Search_Tree_First_And_Last is new + Traverse_Proc (Test_First_And_Last); -- Create traversal procedure - ------------------ - -- Test_Earlier -- - ------------------ + ------------------------- + -- Test_First_And_Last -- + ------------------------- - function Test_Earlier (N : Node_Id) return Traverse_Result is + function Test_First_And_Last (N : Node_Id) return Traverse_Result is Norig : constant Node_Id := Original_Node (N); Loc : constant Source_Ptr := Sloc (Norig); @@ -1670,22 +1774,63 @@ package body Errout is Eloc := Loc; end if; + -- Check for later + + if Loc > Lloc + + -- Ignore nodes with no useful location information + + and then Loc /= Standard_Location + and then Loc /= No_Location + + -- Ignore nodes from a different file. This ensures against cases + -- of strange foreign code somehow being present. We don't want + -- wild placement of messages if that happens. + + and then Get_Source_File_Index (Loc) = Sfile + then + Latest := Norig; + Lloc := Loc; + end if; + return OK_Orig; - end Test_Earlier; + end Test_First_And_Last; - -- Start of processing for First_Node + -- Start of processing for First_And_Last_Nodes begin - if Nkind (Orig) in N_Subexpr then + if Nkind (Orig) in N_Subexpr + | N_Declaration + | N_Access_To_Subprogram_Definition + | N_Generic_Instantiation + | N_Later_Decl_Item + | N_Use_Package_Clause + | N_Array_Type_Definition + | N_Renaming_Declaration + | N_Generic_Renaming_Declaration + | N_Assignment_Statement + | N_Raise_Statement + | N_Simple_Return_Statement + | N_Exit_Statement + | N_Pragma + | N_Use_Type_Clause + | N_With_Clause + | N_Attribute_Definition_Clause + | N_Subtype_Indication + then Earliest := Orig; Eloc := Loc; - Search_Tree_First (Orig); - return Earliest; + Latest := Orig; + Lloc := Loc; + Search_Tree_First_And_Last (Orig); + First_Node := Earliest; + Last_Node := Latest; else - return Orig; + First_Node := Orig; + Last_Node := Orig; end if; - end First_Node; + end First_And_Last_Nodes; ---------------- -- First_Sloc -- @@ -1694,6 +1839,7 @@ package body Errout is function First_Sloc (N : Node_Id) return Source_Ptr is SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N)); SF : constant Source_Ptr := Source_First (SI); + SL : constant Source_Ptr := Source_Last (SI); F : Node_Id; S : Source_Ptr; @@ -1701,6 +1847,10 @@ package body Errout is F := First_Node (N); S := Sloc (F); + if S not in SF .. SL then + return S; + end if; + -- The following circuit is a bit subtle. When we have parenthesized -- expressions, then the Sloc will not record the location of the paren, -- but we would like to post the flag on the paren. So what we do is to @@ -1786,6 +1936,88 @@ package body Errout is -- True if S starts with Size_For end Is_Size_Too_Small_Message; + --------------- + -- Last_Node -- + --------------- + + function Last_Node (C : Node_Id) return Node_Id is + Fst, Lst : Node_Id; + begin + First_And_Last_Nodes (C, Fst, Lst); + return Lst; + end Last_Node; + + --------------- + -- Last_Sloc -- + --------------- + + function Last_Sloc (N : Node_Id) return Source_Ptr is + SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N)); + SF : constant Source_Ptr := Source_First (SI); + SL : constant Source_Ptr := Source_Last (SI); + F : Node_Id; + S : Source_Ptr; + + begin + F := Last_Node (N); + S := Sloc (F); + + if S not in SF .. SL then + return S; + end if; + + -- Skip past an identifier + + while S in SF .. SL - 1 + and then Source_Text (SI) (S + 1) + in + '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '.' | '_' + loop + S := S + 1; + end loop; + + -- The following circuit attempts at crawling up the tree from the + -- Last_Node, adjusting the Sloc value for any parentheses we know + -- are present, similarly to what is done in First_Sloc. + + Node_Loop : loop + Paren_Loop : for J in 1 .. Paren_Count (F) loop + + -- We don't look more than 12 characters after the current + -- location + + Search_Loop : for K in 1 .. 12 loop + exit Node_Loop when S = SL; + + if Source_Text (SI) (S + 1) = ')' then + S := S + 1; + exit Search_Loop; + + elsif Source_Text (SI) (S + 1) <= ' ' then + S := S + 1; + + else + exit Search_Loop; + end if; + end loop Search_Loop; + end loop Paren_Loop; + + exit Node_Loop when F = N; + F := Parent (F); + exit Node_Loop when Nkind (F) not in N_Subexpr; + end loop Node_Loop; + + -- Remove any trailing space + + while S in SF + 1 .. SL + and then Source_Text (SI) (S) = ' ' + loop + S := S - 1; + end loop; + + return S; + end Last_Sloc; + ----------------- -- No_Warnings -- ----------------- @@ -1841,6 +2073,158 @@ package body Errout is end if; end OK_Node; + ------------------------- + -- Output_JSON_Message -- + ------------------------- + + procedure Output_JSON_Message (Error_Id : Error_Msg_Id) is + + function Is_Continuation (E : Error_Msg_Id) return Boolean; + -- Return True if E is a continuation message. + + procedure Write_JSON_Escaped_String (Str : String_Ptr); + -- Write each character of Str, taking care of preceding each quote and + -- backslash with a backslash. Note that this escaping differs from what + -- GCC does. + -- + -- Indeed, the JSON specification mandates encoding wide characters + -- either as their direct UTF-8 representation or as their escaped + -- UTF-16 surrogate pairs representation. GCC seems to prefer escaping - + -- we choose to use the UTF-8 representation instead. + + procedure Write_JSON_Location (Sptr : Source_Ptr); + -- Write Sptr as a JSON location, an object containing a file attribute, + -- a line number and a column number. + + procedure Write_JSON_Span (Span : Source_Span); + -- Write Span as a JSON span, an object containing a "caret" attribute + -- whose value is the JSON location of Span.Ptr. If Span.First and + -- Span.Last are different from Span.Ptr, they will be printed as JSON + -- locations under the names "start" and "finish". + + ----------------------- + -- Is_Continuation -- + ----------------------- + + function Is_Continuation (E : Error_Msg_Id) return Boolean is + begin + return E <= Last_Error_Msg and then Errors.Table (E).Msg_Cont; + end Is_Continuation; + + ------------------------------- + -- Write_JSON_Escaped_String -- + ------------------------------- + + procedure Write_JSON_Escaped_String (Str : String_Ptr) is + begin + for C of Str.all loop + if C = '"' or else C = '\' then + Write_Char ('\'); + end if; + + Write_Char (C); + end loop; + end Write_JSON_Escaped_String; + + ------------------------- + -- Write_JSON_Location -- + ------------------------- + + procedure Write_JSON_Location (Sptr : Source_Ptr) is + begin + Write_Str ("{""file"":"""); + Write_Name (Full_Ref_Name (Get_Source_File_Index (Sptr))); + Write_Str (""",""line"":"); + Write_Int (Pos (Get_Physical_Line_Number (Sptr))); + Write_Str (", ""column"":"); + Write_Int (Nat (Get_Column_Number (Sptr))); + Write_Str ("}"); + end Write_JSON_Location; + + --------------------- + -- Write_JSON_Span -- + --------------------- + + procedure Write_JSON_Span (Span : Source_Span) is + begin + Write_Str ("{""caret"":"); + Write_JSON_Location (Span.Ptr); + + if Span.Ptr /= Span.First then + Write_Str (",""start"":"); + Write_JSON_Location (Span.First); + end if; + + if Span.Ptr /= Span.Last then + Write_Str (",""finish"":"); + Write_JSON_Location (Span.Last); + end if; + + Write_Str ("}"); + end Write_JSON_Span; + + -- Local Variables + + E : Error_Msg_Id := Error_Id; + + Print_Continuations : constant Boolean := not Is_Continuation (E); + -- Do not print continuations messages as children of the current + -- message if the current message is a continuation message. + + -- Start of processing for Output_JSON_Message + + begin + + -- Print message kind + + Write_Str ("{""kind"":"); + + if Errors.Table (E).Warn and then not Errors.Table (E).Warn_Err then + Write_Str ("""warning"""); + elsif Errors.Table (E).Info or else Errors.Table (E).Check then + Write_Str ("""note"""); + else + Write_Str ("""error"""); + end if; + + -- Print message location + + Write_Str (",""locations"":["); + Write_JSON_Span (Errors.Table (E).Sptr); + + if Errors.Table (E).Optr /= Errors.Table (E).Sptr.Ptr then + Write_Str (",{""caret"":"); + Write_JSON_Location (Errors.Table (E).Optr); + Write_Str ("}"); + end if; + + -- Print message content + + Write_Str ("],""message"":"""); + Write_JSON_Escaped_String (Errors.Table (E).Text); + Write_Str (""""); + + E := E + 1; + + if Print_Continuations and then Is_Continuation (E) then + + Write_Str (",""children"": ["); + Output_JSON_Message (E); + E := E + 1; + + while Is_Continuation (E) loop + Write_Str (", "); + Output_JSON_Message (E); + E := E + 1; + end loop; + + Write_Str ("]"); + + end if; + + Write_Str ("}"); + end Output_JSON_Message; + --------------------- -- Output_Messages -- --------------------- @@ -1858,13 +2242,35 @@ package body Errout is procedure Write_Max_Errors; -- Write message if max errors reached - procedure Write_Source_Code_Line (Loc : Source_Ptr); - -- Write the source code line corresponding to Loc, as follows: + procedure Write_Source_Code_Lines + (Span : Source_Span; + SGR_Span : String); + -- Write the source code line corresponding to Span, as follows when + -- Span in on one line: + -- + -- line | actual code line here with Span somewhere + -- | ~~~~~^~~~ + -- + -- where the caret on the line points to location Span.Ptr, and the + -- range Span.First..Span.Last is underlined. + -- + -- or when the span is over multiple lines: + -- + -- line | beginning of the Span on this line + -- ... | ... + -- line>| actual code line here with Span.Ptr somewhere + -- ... | ... + -- line | end of the Span on this line -- - -- line | actual code line here with Loc somewhere + -- or when the span is a simple location, as follows: + -- + -- line | actual code line here with Span somewhere -- | ^ here -- - -- where the carret on the last line points to location Loc. + -- where the caret on the line points to location Span.Ptr + -- + -- SGR_Span is the SGR string to start the section of code in the span, + -- that should be closed with SGR_Reset. ------------------------- -- Write_Error_Summary -- @@ -2056,17 +2462,89 @@ package body Errout is end if; end Write_Max_Errors; - ---------------------------- - -- Write_Source_Code_Line -- - ---------------------------- + ----------------------------- + -- Write_Source_Code_Lines -- + ----------------------------- - procedure Write_Source_Code_Line (Loc : Source_Ptr) is + procedure Write_Source_Code_Lines + (Span : Source_Span; + SGR_Span : String) + is + function Get_Line_End + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) return Source_Ptr; + -- Get the source location for the end of the line in Buf for Loc + + function Get_Line_Start + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) return Source_Ptr; + -- Get the source location for the start of the line in Buf for Loc function Image (X : Positive; Width : Positive) return String; -- Output number X over Width characters, with whitespace padding. -- Only output the low-order Width digits of X, if X is larger than -- Width digits. + procedure Write_Buffer + (Buf : Source_Buffer_Ptr; + First : Source_Ptr; + Last : Source_Ptr); + -- Output the characters from First to Last position in Buf, using + -- Write_Buffer_Char. + + procedure Write_Buffer_Char + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr); + -- Output the characters at position Loc in Buf, translating ASCII.HT + -- in a suitable number of spaces so that the output is not modified + -- by starting in a different column that 1. + + procedure Write_Line_Marker + (Num : Pos; + Mark : Boolean; + Width : Positive); + -- Output the line number Num over Width characters, with possibly + -- a Mark to denote the line with the main location when reporting + -- a span over multiple lines. + + ------------------ + -- Get_Line_End -- + ------------------ + + function Get_Line_End + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) return Source_Ptr + is + Cur_Loc : Source_Ptr := Loc; + begin + while Cur_Loc <= Buf'Last + and then Buf (Cur_Loc) /= ASCII.LF + loop + Cur_Loc := Cur_Loc + 1; + end loop; + + return Cur_Loc; + end Get_Line_End; + + -------------------- + -- Get_Line_Start -- + -------------------- + + function Get_Line_Start + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) return Source_Ptr + is + Cur_Loc : Source_Ptr := Loc; + begin + while Cur_Loc > Buf'First + and then Buf (Cur_Loc - 1) /= ASCII.LF + loop + Cur_Loc := Cur_Loc - 1; + end loop; + + return Cur_Loc; + end Get_Line_Start; + ----------- -- Image -- ----------- @@ -2087,45 +2565,200 @@ package body Errout is return Str; end Image; + ------------------ + -- Write_Buffer -- + ------------------ + + procedure Write_Buffer + (Buf : Source_Buffer_Ptr; + First : Source_Ptr; + Last : Source_Ptr) + is + begin + for Loc in First .. Last loop + Write_Buffer_Char (Buf, Loc); + end loop; + end Write_Buffer; + + ----------------------- + -- Write_Buffer_Char -- + ----------------------- + + procedure Write_Buffer_Char + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) + is + begin + -- If the character ASCII.HT is not the last one in the file, + -- output as many spaces as the character represents in the + -- original source file. + + if Buf (Loc) = ASCII.HT + and then Loc < Buf'Last + then + for X in Get_Column_Number (Loc) .. + Get_Column_Number (Loc + 1) - 1 + loop + Write_Char (' '); + end loop; + + -- Otherwise output the character itself + + else + Write_Char (Buf (Loc)); + end if; + end Write_Buffer_Char; + + ----------------------- + -- Write_Line_Marker -- + ----------------------- + + procedure Write_Line_Marker + (Num : Pos; + Mark : Boolean; + Width : Positive) + is + begin + Write_Str (Image (Positive (Num), Width => Width)); + Write_Str ((if Mark then ">" else " ") & "|"); + end Write_Line_Marker; + -- Local variables - Line : constant Pos := Pos (Get_Physical_Line_Number (Loc)); - Col : constant Natural := Natural (Get_Column_Number (Loc)); - Width : constant := 5; + Loc : constant Source_Ptr := Span.Ptr; + Line : constant Pos := Pos (Get_Physical_Line_Number (Loc)); + + Col : constant Natural := Natural (Get_Column_Number (Loc)); - Buf : Source_Buffer_Ptr; - Cur_Loc : Source_Ptr := Loc; + Fst : constant Source_Ptr := Span.First; + Line_Fst : constant Pos := + Pos (Get_Physical_Line_Number (Fst)); + Col_Fst : constant Natural := + Natural (Get_Column_Number (Fst)); + Lst : constant Source_Ptr := Span.Last; + Line_Lst : constant Pos := + Pos (Get_Physical_Line_Number (Lst)); + Col_Lst : constant Natural := + Natural (Get_Column_Number (Lst)); - -- Start of processing for Write_Source_Code_Line + Width : constant := 5; + Buf : Source_Buffer_Ptr; + Cur_Loc : Source_Ptr := Fst; + Cur_Line : Pos := Line_Fst; + + -- Start of processing for Write_Source_Code_Lines begin if Loc >= First_Source_Ptr then Buf := Source_Text (Get_Source_File_Index (Loc)); - -- First line with the actual source code line + -- First line of the span with actual source code. We retrieve + -- the beginning of the line instead of relying on Col_Fst, as + -- ASCII.HT characters change column numbers by possibly more + -- than one. - Write_Str (Image (Positive (Line), Width => Width)); - Write_Str (" |"); - Write_Str (String (Buf (Loc - Source_Ptr (Col) + 1 .. Loc - 1))); + Write_Line_Marker + (Cur_Line, + Line_Fst /= Line_Lst and then Cur_Line = Line, + Width); + Write_Buffer (Buf, Get_Line_Start (Buf, Cur_Loc), Cur_Loc - 1); - while Cur_Loc <= Buf'Last - and then Buf (Cur_Loc) /= ASCII.LF - loop - Write_Char (Buf (Cur_Loc)); - Cur_Loc := Cur_Loc + 1; - end loop; + -- Output the first/caret/last lines of the span, as well as + -- lines that are directly above/below the caret if they complete + -- the gap with first/last lines, otherwise use ... to denote + -- intermediate lines. - Write_Eol; + -- If the span is on one line and not a simple source location, + -- color it appropriately. - -- Second line with carret sign pointing to location Loc + if Line_Fst = Line_Lst + and then Col_Fst /= Col_Lst + then + Write_Str (SGR_Span); + end if; - Write_Str (String'(1 .. Width => ' ')); - Write_Str (" |"); - Write_Str (String'(1 .. Col - 1 => ' ')); - Write_Str ("^ here"); - Write_Eol; + declare + function Do_Write_Line (Cur_Line : Pos) return Boolean is + (Cur_Line in Line_Fst | Line | Line_Lst + or else + (Cur_Line = Line_Fst + 1 and then Cur_Line = Line - 1) + or else + (Cur_Line = Line + 1 and then Cur_Line = Line_Lst - 1)); + begin + while Cur_Loc <= Buf'Last + and then Cur_Loc <= Lst + loop + if Do_Write_Line (Cur_Line) then + Write_Buffer_Char (Buf, Cur_Loc); + end if; + + Cur_Loc := Cur_Loc + 1; + + if Buf (Cur_Loc - 1) = ASCII.LF then + Cur_Line := Cur_Line + 1; + + -- Output ... for skipped lines + + if (Cur_Line = Line + and then not Do_Write_Line (Cur_Line - 1)) + or else + (Cur_Line = Line + 1 + and then not Do_Write_Line (Cur_Line)) + then + Write_Str ((1 .. Width - 3 => ' ') & "... | ..."); + Write_Eol; + end if; + + -- Display the line marker if the line should be + -- displayed. + + if Do_Write_Line (Cur_Line) then + Write_Line_Marker + (Cur_Line, + Line_Fst /= Line_Lst and then Cur_Line = Line, + Width); + end if; + end if; + end loop; + end; + + if Line_Fst = Line_Lst + and then Col_Fst /= Col_Lst + then + Write_Str (SGR_Reset); + end if; + + -- Output the rest of the last line of the span + + Write_Buffer (Buf, Cur_Loc, Get_Line_End (Buf, Cur_Loc)); + + -- If the span is on one line, output a second line with caret + -- sign pointing to location Loc + + if Line_Fst = Line_Lst then + Write_Str (String'(1 .. Width => ' ')); + Write_Str (" |"); + Write_Str (String'(1 .. Col_Fst - 1 => ' ')); + + Write_Str (SGR_Span); + + Write_Str (String'(Col_Fst .. Col - 1 => '~')); + Write_Str ("^"); + Write_Str (String'(Col + 1 .. Col_Lst => '~')); + + -- If the span is really just a location, add the word "here" + -- to clarify this is the location for the message. + + if Col_Fst = Col_Lst then + Write_Str (" here"); + end if; + + Write_Str (SGR_Reset); + + Write_Eol; + end if; end if; - end Write_Source_Code_Line; + end Write_Source_Code_Lines; -- Local variables @@ -2152,9 +2785,46 @@ package body Errout is Current_Error_Source_File := No_Source_File; end if; + if Opt.JSON_Output then + Set_Standard_Error; + + E := First_Error_Msg; + + -- Find first printable message + + while E /= No_Error_Msg and then Errors.Table (E).Deleted loop + E := Errors.Table (E).Next; + end loop; + + Write_Char ('['); + + if E /= No_Error_Msg then + + Output_JSON_Message (E); + + E := Errors.Table (E).Next; + + -- Skip deleted messages. + -- Also skip continuation messages, as they have already been + -- printed along the message they're attached to. + + while E /= No_Error_Msg + and then not Errors.Table (E).Deleted + and then not Errors.Table (E).Msg_Cont + loop + Write_Char (','); + Output_JSON_Message (E); + E := Errors.Table (E).Next; + end loop; + end if; + + Write_Char (']'); + + Set_Standard_Output; + -- Brief Error mode - if Brief_Output or (not Full_List and not Verbose_Mode) then + elsif Brief_Output or (not Full_List and not Verbose_Mode) then Set_Standard_Error; E := First_Error_Msg; @@ -2180,6 +2850,8 @@ package body Errout is end if; if Use_Prefix then + Write_Str (SGR_Locus); + if Full_Path_Name_For_Brief_Errors then Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); else @@ -2198,6 +2870,8 @@ package body Errout is Write_Int (Int (Errors.Table (E).Col)); Write_Str (": "); + + Write_Str (SGR_Reset); end if; Output_Msg_Text (E); @@ -2217,12 +2891,23 @@ package body Errout is Errors.Table (E).Insertion_Sloc; begin if Loc /= No_Location then - Write_Source_Code_Line (Loc); + Write_Source_Code_Lines + (To_Span (Loc), SGR_Span => SGR_Note); end if; end; else - Write_Source_Code_Line (Errors.Table (E).Sptr); + declare + SGR_Span : constant String := + (if Errors.Table (E).Info then SGR_Note + elsif Errors.Table (E).Warn + and then not Errors.Table (E).Warn_Err + then SGR_Warning + else SGR_Error); + begin + Write_Source_Code_Lines + (Errors.Table (E).Sptr, SGR_Span); + end; end if; end if; end if; @@ -2355,11 +3040,12 @@ package body Errout is -- subunits for a body). while E /= No_Error_Msg - and then (not In_Extended_Main_Source_Unit (Errors.Table (E).Sptr) + and then (not In_Extended_Main_Source_Unit + (Errors.Table (E).Sptr.Ptr) or else (Debug_Flag_Dot_M and then Get_Source_Unit - (Errors.Table (E).Sptr) /= Main_Unit)) + (Errors.Table (E).Sptr.Ptr) /= Main_Unit)) loop if Errors.Table (E).Deleted then E := Errors.Table (E).Next; @@ -2420,7 +3106,9 @@ package body Errout is Write_Error_Summary; end if; - Write_Max_Errors; + if not Opt.JSON_Output then + Write_Max_Errors; + end if; -- Even though Warning_Info_Messages are a subclass of warnings, they -- must not be treated as errors when -gnatwe is in effect. @@ -2739,7 +3427,7 @@ package body Errout is -- For standard locations, always use mixed case if Loc <= No_Location then - Set_Casing (Mixed_Case); + Set_Casing (Buf, Mixed_Case); else -- Determine if the reference we are dealing with corresponds to @@ -2777,11 +3465,6 @@ package body Errout is end; end Adjust_Name_Case; - procedure Adjust_Name_Case (Loc : Source_Ptr) is - begin - Adjust_Name_Case (Global_Name_Buffer, Loc); - end Adjust_Name_Case; - --------------------------- -- Set_Identifier_Casing -- --------------------------- @@ -3535,7 +4218,8 @@ package body Errout is -- other errors. The reason we eliminate unfrozen types is that -- messages issued before the freeze type are for sure OK. - elsif Is_Frozen (E) + elsif Nkind (N) in N_Entity + and then Is_Frozen (E) and then Serious_Errors_Detected > 0 and then Nkind (N) /= N_Component_Clause and then Nkind (Parent (N)) /= N_Component_Clause |