--  GHDL Run Time (GRT) - Error handling.--  Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold----  GHDL is free software; you can redistribute it and/or modify it under--  the terms of the GNU General Public License as published by the Free--  Software Foundation; either version 2, or (at your option) any later--  version.----  GHDL is distributed in the hope that it will be useful, but WITHOUT 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--  along with GCC; see the file COPYING.  If not, write to the Free--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA--  02111-1307, USA.with Grt.Stdio; use Grt.Stdio;with Grt.Astdio; use Grt.Astdio;with Grt.Types; use Grt.Types;with Grt.Options; use Grt.Options;package body Grt.Errors is   procedure Fatal_Error;   pragma No_Return (Fatal_Error);   pragma Export (C, Fatal_Error, "__ghdl_fatal");   --  Called in case of premature exit.   --  CODE is 0 for success, 1 for failure.   procedure Ghdl_Exit (Code : Integer);   pragma No_Return (Ghdl_Exit);   procedure Ghdl_Exit (Code : Integer)   is      procedure C_Exit (Status : Integer);      pragma Import (C, C_Exit, "exit");      pragma No_Return (C_Exit);   begin      if Ghdl_Exit_Cb1 /= null then         Ghdl_Exit_Cb1.all (Code);      end if;      if Ghdl_Exit_Cb /= null then         Ghdl_Exit_Cb.all (Code);      end if;      C_Exit (Code);   end Ghdl_Exit;   procedure Maybe_Return_Via_Longjump (Val : Integer);   pragma Import (C, Maybe_Return_Via_Longjump,                  "__ghdl_maybe_return_via_longjump");   procedure Fatal_Error is   begin      Maybe_Return_Via_Longjump (-1);      if Expect_Failure then         Ghdl_Exit (0);      else         Ghdl_Exit (1);      end if;   end Fatal_Error;   procedure Put_Err (Str : String) is   begin      Put (stderr, Str);   end Put_Err;   procedure Put_Err (Str : Ghdl_C_String) is   begin      Put (stderr, Str);   end Put_Err;   procedure Put_Err (N : Integer) is   begin      Put_I32 (stderr, Ghdl_I32 (N));   end Put_Err;   procedure Newline_Err is   begin      New_Line (stderr);   end Newline_Err;--    procedure Put_Err (Str : Ghdl_Str_Len_Type)--    is--       S : String (1 .. 3);--    begin--       if Str.Str = null then--          S (1) := ''';--          S (2) := Character'Val (Str.Len);--          S (3) := ''';--          Put_Err (S);--       else--          Put_Err (Str.Str (1 .. Str.Len));--       end if;--    end Put_Err;   procedure Report_H (Str : String := "") is   begin      Put_Err (Str);   end Report_H;   procedure Report_C (Str : String) is   begin      Put_Err (Str);   end Report_C;   procedure Report_C (Str : Ghdl_C_String)   is      Len : Natural := strlen (Str);   begin      Put_Err (Str (1 .. Len));   end Report_C;   procedure Report_C (N : Integer)     renames Put_Err;   procedure Report_Now_C is   begin      Put_Time (stderr, Grt.Types.Current_Time);   end Report_Now_C;   procedure Report_E (Str : String) is   begin      Put_Err (Str);      Newline_Err;   end Report_E;   procedure Error_H is   begin      Put_Err (Progname);      Put_Err (":error: ");   end Error_H;   Cont : Boolean := False;   procedure Error_C (Str : String) is   begin      if not Cont then         Error_H;         Cont := True;      end if;      Put_Err (Str);   end Error_C;   procedure Error_C (Str : Ghdl_C_String)   is      Len : Natural := strlen (Str);   begin      if not Cont then         Error_H;         Cont := True;      end if;      Put_Err (Str (1 .. Len));   end Error_C;   procedure Error_C (N : Integer) is   begin      if not Cont then         Error_H;         Cont := True;      end if;      Put_Err (N);   end Error_C;--    procedure Error_C (Inst : Ghdl_Instance_Name_Acc)--    is--    begin--       if not Cont then--          Error_H;--          Cont := True;--       end if;--       if Inst.Parent /= null then--          Error_C (Inst.Parent);--          Put_Err (".");--       end if;--       case Inst.Kind is--          when Ghdl_Name_Architecture =>--             Put_Err ("(");--             Put_Err (Inst.Name.all);--             Put_Err (")");--          when others =>--             if Inst.Name /= null then--                Put_Err (Inst.Name.all);--             end if;--       end case;--    end Error_C;   procedure Error_E (Str : String) is   begin      Put_Err (Str);      Newline_Err;      Cont := False;      Fatal_Error;   end Error_E;   procedure Error (Str : String) is   begin      Error_H;      Put_Err (Str);      Newline_Err;      Fatal_Error;   end Error;   procedure Info (Str : String) is   begin      Put_Err (Progname);      Put_Err (":info: ");      Put_Err (Str);      Newline_Err;   end Info;   procedure Internal_Error (Msg : String) is   begin      Put_Err (Progname);      Put_Err (":internal error: ");      Put_Err (Msg);      Newline_Err;      Fatal_Error;   end Internal_Error;   procedure Grt_Overflow_Error is   begin      Error ("overflow detected");   end Grt_Overflow_Error;end Grt.Errors;