1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163 | with Ada.Command_Line;
with GNAT.OS_Lib;
package body Rx.Debug is
-------------
-- Bailout --
-------------
procedure Bailout (Exit_Code : Integer := 0) is
begin
GNAT.OS_Lib.OS_Exit (Exit_Code);
end Bailout;
------------
-- Tracer --
------------
protected Tracer is
procedure Put_Line (S : String);
end Tracer;
protected body Tracer is
procedure Put_Line (S : String) is
begin
Gnat.IO.Put_Line (S);
end Put_Line;
end Tracer;
type Tracing_States is (Off, Unknown, On);
Tracing : Tracing_States := Unknown with Atomic;
-------------------
-- Check_Tracing --
-------------------
procedure Check_Tracing is
use Ada.Command_Line;
begin
Tracing := Off;
for I in 1 .. Argument_Count loop
if Argument (I) = "-vvv" then
Tracing := On;
end if;
end loop;
end Check_Tracing;
----------
-- Head --
----------
function Head (S : String; Sep : Character := ' ') return String is
begin
for I in S'Range loop
if S (I) = Sep then
return S (S'First .. I - 1);
end if;
end loop;
return S;
end Head;
-----------
-- Trace --
-----------
procedure Trace (S : String; Prefix : String := GNAT.Source_Info.Source_Location) is
begin
if Tracing = Unknown then
Check_Tracing;
end if;
-- Trace when either log level demands it, or command-line -vvv given
pragma Warnings (Off);
if Level > Impl and then Tracing = On then
declare
Line : constant String := "trace: " & S & " @ " & Head (Prefix);
begin
if Serialize_Trace then
Tracer.Put_Line (Line);
else
Put_Line (Line);
end if;
end;
end if;
if Level = Impl then
Log (S & " @ " & Head (Prefix), Impl);
end if;
pragma Warnings (On);
end Trace;
procedure Trace (E : Ada.Exceptions.Exception_Occurrence;
Msg : String) is
begin
Trace ("---8<---Exception dump---8<---");
Trace (Msg);
Trace (Ada.Exceptions.Exception_Name (E));
Trace (Ada.Exceptions.Exception_Message (E));
Trace (Ada.Exceptions.Exception_Information (E));
Trace ("---8<---Exception end----8<---");
end Trace;
---------
-- Log --
---------
procedure Log (S : String; Level : Levels) is
begin
pragma Warnings (Off);
if Level >= Debug.Level then
Put_Line ("debug [" & Level'Img & "]: " & S);
end if;
pragma Warnings (On);
end Log;
--------------
-- Put_Line --
--------------
procedure Put_Line (I : Rx_Integer) is
begin
Put_Line (I'Img);
end Put_Line;
-----------
-- Print --
-----------
procedure Print (E : Ada.Exceptions.Exception_Occurrence) is
begin
Put_Line ("---8<---Exception dump---8<---");
Put_Line (Ada.Exceptions.Exception_Name (E));
Put_Line (Ada.Exceptions.Exception_Message (E));
Put_Line (Ada.Exceptions.Exception_Information (E));
Put_Line ("---8<---Exception end----8<---");
end Print;
------------
-- Report --
------------
procedure Report (E : Ada.Exceptions.Exception_Occurrence;
Msg : String;
Level : Levels := Error;
Reraise : Boolean := False)
is
begin
Log (Msg, Level);
Log (Ada.Exceptions.Exception_Name (E), Level);
Log (Ada.Exceptions.Exception_Message (E), Level);
Log (Ada.Exceptions.Exception_Information (E), Level);
if Reraise then
Log ("Reraising", Level);
Ada.Exceptions.Reraise_Occurrence (E);
end if;
end Report;
end Rx.Debug;
|