diff options
Diffstat (limited to 'translate/grt/grt-errors.adb')
| -rw-r--r-- | translate/grt/grt-errors.adb | 225 |
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 000000000..4a6aca83c --- /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; |