cgit.sxemacs.org Git - packages/blob - xemacs-packages/ocaml/camldebug.el

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