diff options
Diffstat (limited to 'translate/grt/grt-errors.adb')
| -rw-r--r-- | translate/grt/grt-errors.adb | 253 |
1 files changed, 0 insertions, 253 deletions
diff --git a/translate/grt/grt-errors.adb b/translate/grt/grt-errors.adb deleted file mode 100644 index eddea38..0000000 --- a/translate/grt/grt-errors.adb +++ /dev/null @@ -1,253 +0,0 @@ --- 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; |