emacs/external/tuareg/camldebug.el

   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)