From 0c3985a955aa99d2970234e2eeb622a6aca2c94c Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Feb 2014 16:48:05 +0100 Subject: [multiple changes] 2014-02-25 Robert Dewar * sem_ch3.adb (Array_Type_Declaration): Check for case of using type name as index. * lib.ads: Minor reformatting. * einfo.ads: Minor reformatting. 2014-02-25 Doug Rupp * sem_mech.adb (Set_Mechanisms): For convention Fortran on VMS use Short_Descriptor(S) as the argument passing mechanism. 2014-02-25 Eric Botcazou * sigtramp-ppcvxw.c (CFI_COMMON_REGS): Also include r0. 2014-02-25 Robert Dewar * atree.ads (Warnings_Treated_As_Errors): New variable. * errout.adb (Error_Msg_Internal): Set Warn_Err flag in error object (Initialize): Initialize Warnings_As_Errors_Count (Write_Error_Summary): Include count of warnings treated as errors. * erroutc.adb (Warning_Treated_As_Error): New function. (Matches): Function moved to outer level of package. * erroutc.ads (Error_Msg_Object): Add Warn_Err flag. (Warning_Treated_As_Error): New function. * gnat_rm.texi: Document pragma Treat_Warning_As_Error. * opt.adb: Add handling of Warnings_As_Errors_Count[_Config]. * opt.ads (Config_Switches_Type): Add entry for Warnings_As_Errors_Count. (Warnings_As_Errors_Count): New variable. (Warnings_As_Errors): New array. * par-prag.adb: Add dummy entry for Warning_As_Error. * sem_prag.adb (Analyze_Pragma): Implement new pragma Warning_As_Error. * snames.ads-tmpl: Add entries for Warning_As_Error pragma. From-SVN: r208145 --- gcc/ada/erroutc.adb | 239 +++++++++++++++++++++++++++++----------------------- 1 file changed, 135 insertions(+), 104 deletions(-) (limited to 'gcc/ada/erroutc.adb') diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index e44d5f6..5c72532 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -45,6 +45,15 @@ with Uintp; use Uintp; package body Erroutc is + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Matches (S : String; P : String) return Boolean; + -- Returns true if the String S patches the pattern P, which can contain + -- wild card chars (*). The entire pattern must match the entire string. + -- Case is ignored in the comparison (so X matches x). + --------------- -- Add_Class -- --------------- @@ -104,13 +113,13 @@ package body Erroutc is N1, N2 : Error_Msg_Id; procedure Delete_Msg (Delete, Keep : Error_Msg_Id); - -- Called to delete message Delete, keeping message Keep. Marks - -- all messages of Delete with deleted flag set to True, and also - -- makes sure that for the error messages that are retained the - -- preferred message is the one retained (we prefer the shorter - -- one in the case where one has an Instance tag). Note that we - -- always know that Keep has at least as many continuations as - -- Delete (since we always delete the shorter sequence). + -- Called to delete message Delete, keeping message Keep. Marks all + -- messages of Delete with deleted flag set to True, and also makes sure + -- that for the error messages that are retained the preferred message + -- is the one retained (we prefer the shorter one in the case where one + -- has an Instance tag). Note that we always know that Keep has at least + -- as many continuations as Delete (since we always delete the shorter + -- sequence). ---------------- -- Delete_Msg -- @@ -219,7 +228,8 @@ package body Erroutc is begin return Total_Errors_Detected /= 0 or else (Warnings_Detected /= 0 - and then Warning_Mode = Treat_As_Error); + and then Warning_Mode = Treat_As_Error) + or else Warnings_Treated_As_Errors /= 0; end Compilation_Errors; ------------------ @@ -289,6 +299,89 @@ package body Erroutc is return Cur_Msg; end Get_Msg_Id; + --------------------- + -- Get_Warning_Tag -- + --------------------- + + function Get_Warning_Tag (Id : Error_Msg_Id) return String is + Warn : constant Boolean := Errors.Table (Id).Warn; + Warn_Chr : constant Character := Errors.Table (Id).Warn_Chr; + begin + if Warn and then Warn_Chr /= ' ' then + if Warn_Chr = '?' then + return " [enabled by default]"; + elsif Warn_Chr in 'a' .. 'z' then + return " [-gnatw" & Warn_Chr & ']'; + else pragma Assert (Warn_Chr in 'A' .. 'Z'); + return " [-gnatw." & Fold_Lower (Warn_Chr) & ']'; + end if; + else + return ""; + end if; + end Get_Warning_Tag; + + ------------- + -- Matches -- + ------------- + + function Matches (S : String; P : String) return Boolean is + Slast : constant Natural := S'Last; + PLast : constant Natural := P'Last; + + SPtr : Natural := S'First; + PPtr : Natural := P'First; + + begin + -- Loop advancing through characters of string and pattern + + SPtr := S'First; + PPtr := P'First; + loop + -- Return True if pattern is a single asterisk + + if PPtr = PLast and then P (PPtr) = '*' then + return True; + + -- Return True if both pattern and string exhausted + + elsif PPtr > PLast and then SPtr > Slast then + return True; + + -- Return False, if one exhausted and not the other + + elsif PPtr > PLast or else SPtr > Slast then + return False; + + -- Case where pattern starts with asterisk + + elsif P (PPtr) = '*' then + + -- Try all possible starting positions in S for match with the + -- remaining characters of the pattern. This is the recursive + -- call that implements the scanner backup. + + for J in SPtr .. Slast loop + if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then + return True; + end if; + end loop; + + return False; + + -- Dealt with end of string and *, advance if we have a match + + elsif Fold_Lower (S (SPtr)) = Fold_Lower (P (PPtr)) then + SPtr := SPtr + 1; + PPtr := PPtr + 1; + + -- If first characters do not match, that's decisive + + else + return False; + end if; + end loop; + end Matches; + ----------------------- -- Output_Error_Msgs -- ----------------------- @@ -455,32 +548,12 @@ package body Erroutc is Length : Nat; -- Maximum total length of lines - Text : constant String_Ptr := Errors.Table (E).Text; - Warn : constant Boolean := Errors.Table (E).Warn; - Warn_Chr : constant Character := Errors.Table (E).Warn_Chr; - Warn_Tag : String_Ptr; - Ptr : Natural; - Split : Natural; - Start : Natural; + Text : constant String_Ptr := Errors.Table (E).Text; + Ptr : Natural; + Split : Natural; + Start : Natural; begin - -- Add warning doc tag if needed - - if Warn and then Warn_Chr /= ' ' then - if Warn_Chr = '?' then - Warn_Tag := new String'(" [enabled by default]"); - - elsif Warn_Chr in 'a' .. 'z' then - Warn_Tag := new String'(" [-gnatw" & Warn_Chr & ']'); - - else pragma Assert (Warn_Chr in 'A' .. 'Z'); - Warn_Tag := new String'(" [-gnatw." & Fold_Lower (Warn_Chr) & ']'); - end if; - - else - Warn_Tag := new String'(""); - end if; - -- Set error message line length if Error_Msg_Line_Length = 0 then @@ -492,7 +565,7 @@ package body Erroutc is Max := Integer (Length - Column + 1); declare - Txt : constant String := Text.all & Warn_Tag.all; + Txt : constant String := Text.all & Get_Warning_Tag (E); Len : constant Natural := Txt'Length; begin @@ -502,8 +575,20 @@ package body Erroutc is if Len < 6 or else Txt (Txt'First .. Txt'First + 5) /= "info: " then - Write_Str ("warning: "); - Max := Max - 9; + -- One more check, if warning is to be treated as error, then + -- here is where we deal with that. + + if Errors.Table (E).Warn_Err then + Write_Str ("warning(error): "); + Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; + Max := Max - 16; + + -- Normal case + + else + Write_Str ("warning: "); + Max := Max - 9; + end if; end if; -- No prefix needed for style message, "(style)" is there already @@ -1358,75 +1443,6 @@ package body Erroutc is (Loc : Source_Ptr; Msg : String_Ptr) return String_Id is - function Matches (S : String; P : String) return Boolean; - -- Returns true if the String S patches the pattern P, which can contain - -- wild card chars (*). The entire pattern must match the entire string. - -- Case is ignored in the comparison (so X matches x). - - ------------- - -- Matches -- - ------------- - - function Matches (S : String; P : String) return Boolean is - Slast : constant Natural := S'Last; - PLast : constant Natural := P'Last; - - SPtr : Natural := S'First; - PPtr : Natural := P'First; - - begin - -- Loop advancing through characters of string and pattern - - SPtr := S'First; - PPtr := P'First; - loop - -- Return True if pattern is a single asterisk - - if PPtr = PLast and then P (PPtr) = '*' then - return True; - - -- Return True if both pattern and string exhausted - - elsif PPtr > PLast and then SPtr > Slast then - return True; - - -- Return False, if one exhausted and not the other - - elsif PPtr > PLast or else SPtr > Slast then - return False; - - -- Case where pattern starts with asterisk - - elsif P (PPtr) = '*' then - - -- Try all possible starting positions in S for match with - -- the remaining characters of the pattern. This is the - -- recursive call that implements the scanner backup. - - for J in SPtr .. Slast loop - if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then - return True; - end if; - end loop; - - return False; - - -- Dealt with end of string and *, advance if we have a match - - elsif Fold_Lower (S (SPtr)) = Fold_Lower (P (PPtr)) then - SPtr := SPtr + 1; - PPtr := PPtr + 1; - - -- If first characters do not match, that's decisive - - else - return False; - end if; - end loop; - end Matches; - - -- Start of processing for Warning_Specifically_Suppressed - begin -- Loop through specific warning suppression entries @@ -1452,6 +1468,21 @@ package body Erroutc is return No_String; end Warning_Specifically_Suppressed; + ------------------------------ + -- Warning_Treated_As_Error -- + ------------------------------ + + function Warning_Treated_As_Error (Msg : String) return Boolean is + begin + for J in 1 .. Warnings_As_Errors_Count loop + if Matches (Msg, Warnings_As_Errors (J).all) then + return True; + end if; + end loop; + + return False; + end Warning_Treated_As_Error; + ------------------------- -- Warnings_Suppressed -- ------------------------- -- cgit v1.1