First import from sources

1 files changed, 225 insertions, 0 deletions

diff --git a/translate/grt/grt-errors.adb b/translate/grt/grt-errors.adb
new file mode 100644
index 0000000..4a6aca8
--- /dev/null
+++ b/translate/grt/grt-errors.adb
@@ -0,0 +1,225 @@
+--  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;