Skip to content

R
riscv-gcc-1
Commit 107cd232 by Robert Dewar Committed by Arnaud Charlet
Options

comperr.adb (Compiler_Abort): New Finalize/Output_Messages interface for Errout 

2007-04-20  Robert Dewar  <dewar@adacore.com>

	* comperr.adb (Compiler_Abort): New Finalize/Output_Messages interface
	for Errout

	* errout.adb: New Finalize/Compilation_Errors/Output_Messages
	implementation

	* errout.ads (Finalize): Changed interface
	(Output_Messages): New procedure
	(Compilation_Errors): New Interface

	* prepcomp.ads, prepcomp.adb (Parse_Preprocessing_Data_File): New
	Finalize/Output_Messages interface for Errout
	(Prepare_To_Preprocess): New Finalize/Output_Messages interface for
	Errout.

From-SVN: r125374
parent 4378d234
Showing with 348 additions and 263 deletions
gcc/ada/comperr.adb
...@@ -121,6 +121,7 @@ package body Comperr is ...@@ -121,6 +121,7 @@ package body Comperr is
if Serious_Errors_Detected /= 0 and then not Debug_Flag_K then if Serious_Errors_Detected /= 0 and then not Debug_Flag_K then
Errout.Finalize; Errout.Finalize;
Errout.Output_Messages;
Set_Standard_Error; Set_Standard_Error;
Write_Str ("compilation abandoned due to previous error"); Write_Str ("compilation abandoned due to previous error");
......
gcc/ada/errout.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -40,7 +40,6 @@ with Fname; use Fname; ...@@ -40,7 +40,6 @@ with Fname; use Fname;
with Gnatvsn; use Gnatvsn; with Gnatvsn; use Gnatvsn;
with Hostparm; use Hostparm; with Hostparm; use Hostparm;
with Lib; use Lib; with Lib; use Lib;
with Namet; use Namet;
with Opt; use Opt; with Opt; use Opt;
with Nlists; use Nlists; with Nlists; use Nlists;
with Output; use Output; with Output; use Output;
...@@ -61,6 +60,9 @@ package body Errout is ...@@ -61,6 +60,9 @@ package body Errout is
-- error message procedures should be ignored (when parsing irrelevant -- error message procedures should be ignored (when parsing irrelevant
-- text in sources being preprocessed). -- text in sources being preprocessed).
Finalize_Called : Boolean := False;
-- Set True if the Finalize routine has been called
Warn_On_Instance : Boolean; Warn_On_Instance : Boolean;
-- Flag set true for warning message to be posted on instance -- Flag set true for warning message to be posted on instance
...@@ -138,8 +140,9 @@ package body Errout is ...@@ -138,8 +140,9 @@ package body Errout is
-- location of the flag, which is provided for the internal call to -- location of the flag, which is provided for the internal call to
-- Set_Msg_Insertion_Line_Number, -- Set_Msg_Insertion_Line_Number,
procedure Set_Msg_Insertion_Unit_Name; procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True);
-- Handle unit name insertion ($ insertion character) -- 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); procedure Set_Msg_Node (Node : Node_Id);
-- Add the sequence of characters for the name associated with the -- Add the sequence of characters for the name associated with the
...@@ -224,6 +227,19 @@ package body Errout is ...@@ -224,6 +227,19 @@ package body Errout is
end if; end if;
end Change_Error_Text; 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 -- -- Error_Msg --
--------------- ---------------
...@@ -1165,7 +1181,250 @@ package body Errout is ...@@ -1165,7 +1181,250 @@ package body Errout is
procedure Finalize is procedure Finalize is
Cur : Error_Msg_Id; Cur : Error_Msg_Id;
Nxt : Error_Msg_Id; Nxt : Error_Msg_Id;
E, F : 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; Err_Flag : Boolean;
procedure Write_Error_Summary; procedure Write_Error_Summary;
...@@ -1297,56 +1556,25 @@ package body Errout is ...@@ -1297,56 +1556,25 @@ package body Errout is
end if; end if;
end Write_Max_Errors; end Write_Max_Errors;
-- Start of processing for Finalize -- Start of processing for Output_Messages
begin 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 -- Reset current error source file if the main unit has a pragma
-- Source_Reference. This ensures outputting the proper name of -- Source_Reference. This ensures outputting the proper name of
-- the source file in this situation. -- the source file in this situation.
if Main_Source_File = No_Source_File or else if Main_Source_File = No_Source_File
Num_SRef_Pragmas (Main_Source_File) /= 0 or else Num_SRef_Pragmas (Main_Source_File) /= 0
then then
Current_Error_Source_File := No_Source_File; Current_Error_Source_File := No_Source_File;
end if; 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 -- Brief Error mode
if Brief_Output or (not Full_List and not Verbose_Mode) then if Brief_Output or (not Full_List and not Verbose_Mode) then
...@@ -1544,194 +1772,7 @@ package body Errout is ...@@ -1544,194 +1772,7 @@ package body Errout is
Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected; Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
Warnings_Detected := 0; Warnings_Detected := 0;
end if; end if;
end Finalize; end Output_Messages;
----------------
-- 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;
------------------------ ------------------------
-- Output_Source_Line -- -- Output_Source_Line --
...@@ -2277,17 +2318,17 @@ package body Errout is ...@@ -2277,17 +2318,17 @@ package body Errout is
-- Set_Msg_Insertion_Unit_Name -- -- Set_Msg_Insertion_Unit_Name --
--------------------------------- ---------------------------------
procedure Set_Msg_Insertion_Unit_Name is procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True) is
begin begin
if Error_Msg_Unit_1 = No_Name then if Error_Msg_Unit_1 = No_Unit_Name then
null; null;
elsif Error_Msg_Unit_1 = Error_Name then elsif Error_Msg_Unit_1 = Error_Unit_Name then
Set_Msg_Blank; Set_Msg_Blank;
Set_Msg_Str ("<error>"); Set_Msg_Str ("<error>");
else else
Get_Unit_Name_String (Error_Msg_Unit_1); Get_Unit_Name_String (Error_Msg_Unit_1, Suffix);
Set_Msg_Blank; Set_Msg_Blank;
Set_Msg_Quote; Set_Msg_Quote;
Set_Msg_Name_Buffer; Set_Msg_Name_Buffer;
...@@ -2471,14 +2512,25 @@ package body Errout is ...@@ -2471,14 +2512,25 @@ package body Errout is
C := Text (P); C := Text (P);
P := P + 1; P := P + 1;
-- Check for insertion character -- Check for insertion character or sequence
case C is case C is
when '%' => when '%' =>
if P <= Text'Last and then Text (P) = '%' then
P := P + 1;
Set_Msg_Insertion_Name_Literal;
else
Set_Msg_Insertion_Name; Set_Msg_Insertion_Name;
end if;
when '$' => when '$' =>
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; Set_Msg_Insertion_Unit_Name;
end if;
when '{' => when '{' =>
Set_Msg_Insertion_File_Name; Set_Msg_Insertion_File_Name;
......
gcc/ada/errout.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,6 +31,7 @@ ...@@ -31,6 +31,7 @@
with Err_Vars; with Err_Vars;
with Erroutc; with Erroutc;
with Namet; use Namet;
with Table; with Table;
with Types; use Types; with Types; use Types;
with Uintp; use Uintp; with Uintp; use Uintp;
...@@ -147,7 +148,15 @@ package Errout is ...@@ -147,7 +148,15 @@ package Errout is
-- message, similarly replaced by the names which are specified by the -- 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 -- 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 -- 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) -- Insertion character $ (Dollar: insert unit name from Names table)
-- The character $ is treated similarly to %, except that the name is -- The character $ is treated similarly to %, except that the name is
...@@ -157,11 +166,13 @@ package Errout is ...@@ -157,11 +166,13 @@ package Errout is
-- strings. If this postfix is not required, use the normal % -- strings. If this postfix is not required, use the normal %
-- insertion for the unit name. -- insertion for the unit name.
-- Insertion character { (Left brace: insert literally from names table) -- Insertion character { (Left brace: insert file name from names table)
-- The character { is treated similarly to %, except that the name is -- The character { is treated similarly to %, except that the input
-- output literally as stored in the names table without adjusting the -- value is a File_Name_Type value stored in Error_Msg_File_1 or
-- casing. This can be used for file names and in other situations -- Error_Msg_File_2 or Error_Msg_File_3. The value is output literally,
-- where the name string is to be output unchanged. -- 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) -- Insertion character * (Asterisk, insert reserved word name)
-- The insertion character * is treated exactly like % except that the -- The insertion character * is treated exactly like % except that the
...@@ -384,9 +395,14 @@ package Errout is ...@@ -384,9 +395,14 @@ package Errout is
Error_Msg_Name_3 : Name_Id renames Err_Vars.Error_Msg_Name_3; Error_Msg_Name_3 : Name_Id renames Err_Vars.Error_Msg_Name_3;
-- Name_Id values for % insertion characters in message -- Name_Id values for % insertion characters in message
Error_Msg_Unit_1 : Name_Id renames Err_Vars.Error_Msg_Unit_1; Error_Msg_File_1 : File_Name_Type renames Err_Vars.Error_Msg_File_1;
Error_Msg_Unit_2 : Name_Id renames Err_Vars.Error_Msg_Unit_2; Error_Msg_File_2 : File_Name_Type renames Err_Vars.Error_Msg_File_2;
-- Name_Id values for $ insertion characters in message 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_1 : Node_Id renames Err_Vars.Error_Msg_Node_1;
Error_Msg_Node_2 : Node_Id renames Err_Vars.Error_Msg_Node_2; Error_Msg_Node_2 : Node_Id renames Err_Vars.Error_Msg_Node_2;
...@@ -545,8 +561,21 @@ package Errout is ...@@ -545,8 +561,21 @@ package Errout is
-- source file before using any of the other routines in the package. -- source file before using any of the other routines in the package.
procedure Finalize; procedure Finalize;
-- Finalize processing of error messages for one file and output message -- Finalize processing of error message list. Includes processing for
-- indicating the number of detected errors. -- 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); procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
-- Output a message at specified location. Can be called from the parser -- Output a message at specified location. Can be called from the parser
...@@ -687,10 +716,10 @@ package Errout is ...@@ -687,10 +716,10 @@ package Errout is
-- the pragma. Err is set to True on return to report the error of no -- the pragma. Err is set to True on return to report the error of no
-- matching Warnings Off pragma preceding this one. -- matching Warnings Off pragma preceding this one.
function Compilation_Errors return Boolean function Compilation_Errors return Boolean;
renames Erroutc.Compilation_Errors;
-- Returns true if errors have been detected, or warnings in -gnatwe -- 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); procedure Error_Msg_CRT (Feature : String; N : Node_Id);
-- Posts a non-fatal message on node N saying that the feature identified -- Posts a non-fatal message on node N saying that the feature identified
......
gcc/ada/prepcomp.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -27,7 +27,6 @@ ...@@ -27,7 +27,6 @@
with Ada.Unchecked_Deallocation; with Ada.Unchecked_Deallocation;
with Errout; use Errout; with Errout; use Errout;
with Namet; use Namet;
with Lib.Writ; use Lib.Writ; with Lib.Writ; use Lib.Writ;
with Opt; use Opt; with Opt; use Opt;
with Osint; use Osint; with Osint; use Osint;
...@@ -37,6 +36,7 @@ with Scn; use Scn; ...@@ -37,6 +36,7 @@ with Scn; use Scn;
with Sinput.L; use Sinput.L; with Sinput.L; use Sinput.L;
with Stringt; use Stringt; with Stringt; use Stringt;
with Table; with Table;
with Types; use Types;
package body Prepcomp is package body Prepcomp is
...@@ -69,7 +69,7 @@ package body Prepcomp is ...@@ -69,7 +69,7 @@ package body Prepcomp is
type Preproc_Data is record type Preproc_Data is record
Mapping : Symbol_Table.Instance; Mapping : Symbol_Table.Instance;
File_Name : Name_Id := No_Name; File_Name : File_Name_Type := No_File;
Deffile : String_Id := No_String; Deffile : String_Id := No_String;
Undef_False : Boolean := False; Undef_False : Boolean := False;
Always_Blank : Boolean := False; Always_Blank : Boolean := False;
...@@ -82,7 +82,7 @@ package body Prepcomp is ...@@ -82,7 +82,7 @@ package body Prepcomp is
No_Preproc_Data : constant Preproc_Data := No_Preproc_Data : constant Preproc_Data :=
(Mapping => No_Mapping, (Mapping => No_Mapping,
File_Name => No_Name, File_Name => No_File,
Deffile => No_String, Deffile => No_String,
Undef_False => False, Undef_False => False,
Always_Blank => False, Always_Blank => False,
...@@ -295,7 +295,7 @@ package body Prepcomp is ...@@ -295,7 +295,7 @@ package body Prepcomp is
if Current_Data.File_Name = if Current_Data.File_Name =
Preproc_Data_Table.Table (Index).File_Name Preproc_Data_Table.Table (Index).File_Name
then then
Error_Msg_Name_1 := Current_Data.File_Name; Error_Msg_File_1 := Current_Data.File_Name;
Error_Msg Error_Msg
("multiple preprocessing data for{", Token_Ptr); ("multiple preprocessing data for{", Token_Ptr);
OK := False; OK := False;
...@@ -544,7 +544,7 @@ package body Prepcomp is ...@@ -544,7 +544,7 @@ package body Prepcomp is
-- Record Current_Data -- Record Current_Data
if Current_Data.File_Name = No_Name then if Current_Data.File_Name = No_File then
Default_Data := Current_Data; Default_Data := Current_Data;
else else
...@@ -561,6 +561,7 @@ package body Prepcomp is ...@@ -561,6 +561,7 @@ package body Prepcomp is
if Total_Errors_Detected > T then if Total_Errors_Detected > T then
Errout.Finalize; Errout.Finalize;
Errout.Output_Messages;
Fail ("errors found in preprocessing data file """, Fail ("errors found in preprocessing data file """,
Get_Name_String (N), Get_Name_String (N),
""""); """");
...@@ -648,8 +649,9 @@ package body Prepcomp is ...@@ -648,8 +649,9 @@ package body Prepcomp is
String_To_Name_Buffer (Current_Data.Deffile); String_To_Name_Buffer (Current_Data.Deffile);
declare declare
N : constant Name_Id := Name_Find; N : constant File_Name_Type := Name_Find;
Deffile : constant Source_File_Index := Load_Definition_File (N); Deffile : constant Source_File_Index :=
Load_Definition_File (N);
Add_Deffile : Boolean := True; Add_Deffile : Boolean := True;
T : constant Nat := Total_Errors_Detected; T : constant Nat := Total_Errors_Detected;
...@@ -686,6 +688,7 @@ package body Prepcomp is ...@@ -686,6 +688,7 @@ package body Prepcomp is
if T /= Total_Errors_Detected then if T /= Total_Errors_Detected then
Errout.Finalize; Errout.Finalize;
Errout.Output_Messages;
Fail ("errors found in definition file """, Fail ("errors found in definition file """,
Get_Name_String (N), Get_Name_String (N),
""""); """");
......
gcc/ada/prepcomp.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2002-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -26,7 +26,7 @@ ...@@ -26,7 +26,7 @@
-- This package stores all preprocessing data for the compiler -- This package stores all preprocessing data for the compiler
with Types; use Types; with Namet; use Namet;
package Prepcomp is package Prepcomp is
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment