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
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225 | with Ada.Task_Identification;
with Agpl.Chronos; pragma Elaborate_All (Agpl.Chronos);
with Agpl.Trace; use Agpl.Trace;
with Gdk.Threads;
with Gtk.Main;
with Gtk.Widget; use Gtk.Widget;
with System;
package body Agpl.Gdk.Managed is
use Widget_List;
Started : Boolean := False;
pragma Atomic (Started);
Gtk_Thread_Id : Ada.Task_Identification.Task_Id :=
Ada.Task_Identification.Null_Task_Id;
pragma Atomic (Gtk_Thread_Id);
-------------------
-- In_Gtk_Thread --
-------------------
function In_Gtk_Thread return Boolean is
use Ada.Task_Identification;
begin
return Ada.Task_Identification.Current_Task = Gtk_Thread_Id;
end In_Gtk_Thread;
task Gtk_Task is
entry Start;
entry Execute (This : in out Gtk_Code'Class; OK : out Boolean);
-- Dispatch on This.Execute inside the Gtk thread.
end Gtk_Task;
-----------------------
-- Glade_Autoconnect --
-----------------------
-- procedure Glade_Autoconnect (Xml : Glade.XML.Glade_XML) is
-- procedure Glade_Connect (X : System.Address);
-- pragma Import (C, Glade_Connect, "glade_xml_signal_autoconnect");
-- procedure Internal is
-- begin
-- Glade_Connect (Xml.Get_Object);
-- end Internal;
-- begin
-- Execute (Internal'Access);
-- end Glade_Autoconnect;
procedure GtkBuilder_Connect (Builder : Gtkada_Builder;
Data : access User_Data) is
procedure Internal (Builder : System.Address;
Data : access User_Data) with
Import,
Convention => C,
External_Name => "gtk_builder_connect_signals";
begin
Internal (Builder.all'Address, Data);
pragma Untested ("The above line is most likely a bomb");
end GtkBuilder_Connect;
procedure GtkBuilder_Connect_Void (Builder : Gtkada_Builder) is
type Void is null record;
procedure Internal is new GtkBuilder_Connect (Void);
begin
Internal (Builder, null);
end GtkBuilder_Connect_Void;
--------------------
-- Execute_In_Gtk --
--------------------
procedure Execute_In_Gtk (This : in out Gtk_Code'Class) is
use type Ada.Task_Identification.Task_Id;
OK : Boolean;
begin
while not Started loop
delay 0.1;
end loop;
-- Avoid re-entering task and thus deadlock.
if Ada.Task_Identification.Current_Task = Gtk_Thread_Id then
Log ("Executing in current thread...", Debug, Det_Section);
This.Execute;
Log ("Executing in current thread... DONE", Debug, Det_Section);
else
Log ("Executing in GTK thread...", Debug, Det_Section);
select
Gtk_Task.Start;
else
null;
end select;
Gtk_Task.Execute (This, OK);
Log ("Executing in GTK thread... DONE", Debug, Det_Section);
if not OK then
raise Program_Error with "GTK execution was aborted";
end if;
end if;
exception
when E : others =>
Log ("Managed.Execute_in_Gtk: " & Report (E), Error, Log_Section);
end Execute_In_Gtk;
-------------
-- Execute --
-------------
procedure Execute (Code : access procedure) is
type Local_Code (Code : access procedure) is
new Gtk_Code with null record;
procedure Execute (X : in out Local_Code) is
begin
X.Code.all;
end Execute;
L : Local_Code (Code);
begin
Execute_In_Gtk (L);
end Execute;
--------------
-- Gtk_Task --
--------------
task body Gtk_Task is
----------
-- Init --
----------
procedure Init is
begin
-- Standard.Gtk.Main.Set_Locale; -- Was obsolescent
Standard.Gtk.Main.Init;
Standard.Gdk.Threads.G_Init;
Standard.Gdk.Threads.Init;
end Init;
---------------------
-- Event_Iteration --
---------------------
procedure Event_Iteration is
begin
Standard.Gdk.Threads.Enter;
while Standard.Gtk.Main.Events_Pending loop
begin
if Standard.Gtk.Main.Main_Iteration then
null;
end if;
exception
when E : others =>
Log ("Managed.Gtk_Task.Event_Iteration: " & Report (E),
Error, Log_Section);
end;
end loop;
Standard.Gdk.Threads.Leave;
end Event_Iteration;
begin
Started := True;
Gtk_Thread_Id := Ada.Task_Identification.Current_Task;
select
accept Start;
or
terminate;
end select;
Init;
Log ("Gtk_Task [managed]: Running...", Debug, Log_Section);
loop
begin
-- Execute codes
select
accept Execute (This : in out Gtk_Code'Class;
OK : out Boolean) do
Standard.Gdk.Threads.Enter;
select
delay 10.0;
Log ("Gtk_Task: Aborted managed code (too long): " &
External_Tag (This'Tag),
Warning, Log_Section);
OK := False;
then abort
declare
Timer : Agpl.Chronos.Object;
begin
This.Execute;
OK := True;
if Timer.Elapsed > 5.0 then
Log ("Managed.Gtk_Task.Execute: Long processing: " &
Timer.Image, Warning, Log_Section);
end if;
exception
when E : others =>
Log ("Managed.Gtk_Task.Execute: " & Report (E),
Error, Log_Section);
end;
end select;
Standard.Gdk.Threads.Leave;
end Execute;
or
delay 0.01;
end select;
-- Process events
Event_Iteration;
exception
when E : others =>
Log ("Gtk_Task.Event_Iteration: " & Report (E),
Error, Log_Section);
delay 0.01; -- Prevent possible CPU hog.
end;
end loop;
end Gtk_Task;
end Agpl.Gdk.Managed;
|