Skip to content
Newer
Older
100644 766 lines (673 sloc) 28.8 KB
d25e931 first commit
Ryan Senior authored
1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;; camldebug.el - Run ocamldebug / camldebug under Emacs.
3 ;; Derived from gdb.el.
4
5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 ;; Copying is covered by the GNU General Public License.
7 ;;
8 ;; This program is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2 of the License, or
11 ;; (at your option) any later version.
12 ;;
13 ;; This program is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
17
18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
19 ;; History
20 ;;
21 ;;itz 04-06-96 I pondered basing this on gud. The potential advantages
22 ;;were: automatic bugfix , keymaps and menus propagation.
23 ;;Disadvantages: gud is not so clean itself, there is little common
24 ;;functionality it abstracts (most of the stuff is done in the
25 ;;debugger specific parts anyway), and, most seriously, gud sees it
26 ;;fit to add C-x C-a bindings to the _global_ map, so there would be a
27 ;;conflict between camldebug and gdb, for instance. While it's OK to
28 ;;assume that a sane person doesn't use gdb and dbx at the same time,
29 ;;it's not so OK (IMHO) for gdb and camldebug.
30
31 ;;Albert Cohen 04-97: Patch for Tuareg support.
32 ;;Albert Cohen 05-98: A few patches and OCaml customization.
33 ;;Albert Cohen 09-98: XEmacs support and some improvements.
34 ;;Erwan Jahier and Albert Cohen 11-05: support for camldebug 3.09.
35
36 (require 'comint)
37 (require 'shell)
38 (require 'tuareg)
39 (require 'derived)
40
41 ;;; Variables.
42
43 (defvar camldebug-last-frame)
44 (defvar camldebug-delete-prompt-marker)
45 (defvar camldebug-filter-accumulator nil)
46 (defvar camldebug-last-frame-displayed-p)
47 (defvar camldebug-filter-function)
48
49 (defvar camldebug-prompt-pattern "^(\\(ocd\\|cdb\\)) *"
50 "A regexp to recognize the prompt for camldebug.")
51
52 (defvar camldebug-overlay-event nil
53 "Overlay for displaying the current event.")
54 (defvar camldebug-overlay-under nil
55 "Overlay for displaying the current event.")
56 (defvar camldebug-event-marker nil
57 "Marker for displaying the current event.")
58
59 (defvar camldebug-track-frame t
60 "*If non-nil, always display current frame position in another window.")
61
62 (cond
63 ((and (fboundp 'make-overlay) window-system)
64 (make-face 'camldebug-event)
65 (make-face 'camldebug-underline)
66 (if (not (face-differs-from-default-p 'camldebug-event))
67 (invert-face 'camldebug-event))
68 (if (not (face-differs-from-default-p 'camldebug-underline))
69 (set-face-underline-p 'camldebug-underline t))
70 (setq camldebug-overlay-event (make-overlay 1 1))
71 (overlay-put camldebug-overlay-event 'face 'camldebug-event)
72 (setq camldebug-overlay-under (make-overlay 1 1))
73 (overlay-put camldebug-overlay-under 'face 'camldebug-underline))
74 (t
75 (setq camldebug-event-marker (make-marker))
76 (setq overlay-arrow-string "=>")))
77
78 ;;; Camldebug mode.
79
80 (define-derived-mode camldebug-mode comint-mode "Caml-Debugger"
81
82 "Major mode for interacting with a Camldebug process.
83
84 The following commands are available:
85
86 \\{camldebug-mode-map}
87
88 \\[camldebug-display-frame] displays in the other window
89 the last line referred to in the camldebug buffer.
90
91 \\[camldebug-step], \\[camldebug-back] and \\[camldebug-next], in the camldebug window,
92 call camldebug to step, backstep or next and then update the other window
93 with the current file and position.
94
95 If you are in a source file, you may select a point to break
96 at, by doing \\[camldebug-break].
97
98 Commands:
99 Many commands are inherited from comint mode.
100 Additionally we have:
101
102 \\[camldebug-display-frame] display frames file in other window
103 \\[camldebug-step] advance one line in program
104 C-x SPACE sets break point at current line."
105
106 (mapcar 'make-local-variable
107 '(camldebug-last-frame-displayed-p camldebug-last-frame
108 camldebug-delete-prompt-marker camldebug-filter-function
109 camldebug-filter-accumulator paragraph-start))
110 (setq
111 camldebug-last-frame nil
112 camldebug-delete-prompt-marker (make-marker)
113 camldebug-filter-accumulator ""
114 camldebug-filter-function 'camldebug-marker-filter
115 comint-prompt-regexp camldebug-prompt-pattern
116 comint-dynamic-complete-functions (cons 'camldebug-complete
117 comint-dynamic-complete-functions)
118 paragraph-start comint-prompt-regexp
119 camldebug-last-frame-displayed-p t)
120 (make-local-variable 'shell-dirtrackp)
121 (setq shell-dirtrackp t)
122 (setq comint-input-sentinel 'shell-directory-tracker))
123
124 ;;; Keymaps.
125
126 (defun camldebug-numeric-arg (arg)
127 (and arg (prefix-numeric-value arg)))
128
129 (defmacro def-camldebug (name key &optional doc args)
130
131 "Define camldebug-NAME to be a command sending NAME ARGS and bound
132 to KEY, with optional doc string DOC. Certain %-escapes in ARGS are
133 interpreted specially if present. These are:
134
135 %m module name of current module.
136 %d directory of current source file.
137 %c number of current character position
138 %e text of the caml variable surrounding point.
139
140 The `current' source file is the file of the current buffer (if
141 we're in a caml buffer) or the source file current at the last break
142 or step (if we're in the camldebug buffer), and the `current' module
143 name is the filename stripped of any *.ml* suffixes (this assumes the
144 usual correspondence between module and file naming is observed). The
145 `current' position is that of the current buffer (if we're in a source
146 file) or the position of the last break or step (if we're in the
147 camldebug buffer).
148
149 If a numeric is present, it overrides any ARGS flags and its string
150 representation is simply concatenated with the COMMAND."
151
152 (let* ((fun (intern (format "camldebug-%s" name))))
153 (list 'progn
154 (if doc
155 (list 'defun fun '(arg)
156 doc
157 '(interactive "P")
158 (list 'camldebug-call name args
159 '(camldebug-numeric-arg arg))))
160 (list 'define-key 'camldebug-mode-map
161 (concat "\C-c" key)
162 (list 'quote fun))
163 (list 'define-key 'tuareg-mode-map
164 (concat "\C-x\C-a" key)
165 (list 'quote fun)))))
166
167 (def-camldebug "step" "\C-s" "Step one source line with display.")
168 (def-camldebug "run" "\C-r" "Run the program.")
169 (def-camldebug "reverse" "\C-v" "Run the program in reverse.")
170 (def-camldebug "last" "\C-l" "Go to latest time in execution history.")
171 (def-camldebug "backtrace" "\C-t" "Print the call stack.")
172 (def-camldebug "open" "\C-o" "Open the current module." "%m")
173 (def-camldebug "close" "\C-c" "Close the current module." "%m")
174 (def-camldebug "finish" "\C-f" "Finish executing current function.")
175 (def-camldebug "print" "\C-p" "Print value of symbol at point." "%e")
176 (def-camldebug "next" "\C-n" "Step one source line (skip functions)")
177 (def-camldebug "up" "<" "Go up N stack frames (numeric arg) with display")
178 (def-camldebug "down" ">" "Go down N stack frames (numeric arg) with display")
179 (def-camldebug "break" "\C-b" "Set breakpoint at current line."
180 "@ \"%m\" # %c")
181
182 (defun camldebug-kill-filter (string)
183 ;gob up stupid questions :-)
184 (setq camldebug-filter-accumulator
185 (concat camldebug-filter-accumulator string))
186 (if (not (string-match "\\(.* \\)(y or n) "
187 camldebug-filter-accumulator)) nil
188 (setq camldebug-kill-output
189 (cons t (match-string 1 camldebug-filter-accumulator)))
190 (setq camldebug-filter-accumulator ""))
191 (if (string-match comint-prompt-regexp camldebug-filter-accumulator)
192 (let ((output (substring camldebug-filter-accumulator
193 (match-beginning 0))))
194 (setq camldebug-kill-output
195 (cons nil (substring camldebug-filter-accumulator 0
196 (1- (match-beginning 0)))))
197 (setq camldebug-filter-accumulator "")
198 output)
199 ""))
200
201 (def-camldebug "kill" "\C-k")
202
203 (defun camldebug-kill ()
204 "Kill the program."
205 (interactive)
206 (let ((camldebug-kill-output))
207 (save-excursion
208 (set-buffer current-camldebug-buffer)
209 (let ((proc (get-buffer-process (current-buffer)))
210 (camldebug-filter-function 'camldebug-kill-filter))
211 (camldebug-call "kill")
212 (while (not (and camldebug-kill-output
213 (zerop (length camldebug-filter-accumulator))))
214 (accept-process-output proc))))
215 (if (not (car camldebug-kill-output))
216 (error (cdr camldebug-kill-output))
217 (sit-for 0 300)
218 (camldebug-call-1 (if (y-or-n-p (cdr camldebug-kill-output)) "y" "n")))))
219 ;;FIXME: camldebug doesn't output the Hide marker on kill
220
221 (defun camldebug-goto-filter (string)
222 ;accumulate onto previous output
223 (setq camldebug-filter-accumulator
224 (concat camldebug-filter-accumulator string))
225 (if (not (or (string-match (concat
226 "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+"
227 camldebug-goto-position
228 "-[0-9]+[ \t]*\\(before\\).*\n")
229 camldebug-filter-accumulator)
230 (string-match (concat
231 "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+[0-9]+-"
232 camldebug-goto-position
233 "[ \t]*\\(after\\).*\n")
234 camldebug-filter-accumulator)))
235 nil
236 (setq camldebug-goto-output
237 (match-string 2 camldebug-filter-accumulator))
238 (setq camldebug-filter-accumulator
239 (substring camldebug-filter-accumulator (1- (match-end 0)))))
240 (if (not (string-match comint-prompt-regexp
241 camldebug-filter-accumulator)) nil
242 (setq camldebug-goto-output (or camldebug-goto-output 'fail))
243 (setq camldebug-filter-accumulator ""))
244 (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator)
245 (setq camldebug-filter-accumulator
246 (match-string 1 camldebug-filter-accumulator)))
247 "")
248
249 (def-camldebug "goto" "\C-g")
250 (defun camldebug-goto (&optional time)
251
252 "Go to the execution time TIME.
253
254 Without TIME, the command behaves as follows: In the camldebug buffer,
255 if the point at buffer end, goto time 0\; otherwise, try to obtain the
256 time from context around point. In a caml mode buffer, try to find the
257 time associated in execution history with the current point location.
258
259 With a negative TIME, move that many lines backward in the camldebug
260 buffer, then try to obtain the time from context around point."
261
262 (interactive "P")
263 (cond
264 (time
265 (let ((ntime (camldebug-numeric-arg time)))
266 (if (>= ntime 0) (camldebug-call "goto" nil ntime)
267 (save-selected-window
268 (select-window (get-buffer-window current-camldebug-buffer))
269 (save-excursion
270 (if (re-search-backward "^Time : [0-9]+ - pc : [0-9]+ "
271 nil t (- 1 ntime))
272 (camldebug-goto nil)
273 (error "I don't have %d times in my history"
274 (- 1 ntime))))))))
275 ((eq (current-buffer) current-camldebug-buffer)
276 (let ((time (cond
277 ((eobp) 0)
278 ((save-excursion
279 (beginning-of-line 1)
280 (looking-at "^Time : \\([0-9]+\\) - pc : [0-9]+ "))
281 (string-to-int (match-string 1)))
282 ((string-to-int (camldebug-format-command "%e"))))))
283 (camldebug-call "goto" nil time)))
284 (t
285 (let ((module (camldebug-module-name (buffer-file-name)))
286 (camldebug-goto-position (int-to-string (1- (point))))
287 (camldebug-goto-output) (address))
288 ;get a list of all events in the current module
289 (save-excursion
290 (set-buffer current-camldebug-buffer)
291 (let* ((proc (get-buffer-process (current-buffer)))
292 (camldebug-filter-function 'camldebug-goto-filter))
293 (camldebug-call-1 (concat "info events " module))
294 (while (not (and camldebug-goto-output
295 (zerop (length camldebug-filter-accumulator))))
296 (accept-process-output proc))
297 (setq address (if (eq camldebug-goto-output 'fail) nil
298 (re-search-backward
299 (concat "^Time : \\([0-9]+\\) - pc : "
300 camldebug-goto-output
301 " - module "
302 module "$") nil t)
303 (match-string 1)))))
304 (if address (camldebug-call "goto" nil (string-to-int address))
305 (error "No time at %s at %s" module camldebug-goto-position))))))
306
307
308 (defun camldebug-delete-filter (string)
309 (setq camldebug-filter-accumulator
310 (concat camldebug-filter-accumulator string))
311 (if (not (string-match
312 (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+[0-9]+[ \t]*in "
313 (regexp-quote camldebug-delete-file)
314 ", character "
315 camldebug-delete-position "\n")
316 camldebug-filter-accumulator)) nil
317 (setq camldebug-delete-output
318 (match-string 2 camldebug-filter-accumulator))
319 (setq camldebug-filter-accumulator
320 (substring camldebug-filter-accumulator (1- (match-end 0)))))
321 (if (not (string-match comint-prompt-regexp
322 camldebug-filter-accumulator)) nil
323 (setq camldebug-delete-output (or camldebug-delete-output 'fail))
324 (setq camldebug-filter-accumulator ""))
325 (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator)
326 (setq camldebug-filter-accumulator
327 (match-string 1 camldebug-filter-accumulator)))
328 "")
329
330
331 (def-camldebug "delete" "\C-d")
332
333 (defun camldebug-delete (&optional arg)
334 "Delete the breakpoint numbered ARG.
335
336 Without ARG, the command behaves as follows: In the camldebug buffer,
337 try to obtain the time from context around point. In a caml mode
338 buffer, try to find the breakpoint associated with the current point
339 location.
340
341 With a negative ARG, look for the -ARGth breakpoint pattern in the
342 camldebug buffer, then try to obtain the breakpoint info from context
343 around point."
344
345 (interactive "P")
346 (cond
347 (arg
348 (let ((narg (camldebug-numeric-arg arg)))
349 (if (> narg 0) (camldebug-call "delete" nil narg)
350 (save-excursion
351 (set-buffer current-camldebug-buffer)
352 (if (re-search-backward "^Breakpoint [0-9]+ at [0-9]+ : file "
353 nil t (- 1 narg))
354 (camldebug-delete nil)
355 (error "I don't have %d breakpoints in my history"
356 (- 1 narg)))))))
357 ((eq (current-buffer) current-camldebug-buffer)
358 (let* ((bpline "^Breakpoint \\([0-9]+\\) at [0-9]+ : file ")
359 (arg (cond
360 ((eobp)
361 (save-excursion (re-search-backward bpline nil t))
362 (string-to-int (match-string 1)))
363 ((save-excursion
364 (beginning-of-line 1)
365 (looking-at bpline))
366 (string-to-int (match-string 1)))
367 ((string-to-int (camldebug-format-command "%e"))))))
368 (camldebug-call "delete" nil arg)))
369 (t
370 (let ((camldebug-delete-file
371 (concat (camldebug-format-command "%m") ".ml"))
372 (camldebug-delete-position (camldebug-format-command "%c")))
373 (save-excursion
374 (set-buffer current-camldebug-buffer)
375 (let ((proc (get-buffer-process (current-buffer)))
376 (camldebug-filter-function 'camldebug-delete-filter)
377 (camldebug-delete-output))
378 (camldebug-call-1 "info break")
379 (while (not (and camldebug-delete-output
380 (zerop (length
381 camldebug-filter-accumulator))))
382 (accept-process-output proc))
383 (if (eq camldebug-delete-output 'fail)
384 (error "No breakpoint in %s at %s"
385 camldebug-delete-file
386 camldebug-delete-position)
387 (camldebug-call "delete" nil
388 (string-to-int camldebug-delete-output)))))))))
389
390 (defun camldebug-complete-filter (string)
391 (setq camldebug-filter-accumulator
392 (concat camldebug-filter-accumulator string))
393 (while (string-match "\\(\n\\|\\`\\)\\(.+\\)\n"
394 camldebug-filter-accumulator)
395 (setq camldebug-complete-list
396 (cons (match-string 2 camldebug-filter-accumulator)
397 camldebug-complete-list))
398 (setq camldebug-filter-accumulator
399 (substring camldebug-filter-accumulator
400 (1- (match-end 0)))))
401 (if (not (string-match comint-prompt-regexp
402 camldebug-filter-accumulator)) nil
403 (setq camldebug-complete-list
404 (or camldebug-complete-list 'fail))
405 (setq camldebug-filter-accumulator ""))
406 (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator)
407 (setq camldebug-filter-accumulator
408 (match-string 1 camldebug-filter-accumulator)))
409 "")
410
411 (defun camldebug-complete ()
412
413 "Perform completion on the camldebug command preceding point."
414
415 (interactive)
416 (let* ((end (point))
417 (command (save-excursion
418 (beginning-of-line)
419 (and (looking-at comint-prompt-regexp)
420 (goto-char (match-end 0)))
421 (buffer-substring (point) end)))
422 (camldebug-complete-list nil) (command-word))
423
424 ;; Find the word break. This match will always succeed.
425 (string-match "\\(\\`\\| \\)\\([^ ]*\\)\\'" command)
426 (setq command-word (match-string 2 command))
427
428 ;itz 04-21-96 if we are trying to complete a word of nonzero
429 ;length, chop off the last character. This is a nasty hack, but it
430 ;works - in general, not just for this set of words: the comint
431 ;call below will weed out false matches - and it avoids further
432 ;mucking with camldebug's lexer.
433 (if (> (length command-word) 0)
434 (setq command (substring command 0 (1- (length command)))))
435
436 (let ((camldebug-filter-function 'camldebug-complete-filter))
437 (camldebug-call-1 (concat "complete " command))
438 (set-marker camldebug-delete-prompt-marker nil)
439 (while (not (and camldebug-complete-list
440 (zerop (length camldebug-filter-accumulator))))
441 (accept-process-output (get-buffer-process
442 (current-buffer)))))
443 (if (eq camldebug-complete-list 'fail)
444 (setq camldebug-complete-list nil))
445 (setq camldebug-complete-list
446 (sort camldebug-complete-list 'string-lessp))
447 (comint-dynamic-simple-complete command-word camldebug-complete-list)))
448
449 (define-key camldebug-mode-map "\C-l" 'camldebug-refresh)
450 (define-key camldebug-mode-map "\t" 'comint-dynamic-complete)
451 (define-key camldebug-mode-map "\M-?" 'comint-dynamic-list-completions)
452
453 (define-key tuareg-mode-map "\C-x " 'camldebug-break)
454
455
456 (defvar current-camldebug-buffer nil)
457
458
459 ;;;###autoload
460 (defvar camldebug-command-name "ocamldebug"
461 "Pathname for executing Caml debugger.")
462
463 ;;;###autoload
464 (defun camldebug (path)
465 "Run camldebug on program FILE in buffer *camldebug-FILE*.
466 The directory containing FILE becomes the initial working directory
467 and source-file directory for camldebug. If you wish to change this, use
468 the camldebug commands `cd DIR' and `directory'."
469 (interactive "fRun camldebug on file: ")
470 (setq path (expand-file-name path))
471 (let ((file (file-name-nondirectory path)))
472 (pop-to-buffer (concat "*camldebug-" file "*"))
473 (setq default-directory (file-name-directory path))
474 (message "Current directory is %s" default-directory)
475 (setq camldebug-command-name
476 (read-from-minibuffer "Caml debugguer to run: "
477 camldebug-command-name))
478 (make-comint (concat "camldebug-" file)
479 (substitute-in-file-name camldebug-command-name)
480 nil
481 "-emacs" "-cd" default-directory path)
482 (set-process-filter (get-buffer-process (current-buffer))
483 'camldebug-filter)
484 (set-process-sentinel (get-buffer-process (current-buffer))
485 'camldebug-sentinel)
486 (camldebug-mode)
487 (camldebug-set-buffer)))
488
489 (defun camldebug-set-buffer ()
490 (if (eq major-mode 'camldebug-mode)
491 (setq current-camldebug-buffer (current-buffer))
492 (save-selected-window (pop-to-buffer current-camldebug-buffer))))
493
494 ;;; Filter and sentinel.
495
496 (defun camldebug-marker-filter (string)
497 (setq camldebug-filter-accumulator
498 (concat camldebug-filter-accumulator string))
499 (let ((output "") (begin))
500 ;; Process all the complete markers in this chunk.
501 (while (setq begin
502 (string-match
503 "\032\032\\(H\\|M\\(.+\\):\\(.+\\):\\(.+\\):\\(before\\|after\\)\\)\n"
504 camldebug-filter-accumulator))
505 (setq camldebug-last-frame
506 (if (char-equal ?H (aref camldebug-filter-accumulator
507 (1+ (1+ begin)))) nil
508 (let ((isbefore
509 (string= "before"
510 (match-string 5 camldebug-filter-accumulator)))
511 (startpos (string-to-int
512 (match-string 3 camldebug-filter-accumulator)))
513 (endpos (string-to-int
514 (match-string 4 camldebug-filter-accumulator))))
515 (list (match-string 2 camldebug-filter-accumulator)
516 (if isbefore startpos endpos)
517 isbefore
518 startpos
519 endpos
520 )))
521 output (concat output
522 (substring camldebug-filter-accumulator
523 0 begin))
524 ;; Set the accumulator to the remaining text.
525 camldebug-filter-accumulator (substring
526 camldebug-filter-accumulator
527 (match-end 0))
528 camldebug-last-frame-displayed-p nil))
529
530 ;; Does the remaining text look like it might end with the
531 ;; beginning of another marker? If it does, then keep it in
532 ;; camldebug-filter-accumulator until we receive the rest of it. Since we
533 ;; know the full marker regexp above failed, it's pretty simple to
534 ;; test for marker starts.
535 (if (string-match "\032.*\\'" camldebug-filter-accumulator)
536 (progn
537 ;; Everything before the potential marker start can be output.
538 (setq output (concat output (substring camldebug-filter-accumulator
539 0 (match-beginning 0))))
540
541 ;; Everything after, we save, to combine with later input.
542 (setq camldebug-filter-accumulator
543 (substring camldebug-filter-accumulator (match-beginning 0))))
544
545 (setq output (concat output camldebug-filter-accumulator)
546 camldebug-filter-accumulator ""))
547
548 output))
549
550 (defun camldebug-filter (proc string)
551 (let ((output))
552 (if (buffer-name (process-buffer proc))
553 (let ((process-window))
554 (save-excursion
555 (set-buffer (process-buffer proc))
556 ;; If we have been so requested, delete the debugger prompt.
557 (if (marker-buffer camldebug-delete-prompt-marker)
558 (progn
559 (delete-region (process-mark proc)
560 camldebug-delete-prompt-marker)
561 (set-marker camldebug-delete-prompt-marker nil)))
562 (setq output (funcall camldebug-filter-function string))
563 ;; Don't display the specified file unless
564 ;; (1) point is at or after the position where output appears
565 ;; and (2) this buffer is on the screen.
566 (setq process-window (and camldebug-track-frame
567 (not camldebug-last-frame-displayed-p)
568 (>= (point) (process-mark proc))
569 (get-buffer-window (current-buffer))))
570 ;; Insert the text, moving the process-marker.
571 (comint-output-filter proc output))
572 (if process-window
573 (save-selected-window
574 (select-window process-window)
575 (camldebug-display-frame)))))))
576
577 (defun camldebug-sentinel (proc msg)
578 (cond ((null (buffer-name (process-buffer proc)))
579 ;; buffer killed
580 ;; Stop displaying an arrow in a source file.
581 (camldebug-remove-current-event)
582 (set-process-buffer proc nil))
583 ((memq (process-status proc) '(signal exit))
584 ;; Stop displaying an arrow in a source file.
585 (camldebug-remove-current-event)
586 ;; Fix the mode line.
587 (setq mode-line-process
588 (concat ": "
589 (symbol-name (process-status proc))))
590 (let* ((obuf (current-buffer)))
591 ;; save-excursion isn't the right thing if
592 ;; process-buffer is current-buffer
593 (unwind-protect
594 (progn
595 ;; Write something in *compilation* and hack its mode line,
596 (set-buffer (process-buffer proc))
597 ;; Force mode line redisplay soon
598 (set-buffer-modified-p (buffer-modified-p))
599 (if (eobp)
600 (insert ?\n mode-name " " msg)
601 (save-excursion
602 (goto-char (point-max))
603 (insert ?\n mode-name " " msg)))
604 ;; If buffer and mode line will show that the process
605 ;; is dead, we can delete it now. Otherwise it
606 ;; will stay around until M-x list-processes.
607 (delete-process proc))
608 ;; Restore old buffer, but don't restore old point
609 ;; if obuf is the cdb buffer.
610 (set-buffer obuf))))))
611
612
613 (defun camldebug-refresh (&optional arg)
614 "Fix up a possibly garbled display, and redraw the mark."
615 (interactive "P")
616 (camldebug-display-frame)
617 (recenter arg))
618
619 (defun camldebug-display-frame ()
620 "Find, obey and delete the last filename-and-line marker from Caml debugger.
621 The marker looks like \\032\\032FILENAME:CHARACTER\\n.
622 Obeying it means displaying in another window the specified file and line."
623 (interactive)
624 (camldebug-set-buffer)
625 (if (not camldebug-last-frame)
626 (camldebug-remove-current-event)
627 (camldebug-display-line (nth 0 camldebug-last-frame)
628 (nth 3 camldebug-last-frame)
629 (nth 4 camldebug-last-frame)
630 (nth 2 camldebug-last-frame)))
631 (setq camldebug-last-frame-displayed-p t))
632
633 ;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
634 ;; and that its character CHARACTER is visible.
635 ;; Put the mark on this character in that buffer.
636
637 (defun camldebug-display-line (true-file schar echar kind)
638 (let* ((pre-display-buffer-function nil) ; screw it, put it all in one screen
639 (pop-up-windows t)
640 (buffer (find-file-noselect true-file))
641 (window (display-buffer buffer t))
642 (spos) (epos) (pos))
643 (save-excursion
644 (set-buffer buffer)
645 (save-restriction
646 (widen)
647 (setq spos (+ (point-min) schar))
648 (setq epos (+ (point-min) echar))
649 (setq pos (if kind spos epos))
650 (camldebug-set-current-event spos epos (current-buffer) kind))
651 (cond ((or (< pos (point-min)) (> pos (point-max)))
652 (widen)
653 (goto-char pos))))
654 (set-window-point window pos)))
655
656 ;;; Events.
657
658 (defun camldebug-remove-current-event ()
659 (if (and (fboundp 'make-overlay) window-system)
660 (progn
661 (delete-overlay camldebug-overlay-event)
662 (delete-overlay camldebug-overlay-under))
663 (setq overlay-arrow-position nil)))
664
665 (defun camldebug-set-current-event (spos epos buffer before)
666 (if window-system
667 (if before
668 (progn
669 (move-overlay camldebug-overlay-event spos (1+ spos) buffer)
670 (move-overlay camldebug-overlay-under
671 (+ spos 1) epos buffer))
672 (move-overlay camldebug-overlay-event (1- epos) epos buffer)
673 (move-overlay camldebug-overlay-under spos (- epos 1) buffer))
674 (save-excursion
675 (set-buffer buffer)
676 (goto-char pos)
677 (beginning-of-line)
678 (move-marker camldebug-event-marker (point))
679 (setq overlay-arrow-position camldebug-event-marker))))
680
681 ;;; Miscellaneous.
682
683 (defun camldebug-module-name (filename)
684 (substring filename (string-match "\\([^/]*\\)\\.ml$" filename) (match-end 1)))
685
686 ;;; The camldebug-call function must do the right thing whether its
687 ;;; invoking keystroke is from the camldebug buffer itself (via
688 ;;; major-mode binding) or a caml buffer. In the former case, we want
689 ;;; to supply data from camldebug-last-frame. Here's how we do it:
690
691 (defun camldebug-format-command (str)
692 (let* ((insource (not (eq (current-buffer) current-camldebug-buffer)))
693 (frame (if insource nil camldebug-last-frame)) (result))
694 (while (and str (string-match "\\([^%]*\\)%\\([mdcep]\\)" str))
695 (let ((key (string-to-char (substring str (match-beginning 2))))
696 (cmd (substring str (match-beginning 1) (match-end 1)))
697 (subst))
698 (setq str (substring str (match-end 2)))
699 (cond
700 ((eq key ?m)
701 (setq subst (camldebug-module-name
702 (if insource (buffer-file-name) (nth 0 frame)))))
703 ((eq key ?d)
704 (setq subst (file-name-directory
705 (if insource (buffer-file-name) (nth 0 frame)))))
706 ((eq key ?c)
707 (setq subst (int-to-string
708 (if insource (1- (point)) (nth 1 frame)))))
709 ((eq key ?e)
710 (setq subst (save-excursion
711 (skip-chars-backward "_0-9A-Za-z\277-\377")
712 (looking-at "[_0-9A-Za-z\277-\377]*")
713 (match-string 0)))))
714 (setq result (concat result cmd subst))))
715 ;; There might be text left in STR when the loop ends.
716 (concat result str)))
717
718 (defun camldebug-call (command &optional fmt arg)
719 "Invoke camldebug COMMAND displaying source in other window.
720
721 Certain %-escapes in FMT are interpreted specially if present.
722 These are:
723
724 %m module name of current module.
725 %d directory of current source file.
726 %c number of current character position
727 %e text of the caml variable surrounding point.
728
729 The `current' source file is the file of the current buffer (if
730 we're in a caml buffer) or the source file current at the last break
731 or step (if we're in the camldebug buffer), and the `current' module
732 name is the filename stripped of any *.ml* suffixes (this assumes the
733 usual correspondence between module and file naming is observed). The
734 `current' position is that of the current buffer (if we're in a source
735 file) or the position of the last break or step (if we're in the
736 camldebug buffer).
737
738 If ARG is present, it overrides any FMT flags and its string
739 representation is simply concatenated with the COMMAND."
740
741 ;; Make sure debugger buffer is displayed in a window.
742 (camldebug-set-buffer)
743 (message "Command: %s" (camldebug-call-1 command fmt arg)))
744
745 (defun camldebug-call-1 (command &optional fmt arg)
746
747 ;; Record info on the last prompt in the buffer and its position.
748 (save-excursion
749 (set-buffer current-camldebug-buffer)
750 (goto-char (process-mark (get-buffer-process current-camldebug-buffer)))
751 (let ((pt (point)))
752 (beginning-of-line)
753 (if (looking-at comint-prompt-regexp)
754 (set-marker camldebug-delete-prompt-marker (point)))))
755 (let ((cmd (cond
756 (arg (concat command " " (int-to-string arg)))
757 (fmt (camldebug-format-command
758 (concat command " " fmt)))
759 (command))))
760 (process-send-string (get-buffer-process current-camldebug-buffer)
761 (concat cmd "\n"))
762 cmd))
763
764
765 (provide 'camldebug)
Something went wrong with that request. Please try again.