diff options
| -rw-r--r-- | gcc/ada/err_vars.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/erroutc.adb | 310 | ||||
| -rw-r--r-- | gcc/ada/erroutc.ads | 97 |
3 files changed, 400 insertions, 12 deletions
diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads index 66a33fa9d10..fedeb0718fd 100644 --- a/gcc/ada/err_vars.ads +++ b/gcc/ada/err_vars.ads @@ -132,4 +132,9 @@ package Err_Vars is -- Used if current message contains a < insertion character to indicate -- if the current message is a warning message. + Error_Msg_String : String (1 .. 4096); + Error_Msg_Strlen : Natural; + -- Used if current message contains a ~ insertion character to indicate + -- insertion of the string Error_Msg_String (1 .. Error_Msg_Strlen). + end Err_Vars; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 7489b294cbf..cb508f22c75 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -43,10 +43,6 @@ with Uintp; use Uintp; package body Erroutc is - ----------------------- - -- Local Subprograms -- - ----------------------- - --------------- -- Add_Class -- --------------- @@ -370,7 +366,6 @@ package body Erroutc is while T /= No_Error_Msg and then Errors.Table (T).Line = Errors.Table (E).Line and then Errors.Table (T).Sfile = Errors.Table (E).Sfile - loop Write_Str (" >>> "); Output_Msg_Text (T); @@ -437,18 +432,106 @@ package body Erroutc is --------------------- procedure Output_Msg_Text (E : Error_Msg_Id) is + Offs : constant Nat := Column - 1; + -- Offset to start of message, used for continuations + + Max : Integer; + -- Maximum characters to output on next line + + Length : Nat; + -- Maximum total length of lines + begin + if Error_Msg_Line_Length = 0 then + Length := Nat'Last; + else + Length := Error_Msg_Line_Length; + end if; + + Max := Integer (Length - Column + 1); + if Errors.Table (E).Warn then Write_Str ("warning: "); + Max := Max - 9; elsif Errors.Table (E).Style then null; elsif Opt.Unique_Error_Tag then Write_Str ("error: "); + Max := Max - 7; end if; - Write_Str (Errors.Table (E).Text.all); + -- Here we have to split the message up into multiple lines + + declare + Txt : constant String_Ptr := Errors.Table (E).Text; + Len : constant Natural := Txt'Length; + Ptr : Natural; + Split : Natural; + Start : Natural; + + begin + Ptr := 1; + loop + -- Make sure we do not have ludicrously small line + + Max := Integer'Max (Max, 20); + + -- If remaining text fits, output it respecting LF and we are done + + if Len - Ptr < Max then + for J in Ptr .. Len loop + if Txt (J) = ASCII.LF then + Write_Eol; + Write_Spaces (Offs); + else + Write_Char (Txt (J)); + end if; + end loop; + + return; + + -- Line does not fit + + else + Start := Ptr; + + -- First scan forward looing for a hard end of line + + for Scan in Ptr .. Ptr + Max - 1 loop + if Txt (Scan) = ASCII.LF then + Split := Scan - 1; + Ptr := Scan + 1; + goto Continue; + end if; + end loop; + + -- Otherwise scan backwards looking for a space + + for Scan in reverse Ptr .. Ptr + Max - 1 loop + if Txt (Scan) = ' ' then + Split := Scan - 1; + Ptr := Scan + 1; + goto Continue; + end if; + end loop; + + -- If we fall through, no space, so split line arbitrarily + + Split := Ptr + Max - 1; + Ptr := Split + 1; + end if; + + <<Continue>> + if Start <= Split then + Write_Line (Txt (Start .. Split)); + Write_Spaces (Offs); + end if; + + Max := Integer (Length - Column + 1); + end loop; + end; end Output_Msg_Text; -------------------- @@ -916,6 +999,79 @@ package body Erroutc is end if; end Set_Next_Non_Deleted_Msg; + ------------------------------ + -- Set_Specific_Warning_Off -- + ------------------------------ + + procedure Set_Specific_Warning_Off (Loc : Source_Ptr; Msg : String) is + pragma Assert (Msg'First = 1); + + Pattern : String := Msg; + Patlen : Natural := Msg'Length; + + Star_Start : Boolean; + Star_End : Boolean; + + begin + if Pattern (1) = '*' then + Star_Start := True; + Pattern (1 .. Patlen - 1) := Pattern (2 .. Patlen); + Patlen := Patlen - 1; + else + Star_Start := False; + end if; + + if Pattern (Patlen) = '*' then + Star_End := True; + Patlen := Patlen - 1; + else + Star_End := False; + end if; + + Specific_Warnings.Increment_Last; + Specific_Warnings.Table (Specific_Warnings.Last) := + (Start => Loc, + Msg => new String'(Msg), + Pattern => new String'(Pattern (1 .. Patlen)), + Patlen => Patlen, + Stop => Source_Last (Current_Source_File), + Open => True, + Used => False, + Star_Start => Star_Start, + Star_End => Star_End); + end Set_Specific_Warning_Off; + + ----------------------------- + -- Set_Specific_Warning_On -- + ----------------------------- + + procedure Set_Specific_Warning_On + (Loc : Source_Ptr; + Msg : String; + Err : out Boolean) + is + begin + for J in 1 .. Specific_Warnings.Last loop + declare + SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); + begin + if Msg = SWE.Msg.all + and then Loc > SWE.Start + and then SWE.Open + and then Get_Source_File_Index (SWE.Start) = + Get_Source_File_Index (Loc) + then + SWE.Stop := Loc; + SWE.Open := False; + Err := False; + return; + end if; + end; + end loop; + + Err := True; + end Set_Specific_Warning_On; + --------------------------- -- Set_Warnings_Mode_Off -- --------------------------- @@ -1017,12 +1173,154 @@ package body Erroutc is end if; end Test_Style_Warning_Serious_Msg; + -------------------------------- + -- Validate_Specific_Warnings -- + -------------------------------- + + procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is + begin + for J in Specific_Warnings.First .. Specific_Warnings.Last loop + declare + SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); + begin + if SWE.Start /= No_Location then + if SWE.Open then + Eproc.all + ("?pragma Warnings Off with no matching Warnings On", + SWE.Start); + elsif not SWE.Used then + Eproc.all + ("?no warning suppressed by this pragma", SWE.Start); + end if; + end if; + end; + end loop; + end Validate_Specific_Warnings; + + ------------------------------------- + -- Warning_Specifically_Suppressed -- + ------------------------------------- + + function Warning_Specifically_Suppressed + (Loc : Source_Ptr; + Msg : String_Ptr) return Boolean + is + pragma Assert (Msg'First = 1); + + Msglen : constant Natural := Msg'Length; + Patlen : Natural; + -- Length of message + + Pattern : String_Ptr; + -- Pattern itself, excluding initial and final * + + Star_Start : Boolean; + Star_End : Boolean; + -- Indications of * at start and end of original pattern + + Msgp : Natural; + Patp : Natural; + -- Scan pointers for message and pattern + + begin + -- Loop through specific warning suppression entries + + for J in Specific_Warnings.First .. Specific_Warnings.Last loop + declare + SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); + + begin + -- See if location is in range + + if SWE.Start = No_Location + or else (SWE.Start <= Loc and then Loc <= SWE.Stop) + then + Patlen := SWE.Patlen; + Pattern := SWE.Pattern; + Star_Start := SWE.Star_Start; + Star_End := SWE.Star_End; + + -- Loop through possible starting positions in Msg + + Outer : for M in 1 .. 1 + (Msglen - Patlen) loop + + -- See if pattern matches string starting at Msg (J) + + Msgp := M; + Patp := 1; + Inner : loop + + -- If pattern exhausted, then match if we are at end + -- of message, or if pattern ended with an asterisk, + -- otherwise match failure at this position. + + if Patp > Patlen then + if Msgp > Msglen or else Star_End then + SWE.Used := True; + return True; + else + exit Inner; + end if; + + -- Otherwise if message exhausted (and we still have + -- pattern characters left), then match failure here. + + elsif Msgp > Msglen then + exit Inner; + end if; + + -- Here we have pattern and message characters left + + -- Handle "*" pattern match + + if Patp < Patlen - 1 and then + Pattern (Patp .. Patp + 2) = """*""" + then + Patp := Patp + 3; + + -- Must have " and at least three chars in msg or we + -- have no match at this position. + + exit Inner when Msg (Msgp) /= '"'; + Msgp := Msgp + 1; + + -- Scan out " string " in message + + Scan : loop + exit Inner when Msgp = Msglen; + Msgp := Msgp + 1; + exit Scan when Msg (Msgp - 1) = '"'; + end loop Scan; + + -- If not "*" case, just compare character + + else + exit Inner when Pattern (Patp) /= Msg (Msgp); + Patp := Patp + 1; + Msgp := Msgp + 1; + end if; + end loop Inner; + + -- Advance to next position if star at end of original + -- pattern, otherwise no more match attempts are possible + + exit Outer when not Star_Start; + end loop Outer; + end if; + end; + end loop; + + return False; + end Warning_Specifically_Suppressed; + ------------------------- -- Warnings_Suppressed -- ------------------------- function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is begin + -- Loop through table of ON/OFF warnings + for J in Warnings.First .. Warnings.Last loop if Warnings.Table (J).Start <= Loc and then Loc <= Warnings.Table (J).Stop diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 8ad6d51c3ec..51934df9547 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -41,6 +41,10 @@ package Erroutc is -- Msg_Cont parameter in Error_Msg_Internal and then set True if a \ -- insertion character is encountered. + Continuation_New_Line : Boolean := False; + -- Indicates if current message was a continuation line marked with \\ to + -- force a new line. Set True if \\ encountered. + Flag_Source : Source_File_Index; -- Source file index for source file where error is being posted @@ -140,7 +144,8 @@ package Erroutc is -- Text of error message, fully expanded with all insertions Next : Error_Msg_Id; - -- Pointer to next message in error chain + -- Pointer to next message in error chain. A value of No_Error_Msg + -- indicates the end of the chain. Sfile : Source_File_Index; -- Source table index of source file. In the case of an error that @@ -218,9 +223,12 @@ package Erroutc is -------------------------- -- Pragma Warnings allows warnings to be turned off for a specified - -- region of code, and the following tabl is the data structure used + -- region of code, and the following tables are the data structure used -- to keep track of these regions. + -- The first table is used for the basic command line control, and for + -- the forms of Warning with a single ON or OFF parameter + -- It contains pairs of source locations, the first being the start -- location for a warnings off region, and the second being the end -- location. When a pragma Warnings (Off) is encountered, a new entry @@ -247,6 +255,49 @@ package Erroutc is Table_Increment => 200, Table_Name => "Warnings"); + -- The second table is used for the specific forms of the pragma, where + -- the first argument is ON or OFF, and the second parameter is a string + -- which is the entire message to suppress, or a prefix of it. + + type Specific_Warning_Entry is record + Start : Source_Ptr; + Stop : Source_Ptr; + -- Starting and ending source pointers for the range. These are always + -- from the same source file. Start is set to No_Location for the case + -- of a configuration pragma. + + Msg : String_Ptr; + -- Message from pragma Warnings (Off, string) + + Pattern : String_Ptr; + -- Same as Msg, excluding initial and final asterisks if present. The + -- lower bound of this string is always one. + + Patlen : Natural; + -- Length of pattern string (excluding initial/final asterisks) + + Open : Boolean; + -- Set to True if OFF has been encountered with no matchin ON + + Used : Boolean; + -- Set to True if entry has been used to suppress a warning + + Star_Start : Boolean; + -- True if given pattern had * at start + + Star_End : Boolean; + -- True if given pattern had * at end + + end record; + + package Specific_Warnings is new Table.Table ( + Table_Component_Type => Specific_Warning_Entry, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "Specific_Warnings"); + ----------------- -- Subprograms -- ----------------- @@ -292,9 +343,11 @@ package Erroutc is -- as all blanks, avoiding output of junk line numbers. procedure Output_Msg_Text (E : Error_Msg_Id); - -- Outputs characters of text in the text of the error message E, excluding - -- any final exclamation point. Note that no end of line is output, the - -- caller is responsible for adding the end of line. + -- Outputs characters of text in the text of the error message E. Note that + -- no end of line is output, the caller is responsible for adding the end + -- of line. If Error_Msg_Line_Length is non-zero, this is the routine that + -- splits the line generating multiple lines of output, and in this case + -- the last line has no terminating end of line character. procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr); -- All error messages whose location is in the range From .. To (not @@ -375,6 +428,24 @@ package Erroutc is -- the input value of E was either already No_Error_Msg, or was the -- last non-deleted message. + procedure Set_Specific_Warning_Off (Loc : Source_Ptr; Msg : String); + -- This is called in response to the two argument form of pragma Warnings + -- where the first argument is OFF, and the second argument is the prefix + -- of a specific warning to be suppressed. The first argument is the start + -- of the suppression range, and the second argument is the string from + -- the pragma. Loc is set to No_Location for the configuration pragma case. + + procedure Set_Specific_Warning_On + (Loc : Source_Ptr; + Msg : String; + Err : out Boolean); + -- This is called in response to the two argument form of pragma Warnings + -- where the first argument is ON, and the second argument is the prefix + -- of a specific warning to be suppressed. The first argument is the end + -- of the suppression range, and the second argument is the string from + -- the pragma. Err is set to True on return to report the error of no + -- matching Warnings Off pragma preceding this one. + procedure Set_Warnings_Mode_Off (Loc : Source_Ptr); -- Called in response to a pragma Warnings (Off) to record the source -- location from which warnings are to be turned off. @@ -395,6 +466,20 @@ package Erroutc is function Warnings_Suppressed (Loc : Source_Ptr) return Boolean; -- Determines if given location is covered by a warnings off suppression -- range in the warnings table (or is suppressed by compilation option, - -- which generates a warning range for the whole source file). + -- which generates a warning range for the whole source file). This routine + -- only deals with the general ON/OFF case, not specific warnings + + function Warning_Specifically_Suppressed + (Loc : Source_Ptr; + Msg : String_Ptr) return Boolean; + -- Determines if given message to be posted at given location is suppressed + -- by specific ON/OFF Warnings pragmas specifying this particular message. + + type Error_Msg_Proc is + access procedure (Msg : String; Flag_Location : Source_Ptr); + procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc); + -- Checks that specific warnings are consistent (for non-configuration + -- case, properly closed, and used). The argument is a pointer to the + -- Error_Msg procedure to be called if any inconsistencies are detected. end Erroutc; |