------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E R R O U T C -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2004 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- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -- Warning! Error messages can be generated during Gigi processing by direct -- calls to error message routines, so it is essential that the processing -- in this body be consistent with the requirements for the Gigi processing -- environment, and that in particular, no disallowed table expansion is -- allowed to occur. with Casing; use Casing; with Debug; use Debug; with Err_Vars; use Err_Vars; with Namet; use Namet; with Opt; use Opt; with Output; use Output; with Sinput; use Sinput; with Snames; use Snames; with Targparm; use Targparm; with Table; with Types; use Types; with Uintp; use Uintp; package body Erroutc is ----------------------- -- Local Subprograms -- ----------------------- --------------- -- Add_Class -- --------------- procedure Add_Class is begin if Class_Flag then Class_Flag := False; Set_Msg_Char ('''); Get_Name_String (Name_Class); Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); Set_Msg_Name_Buffer; end if; end Add_Class; ---------------------- -- Buffer_Ends_With -- ---------------------- function Buffer_Ends_With (S : String) return Boolean is Len : constant Natural := S'Length; begin return Msglen > Len and then Msg_Buffer (Msglen - Len) = ' ' and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S; end Buffer_Ends_With; ------------------- -- Buffer_Remove -- ------------------- procedure Buffer_Remove (S : String) is begin if Buffer_Ends_With (S) then Msglen := Msglen - S'Length; end if; end Buffer_Remove; ----------------------------- -- Check_Duplicate_Message -- ----------------------------- procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is L1, L2 : Error_Msg_Id; 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). ---------------- -- Delete_Msg -- ---------------- procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is D, K : Error_Msg_Id; begin D := Delete; K := Keep; loop Errors.Table (D).Deleted := True; -- Adjust error message count if Errors.Table (D).Warn or Errors.Table (D).Style then Warnings_Detected := Warnings_Detected - 1; else Total_Errors_Detected := Total_Errors_Detected - 1; if Errors.Table (D).Serious then Serious_Errors_Detected := Serious_Errors_Detected - 1; end if; end if; -- Substitute shorter of the two error messages if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then Errors.Table (K).Text := Errors.Table (D).Text; end if; D := Errors.Table (D).Next; K := Errors.Table (K).Next; if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then return; end if; end loop; end Delete_Msg; -- Start of processing for Check_Duplicate_Message begin -- Both messages must be non-continuation messages and not deleted if Errors.Table (M1).Msg_Cont or else Errors.Table (M2).Msg_Cont or else Errors.Table (M1).Deleted or else Errors.Table (M2).Deleted then return; end if; -- Definitely not equal if message text does not match if not Same_Error (M1, M2) then return; end if; -- Same text. See if all continuations are also identical L1 := M1; L2 := M2; loop N1 := Errors.Table (L1).Next; N2 := Errors.Table (L2).Next; -- If M1 continuations have run out, we delete M1, either the -- messages have the same number of continuations, or M2 has -- more and we prefer the one with more anyway. if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then Delete_Msg (M1, M2); return; -- If M2 continuatins have run out, we delete M2 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then Delete_Msg (M2, M1); return; -- Otherwise see if continuations are the same, if not, keep both -- sequences, a curious case, but better to keep everything! elsif not Same_Error (N1, N2) then return; -- If continuations are the same, continue scan else L1 := N1; L2 := N2; end if; end loop; end Check_Duplicate_Message; ------------------------ -- Compilation_Errors -- ------------------------ function Compilation_Errors return Boolean is begin return Total_Errors_Detected /= 0 or else (Warnings_Detected /= 0 and then Warning_Mode = Treat_As_Error); end Compilation_Errors; ------------------ -- Debug_Output -- ------------------ procedure Debug_Output (N : Node_Id) is begin if Debug_Flag_1 then Write_Str ("*** following error message posted on node id = #"); Write_Int (Int (N)); Write_Str (" ***"); Write_Eol; end if; end Debug_Output; ---------- -- dmsg -- ---------- procedure dmsg (Id : Error_Msg_Id) is E : Error_Msg_Object renames Errors.Table (Id); begin w ("Dumping error message, Id = ", Int (Id)); w (" Text = ", E.Text.all); w (" Next = ", Int (E.Next)); w (" Sfile = ", Int (E.Sfile)); Write_Str (" Sptr = "); Write_Location (E.Sptr); Write_Eol; Write_Str (" Optr = "); Write_Location (E.Optr); Write_Eol; w (" Line = ", Int (E.Line)); w (" Col = ", Int (E.Col)); w (" Warn = ", E.Warn); w (" Style = ", E.Style); w (" Serious = ", E.Serious); w (" Uncond = ", E.Uncond); w (" Msg_Cont = ", E.Msg_Cont); w (" Deleted = ", E.Deleted); Write_Eol; end dmsg; ------------------ -- Get_Location -- ------------------ function Get_Location (E : Error_Msg_Id) return Source_Ptr is begin return Errors.Table (E).Sptr; end Get_Location; ---------------- -- Get_Msg_Id -- ---------------- function Get_Msg_Id return Error_Msg_Id is begin return Cur_Msg; end Get_Msg_Id; ----------------------- -- Output_Error_Msgs -- ----------------------- procedure Output_Error_Msgs (E : in out Error_Msg_Id) is P : Source_Ptr; T : Error_Msg_Id; S : Error_Msg_Id; Flag_Num : Pos; Mult_Flags : Boolean := False; begin S := E; -- Skip deleted messages at start if Errors.Table (S).Deleted then Set_Next_Non_Deleted_Msg (S); end if; -- Figure out if we will place more than one error flag on this line T := S; 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 if Errors.Table (T).Sptr > Errors.Table (E).Sptr then Mult_Flags := True; end if; Set_Next_Non_Deleted_Msg (T); end loop; -- Output the error flags. The circuit here makes sure that the tab -- characters in the original line are properly accounted for. The -- eight blanks at the start are to match the line number. if not Debug_Flag_2 then Write_Str (" "); P := Line_Start (Errors.Table (E).Sptr); Flag_Num := 1; -- Loop through error messages for this line to place flags T := S; 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 -- Loop to output blanks till current flag position while P < Errors.Table (T).Sptr loop if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then Write_Char (ASCII.HT); else Write_Char (' '); end if; P := P + 1; end loop; -- 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 (Flag_Num = 1 and then not Mult_Flags) or else Flag_Num > 9 then Write_Char ('|'); else Write_Char (Character'Val (Character'Pos ('0') + Flag_Num)); end if; P := P + 1; end if; Set_Next_Non_Deleted_Msg (T); Flag_Num := Flag_Num + 1; end loop; Write_Eol; end if; -- Now output the error messages T := S; 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); if Debug_Flag_2 then while Column < 74 loop Write_Char (' '); end loop; Write_Str (" <<<"); end if; Write_Eol; Set_Next_Non_Deleted_Msg (T); end loop; E := T; end Output_Error_Msgs; ------------------------ -- Output_Line_Number -- ------------------------ procedure Output_Line_Number (L : Logical_Line_Number) is D : Int; -- next digit C : Character; -- next character Z : Boolean; -- flag for zero suppress N, M : Int; -- temporaries begin if L = No_Line_Number then Write_Str (" "); else Z := False; N := Int (L); M := 100_000; while M /= 0 loop D := Int (N / M); N := N rem M; M := M / 10; if D = 0 then if Z then C := '0'; else C := ' '; end if; else Z := True; C := Character'Val (D + 48); end if; Write_Char (C); end loop; Write_Str (". "); end if; end Output_Line_Number; --------------------- -- Output_Msg_Text -- --------------------- procedure Output_Msg_Text (E : Error_Msg_Id) is begin if Errors.Table (E).Warn then Write_Str ("warning: "); elsif Errors.Table (E).Style then null; elsif Opt.Unique_Error_Tag then Write_Str ("error: "); end if; Write_Str (Errors.Table (E).Text.all); end Output_Msg_Text; -------------------- -- Purge_Messages -- -------------------- procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is E : Error_Msg_Id; function To_Be_Purged (E : Error_Msg_Id) return Boolean; -- Returns True for a message that is to be purged. Also adjusts -- error counts appropriately. ------------------ -- To_Be_Purged -- ------------------ 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 then if Errors.Table (E).Warn or Errors.Table (E).Style then Warnings_Detected := Warnings_Detected - 1; else Total_Errors_Detected := Total_Errors_Detected - 1; if Errors.Table (E).Serious then Serious_Errors_Detected := Serious_Errors_Detected - 1; end if; end if; return True; else return False; end if; end To_Be_Purged; -- Start of processing for Purge_Messages begin while To_Be_Purged (First_Error_Msg) loop First_Error_Msg := Errors.Table (First_Error_Msg).Next; end loop; E := First_Error_Msg; while E /= No_Error_Msg loop while To_Be_Purged (Errors.Table (E).Next) loop Errors.Table (E).Next := Errors.Table (Errors.Table (E).Next).Next; end loop; E := Errors.Table (E).Next; end loop; end Purge_Messages; ---------------- -- Same_Error -- ---------------- function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is Msg1 : constant String_Ptr := Errors.Table (M1).Text; Msg2 : constant String_Ptr := Errors.Table (M2).Text; Msg2_Len : constant Integer := Msg2'Length; Msg1_Len : constant Integer := Msg1'Length; begin return Msg1.all = Msg2.all or else (Msg1_Len - 10 > Msg2_Len and then Msg2.all = Msg1.all (1 .. Msg2_Len) and then Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance") or else (Msg2_Len - 10 > Msg1_Len and then Msg1.all = Msg2.all (1 .. Msg1_Len) and then Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance"); end Same_Error; ------------------- -- Set_Msg_Blank -- ------------------- procedure Set_Msg_Blank is begin if Msglen > 0 and then Msg_Buffer (Msglen) /= ' ' and then Msg_Buffer (Msglen) /= '(' and then not Manual_Quote_Mode then Set_Msg_Char (' '); end if; end Set_Msg_Blank; ------------------------------- -- Set_Msg_Blank_Conditional -- ------------------------------- procedure Set_Msg_Blank_Conditional is begin if Msglen > 0 and then Msg_Buffer (Msglen) /= ' ' and then Msg_Buffer (Msglen) /= '(' and then Msg_Buffer (Msglen) /= '"' and then not Manual_Quote_Mode then Set_Msg_Char (' '); end if; end Set_Msg_Blank_Conditional; ------------------ -- Set_Msg_Char -- ------------------ procedure Set_Msg_Char (C : Character) is begin -- The check for message buffer overflow is needed to deal with cases -- where insertions get too long (in particular a child unit name can -- be very long). if Msglen < Max_Msg_Length then Msglen := Msglen + 1; Msg_Buffer (Msglen) := C; end if; end Set_Msg_Char; --------------------------------- -- Set_Msg_Insertion_File_Name -- --------------------------------- procedure Set_Msg_Insertion_File_Name is begin if Error_Msg_Name_1 = No_Name then null; elsif Error_Msg_Name_1 = Error_Name then Set_Msg_Blank; Set_Msg_Str (""); else Set_Msg_Blank; Get_Name_String (Error_Msg_Name_1); Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; end if; -- The following assignments ensure that the second and third percent -- insertion characters will correspond to the Error_Msg_Name_2 and -- Error_Msg_Name_3 as required. Error_Msg_Name_1 := Error_Msg_Name_2; Error_Msg_Name_2 := Error_Msg_Name_3; end Set_Msg_Insertion_File_Name; ----------------------------------- -- Set_Msg_Insertion_Line_Number -- ----------------------------------- procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is Sindex_Loc : Source_File_Index; Sindex_Flag : Source_File_Index; begin Set_Msg_Blank; if Loc = No_Location then Set_Msg_Str ("at unknown location"); elsif Loc = System_Location then Set_Msg_Str ("in package System"); Set_Msg_Insertion_Run_Time_Name; elsif Loc = Standard_Location then Set_Msg_Str ("in package Standard"); elsif Loc = Standard_ASCII_Location then Set_Msg_Str ("in package Standard.ASCII"); else -- Add "at file-name:" if reference is to other than the source -- file in which the error message is placed. Note that we check -- full file names, rather than just the source indexes, to -- deal with generic instantiations from the current file. Sindex_Loc := Get_Source_File_Index (Loc); Sindex_Flag := Get_Source_File_Index (Flag); if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then Set_Msg_Str ("at "); Get_Name_String (Reference_Name (Get_Source_File_Index (Loc))); Set_Msg_Name_Buffer; Set_Msg_Char (':'); -- If in current file, add text "at line " else Set_Msg_Str ("at line "); end if; -- Output line number for reference Set_Msg_Int (Int (Get_Logical_Line_Number (Loc))); -- Deal with the instantiation case. We may have a reference to, -- e.g. a type, that is declared within a generic template, and -- what we are really referring to is the occurrence in an instance. -- In this case, the line number of the instantiation is also of -- interest, and we add a notation: -- , instance at xxx -- where xxx is a line number output using this same routine (and -- the recursion can go further if the instantiation is itself in -- a generic template). -- The flag location passed to us in this situation is indeed the -- line number within the template, but as described in Sinput.L -- (file sinput-l.ads, section "Handling Generic Instantiations") -- we can retrieve the location of the instantiation itself from -- this flag location value. -- Note: this processing is suppressed if Suppress_Instance_Location -- is set True. This is used to prevent redundant annotations of the -- location of the instantiation in the case where we are placing -- the messages on the instantiation in any case. if Instantiation (Sindex_Loc) /= No_Location and then not Suppress_Instance_Location then Set_Msg_Str (", instance "); Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag); end if; end if; end Set_Msg_Insertion_Line_Number; ---------------------------- -- Set_Msg_Insertion_Name -- ---------------------------- procedure Set_Msg_Insertion_Name is begin if Error_Msg_Name_1 = No_Name then null; elsif Error_Msg_Name_1 = Error_Name then Set_Msg_Blank; Set_Msg_Str (""); else Set_Msg_Blank_Conditional; Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1); -- Remove %s or %b at end. These come from unit names. If the -- caller wanted the (unit) or (body), then they would have used -- the $ insertion character. Certainly no error message should -- ever have %b or %s explicitly occurring. if Name_Len > 2 and then Name_Buffer (Name_Len - 1) = '%' and then (Name_Buffer (Name_Len) = 'b' or else Name_Buffer (Name_Len) = 's') then Name_Len := Name_Len - 2; end if; -- Remove upper case letter at end, again, we should not be getting -- such names, and what we hope is that the remainder makes sense. if Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' then Name_Len := Name_Len - 1; end if; -- If operator name or character literal name, just print it as is -- Also print as is if it ends in a right paren (case of x'val(nnn)) if Name_Buffer (1) = '"' or else Name_Buffer (1) = ''' or else Name_Buffer (Name_Len) = ')' then Set_Msg_Name_Buffer; -- Else output with surrounding quotes in proper casing mode else Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; end if; end if; -- The following assignments ensure that the second and third percent -- insertion characters will correspond to the Error_Msg_Name_2 and -- Error_Msg_Name_3 as required. Error_Msg_Name_1 := Error_Msg_Name_2; Error_Msg_Name_2 := Error_Msg_Name_3; end Set_Msg_Insertion_Name; ------------------------------------- -- Set_Msg_Insertion_Reserved_Name -- ------------------------------------- procedure Set_Msg_Insertion_Reserved_Name is begin Set_Msg_Blank_Conditional; Get_Name_String (Error_Msg_Name_1); Set_Msg_Quote; Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case); Set_Msg_Name_Buffer; Set_Msg_Quote; end Set_Msg_Insertion_Reserved_Name; ------------------------------------- -- Set_Msg_Insertion_Reserved_Word -- ------------------------------------- procedure Set_Msg_Insertion_Reserved_Word (Text : String; J : in out Integer) is begin Set_Msg_Blank_Conditional; Name_Len := 0; while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Text (J); J := J + 1; end loop; Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case); Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; end Set_Msg_Insertion_Reserved_Word; ------------------------------------- -- Set_Msg_Insertion_Run_Time_Name -- ------------------------------------- procedure Set_Msg_Insertion_Run_Time_Name is begin if Targparm.Run_Time_Name_On_Target /= No_Name then Set_Msg_Blank_Conditional; Set_Msg_Char ('('); Get_Name_String (Targparm.Run_Time_Name_On_Target); Set_Casing (Mixed_Case); Set_Msg_Str (Name_Buffer (1 .. Name_Len)); Set_Msg_Char (')'); end if; end Set_Msg_Insertion_Run_Time_Name; ---------------------------- -- Set_Msg_Insertion_Uint -- ---------------------------- procedure Set_Msg_Insertion_Uint is begin Set_Msg_Blank; UI_Image (Error_Msg_Uint_1); for J in 1 .. UI_Image_Length loop Set_Msg_Char (UI_Image_Buffer (J)); end loop; -- The following assignment ensures that a second carret insertion -- character will correspond to the Error_Msg_Uint_2 parameter. Error_Msg_Uint_1 := Error_Msg_Uint_2; end Set_Msg_Insertion_Uint; ----------------- -- Set_Msg_Int -- ----------------- procedure Set_Msg_Int (Line : Int) is begin if Line > 9 then Set_Msg_Int (Line / 10); end if; Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10))); end Set_Msg_Int; ------------------------- -- Set_Msg_Name_Buffer -- ------------------------- procedure Set_Msg_Name_Buffer is begin for J in 1 .. Name_Len loop Set_Msg_Char (Name_Buffer (J)); end loop; end Set_Msg_Name_Buffer; ------------------- -- Set_Msg_Quote -- ------------------- procedure Set_Msg_Quote is begin if not Manual_Quote_Mode then Set_Msg_Char ('"'); end if; end Set_Msg_Quote; ----------------- -- Set_Msg_Str -- ----------------- procedure Set_Msg_Str (Text : String) is begin for J in Text'Range loop Set_Msg_Char (Text (J)); end loop; end Set_Msg_Str; ------------------------------ -- Set_Next_Non_Deleted_Msg -- ------------------------------ procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is begin if E = No_Error_Msg then return; else loop E := Errors.Table (E).Next; exit when E = No_Error_Msg or else not Errors.Table (E).Deleted; end loop; end if; end Set_Next_Non_Deleted_Msg; --------------------------- -- Set_Warnings_Mode_Off -- --------------------------- procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is begin -- Don't bother with entries from instantiation copies, since we -- will already have a copy in the template, which is what matters if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then return; end if; -- If last entry in table already covers us, this is a redundant -- pragma Warnings (Off) and can be ignored. This also handles the -- case where all warnings are suppressed by command line switch. if Warnings.Last >= Warnings.First and then Warnings.Table (Warnings.Last).Start <= Loc and then Loc <= Warnings.Table (Warnings.Last).Stop then return; -- Otherwise establish a new entry, extending from the location of -- the pragma to the end of the current source file. This ending -- point will be adjusted by a subsequent pragma Warnings (On). else Warnings.Increment_Last; Warnings.Table (Warnings.Last).Start := Loc; Warnings.Table (Warnings.Last).Stop := Source_Last (Current_Source_File); end if; end Set_Warnings_Mode_Off; -------------------------- -- Set_Warnings_Mode_On -- -------------------------- procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is begin -- Don't bother with entries from instantiation copies, since we -- will already have a copy in the template, which is what matters if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then return; end if; -- Nothing to do unless command line switch to suppress all warnings -- is off, and the last entry in the warnings table covers this -- pragma Warnings (On), in which case adjust the end point. if (Warnings.Last >= Warnings.First and then Warnings.Table (Warnings.Last).Start <= Loc and then Loc <= Warnings.Table (Warnings.Last).Stop) and then Warning_Mode /= Suppress then Warnings.Table (Warnings.Last).Stop := Loc; end if; end Set_Warnings_Mode_On; ------------------------------------ -- Test_Style_Warning_Serious_Msg -- ------------------------------------ procedure Test_Style_Warning_Serious_Msg (Msg : String) is begin if Msg (Msg'First) = '\' then return; end if; Is_Serious_Error := True; Is_Warning_Msg := False; Is_Style_Msg := (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)"); for J in Msg'Range loop if Msg (J) = '?' and then (J = Msg'First or else Msg (J - 1) /= ''') then Is_Warning_Msg := True; elsif Msg (J) = '|' and then (J = Msg'First or else Msg (J - 1) /= ''') then Is_Serious_Error := False; end if; end loop; if Is_Warning_Msg or else Is_Style_Msg then Is_Serious_Error := False; end if; end Test_Style_Warning_Serious_Msg; ------------------------- -- Warnings_Suppressed -- ------------------------- function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is begin for J in Warnings.First .. Warnings.Last loop if Warnings.Table (J).Start <= Loc and then Loc <= Warnings.Table (J).Stop then return True; end if; end loop; return False; end Warnings_Suppressed; end Erroutc;