diff options
Diffstat (limited to 'src/grt/grt-errors.adb')
| -rw-r--r-- | src/grt/grt-errors.adb | 253 |
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 0000000..eddea38 --- /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; |