ocaml/emacs/camldebug.el

;;; Run camldebug under Emacs
;;; Derived from gdb.el.
;;; gdb.el is Copyright (C) 1988 Free Software Foundation, Inc, and is part
;;; of GNU Emacs
;;; Modified by Jerome Vouillon, 1994.
;;; Modified by Ian T. Zimmerman, 1996.
;;; Modified by Xavier Leroy, 1997.

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;;itz 04-06-96 I pondered basing this on gud. The potential advantages
;;were: automatic bugfix , keymaps and menus propagation.
;;Disadvantages: gud is not so clean itself, there is little common
;;functionality it abstracts (most of the stuff is done in the
;;debugger specific parts anyway), and, most seriously, gud sees it
;;fit to add C-x C-a bindings to the _global_ map, so there would be a
;;conflict between camldebug and gdb, for instance. While it's OK to
;;assume that a sane person doesn't use gdb and dbx at the same time,
;;it's not so OK (IMHO) for gdb and camldebug.

;; Xavier Leroy, 21/02/97: adaptation to ocamldebug.

(require 'comint)
(require 'shell)
(require 'caml)
(require 'derived)
(require 'thingatpt)

;;; Variables.

(defvar camldebug-last-frame)
(defvar camldebug-delete-prompt-marker)
(defvar camldebug-filter-accumulator nil)
(defvar camldebug-last-frame-displayed-p)
(defvar camldebug-filter-function)

(defvar camldebug-prompt-pattern "^(ocd) *"
  "A regexp to recognize the prompt for ocamldebug.") 

(defvar camldebug-overlay-event nil
  "Overlay for displaying the current event.")
(defvar camldebug-overlay-under nil
  "Overlay for displaying the current event.")
(defvar camldebug-event-marker nil
  "Marker for displaying the current event.")

(defvar camldebug-track-frame t
  "*If non-nil, always display current frame position in another window.")

(cond
 (window-system
  (make-face 'camldebug-event)
  (make-face 'camldebug-underline)
  (if (not (face-differs-from-default-p 'camldebug-event))
      (invert-face 'camldebug-event))
  (if (not (face-differs-from-default-p 'camldebug-underline))
      (set-face-underline-p 'camldebug-underline t))
  (setq camldebug-overlay-event (make-overlay 1 1))
  (overlay-put camldebug-overlay-event 'face 'camldebug-event)
  (setq camldebug-overlay-under (make-overlay 1 1))
  (overlay-put camldebug-overlay-under 'face 'camldebug-underline))
 (t
  (setq camldebug-event-marker (make-marker))
  (setq overlay-arrow-string "=>")))

;;; Camldebug mode.

(define-derived-mode camldebug-mode comint-mode "Inferior CDB"

  "Major mode for interacting with an inferior Camldebug process.

The following commands are available:

\\{camldebug-mode-map}

\\[camldebug-display-frame] displays in the other window
the last line referred to in the camldebug buffer.

\\[camldebug-step], \\[camldebug-back] and \\[camldebug-next], in the camldebug window,
call camldebug to step, backstep or next and then update the other window
with the current file and position.

If you are in a source file, you may select a point to break
at, by doing \\[camldebug-break].

Commands:
Many commands are inherited from comint mode. 
Additionally we have:

\\[camldebug-display-frame] display frames file in other window
\\[camldebug-step] advance one line in program
C-x SPACE sets break point at current line."

  (mapcar 'make-local-variable
	  '(camldebug-last-frame-displayed-p  camldebug-last-frame
	    camldebug-delete-prompt-marker camldebug-filter-function
           camldebug-filter-accumulator paragraph-start))
  (setq
   camldebug-last-frame nil
   camldebug-delete-prompt-marker (make-marker)
   camldebug-filter-accumulator ""
   camldebug-filter-function 'camldebug-marker-filter
   comint-prompt-regexp camldebug-prompt-pattern
   comint-dynamic-complete-functions (cons 'camldebug-complete
					   comint-dynamic-complete-functions)
   paragraph-start comint-prompt-regexp
   camldebug-last-frame-displayed-p t)
  (make-local-variable 'shell-dirtrackp)
  (setq shell-dirtrackp t)
  (setq comint-input-sentinel 'shell-directory-tracker))

;;; Keymaps.

(defun camldebug-numeric-arg (arg)
  (and arg (prefix-numeric-value arg)))

(defmacro def-camldebug (name key &optional doc args)

  "Define camldebug-NAME to be a command sending NAME ARGS and bound
to KEY, with optional doc string DOC.  Certain %-escapes in ARGS are
interpreted specially if present.  These are:

  %m	module name of current module. 
  %d	directory of current source file. 
  %c	number of current character position
  %e	text of the caml variable surrounding point.

  The `current' source file is the file of the current buffer (if
we're in a caml buffer) or the source file current at the last break
or step (if we're in the camldebug buffer), and the `current' module
name is the filename stripped of any *.ml* suffixes (this assumes the
usual correspondence between module and file naming is observed).  The
`current' position is that of the current buffer (if we're in a source
file) or the position of the last break or step (if we're in the
camldebug buffer).

If a numeric is present, it overrides any ARGS flags and its string
representation is simply concatenated with the COMMAND."

  (let* ((fun (intern (format "camldebug-%s" name))))
    (list 'progn
	  (if doc
	      (list 'defun fun '(arg)
		    doc 
		    '(interactive "P")
		    (list 'camldebug-call name args
			  '(camldebug-numeric-arg arg))))
	  (list 'define-key 'camldebug-mode-map
		(concat "\C-c" key)
		(list 'quote fun))
	  (list 'define-key 'caml-mode-map
		(concat "\C-x\C-a" key)
		(list 'quote fun)))))

(def-camldebug "step"	"\C-s"	"Step one event forward.")
(def-camldebug "backstep" "\C-k" "Step one event backward.")
(def-camldebug "run"	"\C-r"	"Run the program.")
(def-camldebug "reverse" "\C-v" "Run the program in reverse.")
(def-camldebug "last"   "\C-l"  "Go to latest time in execution history.")
(def-camldebug "backtrace" "\C-t" "Print the call stack.")
(def-camldebug "finish" "\C-f"	"Finish executing current function.")
(def-camldebug "print"	"\C-p"	"Print value of symbol at point."	"%e")
(def-camldebug "display" "\C-d"	"Display value of symbol at point."	"%e")
(def-camldebug "next"   "\C-n"	"Step one event forward (skip functions)")
(def-camldebug "up"     "<"  "Go up N stack frames (numeric arg) with display")
(def-camldebug "down"  ">" "Go down N stack frames (numeric arg) with display")
(def-camldebug "break"  "\C-b"	"Set breakpoint at current line."
  "@ \"%m\" # %c")

(defun camldebug-mouse-display (click)
  "Display value of $NNN clicked on."
  (interactive "e")
  (let* ((start (event-start click))
	 (window (car start))
	 (pos (car (cdr start)))
         symb)
    (save-excursion
      (select-window window)
      (goto-char pos)
      (setq symb (thing-at-point 'symbol))
      (if (string-match "^\\$[0-9]+$" symb)
          (camldebug-call "display" symb)))))

(define-key camldebug-mode-map [mouse-2] 'camldebug-mouse-display)

(defun camldebug-kill-filter (string)
  ;gob up stupid questions :-)
  (setq camldebug-filter-accumulator
	(concat camldebug-filter-accumulator string))
  (if (not (string-match "\\(.* \\)(y or n) "
			 camldebug-filter-accumulator)) nil
    (setq camldebug-kill-output
	  (cons t (match-string 1 camldebug-filter-accumulator)))
    (setq camldebug-filter-accumulator ""))
  (if (string-match comint-prompt-regexp camldebug-filter-accumulator)
      (let ((output (substring camldebug-filter-accumulator
			       (match-beginning 0))))
	(setq camldebug-kill-output 
	      (cons nil (substring camldebug-filter-accumulator 0
				   (1- (match-beginning 0)))))
	(setq camldebug-filter-accumulator "")
	output)
    ""))

(def-camldebug "kill"	"\C-k")

(defun camldebug-kill ()
  "Kill the program."
  (interactive)
  (let ((camldebug-kill-output))
    (save-excursion
      (set-buffer current-camldebug-buffer)
      (let ((proc (get-buffer-process (current-buffer)))
	    (camldebug-filter-function 'camldebug-kill-filter))
	(camldebug-call "kill")
	(while (not (and camldebug-kill-output
			 (zerop (length camldebug-filter-accumulator))))
	  (accept-process-output proc))))
    (if (not (car camldebug-kill-output))
	(error (cdr camldebug-kill-output))
      (sit-for 0 300)
      (camldebug-call-1 (if (y-or-n-p (cdr camldebug-kill-output)) "y" "n")))))
;;FIXME: camldebug doesn't output the Hide marker on kill

(defun camldebug-goto-filter (string)
  ;accumulate onto previous output
  (setq camldebug-filter-accumulator
	(concat camldebug-filter-accumulator string))
  (if (not (string-match (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+"
			  camldebug-goto-position
			  "[ \t]*\\(before\\|after\\)\n")
		  camldebug-filter-accumulator)) nil
    (setq camldebug-goto-output
	  (match-string 2 camldebug-filter-accumulator))
    (setq camldebug-filter-accumulator
	  (substring camldebug-filter-accumulator (1- (match-end 0)))))
  (if (not (string-match comint-prompt-regexp
			 camldebug-filter-accumulator)) nil
    (setq camldebug-goto-output (or camldebug-goto-output 'fail))
    (setq camldebug-filter-accumulator ""))
  (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator)
      (setq camldebug-filter-accumulator
	    (match-string 1 camldebug-filter-accumulator)))
  "")

(def-camldebug "goto" "\C-g")
(defun camldebug-goto (&optional time)

  "Go to the execution time TIME.

Without TIME, the command behaves as follows: In the camldebug buffer,
if the point at buffer end, goto time 0\; otherwise, try to obtain the 
time from context around point. In a caml mode buffer, try to find the
time associated in execution history with the current point location.

With a negative TIME, move that many lines backward in the camldebug
buffer, then try to obtain the time from context around point."

  (interactive "P")
  (cond
   (time
    (let ((ntime (camldebug-numeric-arg time)))
      (if (>= ntime 0) (camldebug-call "goto" nil ntime)
	(save-selected-window
	  (select-window (get-buffer-window current-camldebug-buffer))
	  (save-excursion
	    (if (re-search-backward "^Time : [0-9]+ - pc : [0-9]+ "
				    nil t (- 1 ntime))
		(camldebug-goto nil)
	      (error "I don't have %d times in my history"
		     (- 1 ntime))))))))
   ((eq (current-buffer) current-camldebug-buffer)
      (let ((time (cond
		   ((eobp) 0)
		   ((save-excursion
		      (beginning-of-line 1)
		      (looking-at "^Time : \\([0-9]+\\) - pc : [0-9]+ "))
		    (string-to-int (match-string 1)))
		   ((string-to-int (camldebug-format-command "%e"))))))
	(camldebug-call "goto" nil time)))
   (t
    (let ((module (camldebug-module-name (buffer-file-name)))
	  (camldebug-goto-position (int-to-string (1- (point))))
	  (camldebug-goto-output) (address))
      ;get a list of all events in the current module
      (save-excursion
	(set-buffer current-camldebug-buffer)
	(let* ((proc (get-buffer-process (current-buffer)))
	       (camldebug-filter-function 'camldebug-goto-filter))
	  (camldebug-call-1 (concat "info events " module))
	  (while (not (and camldebug-goto-output
		      (zerop (length camldebug-filter-accumulator))))
	    (accept-process-output proc))
	  (setq address (if (eq camldebug-goto-output 'fail) nil
			  (re-search-backward
			   (concat "^Time : \\([0-9]+\\) - pc : "
				   camldebug-goto-output
				   " - module "
				   module "$") nil t)
			  (match-string 1)))))
      (if address (camldebug-call "goto" nil (string-to-int address))
	(error "No time at %s at %s" module camldebug-goto-position))))))


(defun camldebug-delete-filter (string)
  (setq camldebug-filter-accumulator
	(concat camldebug-filter-accumulator string))
  (if (not (string-match
	    (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+[0-9]+[ \t]*in "
		    (regexp-quote camldebug-delete-file)
		    ", character "
		    camldebug-delete-position "\n")
		  camldebug-filter-accumulator)) nil
    (setq camldebug-delete-output
	  (match-string 2 camldebug-filter-accumulator))
    (setq camldebug-filter-accumulator
	  (substring camldebug-filter-accumulator (1- (match-end 0)))))
  (if (not (string-match comint-prompt-regexp
			 camldebug-filter-accumulator)) nil
    (setq camldebug-delete-output (or camldebug-delete-output 'fail))
    (setq camldebug-filter-accumulator ""))
  (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator)
      (setq camldebug-filter-accumulator
	    (match-string 1 camldebug-filter-accumulator)))
  "")
  

(def-camldebug "delete" "\C-d")

(defun camldebug-delete (&optional arg)
  "Delete the breakpoint numbered ARG.

Without ARG, the command behaves as follows: In the camldebug buffer,
try to obtain the time from context around point. In a caml mode
buffer, try to find the breakpoint associated with the current point
location.

With a negative ARG, look for the -ARGth breakpoint pattern in the
camldebug buffer, then try to obtain the breakpoint info from context
around point."

  (interactive "P")
  (cond
   (arg
    (let ((narg (camldebug-numeric-arg arg)))
      (if (> narg 0) (camldebug-call "delete" nil narg)
	(save-excursion
	  (set-buffer current-camldebug-buffer)
	  (if (re-search-backward "^Breakpoint [0-9]+ at [0-9]+ : file "
				  nil t (- 1 narg))
	      (camldebug-delete nil)
	    (error "I don't have %d breakpoints in my history"
		     (- 1 narg)))))))
   ((eq (current-buffer) current-camldebug-buffer)
    (let* ((bpline "^Breakpoint \\([0-9]+\\) at [0-9]+ : file ")
	   (arg (cond
		 ((eobp)
		  (save-excursion (re-search-backward bpline nil t))
		  (string-to-int (match-string 1)))
		 ((save-excursion
		    (beginning-of-line 1)
		    (looking-at bpline))
		  (string-to-int (match-string 1)))
		 ((string-to-int (camldebug-format-command "%e"))))))
      (camldebug-call "delete" nil arg)))
   (t
    (let ((camldebug-delete-file
	   (concat (camldebug-format-command "%m") ".ml"))
	  (camldebug-delete-position (camldebug-format-command "%c")))
      (save-excursion
	(set-buffer current-camldebug-buffer)
	(let ((proc (get-buffer-process (current-buffer)))
	      (camldebug-filter-function 'camldebug-delete-filter)
	      (camldebug-delete-output))
	  (camldebug-call-1 "info break")
	  (while (not (and camldebug-delete-output
			   (zerop (length
				   camldebug-filter-accumulator))))
	    (accept-process-output proc))
	  (if (eq camldebug-delete-output 'fail)
	      (error "No breakpoint in %s at %s"
		     camldebug-delete-file
		     camldebug-delete-position)	  
	    (camldebug-call "delete" nil
			    (string-to-int camldebug-delete-output)))))))))  

(defun camldebug-complete-filter (string)
  (setq camldebug-filter-accumulator
	(concat camldebug-filter-accumulator string))
  (while (string-match "\\(\n\\|\\`\\)\\(.+\\)\n"
		       camldebug-filter-accumulator) 
    (setq camldebug-complete-list
	  (cons (match-string 2 camldebug-filter-accumulator)
		camldebug-complete-list))
    (setq camldebug-filter-accumulator
	  (substring camldebug-filter-accumulator
		     (1- (match-end 0)))))
  (if (not (string-match comint-prompt-regexp
			 camldebug-filter-accumulator)) nil
    (setq camldebug-complete-list
	  (or camldebug-complete-list 'fail))
    (setq camldebug-filter-accumulator ""))
  (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator)
      (setq camldebug-filter-accumulator
	    (match-string 1 camldebug-filter-accumulator)))
  "")
     
(defun camldebug-complete ()

  "Perform completion on the camldebug command preceding point."

  (interactive)
  (let* ((end (point))
	 (command (save-excursion
		    (beginning-of-line)
		    (and (looking-at comint-prompt-regexp)
			 (goto-char (match-end 0)))
		    (buffer-substring (point) end)))
	 (camldebug-complete-list nil) (command-word))

    ;; Find the word break.  This match will always succeed.
    (string-match "\\(\\`\\| \\)\\([^ ]*\\)\\'" command)
    (setq command-word (match-string 2 command))
    
    ;itz 04-21-96 if we are trying to complete a word of nonzero
    ;length, chop off the last character. This is a nasty hack, but it
    ;works - in general, not just for this set of words: the comint
    ;call below will weed out false matches - and it avoids further
    ;mucking with camldebug's lexer.
    (if (> (length command-word) 0)
	(setq command (substring command 0 (1- (length command)))))
    
    (let ((camldebug-filter-function 'camldebug-complete-filter))
      (camldebug-call-1 (concat "complete " command))
      (set-marker camldebug-delete-prompt-marker nil)
      (while (not (and camldebug-complete-list
		       (zerop (length camldebug-filter-accumulator))))
	(accept-process-output (get-buffer-process
				(current-buffer)))))
    (if (eq camldebug-complete-list 'fail)
	(setq camldebug-complete-list nil))
    (setq camldebug-complete-list
	  (sort camldebug-complete-list 'string-lessp))
    (comint-dynamic-simple-complete command-word camldebug-complete-list)))
	
(define-key camldebug-mode-map "\C-l" 'camldebug-refresh)
(define-key camldebug-mode-map "\t" 'comint-dynamic-complete)
(define-key camldebug-mode-map "\M-?" 'comint-dynamic-list-completions)

(define-key caml-mode-map "\C-x " 'camldebug-break)


(defvar current-camldebug-buffer nil)


;;;###autoload
(defvar camldebug-command-name "ocamldebug"
  "Pathname for executing camldebug.")

;;;###autoload
(defun camldebug (path)
  "Run camldebug on program FILE in buffer *camldebug-FILE*.
The directory containing FILE becomes the initial working directory
and source-file directory for camldebug.  If you wish to change this, use
the camldebug commands `cd DIR' and `directory'."
  (interactive "fRun ocamldebug on file: ")
  (setq path (expand-file-name path))
  (let ((file (file-name-nondirectory path)))
    (pop-to-buffer (concat "*camldebug-" file "*"))
    (setq default-directory (file-name-directory path))
    (message "Current directory is %s" default-directory)
    (make-comint (concat "camldebug-" file)
		 (substitute-in-file-name camldebug-command-name)
		 nil
		 "-emacs" "-cd" default-directory file)
    (set-process-filter (get-buffer-process (current-buffer))
			'camldebug-filter)
    (set-process-sentinel (get-buffer-process (current-buffer))
			  'camldebug-sentinel)
    (camldebug-mode)
    (camldebug-set-buffer)))

(defun camldebug-set-buffer ()
  (if (eq major-mode 'camldebug-mode)
      (setq current-camldebug-buffer (current-buffer))
    (save-selected-window (pop-to-buffer current-camldebug-buffer))))

;;; Filter and sentinel.

(defun camldebug-marker-filter (string)
  (setq camldebug-filter-accumulator
	(concat camldebug-filter-accumulator string))
  (let ((output "") (begin))
    ;; Process all the complete markers in this chunk.
    (while (setq begin
		 (string-match 
		  "\032\032\\(H\\|M\\(.+\\):\\(.+\\):\\(before\\|after\\)\\)\n"
		  camldebug-filter-accumulator))
      (setq camldebug-last-frame
	    (if (char-equal ?H (aref camldebug-filter-accumulator
				     (1+ (1+ begin)))) nil
	      (list (match-string 2 camldebug-filter-accumulator)
		    (string-to-int
		     (match-string 3 camldebug-filter-accumulator))
		    (string= "before"
			     (match-string 4
					   camldebug-filter-accumulator))))
	    output (concat output
			   (substring camldebug-filter-accumulator
				      0 begin))
	    ;; Set the accumulator to the remaining text.
	    camldebug-filter-accumulator (substring
					  camldebug-filter-accumulator
					  (match-end 0))
	    camldebug-last-frame-displayed-p nil))

    ;; Does the remaining text look like it might end with the
    ;; beginning of another marker?  If it does, then keep it in
    ;; camldebug-filter-accumulator until we receive the rest of it.  Since we
    ;; know the full marker regexp above failed, it's pretty simple to
    ;; test for marker starts.
    (if (string-match "\032.*\\'" camldebug-filter-accumulator)
	(progn
	  ;; Everything before the potential marker start can be output.
	  (setq output (concat output (substring camldebug-filter-accumulator
						 0 (match-beginning 0))))

	  ;; Everything after, we save, to combine with later input.
	  (setq camldebug-filter-accumulator
		(substring camldebug-filter-accumulator (match-beginning 0))))

      (setq output (concat output camldebug-filter-accumulator)
	    camldebug-filter-accumulator ""))

    output))

(defun camldebug-filter (proc string)
  (let ((output))
    (if (buffer-name (process-buffer proc))
	(let ((process-window))
	  (save-excursion
	    (set-buffer (process-buffer proc))
	    ;; If we have been so requested, delete the debugger prompt.
	    (if (marker-buffer camldebug-delete-prompt-marker)
		(progn
		  (delete-region (process-mark proc)
				 camldebug-delete-prompt-marker)
		  (set-marker camldebug-delete-prompt-marker nil)))
	    (setq output (funcall camldebug-filter-function string))
	    ;; Don't display the specified file unless
	    ;; (1) point is at or after the position where output appears
	    ;; and (2) this buffer is on the screen.
	    (setq process-window (and camldebug-track-frame
				      (not camldebug-last-frame-displayed-p)
				      (>= (point) (process-mark proc))
				      (get-buffer-window (current-buffer))))
	    ;; Insert the text, moving the process-marker.
	    (comint-output-filter proc output))
	  (if process-window
	      (save-selected-window
		(select-window process-window)
		(camldebug-display-frame)))))))

(defun camldebug-sentinel (proc msg)
  (cond ((null (buffer-name (process-buffer proc)))
	 ;; buffer killed
	 ;; Stop displaying an arrow in a source file.
	 (camldebug-remove-current-event)
	 (set-process-buffer proc nil))
	((memq (process-status proc) '(signal exit))
	 ;; Stop displaying an arrow in a source file.
	 (camldebug-remove-current-event)
	 ;; Fix the mode line.
	 (setq mode-line-process
	       (concat ": "
		       (symbol-name (process-status proc))))
	 (let* ((obuf (current-buffer)))
	   ;; save-excursion isn't the right thing if
	   ;;  process-buffer is current-buffer
	   (unwind-protect
	       (progn
		 ;; Write something in *compilation* and hack its mode line,
		 (set-buffer (process-buffer proc))
		 ;; Force mode line redisplay soon
		 (set-buffer-modified-p (buffer-modified-p))
		 (if (eobp)
		     (insert ?\n mode-name " " msg)
		   (save-excursion
		     (goto-char (point-max))
		     (insert ?\n mode-name " " msg)))
		 ;; If buffer and mode line will show that the process
		 ;; is dead, we can delete it now.  Otherwise it
		 ;; will stay around until M-x list-processes.
		 (delete-process proc))
	     ;; Restore old buffer, but don't restore old point
	     ;; if obuf is the cdb buffer.
	     (set-buffer obuf))))))


(defun camldebug-refresh (&optional arg)
  "Fix up a possibly garbled display, and redraw the mark."
  (interactive "P")
  (camldebug-display-frame)
  (recenter arg))

(defun camldebug-display-frame ()
  "Find, obey and delete the last filename-and-line marker from CDB.
The marker looks like \\032\\032FILENAME:CHARACTER\\n.
Obeying it means displaying in another window the specified file and line."
  (interactive)
  (camldebug-set-buffer)
  (if (not camldebug-last-frame)
      (camldebug-remove-current-event)
    (camldebug-display-line (car camldebug-last-frame)
			    (car (cdr camldebug-last-frame))
			    (car (cdr (cdr camldebug-last-frame)))))
  (setq camldebug-last-frame-displayed-p t))

;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
;; and that its character CHARACTER is visible.
;; Put the mark on this character in that buffer.

(defun camldebug-display-line (true-file character kind)
  (let* ((pre-display-buffer-function nil) ; screw it, put it all in one screen
	 (pop-up-windows t)
	 (buffer (find-file-noselect true-file))
	 (window (display-buffer buffer t))
	 (pos))
    (save-excursion
      (set-buffer buffer)
      (save-restriction
	(widen)
	(setq pos (+ (point-min) character))
	(camldebug-set-current-event pos (current-buffer) kind))
      (cond ((or (< pos (point-min)) (> pos (point-max)))
	     (widen)
	     (goto-char pos))))
    (set-window-point window pos)))

;;; Events.

(defun camldebug-remove-current-event ()
  (if window-system
      (progn
        (delete-overlay camldebug-overlay-event)
        (delete-overlay camldebug-overlay-under))
    (setq overlay-arrow-position nil)))

(defun camldebug-set-current-event (pos buffer before)
  (if window-system
      (if before
	  (progn
	    (move-overlay camldebug-overlay-event pos (1+ pos) buffer)
	    (move-overlay camldebug-overlay-under
			  (+ pos 1) (+ pos 3) buffer))
	(move-overlay camldebug-overlay-event (1- pos) pos buffer)
	(move-overlay camldebug-overlay-under (- pos 3) (- pos 1) buffer))
    (save-excursion
      (set-buffer buffer)
      (goto-char pos)
      (beginning-of-line)
      (move-marker camldebug-event-marker (point))
      (setq overlay-arrow-position camldebug-event-marker))))

;;; Miscellaneous.

(defun camldebug-module-name (filename)
  (substring filename (string-match "\\([^/]*\\)\\.ml$" filename) (match-end 1)))

;;; The camldebug-call function must do the right thing whether its
;;; invoking keystroke is from the camldebug buffer itself (via
;;; major-mode binding) or a caml buffer.  In the former case, we want
;;; to supply data from camldebug-last-frame.  Here's how we do it:

(defun camldebug-format-command (str)
  (let* ((insource (not (eq (current-buffer) current-camldebug-buffer)))
	(frame (if insource nil camldebug-last-frame)) (result))
    (while (and str (string-match "\\([^%]*\\)%\\([mdcep]\\)" str))
      (let ((key (string-to-char (substring str (match-beginning 2))))
	    (cmd (substring str (match-beginning 1) (match-end 1)))
	    (subst))
	(setq str (substring str (match-end 2)))
	(cond
	 ((eq key ?m)
	  (setq subst (camldebug-module-name
		       (if insource (buffer-file-name) (nth 0 frame)))))
	 ((eq key ?d)
	  (setq subst (file-name-directory
		       (if insource (buffer-file-name) (nth 0 frame)))))
	 ((eq key ?c)
	  (setq subst (int-to-string
		       (if insource (1- (point)) (nth 1 frame)))))
	 ((eq key ?e)
	  (setq subst (thing-at-point 'symbol))))
	(setq result (concat result cmd subst))))
    ;; There might be text left in STR when the loop ends.
    (concat result str)))

(defun camldebug-call (command &optional fmt arg)
  "Invoke camldebug COMMAND displaying source in other window.

Certain %-escapes in FMT are interpreted specially if present.
These are:

  %m	module name of current module. 
  %d	directory of current source file. 
  %c	number of current character position
  %e	text of the caml variable surrounding point.

  The `current' source file is the file of the current buffer (if
we're in a caml buffer) or the source file current at the last break
or step (if we're in the camldebug buffer), and the `current' module
name is the filename stripped of any *.ml* suffixes (this assumes the
usual correspondence between module and file naming is observed).  The
`current' position is that of the current buffer (if we're in a source
file) or the position of the last break or step (if we're in the
camldebug buffer).

If ARG is present, it overrides any FMT flags and its string
representation is simply concatenated with the COMMAND."

  ;; Make sure debugger buffer is displayed in a window.
  (camldebug-set-buffer)
  (message "Command: %s" (camldebug-call-1 command fmt arg)))

(defun camldebug-call-1 (command &optional fmt arg)
  
  ;; Record info on the last prompt in the buffer and its position.
  (save-excursion
    (set-buffer current-camldebug-buffer)
    (goto-char (process-mark (get-buffer-process current-camldebug-buffer)))
    (let ((pt (point)))
      (beginning-of-line)
      (if (looking-at comint-prompt-regexp)
	  (set-marker camldebug-delete-prompt-marker (point)))))
  (let ((cmd (cond
	      (arg (concat command " " (int-to-string arg)))
	      (fmt (camldebug-format-command
		    (concat command " " fmt)))
	      (command))))
    (process-send-string (get-buffer-process current-camldebug-buffer)
			 (concat cmd "\n"))
    cmd))


(provide 'camldebug)