mirror of
https://github.com/AdaCore/PolyORB.git
synced 2026-02-12 13:01:15 -08:00
124 lines
3.0 KiB
Ada
124 lines
3.0 KiB
Ada
with Ada.Command_Line; use Ada.Command_Line;
|
|
|
|
with Output; use Output;
|
|
with Namet; use Namet;
|
|
|
|
package body Errors is
|
|
|
|
procedure Check_Space;
|
|
-- Check there is a trailing space in order to append a string to
|
|
-- name buffer.
|
|
|
|
-----------------
|
|
-- Check_Space --
|
|
-----------------
|
|
|
|
procedure Check_Space is
|
|
begin
|
|
if Name_Len > 0 and then Name_Buffer (Name_Len) /= ' ' then
|
|
Add_Char_To_Name_Buffer (' ');
|
|
end if;
|
|
end Check_Space;
|
|
|
|
-------------------
|
|
-- Display_Error --
|
|
-------------------
|
|
|
|
procedure Display_Error (S : String; K : Error_Kind := K_Error)
|
|
is
|
|
L : Natural := 1;
|
|
I : Natural := 1;
|
|
N : Natural := 1;
|
|
M : Boolean := False; -- Meta-character
|
|
J : Natural := S'First;
|
|
begin
|
|
if K = K_Error then
|
|
N_Errors := N_Errors + 1;
|
|
elsif K = K_Warning then
|
|
N_Warnings := N_Warnings + 1;
|
|
end if;
|
|
|
|
if Error_Loc (L) = No_Location then
|
|
Set_Str_To_Name_Buffer (Command_Name);
|
|
else
|
|
Set_Str_To_Name_Buffer (Image (Error_Loc (L)));
|
|
end if;
|
|
L := L + 1;
|
|
Add_Str_To_Name_Buffer (": ");
|
|
|
|
while J <= S'Last loop
|
|
|
|
-- Escape meta-character
|
|
|
|
if S (J) = '|' then
|
|
if J < S'Last then
|
|
J := J + 1;
|
|
end if;
|
|
Add_Char_To_Name_Buffer (S (J));
|
|
|
|
elsif S (J) = '%' then
|
|
Check_Space;
|
|
Get_Name_String_And_Append (Error_Name (N));
|
|
N := N + 1;
|
|
M := True;
|
|
|
|
elsif S (J) = '#' then
|
|
Check_Space;
|
|
Add_Char_To_Name_Buffer ('"'); -- "
|
|
Get_Name_String_And_Append (Error_Name (N));
|
|
Add_Char_To_Name_Buffer ('"'); -- "
|
|
N := N + 1;
|
|
M := True;
|
|
|
|
elsif S (J) = '!' then
|
|
if L = 1 then
|
|
Add_Str_To_Name_Buffer (Image (Error_Loc (1)));
|
|
|
|
elsif Error_Loc (1).File = Error_Loc (L).File then
|
|
Check_Space;
|
|
Add_Str_To_Name_Buffer ("at line ");
|
|
Add_Nat_To_Name_Buffer (Error_Loc (L).Line);
|
|
|
|
else
|
|
Check_Space;
|
|
Add_Str_To_Name_Buffer ("in ");
|
|
Add_Str_To_Name_Buffer (Image (Error_Loc (1)));
|
|
end if;
|
|
L := L + 1;
|
|
M := True;
|
|
|
|
elsif S (J) = '$' then
|
|
Add_Nat_To_Name_Buffer (Error_Int (I));
|
|
I := I + 1;
|
|
M := False;
|
|
|
|
else
|
|
if M then
|
|
Add_Char_To_Name_Buffer (' ');
|
|
M := False;
|
|
end if;
|
|
Add_Char_To_Name_Buffer (S (J));
|
|
end if;
|
|
|
|
J := J + 1;
|
|
end loop;
|
|
Set_Standard_Error;
|
|
Write_Line (Name_Buffer (1 .. Name_Len));
|
|
Set_Standard_Output;
|
|
|
|
Initialize;
|
|
end Display_Error;
|
|
|
|
----------------
|
|
-- Initialize --
|
|
----------------
|
|
|
|
procedure Initialize is
|
|
begin
|
|
Error_Loc := (others => No_Location);
|
|
Error_Name := (others => No_Name);
|
|
Error_Int := (others => 0);
|
|
end Initialize;
|
|
|
|
end Errors;
|