Move files and dirs from translate/

1 files changed, 253 insertions, 0 deletions

diff --git a/src/grt/grt-errors.adb b/src/grt/grt-errors.adb
new file mode 100644
index 000000000..eddea38c1
--- /dev/null
+++ b/src/grt/grt-errors.adb
@@ -0,0 +1,253 @@
+--  GHDL Run Time (GRT) - Error handling.
+--  Copyright (C) 2002 - 2014 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.
+--
+--  As a special exception, if other files instantiate generics from this
+--  unit, or you link this unit with other files to produce an executable,
+--  this unit does not by itself cause the resulting executable to be
+--  covered by the GNU General Public License. This exception does not
+--  however invalidate any other reasons why the executable file might be
+--  covered by the GNU Public License.
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Options; use Grt.Options;
+with Grt.Hooks; use Grt.Hooks;
+
+package body Grt.Errors is
+   --  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
+      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 Exit_Simulation is
+   begin
+      Maybe_Return_Via_Longjump (-2);
+      Internal_Error ("exit_simulation");
+   end Exit_Simulation;
+
+   procedure Fatal_Error is
+   begin
+      if Error_Hook /= null then
+         --  Call the hook, but avoid infinite loop by reseting it.
+         declare
+            Current_Hook : constant Proc_Hook_Type := Error_Hook;
+         begin
+            Error_Hook := null;
+            Current_Hook.all;
+         end;
+      end if;
+      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 : constant 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 Report_E (Str : Std_String_Ptr)
+   is
+      subtype Ada_Str is String (1 .. Natural (Str.Bounds.Dim_1.Length));
+   begin
+      if Ada_Str'Length > 0 then
+         Put_Err (Ada_Str (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1)));
+      end if;
+      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 : constant 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_C_Std (Str : Std_String_Uncons)
+   is
+      subtype Str_Subtype is String (1 .. Str'Length);
+   begin
+      Error_C (Str_Subtype (Str));
+   end Error_C_Std;
+
+   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;