-
Notifications
You must be signed in to change notification settings - Fork 10
/
gdb-mi.el
2764 lines (2348 loc) · 126 KB
/
gdb-mi.el
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
;;; gdb-mi.el --- GDB Graphical Interface -*- lexical-binding: t; -*-
;; Copyright (C) 2017-2018 Gonçalo Santos
;; Author: Gonçalo Santos (weirdNox @ GitHub)
;; Homepage: https://github.com/weirdNox/emacs-gdb
;; Keywords: lisp gdb mi debugger graphical interface
;; Package-Requires: ((emacs "26.1") (hydra "0.14.0"))
;; Version: 0.1
;; This program 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 3 of the License, or
;; (at your option) any later version.
;; This program 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 program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This package provides a graphical user interface to GDB.
;;; Code:
;; ------------------------------------------------------------------------------------------
;; Package and related things
(require 'cl-lib)
(require 'subr-x)
(require 'comint)
(require 'hydra)
(eval-and-compile
(unless (bound-and-true-p module-file-suffix)
(error "Dynamic modules are NOT supported in your build of Emacs")))
(let* ((default-directory (file-name-directory (or load-file-name default-directory)))
(required-module (concat "gdb-module" module-file-suffix))
(path-to-module (concat default-directory required-module)))
(if (file-exists-p required-module)
(require 'gdb-module path-to-module)
(message "Compiling GDB dynamic module...")
(with-current-buffer (compile (concat "make -k " required-module))
(add-hook 'compilation-finish-functions
(lambda (_buffer _status) (require 'gdb-module path-to-module)) nil t))))
(declare-function gdb--handle-mi-output "ext:gdb-module")
(defun gdb--clear-old-customization-vars ()
(setplist 'gdb-buffers nil)
(setplist 'gdb-non-stop nil))
(eval-after-load 'cus-load #'gdb--clear-old-customization-vars)
;; ------------------------------------------------------------------------------------------
;; User configurable variables
(defgroup gdb nil
"A GDB graphical interface"
:group 'tools
:prefix "gdb-"
:version "26.1")
(defcustom gdb-enable-global-keybindings t
"If non-nil, enable `gdb-keys-mode' which provides global keybindings while there are open sessions."
:group 'gdb
:type 'boolean
:version "26.1")
(defcustom gdb-window-setup-function #'gdb--setup-windows
"Function to setup the windows and buffers in the main frame.
If you want to write your own, use `gdb--setup-windows' as inspiration!"
:group 'gdb
:type 'function
:version "26.1")
(defcustom gdb-watchers-hide-access-specifiers t
"When non-nil, this will hide the access specifiers in the watchers.
This can be changed in a debugging session with the command `gdb-watchers-toggle-access-specifiers'."
:group 'gdb
:type 'boolean
:version "26.1")
(defcustom gdb-ignore-gdbinit t
"When non-nil, use the flag \"-nx\" which makes GDB ignore .gdbinit."
:group 'gdb
:type 'boolean
:version "26.1")
(defcustom gdb-executable-name "gdb"
"GDB executable name or path."
:group 'gdb
:type 'string
:version "26.2")
(defcustom gdb-debug nil
"List of debug symbols, which will enable different components.
Possible values are:
- `timings': show timings of some function calls
- `commands': print to the messages buffer which GDB commands are sent
- `raw-input': send comint input as is
- `raw-output': print GDB/MI output to the messages buffer
This can also be set to t, which means that all debug components are active."
:group 'gdb
:type '(choice boolean
(set (const :tag "Timings of some function calls" timings)
(const :tag "Print, to the messages buffer, which GDB commands are sent" commands)
(const :tag "Send comint input as is" raw-input)
(const :tag "Print GDB/MI output to the messages buffer" raw-output)))
:version "26.1")
;; ------------------------------------------------------------------------------------------
;; Faces and bitmaps
(when (display-images-p)
(define-fringe-bitmap 'gdb--fringe-breakpoint "\x3c\x7e\xff\xff\xff\xff\x7e\x3c"))
(defgroup gdb-faces nil
"Faces in the GDB graphical interface"
:group 'gdb
:version "26.1"
:prefix "gdb-")
(defface gdb-breakpoint-enabled-face
'((t :foreground "red1" :weight bold))
"Face for enabled breakpoint icon in fringe."
:group 'gdb-faces
:version "26.1")
(defface gdb-breakpoint-disabled-face
'((((class color) (min-colors 88)) :foreground "gray70")
(((class color) (min-colors 8) (background light)) :foreground "black")
(((class color) (min-colors 8) (background dark)) :foreground "white")
(((type tty) (class mono)) :inverse-video t)
(t :background "gray"))
"Face for disabled breakpoint icon in fringe."
:group 'gdb-faces
:version "26.1")
(defface gdb-function-face '((t :inherit font-lock-function-name-face))
"Face for highlighting function names."
:group 'gdb-faces
:version "26.1")
(defface gdb-constant-face '((t :inherit font-lock-constant-face))
"Face for highlighting constant values."
:group 'gdb-faces
:version "26.1")
(defface gdb-variable-face '((t :inherit font-lock-variable-name-face))
"Face for highlighting variable and register names in watcher, variables and registers buffers.")
(defface gdb-type-face '((t :inherit font-lock-type-face))
"Face for highlighting types names in watcher and variables buffers.")
(defface gdb-modified-face '((t :inherit error))
"Face for highlighting modified values in watcher and register buffers."
:group 'gdb-faces
:version "26.1")
(defface gdb-disassembly-src-face '((t :inherit font-lock-string-face))
"Face for highlighting the source code in disassembly buffers."
:group 'gdb-faces
:version "26.1")
(defface gdb-disassembly-line-indicator-face '((t :inherit font-lock-type-face))
"Face for highlighting the source code line number in disassembly buffers."
:group 'gdb-faces
:version "26.1")
(defface gdb-opcode-face '((t :inherit font-lock-keyword-face))
"Face for highlighting opcodes in disassembly buffers."
:group 'gdb-faces
:version "26.1")
(defface gdb-raw-opcode-face '((t :inherit font-lock-comment-face))
"Face for highlighting raw opcodes in disassembly buffers."
:group 'gdb-faces
:version "26.1")
(eval-and-compile
(defface gdb-running-face '((t :inherit font-lock-string-face))
"Face for highlighting the \"running\" keyword."
:group 'gdb-faces
:version "26.1")
(defface gdb-stopped-face '((t :inherit font-lock-warning-face))
"Face for highlighting the \"stopped\" keyword."
:group 'gdb-faces
:version "26.1")
(defface gdb-out-of-scope-face '((t :inherit font-lock-comment-face))
"Face for highlighting \"Out of scope\" in watcher buffers."
:group 'gdb-faces
:version "26.1")
(defface gdb-watcher-hold-face '((t :inherit error))
"Face for highlighting \"HOLD\" in watcher buffers."
:group 'gdb-faces
:version "26.1")
(defface gdb-y-face '((t :inherit font-lock-warning-face))
"Face for highlighting the enabled symbol \"y\" in breakpoint buffers."
:group 'gdb-faces
:version "26.1")
(defface gdb-n-face '((t :inherit font-lock-comment-face))
"Face for highlighting the disabled symbol \"n\" in breakpoint buffers."
:group 'gdb-faces
:version "26.1"))
;; ------------------------------------------------------------------------------------------
;; Private constants and variables
(defvar gdb--previous-executable nil
"Previous executable path.")
(defconst gdb--available-contexts
'(gdb--context-tty-set ;; Data (optional): Old TTY process
gdb--context-initial-file
gdb--context-thread-info
gdb--context-frame-info ;; Data: Thread
gdb--context-breakpoint-insert
gdb--context-breakpoint-enable-disable ;; Data: (Breakpoint . NewState)
gdb--context-breakpoint-delete ;; Data: Breakpoint
gdb--context-get-variables ;; Data: Frame
gdb--context-watcher-create ;; Data: [Expression WatcherToReplace StackDepth]
gdb--context-watcher-update ;; Data: ShouldHighlight
gdb--context-watcher-list-children
gdb--context-watcher-change-format ;; Data: Watcher
gdb--context-registers-list-names ;; Data: Thread
gdb--context-registers-get-changed ;; Data: (FormatString . Thread)
gdb--context-registers-update ;; Data: Thread
gdb--context-disassemble ;; Data: BufferData
gdb--context-persist-thread
gdb--context-get-data ;; Data: Result name string
gdb--context-get-console-data
gdb--context-ignore-errors
)
"List of implemented token contexts.
Must be in the same order of the `token_context' enum in the
dynamic module.")
(eval-and-compile
(defconst gdb--buffer-types
'(gdb--comint
gdb--inferior-io
gdb--threads
gdb--frames
gdb--breakpoints
gdb--variables
gdb--watchers
gdb--registers
gdb--disassembly)
"List of available buffer types."))
(defconst gdb--keep-buffer-types '(gdb--comint gdb--inferior-io)
"List of buffer types that should be kept after GDB is killed.")
(cl-defstruct gdb--register number name value tick)
(cl-defstruct gdb--thread
id target-id name state frames core
(registers-tick most-negative-fixnum) registers
;; NOTE(nox): This was previously "N" for natural representation.
;; However, gdb/mpfr/gmp/guile/libgc have a bug in which the garbage collector deallocates a block
;; twice, resulting in a crash with the error "Duplicate large block deallocation".
;; It seems defaulting to hexadecimal representation makes it less probable to occur...
(registers-format "x"))
(cl-defstruct gdb--variable name type value)
(cl-defstruct gdb--frame thread level addr func file line from variables)
(cl-defstruct gdb--breakpoint
session number type disp enabled addr hits ignore-count what
thread pending condition file gdb-fullname line func overlays)
(defconst gdb--available-breakpoint-types
'(("Breakpoint" . "")
("Temporary Breakpoint" . "-t ")
("Hardware Breakpoint" . "-h ")
("Temporary Hardware Breakpoint" . "-t -h "))
"Alist of (TYPE . FLAGS).
Both are strings. FLAGS are the flags to be passed to -break-insert in order to create a
breakpoint of TYPE.")
(cl-defstruct gdb--watcher name expr type value parent children-count children open flag
thread-id stack-depth)
(cl-defstruct gdb--session
handling-output buffered-output
frame process buffers source-window debuggee-path debuggee-args
buffer-types-to-update buffers-to-update
threads selected-thread persist-thread selected-frame
breakpoints killed-inferior
(watchers-tick most-negative-fixnum) (watchers (make-hash-table :test 'equal)) root-watchers
(hide-access-spec gdb-watchers-hide-access-specifiers))
(defvar gdb--sessions nil
"List of active sessions.")
(defvar gdb--session nil
"Let-bound chosen session.")
(cl-defstruct gdb--buffer-info session type thread update-func data)
(defvar-local gdb--buffer-info nil
"GDB related information related to each buffer.")
(put 'gdb--buffer-info 'permanent-local t)
(defvar gdb--next-token 0
"Next token value to be used for context matching.
This is shared among all sessions.")
(defvar gdb--token-contexts nil
"Alist of tokens and contexts.
The alist has the format ((TOKEN . (TYPE . DATA)) ...).
This is shared among all sessions.")
(defvar gdb--inferior-argument-history nil
"History of arguments passed to the inferior.")
(cl-defstruct gdb--disassembly-instr addr func offset instr opcodes)
(cl-defstruct gdb--disassembly-src file line-str instrs)
(cl-defstruct gdb--disassembly-data (mode 4) func list new widths) ;; NOTE(nox): widths - [addr opcode instr]
(defvar gdb--inhibit-display-source nil)
(defvar gdb--open-buffer-new-frame nil)
(defvar gdb--data nil)
(defvar gdb--user-ptr nil)
(defvar gdb--omit-console-output nil)
;; ------------------------------------------------------------------------------------------
;; Utilities
(defun gdb--debug-check (arg)
"Check if debug ARG is enabled.
Type may be a symbol or a list of symbols and are checked against `gdb-debug'."
(or (eq gdb-debug t)
(and (listp arg) (cl-loop for type in arg when (memq type gdb-debug) return t))
(and (symbolp arg) (memq arg gdb-debug))))
(defmacro gdb--debug-execute-body (debug-symbol &rest body)
"Execute body when DEBUG-SYMBOL is in `gdb-debug'.
DEBUG-SYMBOL may be a symbol or a list of symbols."
(declare (indent defun))
`(when (gdb--debug-check ,debug-symbol) (progn ,@body)))
(defun gdb--read-line (prompt &optional default)
"Read a line of user input with PROMPT and DEFAULT value.
The string is trimmed and all the spaces (including newlines) are converted into a single space."
(let ((result (replace-regexp-in-string
"\\(\\`[ \t\r\n\v\f]+\\|[ \t\r\n\v\f]+\\'\\)" "" (read-string prompt default))))
(and (> (length result) 0) (replace-regexp-in-string "[ \t\r\n\v\f]+" " " result))))
(defun gdb--escape-argument (string)
"Return STRING quoted properly as an MI argument.
The string is enclosed in double quotes.
All embedded quotes, newlines, and backslashes are preceded with a backslash."
(setq string (replace-regexp-in-string "\\([\"\\]\\)" "\\\\\\&" string t))
(setq string (replace-regexp-in-string "\n" "\\n" string t t))
(concat "\"" string "\""))
(defmacro gdb--measure-time (string &rest body)
"Measure the time it takes to evaluate BODY."
`(if (gdb--debug-check 'timings)
(progn
(message (concat "Starting measurement: " ,string))
(let ((time (current-time))
(result (progn ,@body)))
(message "GDB TIME MEASUREMENT: %s - %.06fs" ,string (float-time (time-since time)))
result))
(progn ,@body)))
(defmacro gdb--current-line (&optional pos)
"Return current line number. When POS is provided, count lines until POS."
`(save-excursion ,(when pos `(goto-char ,pos))
(beginning-of-line)
(1+ (count-lines 1 (point)))))
(defsubst gdb--stn (str) (and (stringp str) (string-to-number str)))
(defsubst gdb--nts (num) (and (numberp num) (number-to-string num)))
(defsubst gdb--add-face (string face) (when string (propertize string 'face face)))
(defmacro gdb--update-struct (type struct &rest pairs)
(declare (indent defun))
`(progn ,@(cl-loop for (key val) in pairs
collect `(setf (,(intern (concat (symbol-name type) "-" (symbol-name key))) ,struct) ,val))))
(defun gdb--location-string (&optional func file line from addr)
(when file (setq file (file-name-nondirectory file)))
(concat "in " (propertize (or func "??") 'face 'gdb-function-face)
(and addr (concat " at " (propertize addr 'face 'gdb-constant-face)))
(or (and file line (format " of %s:%d" file line))
(and from (concat " of " from)))))
(defun gdb--frame-location-string (frame &optional for-threads-view)
(cond (frame (gdb--location-string (gdb--frame-func frame) (gdb--frame-file frame) (gdb--frame-line frame)
(gdb--frame-from frame) (and for-threads-view (gdb--frame-addr frame))))
(t "No information")))
(defun gdb--append-to-buffer (buffer string)
(when (buffer-live-p buffer)
(let* ((windows (get-buffer-window-list buffer nil t))
windows-to-move return-pos)
(with-current-buffer buffer
(dolist (window windows)
(when (= (window-point window) (point-max))
(push window windows-to-move)))
(unless (= (point) (point-max))
(setq return-pos (point))
(goto-char (point-max)))
(insert string)
(when return-pos (goto-char return-pos))
(dolist (window windows-to-move)
(set-window-point window (point-max)))))))
(defsubst gdb--parse-address (addr-str)
(and addr-str (string-to-number (substring addr-str 2) 16)))
;; ------------------------------------------------------------------------------------------
;; Session management
(defsubst gdb--infer-session (&optional only-from-buffer)
(or (and (not only-from-buffer) gdb--session)
(and (gdb--buffer-info-p gdb--buffer-info)
(gdb--session-p (gdb--buffer-info-session gdb--buffer-info))
(gdb--buffer-info-session gdb--buffer-info))
(and (not only-from-buffer)
(gdb--session-p (frame-parameter nil 'gdb--session))
(frame-parameter nil 'gdb--session))))
(defun gdb--valid-session (session)
"Returns t if SESSION is valid. Else, nil."
(when (gdb--session-p session)
(if (and (frame-live-p (gdb--session-frame session))
(process-live-p (gdb--session-process session)))
t
(gdb--kill-session session)
nil)))
(defmacro gdb--with-valid-session (&rest body)
(declare (debug ([&optional stringp] body)))
(let ((message (and (stringp (car body)) (pop body))))
`(let* ((session (gdb--infer-session))
(gdb--session session))
(if (gdb--valid-session session)
(progn ,@body)
,(when message `(error "%s" ,message))))))
(defun gdb--session-name (session)
(let ((debuggee (gdb--session-debuggee-path session)))
(concat "Session " (if (stringp debuggee)
(concat "debugging " (abbreviate-file-name debuggee))
"without debuggee"))))
(defmacro gdb--after-choosing-session (&rest body)
(declare (debug (body)))
`(let* ((collection (cl-loop for session in gdb--sessions
collect (cons (gdb--session-name session) session)))
(session (or (gdb--infer-session)
(if (= (length gdb--sessions) 1)
(car gdb--sessions)
(cdr (assoc-string (completing-read "Which session? " collection nil t nil nil)
collection)))))
(gdb--session session))
(when (gdb--valid-session session)
,@body)))
(defun gdb--kill-session (session)
(when (and (gdb--session-p session) (memq session gdb--sessions))
(setq gdb--sessions (delq session gdb--sessions))
(when (= (length gdb--sessions) 0)
(remove-hook 'delete-frame-functions #'gdb--handle-delete-frame)
(remove-hook 'window-configuration-change-hook #'gdb--rename-frame)
(gdb-keys-mode -1))
(unless (cl-loop for frame in (frame-list)
when (and (not (eq (frame-parameter frame 'gdb--session) session))
(frame-visible-p frame) (not (frame-parent frame))
(not (frame-parameter frame 'delete-before)))
return t)
(save-buffers-kill-emacs)
(make-frame))
(cl-loop for frame in (frame-list)
when (and (eq (frame-parameter frame 'gdb--session) session)
(not (eq frame (gdb--session-frame session))))
do (delete-frame frame))
(when (frame-live-p (gdb--session-frame session))
(set-frame-parameter (gdb--session-frame session) 'gdb--session nil)
(delete-frame (gdb--session-frame session)))
(set-process-sentinel (gdb--session-process session) nil)
(delete-process (gdb--session-process session))
(dolist (buffer (gdb--session-buffers session))
(when (buffer-live-p buffer)
(with-current-buffer buffer
(if gdb--buffer-info
(let ((type (gdb--buffer-info-type gdb--buffer-info)))
(when (eq type 'gdb--inferior-io)
(let ((proc (get-buffer-process buffer)))
(when proc
(set-process-sentinel proc nil)
(delete-process (get-buffer-process buffer)))))
(if (memq type gdb--keep-buffer-types)
(setq gdb--buffer-info nil)
(kill-buffer)))
(kill-buffer)))))
(gdb--remove-all-symbols session 'all)))
(defun gdb--get-data (command key &rest args-to-command)
"Synchronously retrieve result KEY of COMMAND.
ARGS-TO-COMMAND are passed to `gdb--command', after the context."
(gdb--with-valid-session
(setq gdb--data nil)
(apply 'gdb--command command (cons 'gdb--context-get-data key) args-to-command)
(while (not gdb--data) (accept-process-output (gdb--session-process session) 0.5))
(when (stringp gdb--data) gdb--data)))
(defun gdb--get-console-data (command &rest args-to-command)
"Synchronously retrieve output from command. Each line will turn into a string in a list.
ARGS-TO-COMMAND are passed to `gdb--command', after the context."
(gdb--with-valid-session
(setq gdb--data nil
gdb--omit-console-output 'to-data)
(apply 'gdb--command command 'gdb--context-get-console-data args-to-command)
(while (or (not gdb--data) (user-ptrp gdb--data))
(accept-process-output (gdb--session-process session) 0.5))
(when (listp gdb--data) gdb--data)))
;; ------------------------------------------------------------------------------------------
;; Files
(defun gdb--find-file (path)
"Return the buffer of the file specified by PATH.
Create the buffer, if it wasn't already open."
(when (and path (not (file-directory-p path)) (file-readable-p path))
(find-file-noselect path t)))
(defun gdb--get-line (path line &optional trim)
(when (and path line (> line 0))
(let ((buffer (gdb--find-file path)))
(when buffer
(with-current-buffer buffer
(save-excursion
(goto-char (point-min))
(forward-line (1- line))
(let ((string (thing-at-point 'line)))
(if trim
(replace-regexp-in-string "\\(\\`[[:space:]\n]*\\|[[:space:]\n]*\\'\\)" "" string)
string))))))))
(defun gdb--complete-path (path)
"Add TRAMP prefix to PATH returned from GDB output, if needed."
(gdb--with-valid-session
(when path (concat (file-remote-p (buffer-local-value 'default-directory (gdb--comint-get-buffer session)))
path))))
(defsubst gdb--local-path (complete-path)
"Returns path local to the machine it is in (without TRAMP prefix)."
(or (file-remote-p complete-path 'localname) complete-path))
;; ------------------------------------------------------------------------------------------
;; Fringe symbols
(defun gdb--place-symbol (session buffer line-or-pos data)
"Place fringe symbol from SESSION on BUFFER.
LINE-OR-POS must be a line number or (pos).
DATA is an alist and must at least include `type'."
(when (and (buffer-live-p buffer) line-or-pos data)
(with-current-buffer buffer
(let* ((type (alist-get 'type data))
(pos (cond ((consp line-or-pos) (save-excursion (goto-char (car line-or-pos))
(line-beginning-position)))
((line-beginning-position (1+ (- line-or-pos (gdb--current-line)))))))
(overlay (make-overlay pos pos buffer))
(dummy-string (make-string 1 ?x))
property)
;; NOTE(nox): Properties for housekeeping, session and type of symbol
(overlay-put overlay 'gdb--session session)
(overlay-put overlay 'gdb--type type)
;; NOTE(nox): Fringe spec: (left-fringe BITMAP [FACE])
;; Margin spec: ((margin left-margin) STRING)
(cond
((eq type 'breakpoint-indicator)
(let ((breakpoint (alist-get 'breakpoint data))
(enabled (alist-get 'enabled data)))
(push overlay (gdb--breakpoint-overlays breakpoint))
(overlay-put overlay 'gdb--breakpoint breakpoint)
(if (display-images-p)
(setq property
`(left-fringe gdb--fringe-breakpoint
,(if enabled 'gdb-breakpoint-enabled-face 'gdb-breakpoint-disabled-face)))
(setq property `((margin left-margin) ,(if enabled "B" "b"))))))
((memq type '(source-indicator frame-indicator thread-indicator disassembly-indicator))
(overlay-put overlay 'priority 10) ;; NOTE(nox): Above breakpoint symbols
(if (display-images-p)
(setq property '(left-fringe right-triangle compilation-warning))
(setq property '((margin left-margin) "=>")))))
(put-text-property 0 1 'display property dummy-string)
(overlay-put overlay 'before-string dummy-string)
(when (eq type 'source-indicator)
(overlay-put overlay 'window (gdb--session-source-window session)))))))
(defsubst gdb--remove-symbols-in-curr-buffer (type)
(remove-overlays nil nil 'gdb--type type))
(defun gdb--remove-all-symbols (session type &optional source-files-only)
"Remove all symbols from SESSION, with type TYPE.
When SOURCE-FILES-ONLY is non-nil, only remove them from buffer
that are not created by GDB."
(dolist (buffer (buffer-list))
(with-current-buffer buffer
(unless (and source-files-only gdb--buffer-info)
(dolist (ov (overlays-in (point-min) (point-max)))
(when (and (eq session (overlay-get ov 'gdb--session))
(or (memq type (list 'all (overlay-get ov 'gdb--type)))))
(delete-overlay ov)))))))
(defun gdb--place-breakpoint-in-disassembly (buffer breakpoint)
(when buffer
(with-current-buffer buffer
(gdb--with-valid-session
(let ((pos (text-property-any (point-min) (point-max) 'gdb--addr-num (gdb--parse-address
(gdb--breakpoint-addr breakpoint)))))
(when pos (gdb--place-symbol session buffer (cons pos nil)
`((type . breakpoint-indicator)
(breakpoint . ,breakpoint)
(enabled . ,(gdb--breakpoint-enabled breakpoint))))))))))
(defun gdb--place-breakpoint (session breakpoint)
(gdb--place-symbol session (gdb--find-file (gdb--breakpoint-file breakpoint)) (gdb--breakpoint-line breakpoint)
`((type . breakpoint-indicator)
(breakpoint . ,breakpoint)
(enabled . ,(gdb--breakpoint-enabled breakpoint))))
(gdb--place-breakpoint-in-disassembly (gdb--get-buffer-with-type session 'gdb--disassembly) breakpoint))
(defun gdb--breakpoint-remove-symbol (breakpoint)
(dolist (overlay (gdb--breakpoint-overlays breakpoint)) (delete-overlay overlay))
(setf (gdb--breakpoint-overlays breakpoint) nil))
;; ------------------------------------------------------------------------------------------
;; Threads and frames
(defun gdb--get-thread-by-id (id)
(gdb--with-valid-session
(when id
(cl-loop for thread in (gdb--session-threads session)
when (= (gdb--thread-id thread) id) return thread))))
(defun gdb--best-frame-to-switch-to (thread)
"Return the most relevant frame to switch to in THREAD's frames."
(when thread
(let ((fallback (car (gdb--thread-frames thread))))
(or (unless (gdb--disassembly-is-visible)
(cl-loop for frame in (gdb--thread-frames thread)
when (and (gdb--frame-file frame) (gdb--frame-line frame)) return frame))
fallback))))
;; NOTE(nox): Called from the dynamic module
(defun gdb--switch-to-thread (thread &optional auto)
"Unconditionally switch to _different_ THREAD. This will also switch to the most relevant frame.
THREAD may be nil, which means to remove the selected THREAD.
THREAD may also be an ID string."
(gdb--with-valid-session
(when (stringp thread) (setq thread (gdb--get-thread-by-id (string-to-number thread))))
(unless (eq thread (gdb--session-selected-thread session))
(setf (gdb--session-selected-thread session) thread)
(when thread
(gdb--command (format "-thread-select %d" (gdb--thread-id thread)) 'gdb--context-ignore-errors)
(message "Switching to thread %d." (gdb--thread-id thread)))
(gdb--switch-to-frame (gdb--best-frame-to-switch-to thread) auto)
(let ((buffer (gdb--get-buffer-with-type session 'gdb--threads)) pos)
(when buffer
(with-current-buffer buffer
(gdb--remove-symbols-in-curr-buffer 'thread-indicator)
(when thread
(when (setq pos (text-property-any (point-min) (point-max) 'gdb--thread thread))
(gdb--place-symbol session (current-buffer) (gdb--current-line pos)
'((type . thread-indicator))))))))
(cl-pushnew 'gdb--frames (gdb--session-buffer-types-to-update session))
(cl-pushnew 'gdb--registers (gdb--session-buffer-types-to-update session)))))
;; NOTE(nox): Called from the dynamic module
(defun gdb--switch-to-frame (frame &optional auto)
"Unconditionally switch to a _different_ FRAME.
When FRAME is in a different thread, switch to it.
FRAME may also be (ThreadIdString . LevelString).
When FRAME is `deselect-frame', then deselect the current frame but keep the selected thread."
(gdb--with-valid-session
(when (consp frame)
(let ((thread (gdb--get-thread-by-id (string-to-number (car frame))))
(level (string-to-number (cdr frame))))
(setq frame (cl-loop for frame in (gdb--thread-frames thread)
when (= (gdb--frame-level frame) level) return frame))))
(let ((keep-thread (eq frame 'deselect-frame)))
(setq frame (if keep-thread nil frame))
(unless (eq frame (gdb--session-selected-frame session))
(setf (gdb--session-selected-frame session) frame)
(unless keep-thread (gdb--switch-to-thread (and frame (gdb--frame-thread frame)) auto))
(when frame
(gdb--command (format "-stack-select-frame %d" (gdb--frame-level frame)))
(gdb--command "-var-update --all-values *" (cons 'gdb--context-watcher-update auto) frame))
(if (and frame (not (gdb--frame-variables frame)))
(gdb--command "-stack-list-variables --simple-values" (cons 'gdb--context-get-variables frame) frame)
(cl-pushnew 'gdb--variables (gdb--session-buffer-types-to-update session)))
(gdb--disassembly-fetch frame)
(gdb--display-source-buffer)
(let ((buffer (gdb--get-buffer-with-type session 'gdb--frames)) pos)
(when buffer
(with-current-buffer buffer
(gdb--remove-symbols-in-curr-buffer 'frame-indicator)
(when frame
(when (setq pos (text-property-any (point-min) (point-max) 'gdb--frame frame))
(gdb--place-symbol session (current-buffer) (gdb--current-line pos)
'((type . frame-indicator))))))))))))
(defun gdb--switch (frame-or-thread)
"Unconditionally switch to a _different_ FRAME-OR-THREAD."
(gdb--with-valid-session
(cl-assert (or (gdb--thread-p frame-or-thread) (gdb--frame-p frame-or-thread)))
(let* ((type (type-of frame-or-thread))
(thread (if (eq type 'gdb--thread) frame-or-thread (gdb--frame-thread frame-or-thread)))
(frame (if (eq type 'gdb--frame) frame-or-thread (gdb--best-frame-to-switch-to frame-or-thread))))
(if frame
(gdb--switch-to-frame frame)
(gdb--switch-to-thread thread)))))
(defun gdb--conditional-switch (frame-or-thread &optional cause)
"Conditionally switch to a _different_ FRAME-OR-THREAD depending on CAUSE.
This will _always_ switch when no thread is selected.
CAUSE should be a list of the following symbols:
- `running': Switch when selected thread is running and is different from THREAD
- `same-thread' (only for frames): Switch when same thread
When the thread is switched, the current frame will also be changed."
(gdb--with-valid-session
(cl-assert (or (gdb--thread-p frame-or-thread) (gdb--frame-p frame-or-thread)))
(let* ((type (type-of frame-or-thread))
(thread (if (eq type 'gdb--thread) frame-or-thread (gdb--frame-thread frame-or-thread)))
(frame (if (eq type 'gdb--frame) frame-or-thread (gdb--best-frame-to-switch-to frame-or-thread)))
(selected-thread (gdb--session-selected-thread session))
(condition (or (not selected-thread)
(and (memq 'running cause)
(string= "running" (gdb--thread-state selected-thread)))
(and (eq type 'gdb--frame) (memq 'same-thread cause)
(eq thread selected-thread)))))
(when condition (if frame
(gdb--switch-to-frame frame t)
(gdb--switch-to-thread thread t))))))
(defun gdb--ask-for-thread (&optional default)
(gdb--with-valid-session
(when (gdb--session-threads session)
(let* ((default-string nil)
(collection (cl-loop for thread in (gdb--session-threads session) with display
do (setq display (format "%d: %s" (gdb--thread-id thread)
(gdb--thread-target-id thread)))
collect (cons display thread)
when (eq thread default) do (setq default-string display))))
(push (cons "NONE" nil) collection)
(unless default-string (setq default-string (caar collection)))
(cdr (assoc (completing-read "Thread: " collection nil t nil nil default-string)
collection))))))
;; ------------------------------------------------------------------------------------------
;; Tables
(cl-defstruct gdb--table header rows (num-rows 0) column-sizes target-line start-line)
(cl-defstruct gdb--table-row table columns properties level has-children children-func)
(eval-when-compile
(defvar gdb-table-mouse-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map t)
(define-key map (kbd "<mouse-1>") #'gdb-table-mouse-toggle)
map)))
(defsubst gdb--pad-string (string padding)
(if (= padding 0)
string
(format (concat "%" (number-to-string padding) "s") (or string ""))))
(defun gdb--table-update-column-sizes (table columns &optional level has-children)
"Update TABLE column sizes to include new COLUMNS.
LEVEL should be an integer specifying the indentation level."
(unless (gdb--table-column-sizes table)
(setf (gdb--table-column-sizes table) (make-list (length columns) 0)))
(setf (gdb--table-column-sizes table)
(cl-loop
with len = (length (gdb--table-column-sizes table))
for string in columns
and size in (gdb--table-column-sizes table)
and first = t then nil
and count from 1
when (= count len) collect 0
else collect (- (max (abs size) (+ (string-width (or string ""))
(* (or (and first level) 0) 4)
(or (and first has-children 4) 0)))))))
(defun gdb--table-add-header (table columns)
"Set TABLE header to COLUMNS, a list of strings, and recalculate column sizes."
(gdb--table-update-column-sizes table columns)
(setf (gdb--table-header table) columns))
(defsubst gdb--get-table-from-table-or-parent (table-or-parent)
"TABLE-OR-PARENT should be a table or a table row, which, in the latter case, will be made the parent of
the inserted row. Returns table."
(cond ((eq (type-of table-or-parent) 'gdb--table) table-or-parent)
((eq (type-of table-or-parent) 'gdb--table-row) (gdb--table-row-table table-or-parent))
(t (error "Unexpected table-or-argument type."))))
(defun gdb--table-add-row (table-or-parent columns &optional properties has-children children-func)
"Add a row of COLUMNS, a list of strings, to TABLE-OR-PARENT and recalculate column sizes.
When non-nil, PROPERTIES will be added to the whole row when printing.
TABLE-OR-PARENT should be a table or a table row, which, in the latter case, will be made the parent of
the inserted row.
HAS-CHILDREN should be t when this node has children."
(let* ((table (gdb--get-table-from-table-or-parent table-or-parent))
(parent (and (eq (type-of table-or-parent) 'gdb--table-row) table-or-parent))
(level (or (and parent (1+ (gdb--table-row-level parent))) 0))
(row (make-gdb--table-row :table table :columns columns :properties properties :level level
:has-children has-children :children-func children-func)))
(gdb--table-update-column-sizes table columns level has-children)
(setf (gdb--table-rows table) (append (gdb--table-rows table) (list row))
(gdb--table-num-rows table) (1+ (gdb--table-num-rows table)))
(when parent (setf (gdb--table-row-has-children parent) 'open))
row))
(defun gdb--table-row-string (columns column-sizes sep &optional with-newline properties level has-children
children-func)
(apply #'propertize (cl-loop
for string in columns
and size in column-sizes
and first = t then nil
unless first concat sep into result
concat (gdb--pad-string
(concat (and first (make-string (* (or level 0) 4) ? ))
(and first (cond ((eq has-children t)
(eval-when-compile
(propertize "[+] " 'keymap gdb-table-mouse-map)))
((eq has-children 'open)
(eval-when-compile
(propertize "[-] " 'keymap gdb-table-mouse-map)))))
string)
size)
into result
finally return (concat result (and with-newline "\n")))
(append properties (when (functionp children-func) (list 'gdb--table-fetch-func children-func)))))
(defun gdb--table-insert (table &optional sep)
"Erase buffer and insert TABLE with columns separated with SEP (space as default)."
(let ((column-sizes (gdb--table-column-sizes table))
(sep (or sep " ")))
(erase-buffer)
(when (gdb--table-header table)
(setq-local header-line-format
(list (if (display-images-p) " " " ")
(gdb--table-row-string (gdb--table-header table) column-sizes sep))))
(cl-loop for row in (gdb--table-rows table)
for row-number from 1 with insert-newline = t
when (= row-number (gdb--table-num-rows table)) do (setq insert-newline nil)
do (insert (gdb--table-row-string (gdb--table-row-columns row) column-sizes sep insert-newline
(gdb--table-row-properties row) (gdb--table-row-level row)
(gdb--table-row-has-children row)
(gdb--table-row-children-func row))))
(let ((buffer (current-buffer))
(start-line (gdb--table-start-line table))
(target-line (gdb--table-target-line table)))
(when start-line
(gdb--scroll-buffer-to-last-line buffer 'bottom)
(gdb--scroll-buffer-to-line buffer (+ start-line scroll-margin) 'top-if-invisible))
(when target-line
(gdb--scroll-buffer-to-line buffer target-line)))))
;; ------------------------------------------------------------------------------------------
;; Buffers
(defun gdb--get-buffer-with-type (session type)
(cl-loop for buffer in (gdb--session-buffers session)
when (let ((buffer-info (buffer-local-value 'gdb--buffer-info buffer)))
(and buffer-info (eq (gdb--buffer-info-type buffer-info) type)))
return buffer
finally return nil))
(defmacro gdb--simple-get-buffer (type update-func name important hidden &rest body)
"Simple buffer creator/fetcher, for buffers that should be unique in a session."
(declare (indent defun) (debug (sexp sexp body)))
(unless (memq type gdb--buffer-types) (error "Type %s does not exist" (symbol-name type)))
`(defun ,(intern (concat (symbol-name type) "-get-buffer")) (session)
,(concat "Creator and fetcher of buffer with type `" (symbol-name type) "'")
(cond ((gdb--get-buffer-with-type session ',type))
(t (let ((buffer (generate-new-buffer " *GDB Temporary Name*")))
(push buffer (gdb--session-buffers session))
(with-current-buffer buffer
(gdb--rename-buffer ,name ,hidden (gdb--session-debuggee-path session))
(setq gdb--buffer-info (make-gdb--buffer-info :session session :type ',type
:update-func #',update-func))
,@body
,(if important
'(add-hook 'kill-buffer-hook #'gdb--important-buffer-kill-cleanup nil t)
'(add-hook 'kill-buffer-hook #'gdb--buffer-kill-cleanup nil t))
(if (display-images-p)
(setq left-fringe-width 8)
(setq left-margin-width 2)))
(gdb--update-buffer buffer)
buffer)))))
(defun gdb--update-buffer (buffer)
(with-current-buffer buffer
(let ((inhibit-read-only t)
(func (gdb--buffer-info-update-func gdb--buffer-info)))
(cl-assert (fboundp func))
(gdb--measure-time (concat "Calling " (symbol-name func)) (funcall func)))))
(defun gdb--update ()
(gdb--with-valid-session
(let ((buffers-to-update (gdb--session-buffers-to-update session))
(types-to-update (gdb--session-buffer-types-to-update session)))
(dolist (buffer (gdb--session-buffers session))
(let ((buffer-info (buffer-local-value 'gdb--buffer-info buffer)))
(if buffer-info
(when (or (memq buffer buffers-to-update) (memq (gdb--buffer-info-type buffer-info) types-to-update))
(gdb--update-buffer buffer))
(kill-buffer buffer))))
(setf (gdb--session-buffers-to-update session) nil
(gdb--session-buffer-types-to-update session) nil))))
(defmacro gdb--rename-buffer (&optional specific-str hidden debuggee-path)
`(save-match-data
(rename-buffer (concat ,(concat (and hidden " ") "*GDB" (when specific-str (concat ": " specific-str)))
(when ,debuggee-path (concat " - " (file-name-nondirectory ,debuggee-path)))
"*")
t)))
(defun gdb--rename-buffers-with-debuggee (debuggee-path)
(let* ((debuggee-name (file-name-nondirectory debuggee-path))
(replacement (concat " - " debuggee-name "*")))
(dolist (buffer (gdb--session-buffers (gdb--infer-session)))
(with-current-buffer buffer
(rename-buffer (replace-regexp-in-string "\\([ ]+-.+\\)?\\*\\(<[0-9]+>\\)?$" replacement (buffer-name) t)
t)))))
(defun gdb--important-buffer-kill-cleanup () (gdb--kill-session (gdb--infer-session t)))
(defun gdb--buffer-kill-cleanup ()
(gdb--with-valid-session
(setf (gdb--session-buffers session) (cl-delete (current-buffer) (gdb--session-buffers session) :test 'eq))))
(defsubst gdb--is-buffer-type (type)
(and gdb--buffer-info (eq (gdb--buffer-info-type gdb--buffer-info) type)))
(defmacro gdb--buffer-get-data (&optional buffer)
(if buffer
`(let ((buffer ,buffer) info)
(when buffer
(setq info (buffer-local-value 'gdb--buffer-info buffer))
(and info (gdb--buffer-info-data info))))
`(and gdb--buffer-info (gdb--buffer-info-data gdb--buffer-info))))
;; ------------------------------------------------------------------------------------------
;; Frames and windows