~ubuntu-branches/ubuntu/trusty/gnat-gps/trusty
» Revision
22
: .pc/bug-653470.patch/gvd/gvd/debugger.adb
« back to all changes in this revision
Viewing changes to .pc/bug-653470.patch/gvd/gvd/debugger.adb
- browse files at revision 22
- compare with another revision
- download diff
- download tarball
- view history from revision 22
- Committer: Package Import Robot
- Author(s): Ludovic Brenta
- Date: 2012-04-09 15:32:28 UTC
- Revision ID: package-import@ubuntu.com-20120409153228-hug83kmnmawfsmf2
Tags: 5.0-8
* debian/patches/bug-653470.patch: remove.
* debian/rules (config.ads): set the Default_Charset variable.
Compile all C source files with the same compiler as the Ada source
files, i.e. gnatgcc instead of $(CC).
* debian/patches/bug-666958.patch: new. Closes: #666958.
* debian/rules (config.ads): set the Default_Charset variable.
Compile all C source files with the same compiler as the Ada source
files, i.e. gnatgcc instead of $(CC).
* debian/patches/bug-666958.patch: new. Closes: #666958.
- files added:
- .pc/bug-666958.patch
- .pc/bug-666958.patch/prj_editor
- .pc/bug-666958.patch/prj_editor/src
- files removed:
- .pc/bug-653470.patch
- .pc/bug-653470.patch/aunit
- .pc/bug-653470.patch/aunit/src
- .pc/bug-653470.patch/gps
- .pc/bug-653470.patch/gps/src
- .pc/bug-653470.patch/gvd
- .pc/bug-653470.patch/gvd/gvd
- .pc/bug-653470.patch/kernel
- .pc/bug-653470.patch/kernel/src
- .pc/bug-653470.patch/kernel/src_info
- .pc/bug-653470.patch/language
- .pc/bug-653470.patch/language/src
- .pc/bug-653470.patch/prj_editor
- .pc/bug-653470.patch/prj_editor/src
- .pc/bug-653470.patch/widgets
- .pc/bug-653470.patch/widgets/src
- files modified:
- .pc/applied-patches
added
removed
.pc/bug-653470.patch/gvd/gvd/debugger.adb
1
-----------------------------------------------------------------------
2
-----------------------------------------------------------------------
3
4
with Ada.Strings; use Ada.Strings;
5
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
6
with GNAT.Expect; use GNAT.Expect;
7
pragma Warnings (Off);
8
with GNAT.Expect.TTY; use GNAT.Expect.TTY;
9
pragma Warnings (On);
10
with GNAT.OS_Lib; use GNAT.OS_Lib;
11
with GNATCOLL.Arg_Lists; use GNATCOLL.Arg_Lists;
12
with GNATCOLL.Utils; use GNATCOLL.Utils;
13
14
with Glib; use Glib;
15
with Glib.Convert;
16
with Glib.Object; use Glib.Object;
17
with Gtk.Main; use Gtk.Main;
18
with Gtk.Window; use Gtk.Window;
19
with Gtkada.Dialogs; use Gtkada.Dialogs;
20
with Gtkada.Types; use Gtkada.Types;
21
22
with Config; use Config;
23
with GVD; use GVD;
24
with GVD.Canvas; use GVD.Canvas;
25
with GVD.Code_Editors; use GVD.Code_Editors;
26
with GVD.Process; use GVD.Process;
27
with GVD.Source_Editor; use GVD.Source_Editor;
28
with GVD.Scripts; use GVD.Scripts;
29
with GVD.Types; use GVD.Types;
30
with GPS.Kernel.Remote; use GPS.Kernel.Remote;
31
with GPS.Intl; use GPS.Intl;
32
with Items; use Items;
33
with Language; use Language;
34
with Language.Debugger; use Language.Debugger;
35
with Process_Proxies; use Process_Proxies;
36
with Remote; use Remote;
37
with String_Utils; use String_Utils;
38
with Traces; use Traces;
39
40
package body Debugger is
41
42
use String_History, Language_Lists;
43
44
Me : constant Debug_Handle := Create ("Debugger");
45
46
Debug_Timeout : constant Guint32 := 100;
47
-- Timeout in millisecond to check input from the underlying debugger
48
-- when handling asynchronous commands.
49
50
package Debugger_Timeout is new Gtk.Main.Timeout (Visual_Debugger);
51
52
---------------------
53
-- Local Functions --
54
---------------------
55
56
function Output_Available (Process : Visual_Debugger) return Boolean;
57
-- Called when waiting output from the debugger.
58
-- This procedure is activated to handle asynchronous commands.
59
-- All it does is read all the available data and call the filters
60
-- that were set for the debugger, until a prompt is found.
61
62
procedure Send_Internal_Pre
63
(Debugger : access Debugger_Root'Class;
64
Cmd : String;
65
Empty_Buffer : Boolean := True;
66
Mode : Command_Type);
67
-- Internal procedure used by Send. This takes care of sending the
68
-- command to the debugger, but doesn't parse or even read the output.
69
-- The command is displayed in the command window and added to the
70
-- history if necessary
71
72
procedure Send_Internal_Post
73
(Debugger : access Debugger_Root'Class;
74
Mode : Command_Type);
75
-- Internal procedure used by Send. This takes care of processing the
76
-- output of the debugger, but it doesn't read it.
77
-- This should be called only if we are currently waiting for the next
78
-- prompt, ie processing the output
79
-- Note that this function will do nothing if Mode is Internal.
80
81
---------------------
82
-- Command Queuing --
83
---------------------
84
85
procedure Queue_Command
86
(Debugger : access Debugger_Root'Class;
87
Cmd : String;
88
Empty_Buffer : Boolean;
89
Mode : Command_Type);
90
-- Queue a given command to be executed after the next call to Wait.
91
92
function Process_Command
93
(Debugger : access Debugger_Root'Class) return Boolean;
94
-- Call the first command queued for Debugger.
95
-- Return False if no command are in the queue, True otherwise.
96
97
-----------------------
98
-- Connect_To_Target --
99
-----------------------
100
101
procedure Connect_To_Target
102
(Debugger : access Debugger_Root;
103
Target : String;
104
Protocol : String;
105
Mode : GVD.Types.Command_Type := GVD.Types.Hidden)
106
is
107
pragma Unreferenced (Debugger, Target, Protocol, Mode);
108
begin
109
null;
110
end Connect_To_Target;
111
112
----------
113
-- Free --
114
----------
115
116
procedure Free (Bt : in out Backtrace_Array) is
117
begin
118
for J in Bt'Range loop
119
Free (Bt (J).Program_Counter);
120
Free (Bt (J).Subprogram);
121
Free (Bt (J).Source_Location);
122
end loop;
123
end Free;
124
125
----------------
126
-- Parse_Type --
127
----------------
128
129
function Parse_Type
130
(Debugger : access Debugger_Root'Class;
131
Entity : String) return Items.Generic_Type_Access
132
is
133
Result : Generic_Type_Access;
134
Type_Str : constant String := Type_Of (Debugger, Entity);
135
Index : Natural := Type_Str'First;
136
137
begin
138
if Type_Str'Length /= 0 then
139
Parse_Type
140
(Language_Debugger_Access (Get_Language (Debugger)),
141
Type_Str, Entity, Index, Result);
142
end if;
143
144
return Result;
145
end Parse_Type;
146
147
-----------------
148
-- Parse_Value --
149
-----------------
150
151
procedure Parse_Value
152
(Debugger : access Debugger_Root'Class;
153
Entity : String;
154
Value : in out Items.Generic_Type_Access;
155
Format : Value_Format := Default_Format;
156
Value_Found : out Boolean)
157
is
158
Type_Str : constant String := Value_Of (Debugger, Entity, Format);
159
Index : Natural := Type_Str'First;
160
Repeat_Num : Positive;
161
162
begin
163
Reset_Recursive (Value);
164
Value_Found := Type_Str'Length /= 0;
165
166
if Value_Found then
167
Parse_Value
168
(Language_Debugger_Access (Get_Language (Debugger)),
169
Type_Str, Index, Value, Repeat_Num);
170
end if;
171
end Parse_Value;
172
173
------------------
174
-- Set_Language --
175
------------------
176
177
procedure Set_Language
178
(Debugger : access Debugger_Root;
179
The_Language : access Language.Language_Root'Class)
180
is
181
C : Language_Lists.Cursor := First (Debugger.Languages);
182
begin
183
while Has_Element (C) loop
184
if Element (C) = The_Language then
185
Debugger.The_Language := C;
186
return;
187
end if;
188
Next (C);
189
end loop;
190
191
Append (Debugger.Languages, Language_Access (The_Language));
192
Debugger.The_Language := Last (Debugger.Languages);
193
end Set_Language;
194
195
------------------
196
-- Get_Language --
197
------------------
198
199
function Get_Language
200
(Debugger : access Debugger_Root;
201
Lang : String := "") return Language.Language_Access
202
is
203
C : Language_Lists.Cursor;
204
begin
205
if Lang = "" then
206
if Has_Element (Debugger.The_Language) then
207
return Element (Debugger.The_Language);
208
else
209
return null;
210
end if;
211
end if;
212
213
C := First (Debugger.Languages);
214
while Has_Element (C) loop
215
if Equal (Get_Name (Element (C)), Lang, Case_Sensitive => False) then
216
return Element (C);
217
end if;
218
Next (C);
219
end loop;
220
return null;
221
end Get_Language;
222
223
---------------------
224
-- Detect_Language --
225
---------------------
226
227
procedure Detect_Language (Debugger : access Debugger_Root) is
228
pragma Unreferenced (Debugger);
229
begin
230
null;
231
end Detect_Language;
232
233
-----------------
234
-- Get_Process --
235
-----------------
236
237
function Get_Process
238
(Debugger : access Debugger_Root) return Process_Proxy_Access is
239
begin
240
return Debugger.Process;
241
end Get_Process;
242
243
-------------------
244
-- General_Spawn --
245
-------------------
246
247
procedure General_Spawn
248
(Debugger : access Debugger_Root'Class;
249
Kernel : access GPS.Kernel.Kernel_Handle_Record'Class;
250
Arguments : GNAT.OS_Lib.Argument_List;
251
Debugger_Name : String;
252
Proxy : Process_Proxies.Process_Proxy_Access)
253
is
254
Descriptor : Process_Descriptor_Access;
255
Success : Boolean;
256
CL : Arg_List := Create (Debugger_Name);
257
258
begin
259
for J in Arguments'Range loop
260
Append_Argument (CL, Arguments (J).all, One_Arg);
261
end loop;
262
263
-- Start the external debugger.
264
-- Note that there is no limitation on the buffer size, since we can
265
-- not control the length of what gdb will return...
266
267
Debugger.Process := Proxy;
268
Debugger.Kernel := Kernel_Handle (Kernel);
269
270
GPS.Kernel.Remote.Spawn
271
(Kernel => Debugger.Kernel,
272
Arguments => CL,
273
Server => Debug_Server,
274
Pd => Descriptor,
275
Success => Success);
276
277
if not Success
278
or else Get_Pid (Descriptor.all) = GNAT.Expect.Invalid_Pid
279
then
280
raise Spawn_Error;
281
end if;
282
283
Set_Descriptor (Debugger.Process, Descriptor);
284
Set_Is_Started (Debugger, False);
285
end General_Spawn;
286
287
---------------------
288
-- Found_File_Name --
289
---------------------
290
291
procedure Found_File_Name
292
(Debugger : access Debugger_Root;
293
Str : String;
294
Name_First : out Natural;
295
Name_Last : out Positive;
296
First, Last : out Natural;
297
Line : out Natural;
298
Addr_First : out Natural;
299
Addr_Last : out Natural)
300
is
301
pragma Unreferenced (Debugger, Str);
302
begin
303
First := 0;
304
Last := 0;
305
Name_First := 0;
306
Name_Last := 1;
307
Line := 0;
308
Addr_First := 0;
309
Addr_Last := 1;
310
end Found_File_Name;
311
312
----------------------
313
-- Found_Frame_Info --
314
----------------------
315
316
procedure Found_Frame_Info
317
(Debugger : access Debugger_Root;
318
Str : String;
319
First, Last : out Natural;
320
Message : out Frame_Info_Type)
321
is
322
pragma Unreferenced (Debugger, Str);
323
begin
324
First := 0;
325
Last := 0;
326
Message := Location_Not_Found;
327
end Found_Frame_Info;
328
329
-----------------
330
-- Get_Uniq_Id --
331
-----------------
332
333
function Get_Uniq_Id
334
(Debugger : access Debugger_Root;
335
Entity : String) return String
336
is
337
pragma Unreferenced (Debugger);
338
begin
339
return Entity;
340
end Get_Uniq_Id;
341
342
---------------------
343
-- Lines_With_Code --
344
---------------------
345
346
procedure Lines_With_Code
347
(Debugger : access Debugger_Root;
348
File : GNATCOLL.VFS.Virtual_File;
349
Result : out Boolean;
350
Lines : out Line_Array)
351
is
352
pragma Unreferenced (Debugger, File, Lines);
353
begin
354
Result := False;
355
end Lines_With_Code;
356
357
-----------------------
358
-- Source_Files_List --
359
-----------------------
360
361
function Source_Files_List
362
(Debugger : access Debugger_Root) return GNAT.Strings.String_List
363
is
364
pragma Unreferenced (Debugger);
365
A : GNAT.Strings.String_List (1 .. 0);
366
begin
367
return A;
368
end Source_Files_List;
369
370
----------------------
371
-- Output_Available --
372
----------------------
373
374
function Output_Available (Process : Visual_Debugger) return Boolean is
375
Debugger : constant Debugger_Access := Process.Debugger;
376
Mode : Command_Type;
377
378
begin
379
-- Get everything that is available (and transparently call the
380
-- output filters set for Pid).
381
-- Nothing should be done if we are already processing a command
382
-- (ie somewhere we are blocked on a Wait call for this Debugger),
383
-- since otherwise that Wait won't see the output and will lose some
384
-- output. We don't have to do that anyway, since the other Wait will
385
-- indirectly call the output filter.
386
387
if Debugger = null then
388
Timeout_Remove (Process.Timeout_Id);
389
Process.Timeout_Id := 0;
390
return False;
391
end if;
392
393
if Wait_Prompt (Debugger, Timeout => 1) then
394
Debugger.Continuation_Line := False;
395
Timeout_Remove (Process.Timeout_Id);
396
Process.Timeout_Id := 0;
397
Mode := Get_Command_Mode (Get_Process (Debugger));
398
399
-- Put back the standard cursor
400
401
if Mode >= Visible then
402
Set_Busy (Process, False);
403
end if;
404
405
Set_Command_In_Process (Get_Process (Debugger), False);
406
Unregister_Dialog (Process);
407
408
-- Do the postprocessing here instead of calling Send_Internal_Post
409
-- since we need to handle post processing slightly differently
410
411
declare
412
Current_Command : constant String := Get_Command (Process);
413
Result : Boolean;
414
pragma Unreferenced (Result);
415
416
begin
417
Free (Process.Current_Command);
418
419
if Process_Command (Debugger) then
420
-- ??? register if needed for some of the hooks
421
-- before returning
422
return False;
423
end if;
424
425
Final_Post_Process (Process, Mode);
426
427
if Is_Load_Command (Debugger, Current_Command) then
428
Run_Debugger_Hook (Process, Debugger_Executable_Changed_Hook);
429
430
elsif Is_Context_Command (Debugger, Current_Command) then
431
Run_Debugger_Hook (Process, Debugger_Context_Changed_Hook);
432
elsif Is_Execution_Command (Debugger, Current_Command) then
433
Run_Debugger_Hook (Process, Debugger_Process_Stopped_Hook);
434
end if;
435
436
Update_Breakpoints
437
(Process,
438
Force => Is_Break_Command (Debugger, Current_Command));
439
440
-- In case a command has been queued while handling the signals
441
-- and breakpoints above.
442
443
Result := Process_Command (Debugger);
444
end;
445
446
return False;
447
448
else
449
return True;
450
end if;
451
452
exception
453
when E : others =>
454
-- Will close the debugger in GVD.Process when getting this
455
-- exception the next time.
456
457
Traces.Trace (Exception_Handle, E);
458
459
if Process.Timeout_Id > 0 then
460
Timeout_Remove (Process.Timeout_Id);
461
end if;
462
Process.Timeout_Id := 0;
463
464
if Debugger /= null and then Get_Process (Debugger) /= null then
465
Set_Command_In_Process (Get_Process (Debugger), False);
466
end if;
467
468
Set_Busy (Process, False);
469
Free (Process.Current_Command);
470
Unregister_Dialog (Process);
471
return False;
472
end Output_Available;
473
474
-----------------------
475
-- Send_Internal_Pre --
476
-----------------------
477
478
procedure Send_Internal_Pre
479
(Debugger : access Debugger_Root'Class;
480
Cmd : String;
481
Empty_Buffer : Boolean := True;
482
Mode : Command_Type)
483
is
484
Data : History_Data;
485
Process : Visual_Debugger;
486
487
begin
488
Set_Command_Mode (Get_Process (Debugger), Mode);
489
490
if not Is_Started (Debugger)
491
and then Is_Execution_Command (Debugger, Cmd)
492
then
493
Set_Is_Started (Debugger, True);
494
end if;
495
496
Process := GVD.Process.Convert (Debugger);
497
if Process /= null then
498
if not Command_In_Process (Get_Process (Debugger)) then
499
-- If we are already processing a command, this means we set a
500
-- Force_Send parameter to True in the call to Send. Most notably,
501
-- this is used when sending additional input to the debugger (for
502
-- instance answering a gdb question), and we do not want to
503
-- change the current command in this case.
504
505
if Process.Current_Command /= null then
506
Assert (Me, Process.Current_Command = null,
507
"Memory leak, still has cmd="
508
& Process.Current_Command.all
509
& " while sending " & Cmd,
510
Raise_Exception => True);
511
end if;
512
513
Process.Current_Command := new String'(Cmd);
514
end if;
515
516
Set_Command_In_Process (Get_Process (Debugger));
517
518
if Mode /= Internal
519
and then Is_Execution_Command (Debugger, Cmd)
520
then
521
Unhighlight_Current_Line
522
(Get_Source (Process.Editor_Text), GObject (Process));
523
end if;
524
525
if Mode >= Visible then
526
Set_Busy (Process);
527
end if;
528
529
-- Display the command in the output window if necessary
530
531
if Mode = Visible then
532
Output_Text (Process, Cmd & ASCII.LF, True);
533
end if;
534
535
else
536
Set_Command_In_Process (Get_Process (Debugger));
537
end if;
538
539
-- Append the command to the history if necessary
540
541
if Index_Non_Blank (Cmd) /= 0
542
and then Mode /= Internal
543
and then Process /= null
544
then
545
Data.Mode := Mode;
546
Data.Command := new String'
547
(Cmd (Index_Non_Blank (Cmd) .. Index_Non_Blank (Cmd, Backward)));
548
Append (Process.Command_History, Data);
549
end if;
550
551
-- Send the command to the debugger
552
553
Send (Get_Process (Debugger), Cmd, Empty_Buffer);
554
end Send_Internal_Pre;
555
556
------------------------
557
-- Send_Internal_Post --
558
------------------------
559
560
procedure Send_Internal_Post
561
(Debugger : access Debugger_Root'Class;
562
Mode : Command_Type)
563
is
564
Process : Visual_Debugger;
565
Result : Boolean;
566
pragma Unreferenced (Result);
567
Is_Context, Is_Exec, Is_Break : Boolean;
568
569
begin
570
-- See also Output_Available for similar handling.
571
Set_Command_In_Process (Get_Process (Debugger), False);
572
573
Process := GVD.Process.Convert (Debugger);
574
575
if Process /= null then
576
Is_Context := Is_Context_Command
577
(Debugger, Process.Current_Command.all);
578
Is_Exec := Is_Execution_Command
579
(Debugger, Process.Current_Command.all);
580
Is_Break := Is_Break_Command
581
(Debugger, Process.Current_Command.all);
582
583
Free (Process.Current_Command);
584
end if;
585
586
if Mode /= Internal and then Process_Command (Debugger) then
587
-- ??? register if needed for hooks before returning
588
return;
589
end if;
590
591
if Process /= null then
592
Final_Post_Process (Process, Mode);
593
594
if Mode /= Internal then
595
-- Postprocessing (e.g handling of auto-update).
596
597
if Is_Context then
598
Run_Debugger_Hook (Process, Debugger_Context_Changed_Hook);
599
elsif Is_Exec then
600
Run_Debugger_Hook (Process, Debugger_Process_Stopped_Hook);
601
end if;
602
603
Update_Breakpoints (Process, Force => Is_Break);
604
end if;
605
606
if Mode >= Visible then
607
Set_Busy (Process, False);
608
end if;
609
610
Unregister_Dialog (Process);
611
612
-- In case a command has been queued while handling the signals
613
-- and breakpoints above.
614
615
if Mode /= Internal then
616
Result := Process_Command (Debugger);
617
end if;
618
end if;
619
end Send_Internal_Post;
620
621
----------
622
-- Send --
623
----------
624
625
procedure Send
626
(Debugger : access Debugger_Root;
627
Cmd : String;
628
Empty_Buffer : Boolean := True;
629
Wait_For_Prompt : Boolean := True;
630
Force_Send : Boolean := False;
631
Mode : Command_Type := Hidden)
632
is
633
Process : Visual_Debugger;
634
Button : Message_Dialog_Buttons;
635
pragma Unreferenced (Button);
636
Last : Positive := Cmd'First;
637
First : Positive;
638
639
begin
640
-- When there are multiple commands separated by ASCII.LF, Force_Send
641
-- applies to the command set as a whole. If the debugger is processing
642
-- a command, we send none of them, otherwise we send them all without
643
-- queuing any of them. Chaining of commands through ASCII.LF seems to
644
-- only occur in a few limited cases anyway (Set_Breakpoint_Command for
645
-- instance).
646
647
if not Force_Send
648
and then Command_In_Process (Get_Process (Debugger))
649
then
650
-- Will be processed by the same Send later on
651
Queue_Command (Debugger, Cmd, Empty_Buffer, Mode);
652
return;
653
end if;
654
655
-- Each command is separated with a ASCII.LF and is handled separately
656
657
loop
658
First := Last;
659
Skip_To_Char (Cmd, Last, ASCII.LF);
660
661
-- Used to have the following text:
662
-- if Mode not in Invisible_Command
663
-- and then Wait_For_Prompt
664
-- and then Command_In_Process (Get_Process (Debugger))
665
-- However, this fails sometimes with gdb: when "cont" terminates the
666
-- program, gdb is emitting a "tty" command while cont is still
667
-- being processed, and therefore the if was changed to the below to
668
-- queue the tty command.
669
-- ??? In fact, I (Manu) am not sure how this was working before: if
670
-- we are waiting for a prompt, we should not be queuing the command
671
-- still this would return to the caller before we saw the prompt.
672
673
Send_Internal_Pre
674
(Debugger, Cmd (First .. Last - 1), Empty_Buffer, Mode);
675
676
case Mode is
677
when Invisible_Command =>
678
if Last > Cmd'Last and then Wait_For_Prompt then
679
-- Only wait for the prompt on the last command when
680
-- there are multiple commands separated by ASCII.LF
681
Wait_Prompt (Debugger_Access (Debugger));
682
Debugger.Continuation_Line := False;
683
Send_Internal_Post (Debugger, Mode);
684
end if;
685
686
when Visible_Command =>
687
if Wait_For_Prompt then
688
if not Async_Commands then
689
-- Synchronous handling of commands, simple case
690
691
Wait_Prompt (Debugger_Access (Debugger));
692
Debugger.Continuation_Line := False;
693
Send_Internal_Post (Debugger, Mode);
694
695
else
696
-- Asynchronous handling of commands, install a
697
-- callback on the debugger's output file descriptor.
698
699
Process := GVD.Process.Convert (Debugger);
700
pragma Assert (Process.Timeout_Id = 0);
701
702
Process.Timeout_Id := Debugger_Timeout.Add
703
(Debug_Timeout, Output_Available'Access, Process);
704
end if;
705
706
else
707
if Mode >= Visible then
708
-- Clear the current output received from the debugger
709
-- to avoid confusing the prompt detection, since
710
-- we're sending input in the middle of a command,
711
-- which is delicate.
712
713
Process_Proxies.Empty_Buffer (Get_Process (Debugger));
714
Process := GVD.Process.Convert (Debugger);
715
Set_Busy (Process, False);
716
end if;
717
end if;
718
end case;
719
720
exit when Last > Cmd'Last;
721
722
Last := Last + 1;
723
end loop;
724
725
exception
726
when Process_Died =>
727
Process := GVD.Process.Convert (Debugger);
728
Free (Process.Current_Command);
729
730
if Process.Exiting then
731
return;
732
end if;
733
734
Trace (Me, "underlying debugger died unexpectedly in 'send'");
735
Button :=
736
Message_Dialog
737
(Expect_Out (Get_Process (Debugger)) & ASCII.LF &
738
(-"The underlying debugger died unexpectedly. Closing it"),
739
Error, Button_OK, Button_OK);
740
Set_Command_In_Process (Get_Process (Debugger), False);
741
Set_Busy (Process, False);
742
Unregister_Dialog (Process);
743
Close_Debugger (Process);
744
end Send;
745
746
---------------
747
-- Send_Full --
748
---------------
749
750
function Send_Full
751
(Debugger : access Debugger_Root;
752
Cmd : String;
753
Mode : Invisible_Command := Hidden) return String
754
is
755
Process : Visual_Debugger;
756
Last : Natural;
757
CR_Found : Boolean;
758
759
begin
760
if Command_In_Process (Get_Process (Debugger)) then
761
-- Should never happen, but it's safer to return immediately in case
762
-- we're compiling without assertions, rather than hanging.
763
764
pragma Assert (False);
765
return "";
766
end if;
767
768
Send_Internal_Pre (Debugger, Cmd, Mode => Mode);
769
Wait_Prompt (Debugger_Access (Debugger));
770
Debugger.Continuation_Line := False;
771
772
declare
773
S : String :=
774
Glib.Convert.Locale_To_UTF8 (Expect_Out (Get_Process (Debugger)));
775
begin
776
Send_Internal_Post (Debugger, Mode);
777
778
-- Strip CRs in remote mode, as we can't know in advance if the debug
779
-- server outputs CR/LF or just LF, and the consequences or removing
780
-- CRs in the latter case are better than not removing them in the
781
-- first case
782
if Need_To_Strip_CR or else not Is_Local (Debug_Server) then
783
Strip_CR (S, Last, CR_Found);
784
return S (S'First .. Last);
785
else
786
return S;
787
end if;
788
end;
789
790
exception
791
when Process_Died =>
792
Trace (Me, "underlying debugger died unexpectedly in 'send_full'");
793
Set_Command_In_Process (Get_Process (Debugger), False);
794
795
Process := GVD.Process.Convert (Debugger);
796
if Process /= null then
797
Free (Process.Current_Command);
798
Set_Busy (Process, False);
799
Unregister_Dialog (Process);
800
Close_Debugger (Process);
801
end if;
802
803
return "";
804
end Send_Full;
805
806
---------------------
807
-- List_Exceptions --
808
---------------------
809
810
function List_Exceptions
811
(Debugger : access Debugger_Root) return Exception_Array
812
is
813
pragma Unreferenced (Debugger);
814
815
Arr : Exception_Array (1 .. 0);
816
begin
817
return Arr;
818
end List_Exceptions;
819
820
-------------------
821
-- Get_Type_Info --
822
-------------------
823
824
function Get_Type_Info
825
(Debugger : access Debugger_Root;
826
Entity : String;
827
Default : String) return String
828
is
829
pragma Unreferenced (Debugger, Entity);
830
begin
831
return Default;
832
end Get_Type_Info;
833
834
---------------
835
-- Find_File --
836
---------------
837
838
function Find_File
839
(Debugger : access Debugger_Root; File_Name : String) return String
840
is
841
pragma Unreferenced (Debugger);
842
begin
843
return File_Name;
844
end Find_File;
845
846
----------------
847
-- Is_Started --
848
----------------
849
850
function Is_Started (Debugger : access Debugger_Root) return Boolean is
851
begin
852
return Debugger.Is_Started;
853
end Is_Started;
854
855
--------------------
856
-- Set_Is_Started --
857
--------------------
858
859
procedure Set_Is_Started
860
(Debugger : access Debugger_Root;
861
Is_Started : Boolean) is
862
begin
863
Debugger.Is_Started := Is_Started;
864
Run_Debugger_Hook
865
(GVD.Process.Convert (Debugger), Debugger_Process_Terminated_Hook);
866
end Set_Is_Started;
867
868
------------------
869
-- Set_Variable --
870
------------------
871
872
procedure Set_Variable
873
(Debugger : access Debugger_Root;
874
Var_Name : String;
875
Value : String)
876
is
877
S : constant String :=
878
Set_Variable (Language_Debugger_Access (Get_Language (Debugger)),
879
Var_Name, Value);
880
begin
881
if S /= "" then
882
-- We need to send the command in hidden mode (synchronously)
883
-- because right after this call, Set_Value will typically request
884
-- the new value of the variable, before we got the debugger's
885
-- prompt asynchronously.
886
887
Send (Debugger, S, Mode => Hidden);
888
end if;
889
end Set_Variable;
890
891
-----------------------
892
-- Wait_User_Command --
893
-----------------------
894
895
procedure Wait_User_Command (Debugger : access Debugger_Root) is
896
Current_Process : Process_Proxy_Access;
897
Tmp : Boolean;
898
pragma Unreferenced (Tmp);
899
900
Num_Events : Positive;
901
Max_Events : constant := 30;
902
-- Limit the number of events to process in one iteration
903
904
begin
905
-- Wait until the command has been processed
906
907
Current_Process := Get_Process (Debugger);
908
909
-- Make sure that Current_Process is not null before calling
910
-- Command_In_Process : this can happen when GVD is exiting.
911
912
while Current_Process /= null
913
and then Command_In_Process (Current_Process)
914
loop
915
Num_Events := 1;
916
917
while Gtk.Main.Events_Pending
918
and then Num_Events <= Max_Events
919
loop
920
Tmp := Gtk.Main.Main_Iteration;
921
Num_Events := Num_Events + 1;
922
end loop;
923
924
Current_Process := Get_Process (Debugger);
925
end loop;
926
end Wait_User_Command;
927
928
----------
929
-- Free --
930
----------
931
932
procedure Free (Info : in out Thread_Information_Array) is
933
begin
934
for J in Info'Range loop
935
Free (Info (J).Information);
936
end loop;
937
end Free;
938
939
-------------------
940
-- Queue_Command --
941
-------------------
942
943
procedure Queue_Command
944
(Debugger : access Debugger_Root'Class;
945
Cmd : String;
946
Empty_Buffer : Boolean;
947
Mode : Command_Type)
948
is
949
Tmp : Command_Access := Debugger.Command_Queue;
950
Command : Command_Access;
951
952
begin
953
Command := new Command_Record'
954
(Cmd => new String'(Cmd),
955
Empty_Buffer => Empty_Buffer,
956
Mode => Mode,
957
Next => null);
958
959
if Tmp = null then
960
Debugger.Command_Queue := Command;
961
else
962
while Tmp.Next /= null loop
963
Tmp := Tmp.Next;
964
end loop;
965
966
Tmp.Next := Command;
967
end if;
968
end Queue_Command;
969
970
---------------------
971
-- Process_Command --
972
---------------------
973
974
procedure Free is new
975
Ada.Unchecked_Deallocation (Command_Record, Command_Access);
976
977
function Process_Command
978
(Debugger : access Debugger_Root'Class) return Boolean
979
is
980
Command : Command_Access := Debugger.Command_Queue;
981
Process : Visual_Debugger;
982
First : Natural;
983
984
begin
985
if Command = null then
986
return False;
987
end if;
988
989
Debugger.Command_Queue := Command.Next;
990
991
First := Command.Cmd'First;
992
Skip_Blanks (Command.Cmd.all, First);
993
994
if Looking_At (Command.Cmd.all, First, "graph") then
995
Process := GVD.Process.Convert (Debugger);
996
if Process /= null then
997
Process_Graph_Cmd (Process, Command.Cmd.all);
998
end if;
999
1000
else
1001
Send
1002
(Debugger, Command.Cmd.all, Command.Empty_Buffer,
1003
Mode => Command.Mode);
1004
end if;
1005
1006
Free (Command.Cmd);
1007
Free (Command);
1008
return True;
1009
end Process_Command;
1010
1011
-----------------
1012
-- Clear_Queue --
1013
-----------------
1014
1015
procedure Clear_Queue (Debugger : access Debugger_Root'Class) is
1016
Command : Command_Access := Debugger.Command_Queue;
1017
begin
1018
while Command /= null loop
1019
Debugger.Command_Queue := Command.Next;
1020
Free (Command.Cmd);
1021
Free (Command);
1022
end loop;
1023
end Clear_Queue;
1024
1025
use GVD.Proc_Utils;
1026
1027
--------------------
1028
-- Open_Processes --
1029
--------------------
1030
1031
procedure Open_Processes (Debugger : access Debugger_Root) is
1032
begin
1033
Open_Processes (Debugger.Handle, Debugger.Kernel);
1034
end Open_Processes;
1035
1036
------------------
1037
-- Next_Process --
1038
------------------
1039
1040
procedure Next_Process
1041
(Debugger : access Debugger_Root;
1042
Info : out GVD.Proc_Utils.Process_Info;
1043
Success : out Boolean) is
1044
begin
1045
Next_Process (Debugger.Handle, Info, Success);
1046
end Next_Process;
1047
1048
---------------------
1049
-- Close_Processes --
1050
---------------------
1051
1052
procedure Close_Processes (Debugger : access Debugger_Root) is
1053
begin
1054
Close_Processes (Debugger.Handle);
1055
end Close_Processes;
1056
1057
-----------------
1058
-- Support_TTY --
1059
-----------------
1060
1061
function Support_TTY (Debugger : access Debugger_Root) return Boolean is
1062
pragma Unreferenced (Debugger);
1063
begin
1064
return False;
1065
end Support_TTY;
1066
1067
-------------
1068
-- Set_TTY --
1069
-------------
1070
1071
procedure Set_TTY (Debugger : access Debugger_Root; TTY : String) is
1072
pragma Unreferenced (Debugger, TTY);
1073
begin
1074
raise Unknown_Command;
1075
end Set_TTY;
1076
1077
-----------------------
1078
-- Continuation_Line --
1079
-----------------------
1080
1081
function Continuation_Line
1082
(Debugger : access Debugger_Root) return Boolean is
1083
begin
1084
return Debugger.Continuation_Line;
1085
end Continuation_Line;
1086
1087
-------------------------------
1088
-- Separate_Execution_Window --
1089
-------------------------------
1090
1091
function Separate_Execution_Window
1092
(Debugger : access Debugger_Root) return Boolean is
1093
begin
1094
return Debugger.Execution_Window;
1095
end Separate_Execution_Window;
1096
1097
-----------
1098
-- Close --
1099
-----------
1100
1101
procedure Close (Debugger : access Debugger_Root) is
1102
Result : Expect_Match;
1103
C : Language_Lists.Cursor := First (Debugger.Languages);
1104
Lang : Language.Language_Access;
1105
begin
1106
while Has_Element (C) loop
1107
Lang := Element (C);
1108
Language.Free (Lang);
1109
Next (C);
1110
end loop;
1111
Clear (Debugger.Languages);
1112
1113
if Get_Process (Debugger) /= null
1114
and then Get_Descriptor (Get_Process (Debugger)) /= null
1115
then
1116
begin
1117
-- Ensure that the debugger is terminated before closing the pipes
1118
-- and trying to kill it abruptly.
1119
1120
begin
1121
Wait (Get_Process (Debugger), Result, ".+", Timeout => 200);
1122
exception
1123
when Process_Died =>
1124
-- This is somewhat expected... RIP.
1125
null;
1126
end;
1127
Close (Get_Descriptor (Get_Process (Debugger)).all);
1128
exception
1129
when Process_Died =>
1130
null;
1131
end;
1132
end if;
1133
1134
Free (Debugger.Process);
1135
Free (Debugger.Remote_Target);
1136
Free (Debugger.Remote_Protocol);
1137
1138
-- ??? Shouldn't we free Command_Queue
1139
end Close;
1140
1141
----------------
1142
-- Get_Kernel --
1143
----------------
1144
1145
function Get_Kernel
1146
(Debugger : access Debugger_Root'Class)
1147
return GPS.Kernel.Kernel_Handle is
1148
begin
1149
return Debugger.Kernel;
1150
end Get_Kernel;
1151
1152
------------------------------
1153
-- Set_Breakpoint_Condition --
1154
------------------------------
1155
1156
procedure Set_Breakpoint_Condition
1157
(Debugger : access Debugger_Root;
1158
Num : GVD.Types.Breakpoint_Identifier;
1159
Condition : String;
1160
Mode : GVD.Types.Command_Type := GVD.Types.Hidden)
1161
is
1162
begin
1163
null;
1164
end Set_Breakpoint_Condition;
1165
1166
----------------------
1167
-- Set_Scope_Action --
1168
----------------------
1169
1170
procedure Set_Breakpoint_Command
1171
(Debugger : access Debugger_Root;
1172
Num : GVD.Types.Breakpoint_Identifier;
1173
Commands : String;
1174
Mode : GVD.Types.Command_Type := GVD.Types.Hidden)
1175
is
1176
begin
1177
null;
1178
end Set_Breakpoint_Command;
1179
1180
----------------------
1181
-- Set_Scope_Action --
1182
----------------------
1183
1184
procedure Set_Breakpoint_Ignore_Count
1185
(Debugger : access Debugger_Root;
1186
Num : GVD.Types.Breakpoint_Identifier;
1187
Count : Integer;
1188
Mode : GVD.Types.Command_Type := GVD.Types.Hidden)
1189
is
1190
begin
1191
null;
1192
end Set_Breakpoint_Ignore_Count;
1193
1194
----------------------
1195
-- Set_Scope_Action --
1196
----------------------
1197
1198
procedure Set_Scope_Action
1199
(Debugger : access Debugger_Root;
1200
Scope : GVD.Types.Scope_Type := GVD.Types.No_Scope;
1201
Action : GVD.Types.Action_Type := GVD.Types.No_Action;
1202
Num : GVD.Types.Breakpoint_Identifier := 0;
1203
Mode : GVD.Types.Command_Type := GVD.Types.Hidden)
1204
is
1205
pragma Unreferenced (Scope, Action, Num, Mode);
1206
begin
1207
null;
1208
end Set_Scope_Action;
1209
1210
-----------------
1211
-- Task_Switch --
1212
-----------------
1213
1214
procedure Task_Switch
1215
(Debugger : access Debugger_Root;
1216
Task_Num : Natural;
1217
Mode : GVD.Types.Command_Type := GVD.Types.Hidden)
1218
is
1219
pragma Unreferenced (Task_Num, Mode);
1220
begin
1221
null;
1222
end Task_Switch;
1223
1224
-------------------
1225
-- Thread_Switch --
1226
-------------------
1227
1228
procedure Thread_Switch
1229
(Debugger : access Debugger_Root;
1230
Thread : Natural;
1231
Mode : GVD.Types.Command_Type := GVD.Types.Hidden)
1232
is
1233
pragma Unreferenced (Thread, Mode);
1234
begin
1235
null;
1236
end Thread_Switch;
1237
1238
---------------
1239
-- PD_Switch --
1240
---------------
1241
1242
procedure PD_Switch
1243
(Debugger : access Debugger_Root;
1244
PD : String;
1245
Mode : GVD.Types.Command_Type := GVD.Types.Hidden)
1246
is
1247
pragma Unreferenced (PD, Mode);
1248
begin
1249
null;
1250
end PD_Switch;
1251
1252
----------------
1253
-- Info_Tasks --
1254
----------------
1255
1256
procedure Info_Tasks
1257
(Debugger : access Debugger_Root;
1258
Info : out Thread_Information_Array;
1259
Len : out Natural)
1260
is
1261
pragma Unreferenced (Info, Debugger);
1262
begin
1263
Len := 0;
1264
end Info_Tasks;
1265
1266
------------------
1267
-- Info_Threads --
1268
------------------
1269
1270
procedure Info_Threads
1271
(Debugger : access Debugger_Root;
1272
Info : out Thread_Information_Array;
1273
Len : out Natural)
1274
is
1275
pragma Unreferenced (Info, Debugger);
1276
begin
1277
Len := 0;
1278
end Info_Threads;
1279
1280
-------------
1281
-- Info_PD --
1282
-------------
1283
1284
procedure Info_PD
1285
(Debugger : access Debugger_Root;
1286
Info : out PD_Information_Array;
1287
Len : out Natural)
1288
is
1289
pragma Unreferenced (Info, Debugger);
1290
begin
1291
Len := 0;
1292
end Info_PD;
1293
1294
-------------------------
1295
-- Set_VxWorks_Version --
1296
-------------------------
1297
1298
procedure Set_VxWorks_Version
1299
(Debugger : access Debugger_Root; Force : Boolean := False)
1300
is
1301
pragma Unreferenced (Force);
1302
begin
1303
null;
1304
end Set_VxWorks_Version;
1305
1306
---------------------
1307
-- VxWorks_Version --
1308
---------------------
1309
1310
function VxWorks_Version
1311
(Debugger : access Debugger_Root)
1312
return GVD.Types.VxWorks_Version_Type
1313
is
1314
pragma Unreferenced (Debugger);
1315
begin
1316
return Vx_None;
1317
end VxWorks_Version;
1318
1319
end Debugger;
Loggerhead is a web-based interface for Breezy
Version: 2.0.1