emacs/external/ml/camldebug.el

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