diff options
Diffstat (limited to 'gcc/ada')
-rw-r--r-- | gcc/ada/errout.adb | 466 | ||||
-rw-r--r-- | gcc/ada/errout.ads | 38 | ||||
-rw-r--r-- | gcc/ada/erroutc.adb | 16 | ||||
-rw-r--r-- | gcc/ada/erroutc.ads | 2 | ||||
-rw-r--r-- | gcc/ada/errutil.adb | 4 | ||||
-rw-r--r-- | gcc/ada/freeze.adb | 4 | ||||
-rw-r--r-- | gcc/ada/par-ch3.adb | 4 | ||||
-rw-r--r-- | gcc/ada/par-prag.adb | 40 | ||||
-rw-r--r-- | gcc/ada/par-util.adb | 2 | ||||
-rw-r--r-- | gcc/ada/sem_case.adb | 10 | ||||
-rw-r--r-- | gcc/ada/sem_ch13.adb | 17 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 5 | ||||
-rw-r--r-- | gcc/ada/sem_prag.adb | 17 | ||||
-rw-r--r-- | gcc/ada/types.ads | 10 |
14 files changed, 479 insertions, 156 deletions
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index cc291c6..97fd9d4 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -98,8 +98,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 @@ -218,7 +218,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 +300,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 +323,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 +332,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 +445,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 +541,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 +577,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 +621,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; @@ -834,8 +850,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,8 +868,13 @@ 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; ------------------------ @@ -857,11 +883,14 @@ 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) 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 @@ -1136,7 +1165,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 +1225,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 +1245,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 +1393,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 +1411,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; ------------------- @@ -1392,6 +1431,16 @@ package body Errout is Flag_Location : Source_Ptr) is begin + Error_Msg_NEL (Msg, N, E, To_Span (Flag_Location)); + 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; end if; @@ -1443,7 +1492,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 +1512,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 +1617,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 +1637,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 +1684,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 +1741,61 @@ 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_Subprogram_Declaration + | 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 + 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 +1804,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 +1812,14 @@ package body Errout is F := First_Node (N); S := Sloc (F); + -- ??? Protect against inconsistency in locations, by returning S + -- immediately if not in the expected range, rather than failing with + -- a Constraint_Error when accessing Source_Text(SI)(S) + + 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 +1905,92 @@ 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); + + -- ??? Protect against inconsistency in locations, by returning S + -- immediately if not in the expected range, rather than failing with + -- a Constraint_Error when accessing Source_Text(SI)(S) + + 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 -- ----------------- @@ -1858,13 +2063,30 @@ 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); + -- 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 + -- + -- or when the span is a simple location, as follows: -- - -- line | actual code line here with Loc somewhere + -- 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 ------------------------- -- Write_Error_Summary -- @@ -2056,17 +2278,25 @@ 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) is 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_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. + ----------- -- Image -- ----------- @@ -2087,26 +2317,76 @@ package body Errout is return Str; end Image; + ----------------------- + -- 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)); - Buf : Source_Buffer_Ptr; - Cur_Loc : Source_Ptr := Loc; + Col : constant Natural := Natural (Get_Column_Number (Loc)); - -- Start of processing for Write_Source_Code_Line + 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)); + + 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 - 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_Str + (String (Buf (Fst - Source_Ptr (Col_Fst) + 1 .. Fst - 1))); + + -- Output all the lines in the span + + while Cur_Loc <= Buf'Last + and then Cur_Loc < Lst + loop + Write_Char (Buf (Cur_Loc)); + Cur_Loc := Cur_Loc + 1; + + if Buf (Cur_Loc - 1) = ASCII.LF then + Cur_Line := Cur_Line + 1; + Write_Line_Marker + (Cur_Line, + Line_Fst /= Line_Lst and then Cur_Line = Line, + Width); + end if; + end loop; + + -- Output the rest of the last line of the span while Cur_Loc <= Buf'Last and then Buf (Cur_Loc) /= ASCII.LF @@ -2117,15 +2397,28 @@ package body Errout is Write_Eol; - -- Second line with carret sign pointing to location Loc + -- If the span is on one line, output a second line with caret + -- sign pointing to location Loc - Write_Str (String'(1 .. Width => ' ')); - Write_Str (" |"); - Write_Str (String'(1 .. Col - 1 => ' ')); - Write_Str ("^ here"); - Write_Eol; + if Line_Fst = Line_Lst then + Write_Str (String'(1 .. Width => ' ')); + Write_Str (" |"); + Write_Str (String'(1 .. Col_Fst - 1 => ' ')); + 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_Eol; + end if; end if; - end Write_Source_Code_Line; + end Write_Source_Code_Lines; -- Local variables @@ -2217,12 +2510,12 @@ 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)); end if; end; else - Write_Source_Code_Line (Errors.Table (E).Sptr); + Write_Source_Code_Lines (Errors.Table (E).Sptr); end if; end if; end if; @@ -2355,11 +2648,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; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 02cfdee..f9a8379 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -703,10 +703,15 @@ package Errout is procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr); procedure Error_Msg + (Msg : String; Flag_Span : Source_Span); + procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr; N : Node_Id); + procedure Error_Msg + (Msg : String; Flag_Span : Source_Span; N : Node_Id); -- Output a message at specified location. Can be called from the parser -- or the semantic analyzer. If N is set, points to the relevant node for - -- this message. + -- this message. The version with a span is preferred whenever possible, + -- in other cases the version with a location can still be used. procedure Error_Msg (Msg : String; @@ -782,8 +787,13 @@ package Errout is N : Node_Or_Entity_Id; E : Node_Or_Entity_Id; Flag_Location : Source_Ptr); + procedure Error_Msg_NEL + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id; + Flag_Span : Source_Span); -- Exactly the same as Error_Msg_NE, except that the flag is placed at - -- the specified Flag_Location instead of at Sloc (N). + -- the specified Flag_Location/Flag_Span instead of at Sloc (N). procedure Error_Msg_NW (Eflag : Boolean; @@ -801,12 +811,17 @@ package Errout is -- the given text. This text may contain insertion characters in the -- usual manner, and need not be the same length as the original text. + procedure First_And_Last_Nodes + (C : Node_Id; + First_Node, Last_Node : out Node_Id); + -- Given a construct C, finds the first and last node in the construct, + -- i.e. the ones with the lowest and highest Sloc value. This is useful in + -- placing error msgs. Note that this procedure uses Original_Node to look + -- at the original source tree, since that's what we want for placing an + -- error message flag in the right place. + function First_Node (C : Node_Id) return Node_Id; - -- Given a construct C, finds the first node in the construct, i.e. the one - -- with the lowest Sloc value. This is useful in placing error msgs. Note - -- that this procedure uses Original_Node to look at the original source - -- tree, since that's what we want for placing an error message flag in - -- the right place. + -- Return the first output of First_And_Last_Nodes function First_Sloc (N : Node_Id) return Source_Ptr; -- Given the node for an expression, return a source pointer value that @@ -817,6 +832,15 @@ package Errout is function Get_Ignore_Errors return Boolean; -- Return True if all error calls are ignored. + function Last_Node (C : Node_Id) return Node_Id; + -- Return the last output of First_And_Last_Nodes + + function Last_Sloc (N : Node_Id) return Source_Ptr; + -- Given the node for an expression, return a source pointer value that + -- points to the end of the last token in the expression. In the case + -- where the expression is parenthesized, an attempt is made to include + -- the parentheses (i.e. to return the location of the final paren). + procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) renames Erroutc.Purge_Messages; -- All error messages whose location is in the range From .. To (not diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index d0cc6ff..d7ca221 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -321,7 +321,7 @@ package body Erroutc is Write_Str (" Sptr = "); - Write_Location (E.Sptr); + Write_Location (E.Sptr.Ptr); -- ??? Do not write the full span for now Write_Eol; Write_Str @@ -350,7 +350,7 @@ package body Erroutc is function Get_Location (E : Error_Msg_Id) return Source_Ptr is begin - return Errors.Table (E).Sptr; + return Errors.Table (E).Sptr.Ptr; end Get_Location; ---------------- @@ -477,7 +477,7 @@ package body Erroutc is and then Errors.Table (T).Line = Errors.Table (E).Line and then Errors.Table (T).Sfile = Errors.Table (E).Sfile loop - if Errors.Table (T).Sptr > Errors.Table (E).Sptr then + if Errors.Table (T).Sptr.Ptr > Errors.Table (E).Sptr.Ptr then Mult_Flags := True; end if; @@ -490,7 +490,7 @@ package body Erroutc is if not Debug_Flag_2 then Write_Str (" "); - P := Line_Start (Errors.Table (E).Sptr); + P := Line_Start (Errors.Table (E).Sptr.Ptr); Flag_Num := 1; -- Loop through error messages for this line to place flags @@ -507,7 +507,7 @@ package body Erroutc is begin -- Loop to output blanks till current flag position - while P < Errors.Table (T).Sptr loop + while P < Errors.Table (T).Sptr.Ptr loop -- Horizontal tab case, just echo the tab @@ -536,7 +536,7 @@ package body Erroutc is -- Output flag (unless already output, this happens if more -- than one error message occurs at the same flag position). - if P = Errors.Table (T).Sptr then + if P = Errors.Table (T).Sptr.Ptr then if (Flag_Num = 1 and then not Mult_Flags) or else Flag_Num > 9 then @@ -955,8 +955,8 @@ package body Erroutc is function To_Be_Purged (E : Error_Msg_Id) return Boolean is begin if E /= No_Error_Msg - and then Errors.Table (E).Sptr > From - and then Errors.Table (E).Sptr < To + and then Errors.Table (E).Sptr.Ptr > From + and then Errors.Table (E).Sptr.Ptr < To then if Errors.Table (E).Warn or else Errors.Table (E).Style then Warnings_Detected := Warnings_Detected - 1; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 4c0e68a..eb43466 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -197,7 +197,7 @@ package Erroutc is -- refers to a template, always references the original template -- not an instantiation copy. - Sptr : Source_Ptr; + Sptr : Source_Span; -- Flag pointer. In the case of an error that refers to a template, -- always references the original template, not an instantiation copy. -- This value is the actual place in the source that the error message diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index d4821fc..0a9f6ad 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -207,7 +207,7 @@ package body Errutil is Next => No_Error_Msg, Prev => No_Error_Msg, Sfile => Get_Source_File_Index (Sptr), - Sptr => Sptr, + Sptr => To_Span (Sptr), Optr => Optr, Insertion_Sloc => No_Location, Line => Get_Physical_Line_Number (Sptr), @@ -234,7 +234,7 @@ package body Errutil is Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile; if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile then - exit when Sptr < Errors.Table (Next_Msg).Sptr; + exit when Sptr < Errors.Table (Next_Msg).Sptr.Ptr; end if; Prev_Msg := Next_Msg; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index da14af9..cbdecaa 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3644,8 +3644,8 @@ package body Freeze is and then not Freezing_Library_Level_Tagged_Type then Error_Msg_Node_1 := F_Type; - Error_Msg - ("type & must be fully defined before this point", Loc); + Error_Msg_N + ("type & must be fully defined before this point", N); end if; end if; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 78a3ebd..41aad79 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -1379,9 +1379,9 @@ package body Ch3 is procedure No_List is begin if Num_Idents > 1 then - Error_Msg + Error_Msg_N ("identifier list not allowed for RENAMES", - Sloc (Idents (2))); + Idents (2)); end if; List_OK := False; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 51409f2..d05f267 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -158,7 +158,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is procedure Check_Arg_Count (Required : Int) is begin if Arg_Count /= Required then - Error_Msg ("wrong number of arguments for pragma%", Pragma_Sloc); + Error_Msg_N ("wrong number of arguments for pragma%", Pragma_Node); raise Error_Resync; end if; end Check_Arg_Count; @@ -177,7 +177,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is Error_Msg_Name_2 := Name_On; Error_Msg_Name_3 := Name_Off; - Error_Msg ("argument for pragma% must be% or%", Sloc (Argx)); + Error_Msg_N ("argument for pragma% must be% or%", Argx); raise Error_Resync; end if; end Check_Arg_Is_On_Or_Off; @@ -189,9 +189,9 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is begin if Nkind (Expression (Arg)) /= N_String_Literal then - Error_Msg + Error_Msg_N ("argument for pragma% must be string literal", - Sloc (Expression (Arg))); + Expression (Arg)); raise Error_Resync; end if; end Check_Arg_Is_String_Literal; @@ -466,7 +466,7 @@ begin A := Expression (Arg1); if Nkind (A) /= N_Identifier then - Error_Msg ("incorrect argument for pragma %", Sloc (A)); + Error_Msg_N ("incorrect argument for pragma %", A); else Set_Name_Table_Boolean3 (Chars (A), True); end if; @@ -718,9 +718,9 @@ begin begin if Prag_Id = Pragma_Source_File_Name then if Project_File_In_Use = In_Use then - Error_Msg + Error_Msg_N ("pragma Source_File_Name cannot be used " & - "with a project file", Pragma_Sloc); + "with a project file", Pragma_Node); else Project_File_In_Use := Not_In_Use; @@ -728,9 +728,9 @@ begin else if Project_File_In_Use = Not_In_Use then - Error_Msg + Error_Msg_N ("pragma Source_File_Name_Project should only be used " & - "with a project file", Pragma_Sloc); + "with a project file", Pragma_Node); else Project_File_In_Use := In_Use; end if; @@ -773,9 +773,9 @@ begin or else Intval (Expr) > 999 or else Intval (Expr) <= 0 then - Error_Msg + Error_Msg_N ("pragma% index must be integer literal" & - " in range 1 .. 999", Sloc (Expr)); + " in range 1 .. 999", Expr); raise Error_Resync; else Index := UI_To_Int (Intval (Expr)); @@ -908,8 +908,8 @@ begin and then Num_SRef_Pragmas (Current_Source_File) = 0 and then Operating_Mode /= Check_Syntax then - Error_Msg -- CODEFIX - ("first % pragma must be first line of file", Pragma_Sloc); + Error_Msg_N -- CODEFIX + ("first % pragma must be first line of file", Pragma_Node); raise Error_Resync; end if; @@ -917,9 +917,9 @@ begin if Arg_Count = 1 then if Num_SRef_Pragmas (Current_Source_File) = 0 then - Error_Msg + Error_Msg_N ("file name required for first % pragma in file", - Pragma_Sloc); + Pragma_Node); raise Error_Resync; else Fname := No_File; @@ -934,17 +934,17 @@ begin if Num_SRef_Pragmas (Current_Source_File) > 0 then if Fname /= Full_Ref_Name (Current_Source_File) then - Error_Msg - ("file name must be same in all % pragmas", Pragma_Sloc); + Error_Msg_N + ("file name must be same in all % pragmas", Pragma_Node); raise Error_Resync; end if; end if; end if; if Nkind (Expression (Arg1)) /= N_Integer_Literal then - Error_Msg + Error_Msg_N ("argument for pragma% must be integer literal", - Sloc (Expression (Arg1))); + Expression (Arg1)); raise Error_Resync; -- OK, this source reference pragma is effective, however, we @@ -1059,7 +1059,7 @@ begin end if; if not OK then - Error_Msg ("incorrect argument for pragma%", Sloc (A)); + Error_Msg_N ("incorrect argument for pragma%", A); raise Error_Resync; end if; end if; diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index 1f26075..0571c0f 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -254,7 +254,7 @@ package body Util is then return Mark; else - Error_Msg ("subtype mark expected", Sloc (Mark)); + Error_Msg_N ("subtype mark expected", Mark); return Error; end if; end Check_Subtype_Mark; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 6cda6a9..7f35cfc 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -677,8 +677,6 @@ package body Sem_Case is -------------------- procedure Missing_Choice (Value1 : Uint; Value2 : Uint) is - Msg_Sloc : constant Source_Ptr := Sloc (Case_Node); - begin -- AI05-0188 : within an instance the non-others choices do not have -- to belong to the actual subtype. @@ -704,10 +702,10 @@ package body Sem_Case is if Value1 = Value2 then if Is_Integer_Type (Bounds_Type) then Error_Msg_Uint_1 := Value1; - Error_Msg ("missing case value: ^!", Msg_Sloc); + Error_Msg_N ("missing case value: ^!", Case_Node); else Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); - Error_Msg ("missing case value: %!", Msg_Sloc); + Error_Msg_N ("missing case value: %!", Case_Node); end if; -- More than one choice value, so print range of values @@ -716,11 +714,11 @@ package body Sem_Case is if Is_Integer_Type (Bounds_Type) then Error_Msg_Uint_1 := Value1; Error_Msg_Uint_2 := Value2; - Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc); + Error_Msg_N ("missing case values: ^ .. ^!", Case_Node); else Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type); - Error_Msg ("missing case values: % .. %!", Msg_Sloc); + Error_Msg_N ("missing case values: % .. %!", Case_Node); end if; end if; end Missing_Choice; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 4724e0e..07dec4c 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4147,8 +4147,8 @@ package body Sem_Ch13 is -- Must not be parenthesized if Paren_Count (Expr) /= 0 then - Error_Msg -- CODEFIX - ("redundant parentheses", First_Sloc (Expr)); + Error_Msg_F -- CODEFIX + ("redundant parentheses", Expr); end if; -- List of arguments is list of aggregate expressions @@ -4442,8 +4442,8 @@ package body Sem_Ch13 is -- parentheses). if Paren_Count (Expr) /= 0 then - Error_Msg -- CODEFIX - ("redundant parentheses", First_Sloc (Expr)); + Error_Msg_F -- CODEFIX + ("redundant parentheses", Expr); goto Continue; end if; @@ -4860,11 +4860,11 @@ package body Sem_Ch13 is Error_Msg_Name_1 := Aspect_Names (A_Id); Error_Msg_Sloc := Sloc (Inherited_Aspect); - Error_Msg + Error_Msg_N ("overriding aspect specification for " & "nonoverridable aspect % does not confirm " & "aspect specification inherited from #", - Sloc (Aspect)); + Aspect); end if; end; end if; @@ -7909,9 +7909,8 @@ package body Sem_Ch13 is -- Check that the expression is a proper aggregate (no parentheses) elsif Paren_Count (Aggr) /= 0 then - Error_Msg - ("extra parentheses surrounding aggregate not allowed", - First_Sloc (Aggr)); + Error_Msg_F + ("extra parentheses surrounding aggregate not allowed", Aggr); return; -- All tests passed, so set rep clause in place diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 41e1e49..4784397 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1575,9 +1575,8 @@ package body Sem_Ch3 is begin if not RTE_Available (RE_Interface_Tag) then - Error_Msg - ("(Ada 2005) interface types not supported by this run-time!", - Sloc (N)); + Error_Msg_N + ("(Ada 2005) interface types not supported by this run-time!", N); return; end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 3ef5e82..1b1e01b 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -566,8 +566,8 @@ package body Sem_Prag is -- Check that the expression is a proper aggregate (no parentheses) if Paren_Count (CCases) /= 0 then - Error_Msg -- CODEFIX - ("redundant parentheses", First_Sloc (CCases)); + Error_Msg_F -- CODEFIX + ("redundant parentheses", CCases); end if; -- Ensure that the formal parameters are visible when analyzing all @@ -15041,9 +15041,8 @@ package body Sem_Prag is else -- All other cases: diagnose error - Error_Msg - ("argument of pragma ""Debug"" is not procedure call", - Sloc (Call)); + Error_Msg_N + ("argument of pragma ""Debug"" is not procedure call", Call); return; end if; @@ -25632,9 +25631,9 @@ package body Sem_Prag is Set_Specific_Warning_On (Loc, Message, Err); if Err then - Error_Msg + Error_Msg_N ("??pragma Warnings On with no matching " - & "Warnings Off", Loc); + & "Warnings Off", N); end if; end if; end; @@ -29206,8 +29205,8 @@ package body Sem_Prag is -- Check that the expression is a proper aggregate (no parentheses) if Paren_Count (Variants) /= 0 then - Error_Msg -- CODEFIX - ("redundant parentheses", First_Sloc (Variants)); + Error_Msg_F -- CODEFIX + ("redundant parentheses", Variants); end if; -- Ensure that the formal parameters are visible when analyzing all diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 175ffb2..408d661 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -218,6 +218,16 @@ package Types is -- which source it refers to. Note that negative numbers are allowed to -- accommodate the following special values. + type Source_Span is record + Ptr, First, Last : Source_Ptr; + end record; + -- Type used to represent a source span, consisting in a main location Ptr, + -- with a First and Last location, such that Ptr in First .. Last + + function To_Span (Loc : Source_Ptr) return Source_Span is ((others => Loc)); + function To_Span (Ptr, First, Last : Source_Ptr) return Source_Span is + ((Ptr, First, Last)); + No_Location : constant Source_Ptr := -1; -- Value used to indicate no source position set in a node. A test for a -- Source_Ptr value being > No_Location is the approved way to test for a |