-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
with Gnatvsn; use Gnatvsn;
with Hostparm; use Hostparm;
with Lib; use Lib;
-with Namet; use Namet;
with Opt; use Opt;
with Nlists; use Nlists;
with Output; use Output;
-- error message procedures should be ignored (when parsing irrelevant
-- text in sources being preprocessed).
+ Finalize_Called : Boolean := False;
+ -- Set True if the Finalize routine has been called
+
Warn_On_Instance : Boolean;
-- Flag set true for warning message to be posted on instance
-- location of the flag, which is provided for the internal call to
-- Set_Msg_Insertion_Line_Number,
- procedure Set_Msg_Insertion_Unit_Name;
- -- Handle unit name insertion ($ insertion character)
+ procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True);
+ -- Handle unit name insertion ($ insertion character). Depending on Boolean
+ -- parameter Suffix, (spec) or (body) is appended after the unit name.
procedure Set_Msg_Node (Node : Node_Id);
-- Add the sequence of characters for the name associated with the
end if;
end Change_Error_Text;
+ ------------------------
+ -- Compilation_Errors --
+ ------------------------
+
+ function Compilation_Errors return Boolean is
+ begin
+ if not Finalize_Called then
+ raise Program_Error;
+ else
+ return Erroutc.Compilation_Errors;
+ end if;
+ end Compilation_Errors;
+
---------------
-- Error_Msg --
---------------
--------------
procedure Finalize is
- Cur : Error_Msg_Id;
- Nxt : Error_Msg_Id;
- E, F : Error_Msg_Id;
+ Cur : Error_Msg_Id;
+ Nxt : Error_Msg_Id;
+ F : Error_Msg_Id;
+
+ begin
+ -- Eliminate any duplicated error messages from the list. This is
+ -- done after the fact to avoid problems with Change_Error_Text.
+
+ Cur := First_Error_Msg;
+ while Cur /= No_Error_Msg loop
+ Nxt := Errors.Table (Cur).Next;
+
+ F := Nxt;
+ while F /= No_Error_Msg
+ and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
+ loop
+ Check_Duplicate_Message (Cur, F);
+ F := Errors.Table (F).Next;
+ end loop;
+
+ Cur := Nxt;
+ end loop;
+
+ -- Mark any messages suppressed by specific warnings as Deleted
+
+ Cur := First_Error_Msg;
+ while Cur /= No_Error_Msg loop
+ if not Errors.Table (Cur).Deleted
+ and then Warning_Specifically_Suppressed
+ (Errors.Table (Cur).Sptr,
+ Errors.Table (Cur).Text)
+ then
+ Errors.Table (Cur).Deleted := True;
+ Warnings_Detected := Warnings_Detected - 1;
+ end if;
+
+ Cur := Errors.Table (Cur).Next;
+ end loop;
+
+ -- Remaining processing should only be done once in the case where
+ -- Finalize has been called more than once.
+
+ if Finalize_Called then
+ return;
+ else
+ Finalize_Called := True;
+ end if;
+
+ -- Check consistency of specific warnings (may add warnings)
+
+ Validate_Specific_Warnings (Error_Msg'Access);
+ end Finalize;
+
+ ----------------
+ -- First_Node --
+ ----------------
+
+ function First_Node (C : Node_Id) return Node_Id is
+ L : constant Source_Ptr := Sloc (Original_Node (C));
+ Sfile : constant Source_File_Index := Get_Source_File_Index (L);
+ Earliest : Node_Id;
+ Eloc : Source_Ptr;
+ Discard : Traverse_Result;
+
+ pragma Warnings (Off, Discard);
+
+ function Test_Earlier (N : Node_Id) return Traverse_Result;
+ -- Function applied to every node in the construct
+
+ function Search_Tree_First is new Traverse_Func (Test_Earlier);
+ -- Create traversal function
+
+ ------------------
+ -- Test_Earlier --
+ ------------------
+
+ function Test_Earlier (N : Node_Id) return Traverse_Result is
+ Loc : constant Source_Ptr := Sloc (Original_Node (N));
+
+ begin
+ -- Check for earlier. The tests for being in the same file ensures
+ -- against strange cases of foreign code somehow being present. We
+ -- don't want wild placement of messages if that happens, so it is
+ -- best to just ignore this situation.
+
+ if Loc < Eloc
+ and then Get_Source_File_Index (Loc) = Sfile
+ then
+ Earliest := Original_Node (N);
+ Eloc := Loc;
+ end if;
+
+ return OK_Orig;
+ end Test_Earlier;
+
+ -- Start of processing for First_Node
+
+ begin
+ Earliest := Original_Node (C);
+ Eloc := Sloc (Earliest);
+ Discard := Search_Tree_First (Original_Node (C));
+ return Earliest;
+ end First_Node;
+
+ ----------------
+ -- First_Sloc --
+ ----------------
+
+ 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);
+ F : Node_Id;
+ S : Source_Ptr;
+
+ begin
+ F := First_Node (N);
+ S := Sloc (F);
+
+ -- 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 crawl up the tree from the First_Node, adjusting the
+ -- Sloc value for any parentheses we know are present. Yes, we know
+ -- this circuit is not 100% reliable (e.g. because we don't record
+ -- all possible paren level values), but this is only for an error
+ -- message so it is good enough.
+
+ Node_Loop : loop
+ Paren_Loop : for J in 1 .. Paren_Count (F) loop
+
+ -- We don't look more than 12 characters behind the current
+ -- location, and in any case not past the front of the source.
+
+ Search_Loop : for K in 1 .. 12 loop
+ exit Search_Loop when S = SF;
+
+ 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;
+
+ return S;
+ end First_Sloc;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Errors.Init;
+ First_Error_Msg := No_Error_Msg;
+ Last_Error_Msg := No_Error_Msg;
+ Serious_Errors_Detected := 0;
+ Total_Errors_Detected := 0;
+ Warnings_Detected := 0;
+ Cur_Msg := No_Error_Msg;
+ List_Pragmas.Init;
+
+ -- Initialize warnings table, if all warnings are suppressed, supply
+ -- an initial dummy entry covering all possible source locations.
+
+ Warnings.Init;
+ Specific_Warnings.Init;
+
+ if Warning_Mode = Suppress then
+ Warnings.Increment_Last;
+ Warnings.Table (Warnings.Last).Start := Source_Ptr'First;
+ Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last;
+ end if;
+ end Initialize;
+
+ -----------------
+ -- No_Warnings --
+ -----------------
+
+ function No_Warnings (N : Node_Or_Entity_Id) return Boolean is
+ begin
+ if Error_Posted (N) then
+ return True;
+
+ elsif Nkind (N) in N_Entity and then Warnings_Off (N) then
+ return True;
+
+ elsif Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then Warnings_Off (Entity (N))
+ then
+ return True;
+
+ else
+ return False;
+ end if;
+ end No_Warnings;
+
+ -------------
+ -- OK_Node --
+ -------------
+
+ function OK_Node (N : Node_Id) return Boolean is
+ K : constant Node_Kind := Nkind (N);
+
+ begin
+ if Error_Posted (N) then
+ return False;
+
+ elsif K in N_Has_Etype
+ and then Present (Etype (N))
+ and then Error_Posted (Etype (N))
+ then
+ return False;
+
+ elsif (K in N_Op
+ or else K = N_Attribute_Reference
+ or else K = N_Character_Literal
+ or else K = N_Expanded_Name
+ or else K = N_Identifier
+ or else K = N_Operator_Symbol)
+ and then Present (Entity (N))
+ and then Error_Posted (Entity (N))
+ then
+ return False;
+ else
+ return True;
+ end if;
+ end OK_Node;
+
+ ---------------------
+ -- Output_Messages --
+ ---------------------
+
+ procedure Output_Messages is
+ E : Error_Msg_Id;
Err_Flag : Boolean;
procedure Write_Error_Summary;
end if;
end Write_Max_Errors;
- -- Start of processing for Finalize
+ -- Start of processing for Output_Messages
begin
+ -- Error if Finalize has not been called
+
+ if not Finalize_Called then
+ raise Program_Error;
+ end if;
+
-- Reset current error source file if the main unit has a pragma
-- Source_Reference. This ensures outputting the proper name of
-- the source file in this situation.
- if Main_Source_File = No_Source_File or else
- Num_SRef_Pragmas (Main_Source_File) /= 0
+ if Main_Source_File = No_Source_File
+ or else Num_SRef_Pragmas (Main_Source_File) /= 0
then
Current_Error_Source_File := No_Source_File;
end if;
- -- Eliminate any duplicated error messages from the list. This is
- -- done after the fact to avoid problems with Change_Error_Text.
-
- Cur := First_Error_Msg;
- while Cur /= No_Error_Msg loop
- Nxt := Errors.Table (Cur).Next;
-
- F := Nxt;
- while F /= No_Error_Msg
- and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
- loop
- Check_Duplicate_Message (Cur, F);
- F := Errors.Table (F).Next;
- end loop;
-
- Cur := Nxt;
- end loop;
-
- -- Mark any messages suppressed by specific warnings as Deleted
-
- Cur := First_Error_Msg;
- while Cur /= No_Error_Msg loop
- if Warning_Specifically_Suppressed
- (Errors.Table (Cur).Sptr,
- Errors.Table (Cur).Text)
- then
- Errors.Table (Cur).Deleted := True;
- Warnings_Detected := Warnings_Detected - 1;
- end if;
-
- Cur := Errors.Table (Cur).Next;
- end loop;
-
- -- Check consistency of specific warnings (may add warnings)
-
- Validate_Specific_Warnings (Error_Msg'Access);
-
-- Brief Error mode
if Brief_Output or (not Full_List and not Verbose_Mode) then
Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
Warnings_Detected := 0;
end if;
- end Finalize;
-
- ----------------
- -- First_Node --
- ----------------
-
- function First_Node (C : Node_Id) return Node_Id is
- L : constant Source_Ptr := Sloc (Original_Node (C));
- Sfile : constant Source_File_Index := Get_Source_File_Index (L);
- Earliest : Node_Id;
- Eloc : Source_Ptr;
- Discard : Traverse_Result;
-
- pragma Warnings (Off, Discard);
-
- function Test_Earlier (N : Node_Id) return Traverse_Result;
- -- Function applied to every node in the construct
-
- function Search_Tree_First is new Traverse_Func (Test_Earlier);
- -- Create traversal function
-
- ------------------
- -- Test_Earlier --
- ------------------
-
- function Test_Earlier (N : Node_Id) return Traverse_Result is
- Loc : constant Source_Ptr := Sloc (Original_Node (N));
-
- begin
- -- Check for earlier. The tests for being in the same file ensures
- -- against strange cases of foreign code somehow being present. We
- -- don't want wild placement of messages if that happens, so it is
- -- best to just ignore this situation.
-
- if Loc < Eloc
- and then Get_Source_File_Index (Loc) = Sfile
- then
- Earliest := Original_Node (N);
- Eloc := Loc;
- end if;
-
- return OK_Orig;
- end Test_Earlier;
-
- -- Start of processing for First_Node
-
- begin
- Earliest := Original_Node (C);
- Eloc := Sloc (Earliest);
- Discard := Search_Tree_First (Original_Node (C));
- return Earliest;
- end First_Node;
-
- ----------------
- -- First_Sloc --
- ----------------
-
- 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);
- F : Node_Id;
- S : Source_Ptr;
-
- begin
- F := First_Node (N);
- S := Sloc (F);
-
- -- 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 crawl up the tree from the First_Node, adjusting the
- -- Sloc value for any parentheses we know are present. Yes, we know
- -- this circuit is not 100% reliable (e.g. because we don't record
- -- all possible paren level valoues), but this is only for an error
- -- message so it is good enough.
-
- Node_Loop : loop
- Paren_Loop : for J in 1 .. Paren_Count (F) loop
-
- -- We don't look more than 12 characters behind the current
- -- location, and in any case not past the front of the source.
-
- Search_Loop : for K in 1 .. 12 loop
- exit Search_Loop when S = SF;
-
- 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;
-
- return S;
- end First_Sloc;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- Errors.Init;
- First_Error_Msg := No_Error_Msg;
- Last_Error_Msg := No_Error_Msg;
- Serious_Errors_Detected := 0;
- Total_Errors_Detected := 0;
- Warnings_Detected := 0;
- Cur_Msg := No_Error_Msg;
- List_Pragmas.Init;
-
- -- Initialize warnings table, if all warnings are suppressed, supply
- -- an initial dummy entry covering all possible source locations.
-
- Warnings.Init;
- Specific_Warnings.Init;
-
- if Warning_Mode = Suppress then
- Warnings.Increment_Last;
- Warnings.Table (Warnings.Last).Start := Source_Ptr'First;
- Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last;
- end if;
- end Initialize;
-
- -----------------
- -- No_Warnings --
- -----------------
-
- function No_Warnings (N : Node_Or_Entity_Id) return Boolean is
- begin
- if Error_Posted (N) then
- return True;
-
- elsif Nkind (N) in N_Entity and then Warnings_Off (N) then
- return True;
-
- elsif Is_Entity_Name (N)
- and then Present (Entity (N))
- and then Warnings_Off (Entity (N))
- then
- return True;
-
- else
- return False;
- end if;
- end No_Warnings;
-
- -------------
- -- OK_Node --
- -------------
-
- function OK_Node (N : Node_Id) return Boolean is
- K : constant Node_Kind := Nkind (N);
-
- begin
- if Error_Posted (N) then
- return False;
-
- elsif K in N_Has_Etype
- and then Present (Etype (N))
- and then Error_Posted (Etype (N))
- then
- return False;
-
- elsif (K in N_Op
- or else K = N_Attribute_Reference
- or else K = N_Character_Literal
- or else K = N_Expanded_Name
- or else K = N_Identifier
- or else K = N_Operator_Symbol)
- and then Present (Entity (N))
- and then Error_Posted (Entity (N))
- then
- return False;
- else
- return True;
- end if;
- end OK_Node;
+ end Output_Messages;
------------------------
-- Output_Source_Line --
-- Set_Msg_Insertion_Unit_Name --
---------------------------------
- procedure Set_Msg_Insertion_Unit_Name is
+ procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True) is
begin
- if Error_Msg_Unit_1 = No_Name then
+ if Error_Msg_Unit_1 = No_Unit_Name then
null;
- elsif Error_Msg_Unit_1 = Error_Name then
+ elsif Error_Msg_Unit_1 = Error_Unit_Name then
Set_Msg_Blank;
Set_Msg_Str ("<error>");
else
- Get_Unit_Name_String (Error_Msg_Unit_1);
+ Get_Unit_Name_String (Error_Msg_Unit_1, Suffix);
Set_Msg_Blank;
Set_Msg_Quote;
Set_Msg_Name_Buffer;
------------------
procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
- C : Character; -- Current character
- P : Natural; -- Current index;
+ C : Character; -- Current character
+ P : Natural; -- Current index;
begin
Manual_Quote_Mode := False;
C := Text (P);
P := P + 1;
- -- Check for insertion character
+ -- Check for insertion character or sequence
case C is
when '%' =>
- Set_Msg_Insertion_Name;
+ if P <= Text'Last and then Text (P) = '%' then
+ P := P + 1;
+ Set_Msg_Insertion_Name_Literal;
+ else
+ Set_Msg_Insertion_Name;
+ end if;
when '$' =>
- Set_Msg_Insertion_Unit_Name;
+ if P <= Text'Last and then Text (P) = '$' then
+ P := P + 1;
+ Set_Msg_Insertion_Unit_Name (Suffix => False);
+
+ else
+ Set_Msg_Insertion_Unit_Name;
+ end if;
when '{' =>
Set_Msg_Insertion_File_Name;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
with Err_Vars;
with Erroutc;
+with Namet; use Namet;
with Table;
-with Types; use Types;
-with Uintp; use Uintp;
+with Types; use Types;
+with Uintp; use Uintp;
with System;
-- message, similarly replaced by the names which are specified by the
-- Name_Id values stored in Error_Msg_Name_2 and Error_Msg_Name_3. The
-- names are decoded and cased according to the current identifier
- -- casing mode.
+ -- casing mode. Note: if a unit name ending with %b or %s is passed
+ -- for this kind of insertion, this suffix is simply stripped. Use a
+ -- unit name insertion ($) to process the suffix.
+
+ -- Insertion character %% (Double percent: insert literal name)
+ -- The character sequence %% acts as described above for %, except
+ -- that the name is simply obtained with Get_Name_String and is not
+ -- decoded or cased, it is inserted literally from the names table.
+ -- A trailing %b or %s is not treated specially.
-- Insertion character $ (Dollar: insert unit name from Names table)
-- The character $ is treated similarly to %, except that the name is
-- strings. If this postfix is not required, use the normal %
-- insertion for the unit name.
- -- Insertion character { (Left brace: insert literally from names table)
- -- The character { is treated similarly to %, except that the name is
- -- output literally as stored in the names table without adjusting the
- -- casing. This can be used for file names and in other situations
- -- where the name string is to be output unchanged.
+ -- Insertion character { (Left brace: insert file name from names table)
+ -- The character { is treated similarly to %, except that the input
+ -- value is a File_Name_Type value stored in Error_Msg_File_1 or
+ -- Error_Msg_File_2 or Error_Msg_File_3. The value is output literally,
+ -- enclosed in quotes as for %, but the case is not modified, the
+ -- insertion is the exact string stored in the names table without
+ -- adjusting the casing.
-- Insertion character * (Asterisk, insert reserved word name)
-- The insertion character * is treated exactly like % except that the
Error_Msg_Name_3 : Name_Id renames Err_Vars.Error_Msg_Name_3;
-- Name_Id values for % insertion characters in message
- Error_Msg_Unit_1 : Name_Id renames Err_Vars.Error_Msg_Unit_1;
- Error_Msg_Unit_2 : Name_Id renames Err_Vars.Error_Msg_Unit_2;
- -- Name_Id values for $ insertion characters in message
+ Error_Msg_File_1 : File_Name_Type renames Err_Vars.Error_Msg_File_1;
+ Error_Msg_File_2 : File_Name_Type renames Err_Vars.Error_Msg_File_2;
+ Error_Msg_File_3 : File_Name_Type renames Err_Vars.Error_Msg_File_3;
+ -- File_Name_Type values for { insertion characters in message
+
+ Error_Msg_Unit_1 : Unit_Name_Type renames Err_Vars.Error_Msg_Unit_1;
+ Error_Msg_Unit_2 : Unit_Name_Type renames Err_Vars.Error_Msg_Unit_2;
+ -- Unit_Name_Type values for $ insertion characters in message
Error_Msg_Node_1 : Node_Id renames Err_Vars.Error_Msg_Node_1;
Error_Msg_Node_2 : Node_Id renames Err_Vars.Error_Msg_Node_2;
-- source file before using any of the other routines in the package.
procedure Finalize;
- -- Finalize processing of error messages for one file and output message
- -- indicating the number of detected errors.
+ -- Finalize processing of error message list. Includes processing for
+ -- duplicated error messages, and other similar final adjustment of the
+ -- list of error messages. Note that this procedure must be called before
+ -- calling Compilation_Errors to determine if there were any errors. It
+ -- is perfectly fine to call Finalize more than once. Indeed this can
+ -- make good sense. For example, do some processing that may generate
+ -- messages. Call Finalize to eliminate duplicates and remove deleted
+ -- warnings. Test for compilation errors using Compilation_Errors, then
+ -- generate some more errors/warnings, call Finalize again to make sure
+ -- that all duplicates in these new messages are dealt with, then finally
+ -- call Output_Messages to output the final list of messages.
+
+ procedure Output_Messages;
+ -- Output list of messages, including messages giving number of detected
+ -- errors and warnings.
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
-- Output a message at specified location. Can be called from the parser
-- the pragma. Err is set to True on return to report the error of no
-- matching Warnings Off pragma preceding this one.
- function Compilation_Errors return Boolean
- renames Erroutc.Compilation_Errors;
+ function Compilation_Errors return Boolean;
-- Returns true if errors have been detected, or warnings in -gnatwe
- -- (treat warnings as errors) mode.
+ -- (treat warnings as errors) mode. Note that it is mandatory to call
+ -- Finalize before calling this routine.
procedure Error_Msg_CRT (Feature : String; N : Node_Id);
-- Posts a non-fatal message on node N saying that the feature identified
projects / gcc.git / commitdiff