aicwl_3.24.1_73939c9e/sources/gtk-main-router.adb

   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
 226
 227
 228
 229
 230
 231
 232
 233
 234
 235
 236
 237
 238
 239
 240
 241
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252
 253
 254
 255
 256
 257
 258
 259
 260
 261
 262
 263
 264
 265
 266
 267
 268
 269
 270
 271
 272
 273
 274
 275
 276
 277
 278
 279
 280
 281
 282
 283
 284
 285
 286
 287
 288
 289
 290
 291
 292
 293
 294
 295
 296
 297
 298
 299
 300
 301
 302
 303
 304
 305
 306
 307
 308
 309
 310
 311
 312
 313
 314
 315
 316
 317
 318
 319
 320
 321
 322
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359
 360
 361
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374
 375
 376
 377
 378
 379
 380
 381
 382
 383
 384
 385
 386
 387
 388
 389
 390
 391
 392
 393
 394
 395
 396
 397
 398
 399
 400
 401
 402
 403
 404
 405
 406
 407
 408
 409
 410
 411
 412
 413
 414
 415
 416
 417
 418
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429
 430
 431
 432
 433
 434
 435
 436
 437
 438
 439
 440
 441
 442
 443
 444
 445
 446
 447
 448
 449
 450
 451
 452
 453
 454
 455
 456
 457
 458
 459
 460
 461
 462
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472
 473
 474
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516
 517
 518
 519
 520
 521
 522
 523
 524
 525
 526
 527
 528
 529
 530
 531
 532
 533
 534
 535
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552
 553
 554
 555
 556
 557
 558
 559
 560
 561
 562
 563
 564
 565
 566
 567
 568
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
--                                                                    --
--  package Gtk.Main.Router         Copyright (c)  Dmitry A. Kazakov  --
--  Implementation                                 Luebeck            --
--                                                 Spring, 2006       --
--                                                                    --
--                                Last revision :  13:14 14 Sep 2019  --
--                                                                    --
--  This  library  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  of  --
--  the License, or (at your option) any later version. This library  --
--  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  --
--  this library; if not, write to  the  Free  Software  Foundation,  --
--  Inc., 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 Ada.Characters.Handling;  use Ada.Characters.Handling;
with Ada.Characters.Latin_1;   use Ada.Characters.Latin_1;
with Ada.Streams;              use Ada.Streams;
with Ada.Strings.Fixed;        use Ada.Strings.Fixed;
with Ada.Strings.Unbounded;    use Ada.Strings.Unbounded;
with Ada.Task_Identification;  use Ada.Task_Identification;
with Gdk.Color.IHLS;           use Gdk.Color.IHLS;
with GLib.Main;                use GLib.Main;
with GLib.Messages;            use GLib.Messages;
with GLib.Values;              use GLib.Values;
with GNAT.Sockets;             use GNAT.Sockets;
with GNAT.Traceback;           use GNAT.Traceback;
with GNAT.Traceback.Symbolic;  use GNAT.Traceback.Symbolic;
with Gtk.Box;                  use Gtk.Box;
with Gtk.Button;               use Gtk.Button;
with Gtk.Check_Button;         use Gtk.Check_Button;
with Gtk.Clipboard;            use Gtk.Clipboard;
with Gtk.Dialog;               use Gtk.Dialog;
with Gtk.Image;                use Gtk.Image;
with Gtk.Image_Menu_Item;      use Gtk.Image_Menu_Item;
with Gtk.Label;                use Gtk.Label;
with Gtk.Menu;                 use Gtk.Menu;
with Gtk.Missed;               use Gtk.Missed;
with Gtk.Scrolled_Window;      use Gtk.Scrolled_Window;
with Gtk.Style_Context;        use Gtk.Style_Context;
with Gtk.Text_Buffer;          use Gtk.Text_Buffer;
with Gtk.Text_Iter;            use Gtk.Text_Iter;
with Gtk.Text_Tag;             use Gtk.Text_Tag;
with Gtk.Text_View;            use Gtk.Text_View;
with Gtk.Widget;               use Gtk.Widget;
with Pango.Font;               use Pango.Font;
with System;                   use System;
with System.Storage_Elements;  use System.Storage_Elements;

with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with Gtk.Handlers;

package body Gtk.Main.Router is
--
-- Gateway_State -- The  state  of  the  protected  object   controlling
--                  interaction between the main loop task  and  an  Ada
-- task  requesting  servicing.  The following diagram illustrates state
-- transitions upon a request.
--
--        main loop                   task
--           :                          |
--           :                          |__
--        sleeping                         | Request_Service (data)
--           :                             |
--  timer -->|                           __|
--           |__                        :
--              | Initiate_Service      :
--              | Service (data)     waiting
--              | Complete_Service -->  :
--            __|                       :__
--           |                            | Serviced
--           :                 <--------- |
--        sleeping                     .__|
--           :                         |
--
   Queue_Size    : constant        := 100;
   Max_Recursion : constant        := 100;
   GPS_Prompt    : constant String := "GPS>> ";
   GPS_Port      : Natural         := 50_000;
   Connected     : Boolean         := Standard.False;
   Recursion     : Natural         := 0;
   Window_X      : GInt            := 0;
   Window_Y      : GInt            := 0;
   Parent        : Gtk_Window      := null;
   Main          : Task_ID         := Null_Task_ID;
   Trace_Dialog  : Gtk_Dialog;
   Channel       : Socket_Type;
   Command       : Unbounded_String;

   function Where (Text : String) return String is
   begin
      return " in Gtk.Main.Router." & Text;
   end Where;

   function Get_Parent (Window : Gtk_Window := null)
      return Gtk_Window is
   begin
      if Window = null then
         return Parent;
      else
         return Window;
      end if;
   end Get_Parent;

   package Window_Callback is
      new Gtk.Handlers.Callback (Gtk_Window_Record);
   procedure On_Quit (Window : access Gtk_Window_Record'Class);

   type Request_State is
        (  Request_Unused,
           Request_Pending,
           Request_Serviced,
           Request_Failed,
           Request_Successful
        );
   type Request_Item;
   type Request_Item_Ptr is access all Request_Item;
   type Request_Item is limited record
      Previous    : Request_Item_Ptr := Request_Item'Unchecked_Access;
      Next        : Request_Item_Ptr := Request_Item'Unchecked_Access;
      State       : Request_State    := Request_Unused;
      Fault       : Exception_Occurrence;
      Synchronous : Boolean;
      Data        : Request_Data_Ptr;
   end record;

   function Get (Head : Request_Item) return Request_Item_Ptr;
   pragma Inline (Get);
   procedure Insert (Head : Request_Item; Item : Request_Item_Ptr);
   pragma Inline (Insert);
   function Length (Head : Request_Item) return Natural;
   pragma Inline (Length);

   function Get (Head : Request_Item) return Request_Item_Ptr is
      Self : constant Request_Item_Ptr := Head.Next.Previous;
   begin
      if Head.Next = Self then -- Empty
         return null;
      else
         declare
            Item : constant Request_Item_Ptr := Head.Next;
         begin
            Self.Next          := Item.Next;
            Item.Next.Previous := Self;
            Item.Next          := Item;
            Item.Previous      := Item;
            return Item;
         end;
      end if;
   end Get;

   procedure Insert (Head : Request_Item; Item : Request_Item_Ptr) is
      Self : constant Request_Item_Ptr := Head.Next.Previous;
   begin
      Item.Next.Previous := Item.Previous;
      Item.Previous.Next := Item.Next;
      Item.Previous      := Self.Previous;
      Item.Next          := Self;
      Item.Next.Previous := Item;
      Item.Previous.Next := Item;
   end Insert;

   function Length (Head : Request_Item) return Natural is
      This  : Request_Item_Ptr := Head.Next;
      Self  : constant Request_Item_Ptr := This.Previous;
      Count : Natural := 0;
   begin
      while This /= Self loop
         Count := Count + 1;
         This  := This.Next;
      end loop;
      return Count;
   end Length;

   protected Gateway is
      procedure Abort_Service
                (  Item  : in out Request_Item_Ptr;
                   Error : Exception_Occurrence
                );
      procedure Allocated_New;
      procedure Clean_Up         (Item : out Request_Item_Ptr);
      procedure Complete_Service (Item : in out Request_Item_Ptr);
      procedure Get_Free_Item    (Item : out Request_Item_Ptr);
      function Get_Max_Async return Positive;
      function Get_Request_Info return String;
      function Is_Quitted return Boolean;
      procedure Initiate_Service (Item : out Request_Item_Ptr);
      entry Request_Asynchronous (Item : Request_Item_Ptr);
      entry Request_Synchronous  (Item : in out Request_Item_Ptr);
      procedure Set_Max_Async (Max : Positive);
      procedure Quit;
   private
      entry Serviced (Boolean) (Item : in out Request_Item_Ptr);
      Quitted   : Boolean  := Standard.False;
      Current   : Boolean  := Standard.False;
      Async     : Natural  := 0;   -- Number of asynchronous requests
      Max_Async : Positive := 100; -- Maximum number of such requests
      Allocated : Natural  := 0;   -- Total allocated items
      Queued    : aliased Request_Item;
      Ready     : aliased Request_Item;
      Free      : aliased Request_Item;
   end Gateway;
--
-- Callback -- Called from the main loop on timer events
--
   function Callback return Boolean is
      Item : Request_Item_Ptr;
   begin
      loop
         Gateway.Initiate_Service (Item);
         exit when Item = null;
         begin
            if Recursion < Max_Recursion then
               Recursion := Recursion + 1;
               begin
                  Service (Item.Data.all);
                  Recursion := Recursion - 1;
               exception
                  when others =>
                     Recursion := Recursion - 1;
                     raise;
               end;
            end if;
            Gateway.Complete_Service (Item);
         exception
            when Error : others =>
               Gateway.Abort_Service (Item, Error);
         end;
      end loop;
      return Standard.True;
   end Callback;

   protected body Gateway is

      procedure Abort_Service
                (  Item  : in out Request_Item_Ptr;
                   Error : Exception_Occurrence
                )  is
      begin
         if Item.Synchronous then
            Item.State := Request_Failed;
            Save_Occurrence (Item.Fault, Error);
            Insert (Ready, Item);
            Current := not Current;
         else
            Item.State := Request_Unused;
            Insert (Free, Item);
            Async := Async - 1;
         end if;
      end Abort_Service;

      procedure Allocated_New is
      begin
         Allocated := Allocated + 1;
      end Allocated_New;

      procedure Clean_Up (Item : out Request_Item_Ptr) is
      begin
         Item := Get (Ready);
         if Item = null then
            Item := Get (Free);
         end if;
      end Clean_Up;

      procedure Complete_Service (Item : in out Request_Item_Ptr) is
      begin
         if Item.Synchronous then
            Item.State := Request_Successful;
            Insert (Ready, Item);
            Current := not Current;
         else
            Item.State := Request_Unused;
            Insert (Free, Item);
            Async := Async - 1;
         end if;
      end Complete_Service;

      procedure Get_Free_Item (Item : out Request_Item_Ptr) is
      begin
         Item := Get (Free);
      end Get_Free_Item;

      function Get_Max_Async return Positive is
      begin
         return Max_Async;
      end Get_Max_Async;

      function Get_Request_Info return String is
         function Is_Quitted return String is
         begin
            if Quitted then
               return " [quitted]";
            else
               return "";
            end if;
         end Is_Quitted;
      begin
         return
         (  "requests: pending" & Integer'Image (Length (Queued))
         &  ", ready"           & Integer'Image (Length (Ready ))
         &  ", free"            & Integer'Image (Length (Free  ))
         &  ", allocated"       & Integer'Image (Allocated)
         &  ", max async"       & Integer'Image (Max_Async)
         &  Is_Quitted
         );
      end Get_Request_Info;

      procedure Initiate_Service (Item : out Request_Item_Ptr) is
      begin
         Item := Get (Queued);
      end Initiate_Service;

      function Is_Quitted return Boolean is
      begin
         return Quitted;
      end Is_Quitted;

      procedure Quit is
      begin
         Quitted := Standard.True;
      end Quit;

      entry Request_Asynchronous
            (  Item : Request_Item_Ptr
            )  when Async < Max_Async or else Quitted is
      begin
         if Quitted then
            Item.State := Request_Unused;
            Insert (Free, Item);
            raise Quit_Error;
         end if;
         Item.State := Request_Pending;
         Insert (Queued, Item);
         Item.Synchronous := Standard.False;
         Async := Async + 1;
      end Request_Asynchronous;

      entry Request_Synchronous
            (  Item : in out Request_Item_Ptr
            )  when Standard.True is
      begin
         if Quitted then
            Item.State := Request_Unused;
            Insert (Free, Item);
            raise Quit_Error;
         end if;
         Item.State := Request_Pending;
         Insert (Queued, Item);
         Item.Synchronous := Standard.True;
         requeue Serviced (not Current);
      end Request_Synchronous;

      entry Serviced (for Toggle in Boolean)
            (  Item : in out Request_Item_Ptr
            )  when Quitted or else Current = Toggle is
      begin
         if Quitted then
            Item.State := Request_Unused;
            Insert (Free, Item);
            raise Quit_Error;
         else
            case Item.State is
               when Request_Unused =>
                  null;
               when Request_Pending | Request_Serviced =>
                  requeue Serviced (not Current);
               when Request_Failed =>
                  Insert (Free, Item);
                  Reraise_Occurrence (Item.Fault);
               when Request_Successful =>
                  Insert (Free, Item);
            end case;
         end if;
      end Serviced;

      procedure Set_Max_Async (Max : Positive) is
      begin
         Max_Async := Max;
      end Set_Max_Async;

   end Gateway;

   package body Generic_Message is

      procedure Free is
         new Ada.Unchecked_Deallocation
             (  Message_Data,
                Message_Data_Ptr
             );

      package Sources is new Generic_Sources (Message_Data_Ptr);

      function Service (Message : Message_Data_Ptr)
         return Boolean is
         Ptr : Message_Data_Ptr := Message;
      begin
         Message.Handler (Message.Data);
         Free (Ptr);
         return Standard.False;
      exception
         when others =>
            Free (Ptr);
            return Standard.False;
      end Service;

      procedure Send
                (  Handler : Handler_Procedure;
                   Data    : User_Data;
                   Timeout : Duration := 0.5
                )  is
         Message : Message_Data_Ptr := new Message_Data;
         Item    : Request_Item_Ptr;
      begin
         Message.Handler := Handler;
         Message.Data    := Data;
         if Main = Current_Task then
            declare
               ID : G_Source_ID;
            begin
               ID := Sources.Idle_Add (Service'Access, Message);
            end;
         elsif Main = Null_Task_ID then
            raise Program_Error;
         else
            Gateway.Get_Free_Item (Item);
            if Item = null then
               Item := new Request_Item;
               Gateway.Allocated_New;
            end if;
            Item.Synchronous := Standard.False;
            Item.Data        := Message.all'Unchecked_Access;
            select
               Gateway.Request_Asynchronous (Item);
            or delay Timeout;
               raise Busy_Error with
                     "Current state " & Gateway.Get_Request_Info;
            end select;
         end if;
      exception
         when others =>
            Free (Message);
            raise;
      end Send;

      procedure Service (Data : in out Message_Data) is
         Message : Message_Data_Ptr := Data'Unchecked_Access;
      begin
         Message.Handler (Message.Data);
         Free (Message);
      exception
         when Error : others =>
            Log
            (  GtkAda_Contributions_Domain,
               Log_Level_Critical,
               (  Exception_Information (Error)
               &  Where ("Generic_Message.Service")
            )  );
            Free (Message);
      end Service;

   end Generic_Message;
--
-- Connect -- To the GPS
--
-- The  procedure shows a dialog box while connecting to the GPS server.
-- The  dialog box shows connection error message when connection fails.
-- Waiting for connection can be canceled by closing the box.
--
   procedure Connect is
      Dialog  : Gtk_Dialog;
      Message : Unbounded_String;
      Label   : Gtk_Label;
   begin
      Gtk_New
      (  Dialog,
         (  "GPS at "
         &  Host_Name
         &  " port"
         &  Integer'Image (GPS_Port)
         ),
         Get_Parent,
         Destroy_With_Parent + Modal
      );
      Gtk_New (Label, "...connecting...");
      Set_Line_Wrap (Label, Standard.True);
      Pack_Start
      (  Get_Content_Area (Dialog),
         Label,
         Standard.True,
         Standard.True
      );
      declare
         --
         -- An independent timer for a connection  task  to  communicate
         -- with  the  dialog  box.  It  must be independent because the
         -- default timer may be blocked at this point.
         --
         package Timers is new Generic_Sources (Integer);
         --
         -- Connect_To_GPS -- The task connecting to GPS
         --
         task Connect_To_GPS;
         task body Connect_To_GPS is
            Address : Sock_Addr_Type;
         begin
            Connected := Standard.False;
            Create_Socket (Channel);
            Address.Addr := Addresses (Get_Host_By_Name ("localhost"));
            Address.Port := Port_Type (GPS_Port);
            begin
               Connect_Socket (Channel, Address);
               Connected := Standard.True;
            exception
               when Error : Socket_Error =>
                  Append
                  (  Message,
                     (  "Check if GPS is started with the server "
                     &  "option. For example"
                     &  Character'Val (10)
                     &  "  > gps --server="
                     &  Trim
                        (  Integer'Image (GPS_Port),
                           Ada.Strings.Both
                        )
                     &  Character'Val (10)
                     &  Exception_Message (Error)
                  )  );
               when Error : others =>
                  Append (Message, Exception_Information (Error));
            end;
         end Connect_To_GPS;
         --
         -- Connect_Callback -- Timer callback
         --
         -- When the task is terminated, the callback either  shows  the
         -- error message in the dialog box, or else closes it.
         --
         function Connect_Callback (Data : Integer) return Boolean is
         begin
            if Connect_To_GPS'Terminated then
               if Length (Message) = 0 then
                  Response (Dialog, Gtk_Response_OK);
               elsif Label /= null then
                  Label := null;
                  Set_Text (Label, To_String (Message));
               end if;
            end if;
            return Standard.True;
         end Connect_Callback;

         ID    : G_Source_Id;
         Close : Gtk_Button;
      begin
         Close := Add_Button_From_Stock
                  (  Dialog   => Dialog,
                     Response => Gtk_Response_Close,
                     Icon     => Stock_Close,
                     Label    => "_Close",
                     Tip      => "Stop connecting"
                  );
         Close.Set_Can_Default (Standard.True);
         Dialog.Show_All;
         ID := Timers.Timeout_Add
               (  Interval => 50,
                  Func     => Connect_Callback'Access,
                  Data     => 0
               );
         case Run (Dialog) is
            when Gtk_Response_OK => -- Closed on success from the task
               Remove (ID);
            when others =>          -- Closed on error or by user
               Remove (ID);            -- Stop polling
               Close_Socket (Channel); -- Will aboort task if active
               Connected := Standard.False;
         end case;
      end;
      Destroy (Dialog);
   end Connect;

   function Get_Max_Asynchronous return Positive is
   begin
      return Gateway.Get_Max_Async;
   end Get_Max_Asynchronous;

   function Get_Request_Info return String is
   begin
      return Gateway.Get_Request_Info;
   end Get_Request_Info;
--
-- GPS_Read -- Reading GPS connection socket until prompt it received
--
   procedure GPS_Read is
      Buffer : Stream_Element_Array (1..1);
      Byte   : Character;
      From   : Sock_Addr_Type;
      Last   : Stream_Element_Offset;
      Index  : Positive := GPS_Prompt'First;
   begin
      loop
         Receive_Socket (Channel, Buffer, Last, From);
         Byte := Character'Val (Stream_Element'Pos (Buffer (1)));
         if Byte = GPS_Prompt (Index) then
            exit when Index = GPS_Prompt'Last;
            Index := Index + 1;
         elsif Index > GPS_Prompt'First then
            Index := GPS_Prompt'First;
            if Byte = GPS_Prompt (Index) then
               Index := GPS_Prompt'First + 1;
            end if;
         end if;
      end loop;
   end GPS_Read;
--
-- GPS_Send -- Writing into GPS socket
--
--    Command - The GPS command to send
--
   procedure GPS_Send (Command : String) is
      Buffer : Stream_Element_Array (1..Command'Length);
      for Buffer'Address use Command (Command'First)'Address;
      pragma Import (Ada, Buffer);
      Last : Stream_Element_Offset;
   begin
      Send_Socket (Channel, Buffer, Last);
   end GPS_Send;

   procedure Init
             (  Window   : not null access Gtk_Window_Record'Class;
                Period   : Duration := 0.2;
                GPS_Port : Natural  := 50_000
             )  is
   begin
      Gtk.Main.Router.GPS_Port := GPS_Port;
      if Main = Null_Task_ID then
         Main := Current_Task;
         declare
            ID : G_Source_Id;
         begin
            ID := Timeout_Add
                  (  Guint (Float (Period) * 1000.0),
                     Callback'Access
                  );
         end;
         Parent := Window.all'Unchecked_Access;
         Window_Callback.Connect (Window, "destroy", On_Quit'Access);
      end if;
   end Init;

   function Is_Active return Boolean is
   begin
      return not Gateway.Is_Quitted;
   end Is_Active;

   procedure Quit is
   begin
      Gateway.Quit;
   end Quit;

   procedure Request (Data : in out Request_Data'Class) is
   begin
      if Main = Current_Task then
         if Gateway.Is_Quitted then
            raise Quit_Error;
         end if;
         if Recursion < Max_Recursion then
            Recursion := Recursion + 1;
            begin
               Service (Data);
               Recursion := Recursion - 1;
            exception
               when others =>
                  Recursion := Recursion - 1;
                  raise;
            end;
         end if;
      elsif Main = Null_Task_ID then
         Log
         (  GtkAda_Contributions_Domain,
            Log_Level_Critical,
            "No main task active" & Where ("Request")
         );
         raise Program_Error;
      else
         declare
            Item : Request_Item_Ptr;
         begin
            Gateway.Get_Free_Item (Item);
            if Item = null then
               Item := new Request_Item;
               Gateway.Allocated_New;
            end if;
            Item.Data := Data'Unchecked_Access;
            Gateway.Request_Synchronous (Item);
         end;
      end if;
   end Request;

   package body Generic_Callback_Request is

      procedure Request
                (  Callback : Callback_Procedure;
                   Data     : not null access User_Data
                )  is
         Marshaler : Callback_Data (Data);
      begin
         Marshaler.Callback := Callback;
         Request (Marshaler);
      end Request;

      procedure Service (Data : in out Callback_Data) is
      begin
         Data.Callback (Data.Parameters);
      end Service;

   end Generic_Callback_Request;

   type Callback_Request_Data is new Request_Data with record
      Callback : Gtk_Callback;
   end record;
   procedure Service (Data : in out Callback_Request_Data);

   procedure Service (Data : in out Callback_Request_Data) is
   begin
      Data.Callback.all;
   end Service;

   procedure Request (Service : Gtk_Callback) is
      Marshaler : Callback_Request_Data;
   begin
      Marshaler.Callback := Service;
      Request (Marshaler);
   end Request;

   type UTF8_String_Ptr is access all UTF8_String;
   type Say_Data is record
      Message       : UTF8_String_Ptr;
      Title         : UTF8_String_Ptr;
      Mode          : UTF8_String_Ptr;
      Justification : Gtk_Justification;
      Parent        : Gtk_Widget;
   end record;
   package Say_Callback is new Generic_Callback_Request (Say_Data);

   procedure Say (Data : not null access Say_Data) is
      Main : Gtk_Window := Parent;
   begin
      if Data.Parent /= null then
         declare
            Top : Gtk_Widget;
         begin
            Top := Data.Parent.Get_Toplevel;
            if (  Top /= null
               and then
                  Top.all in Gtk_Window_Record'Class
               )
            then
               Main :=
                  Gtk_Window_Record'Class (Top.all)'Unchecked_Access;
            end if;
         end;
      end if;
      Message_Dialog
      (  Message       => Data.Message.all,
         Mode          => Data.Mode.all,
         Title         => Data.Title.all,
         Justification => Data.Justification,
         Parent        => Main
      );
   end Say;

   procedure Say
             (  Message       : UTF8_String;
                Title         : UTF8_String := "";
                Mode          : UTF8_String := Stock_Dialog_Info;
                Justification : Gtk_Justification := Justify_Left;
                Parent        : access Gtk_Widget_Record'Class := null
             )  is
      Message_Text : aliased UTF8_String := Message;
      Title_Text   : aliased UTF8_String := Title;
      Mode_Text    : aliased UTF8_String := Mode;
      Data         : aliased Say_Data;
   begin
      Data.Message := Message_Text'Unchecked_Access;
      Data.Title   := Title_Text'Unchecked_Access;
      Data.Mode    := Mode_Text'Unchecked_Access;
      Data.Justification := Justification;
      if Parent /= null then
         Data.Parent := Parent.all'Unchecked_Access;
      end if;
      Say_Callback.Request (Say'Access, Data'Access);
   end Say;

   procedure Set_Max_Asynchronous (Max : Positive) is
   begin
      Gateway.Set_Max_Async (Max);
   end Set_Max_Asynchronous;

   type Trace_Request (Length : Natural; Break : Boolean) is record
      Text : String (1..Length);
   end record;

   package Trace_Callback is
      new Generic_Callback_Request (Trace_Request);

   package Dialog_Handlers is
      new Gtk.Handlers.Callback (Gtk_Dialog_Record);

   package View_Handlers is
      new Gtk.Handlers.User_Callback (Gtk_Text_View_Record, Gtk_Dialog);

   package View_Event_Handlers is
      new Gtk.Handlers.User_Return_Callback
          (  Gtk_Text_View_Record,
             Boolean,
             Gtk_Dialog
          );

   package Gtk_Image_Menu_Item_Handlers is
      new Gtk.Handlers.Callback (Gtk_Image_Menu_Item_Record);

   Messages_List : Gtk_Text_Buffer;
   Step_Button   : Gtk_Button;
   Run_Button    : Gtk_Button;
   View          : Gtk_Text_View;
   Break_Button  : Gtk_Check_Button;

   type Tag_Index is mod 5;
   Tags        : array (Tag_Index) of Gtk_Text_Tag;
   Current_Tag : Tag_Index := 0;
--
-- On_Button_Press -- Event handler
--
   function On_Button_Press
            (  Dialog : access Gtk_Text_View_Record'Class;
               Event  : Gdk_Event;
               Parent : Gtk_Dialog
            )  return Boolean is
   begin
      if Get_Event_Type (Event) = Button_Press then
         Window_X := GInt (Event.Button.X);
         Window_Y := GInt (Event.Button.Y);
      end if;
      return Standard.False;
   end On_Button_Press;
--
-- On_Go_To_Location -- Event handler
--
   procedure On_Go_To_Location
             (  Item : access Gtk_Image_Menu_Item_Record'Class
             )  is
   begin
      if not Connected then
         Connect;
      end if;
      if Connected then
         GPS_Send (To_String (Command));
         GPS_Read;
      end if;
   end On_Go_To_Location;
--
-- On_Paste_Trace -- Event handler
--
   procedure On_Paste_Trace
             (  Item : access Gtk_Image_Menu_Item_Record'Class
             )  is
      Text    : constant String := Wait_For_Text (Get);
      Pointer : Integer := Text'First;
      procedure Skip is
      begin
         while Pointer < Text'Last loop
            exit when Text (Pointer) /= ' ';
            Pointer := Pointer + 1;
         end loop;
      end Skip;
      function Get_Item return Address is
         Value : Integer_Address := 0;
      begin
         if Pointer + 1 > Text'Last then
            raise Constraint_Error;
         end if;
         if Text (Pointer..Pointer + 1) /= "0x" then
            raise Constraint_Error;
         end if;
         Pointer := Pointer + 2;
         while Pointer < Text'Last loop
            case Text (Pointer) is
               when '0'..'9' =>
                  Value :=
                     (  Value * 16
                     +  Character'Pos (Text (Pointer))
                     -  Character'Pos ('0')
                     );
               when 'a'..'f' =>
                  Value :=
                     (  Value * 16
                     +  Character'Pos (Text (Pointer))
                     -  Character'Pos ('a')
                     +  10
                     );
               when 'A'..'F' =>
                  Value :=
                     (  Value * 16
                     +  Character'Pos (Text (Pointer))
                     -  Character'Pos ('A')
                     +  10
                     );
               when others =>
                  exit;
            end case;
            Pointer := Pointer + 1;
         end loop;
         if Text (Pointer - 1) = 'x' then
            raise Constraint_Error;
         end if;
         return To_Address (Value);
      end Get_Item;
      Count : Natural := 0;
   begin
      declare
         Location : Address;
      begin
         while Pointer <= Text'Last loop
            Skip;
            Location := Get_Item;
            Count    := Count + 1;
         end loop;
      exception
         when others =>
            null;
      end;
      if Count > 0 then
         declare
            TB : Tracebacks_Array (1..Count);
         begin
            Pointer := Text'First;
            for Index in TB'Range loop
               Skip;
               TB (Index) := Get_Item;
            end loop;
            Trace
            (  "Symbolic stack traceback from the clipboard:" & LF
            &  Symbolic_Traceback (TB) &  LF
            );
         end;
      end if;
   end On_Paste_Trace;
--
-- On_Populate_Popup -- Event handler
--
   procedure On_Populate_Popup
             (  Dialog : access Gtk_Text_View_Record'Class;
                Params : GValues;
                Parent : Gtk_Dialog
             )  is
      Buffer : constant Gtk_Text_Buffer := Get_Buffer (Dialog);
      Widget : Gtk_Widget;
      Menu   : Gtk_Menu;
      Item   : Gtk_Image_Menu_Item;
      Icon   : Gtk_Image;
      Start  : Gtk_Text_Iter;
      Stop   : Gtk_Text_Iter;
      Can_Go : Boolean := Standard.False;
   begin
      Widget := Convert (Get_Address (Nth (Params, 1)));
      if Widget /= null and then Widget.all in Gtk_Menu_Record'Class
      then
         Menu := Gtk_Menu_Record'Class (Widget.all)'Unchecked_Access;
         Menu.Modify_Font
         (  Get_Font
            (  Get_Style_Context (Parent),
               Gtk_State_Flag_Normal
         )  );
         if Get.Wait_Is_Text_Available then -- Paste traceback item
            Gtk_New (Item, "Paste stack traceback");
            Gtk_New (Icon, Stock_Find, Icon_Size_Menu);
            Item.Set_Image (Icon);
            Item.Show_All;
            Gtk_Image_Menu_Item_Handlers.Connect
            (  Item,
               "activate",
               On_Paste_Trace'Access
            );
            Menu.Add (Item);
         end if;
         if Main /= Null_Task_ID then -- Go to the location item
            declare
               use type Gdk.Gdk_Window;
               Buffer_X : GInt;
               Buffer_Y : GInt;
               Moved    : Boolean;
            begin
               Dialog.Window_To_Buffer_Coords
               (  Text_Window_Widget,
                  Window_X,
                  Window_Y,
                  Buffer_X,
                  Buffer_Y
               );
               Dialog.Get_Iter_At_Location (Start, Buffer_X, Buffer_Y);
               Copy (Start, Stop);
               Moved := Standard.True;
               while Moved and then not Starts_Line (Start) loop
                  Backward_Cursor_Position (Start, Moved);
               end loop;
               Moved := Standard.True;
               while Moved and then not Ends_Line (Stop) loop
                  Forward_Cursor_Position (Stop, Moved);
               end loop;
            end;
            declare
               Line    : String  := Buffer.Get_Text (Start, Stop);
               Pointer : Integer := Line'Last + 1;
            begin
               if (  Line'Length < 3
                  or else
                     Line (Line'First) /= '0'
                  or else
                     Line (Line'First + 1) /= 'x'
                  )
               then
                  goto Break;
               end if;
               loop
                  if Pointer = Line'First then
                     goto Break;
                  end if;
                  Pointer := Pointer - 1;
                  exit when Line (Pointer) not in '0'..'9';
               end loop;
               if (  Pointer - 4 < Line'First
                  or else
                     Line (Pointer - 4) /= '.'
                  or else
                     To_Lower (Line (Pointer - 3)) /= 'a'
                  or else
                     To_Lower (Line (Pointer - 2)) /= 'd'
                  or else
                     Line (Pointer) /= ':'
                  )
               then
                  goto Break;
               end if;
               Line (Pointer) := ' ';
               case To_Lower (Line (Pointer - 1)) is
                  when 's' | 'b' =>
                     Pointer := Pointer - 4;
                  when others =>
                     goto Break;
               end case;
               loop
                  if Pointer - 4 < Line'First then
                     goto Break;
                  end if;
                  exit when Line (Pointer - 4..Pointer - 1) = " at ";
                  Pointer := Pointer - 1;
               end loop;
               Can_Go := Standard.True;
               Command := To_Unbounded_String ("Editor.edit ");
               Append (Command, Line (Pointer..Line'Last));
               Append (Command, Character'Val (10));
            end;
<<Break>>   Gtk_New (Item, "Go to the source location");
            Item.Set_Sensitive (Can_Go);
            Gtk_New (Icon, Stock_Jump_To, Icon_Size_Menu);
            Item.Set_Image (Icon);
            Item.Show_All;
            Gtk_Image_Menu_Item_Handlers.Connect
            (  Item,
               "activate",
               On_Go_To_Location'Access
            );
            Menu.Add (Item);
         end if;
      end if;
   end On_Populate_Popup;

   procedure On_Quit (Window : access Gtk_Window_Record'Class) is
      procedure Free is
         new Ada.Unchecked_Deallocation
             (  Request_Item,
                Request_Item_Ptr
             );
      procedure Free is
         new Ada.Unchecked_Deallocation
             (  Request_Data'Class,
                Request_Data_Ptr
             );
      Item : Request_Item_Ptr;
   begin
      Parent := null;
      Gateway.Quit;
      loop
         Gateway.Initiate_Service (Item);
         exit when Item = null;
         if not Item.Synchronous then
            Free (Item.Data);
         end if;
         Free (Item);
      end loop;
      loop
         Gateway.Clean_Up (Item);
         exit when Item = null;
         Free (Item);
      end loop;
   end On_Quit;

   procedure On_Response
             (  Dialog   : access Gtk_Dialog_Record'Class;
                Response : Glib.Values.GValues
             )  is
   begin
      case Gtk_Response_Type (Get_Int (Nth (Response, 1))) is
         when Gtk_Response_None =>
            Trace_Dialog := null;
         when Gtk_Response_Cancel =>
            Set_Active (Break_Button, Standard.False);
         when Gtk_Response_OK =>
            Set_Active (Break_Button, Standard.True);
         when others =>
            Destroy (Trace_Dialog);
            Trace_Dialog := null;
      end case;
   end On_Response;

   procedure Trace (Data : not null access Trace_Request) is
      Start : Gtk_Text_Iter;
      Stop  : Gtk_Text_Iter;
   begin
      if Trace_Dialog = null then
         declare
            Scroll : Gtk_Scrolled_Window;
            Button : Gtk_Button;
            Font   : Pango_Font_Description :=
                        From_String ("monospace 10");
         begin
            Gtk_New
            (  Trace_Dialog,
               "Trace",
               Get_Parent,
               Destroy_With_Parent
            );

            Tags := (others => null);
            Gtk_New (Messages_List);
            Gtk_New (View, Messages_List);
            Messages_List.Unref;
            View.Modify_Font (Font);
            Free (Font);
               -- Get menu
            View_Handlers.Connect
            (  View,
               "populate-popup",
               On_Populate_Popup'Access,
               Trace_Dialog
            );
            View_Event_Handlers.Connect
            (  View,
               "button_press_event",
               View_Event_Handlers.To_Marshaller
               (  On_Button_Press'Access
               ),
               Trace_Dialog
            );
               -- Scrolled window
            Gtk_New (Scroll);
            Scroll.Set_Policy (Policy_Automatic, Policy_Automatic);
            Scroll.Add (View);
            Get_Content_Area (Trace_Dialog).Pack_Start (Scroll);
               -- Break button
            Gtk_New (Break_Button, "Break");
            Break_Button.Set_Active (Standard.True);
            Trace_Dialog.Get_Action_Area.Pack_Start
            (  Break_Button,
               Standard.False,
               Standard.False
            );
               -- Continue button
            Step_Button :=
               Add_Button_From_Stock
               (  Dialog   => Trace_Dialog,
                  Response => Gtk_Response_OK,
                  Icon     => Stock_Media_Next,
                  Label    => "_Next",
                  Tip      => "Run to the next message"
               );
            Step_Button.Set_Can_Default (Standard.True);
            Run_Button :=
               Add_Button_From_Stock
               (  Dialog   => Trace_Dialog,
                  Response => Gtk_Response_Cancel,
                  Icon     => Stock_Media_Record,
                  Label    => "_Continue",
                  Tip      => "Continue without breaking"
               );
            Button :=
               Add_Button_From_Stock
               (  Dialog   => Trace_Dialog,
                  Response => Gtk_Response_Close,
                  Icon     => Stock_Quit,
                  Label    => "_Close",
                  Tip      => "Close trace window and continue"
               );
            Dialog_Handlers.Connect
            (  Trace_Dialog,
               "response",
               On_Response'Access
            );
            Trace_Dialog.Set_Default_Size (200, 400);
            Trace_Dialog.Show_All;
            Trace_Dialog.Set_Transient_For (Get_Parent);
         end;
      end if;
      declare
--           Max_Buffer_Size : constant := 10_000;
         Offset : constant GInt := Messages_List.Get_Char_Count;
      begin
--           while Offset > Max_Buffer_Size loop
--              Messages_List.Get_Iter_At_Line (Start, 0);
--              Messages_List.Get_End_Iter (Stop);
--              Messages_List.Get_Iter_At_Line (Stop, 1);
--              Messages_List.Delete (Start, Stop);
--              Offset := Messages_List.Get_Char_Count;
--           end loop;
         Messages_List.Get_End_Iter (Start);
--         Messages_List.Insert (Start, Data.Text);
         Insert_Alt (Messages_List, Start, Data.Text);
         Messages_List.Get_Iter_At_Offset (Start, Offset);
      end;
      if View.Scroll_To_Iter
         (  Start,
            0.25,
            Standard.False,
            0.0,
            0.0
         )
      then
         null;
      end if;
         -- Colorize new text
      if Tags (Current_Tag) = null then
         Tags (Current_Tag) := Create_Tag (Messages_List);
         Gdk.Color.Set_Property
         (  Tags (Current_Tag),
            Background_Gdk_Property,
            To_RGB
            (  Val
               (  (  Hue        => 0,
                     Luminance  => 240 * 256,
                     Saturation => 29  * 256
                  ),
                  Natural (Current_Tag),
                  Tags'Length
         )  )  );
      end if;
      declare
         Offset : constant GInt := Messages_List.Get_Char_Count;
      begin
         Messages_List.Get_Iter_At_Offset (Stop, Offset);
      end;
      Messages_List.Apply_Tag (Tags (Current_Tag), Start, Stop);
      Current_Tag := Current_Tag + 1;
      if not (Data.Break or else Break_Button.Get_Active) then
         while Events_Pending loop -- Pump messages queue
             exit when not Main_Iteration_Do (Standard.False);
         end loop;
         return;
      end if;
         -- Setting buttons
      Step_Button.Set_Sensitive (Standard.True);
      Run_Button.Set_Sensitive (Standard.True);
      Trace_Dialog.Set_Default (Step_Button);
      Trace_Dialog.Set_Modal (Standard.True);
      case Trace_Dialog.Run is
         when Gtk_Response_Cancel | Gtk_Response_OK =>
            Trace_Dialog.Set_Modal (Standard.False);
            Step_Button.Set_Sensitive (Standard.False);
            Run_Button.Set_Sensitive (Standard.False);
         when others =>
            null;
      end case;
   end Trace;

   procedure Trace
             (  Message : UTF8_String;
                Break   : Boolean := Standard.False
             )  is
      Data : aliased Trace_Request (Message'Length + 1, Break);
   begin
      Data.Text := Message & LF;
      Trace_Callback.Request (Trace'Access, Data'Access);
   end Trace;

   procedure Trace
             (  Error : Exception_Occurrence;
                Break : Boolean := Standard.True
             )  is
   begin
      Trace (Exception_Information (Error), Break);
   end Trace;

end Gtk.Main.Router;