Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

ocamldebug.el: Try and partially sync with camldebug.el (#227) #319

Merged
merged 2 commits into from
Feb 27, 2025
Merged

ocamldebug.el: Try and partially sync with camldebug.el (#227) #319

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
a04ffba
Fix compilation warnings so the CI tests pass again
monnier Feb 26, 2025
92c7a97
ocamldebug.el: Try and partially sync with `camldebug.el` (#227)
monnier Feb 26, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
150 changes: 82 additions & 68 deletions ocamldebug.el
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,22 +1,24 @@
;;; ocamldebug.el --- Run ocamldebug / camldebug under Emacs -*- lexical-binding:t -*-
;; Derived from gdb.el.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Copying is covered by the GNU General Public License.
;;
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 3 of the License, or
;; (at your option) any later version.
;;
;; This program 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.
;; This program 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.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; History:
;;
;; This is based on the `camldebug.el' by Jacques Garrigue
;; and Ian T Zimmerman, that's in the `caml' package.
;;
;;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
Expand All @@ -27,21 +29,36 @@
;;assume that a sane person doesn't use gdb and dbx at the same time,
;;it's not so OK (IMHO) for gdb and ocamldebug.

;; Derived from gdb.el.
;; gdb.el is Copyright (C) 1988, 2025 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.

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

;;Albert Cohen 04-97: Patch for Tuareg support.
;;Albert Cohen 05-98: A few patches and OCaml customization.
;;Albert Cohen 09-98: XEmacs support and some improvements.
;;Erwan Jahier and Albert Cohen 11-05: support for ocamldebug 3.09.
;; Copyright (C) 2011-2025 Free Software Foundation, Inc.

;;; Commentary:

;;; Code:

;; FIXME: Sync with `camldebug.el', or even merge them back!

(require 'comint)
(require 'shell)
(require 'tuareg (expand-file-name "tuareg" (file-name-directory
(or load-file-name
byte-compile-current-file
buffer-file-name))))
(require 'tuareg (expand-file-name "tuareg"
(file-name-directory
(if (fboundp 'macroexp-file-name) ;Emacs≥28
(macroexp-file-name)
(or load-file-name
byte-compile-current-file
buffer-file-name)))))
(require 'derived)
(require 'seq)

Expand Down Expand Up @@ -79,11 +96,11 @@
(defvar ocamldebug-event-marker (make-marker)
"Marker for displaying the current event.")

(defvar ocamldebug-track-frame t
"If non-nil, always display current frame position in another window.")
(defvar ocamldebug-track-frame t ;FIXME: Make it a `defcustom'?
"*If non-nil, always display current frame position in another window.")

(defface ocamldebug-event
'((t :invert t))
'((t :inverse-video t))
"Face to highlight the first/last char of current event."
:group 'tuareg)

Expand All @@ -106,19 +123,18 @@
(define-key map "\C-c" ocamldebug-prefix-map)
(define-key map "\C-l" #'ocamldebug-refresh)
;; This is already the default anyway!
;;(define-key map "\t" 'comint-dynamic-complete)
(define-key map "\M-?"
;; FIXME: This binding is wrong since comint-dynamic-list-completions
;; is a function, not a command.
#'comint-dynamic-list-completions)
;;(define-key map "\t" #'comint-dynamic-complete)
;; FIXME: This binding is wrong since comint-dynamic-list-completions
;; is a function, not a command.
;;(define-key map "\M-?" #'comint-dynamic-list-completions)
map))

(define-derived-mode ocamldebug-mode comint-mode "OCaml-Debugger"
"Major mode for interacting with an ocamldebug process.

The following commands are available:

\\{ocamldebug-mode-map}
\\<ocamldebug-mode-map>\\{ocamldebug-mode-map}

\\[ocamldebug-display-frame] displays in the other window
the last line referred to in the ocamldebug buffer.
Expand Down Expand Up @@ -179,15 +195,16 @@ representation is simply concatenated with the COMMAND."

(let* ((fun (intern (format "ocamldebug-%s" name))))
`(progn
,(if doc
`(defun ,fun (arg)
,doc
(interactive "P")
(ocamldebug-call ,name ,args
(ocamldebug-numeric-arg arg))))
,(when doc
`(defun ,fun (arg)
,doc
(interactive "P")
(ocamldebug-call ,name ,args
(ocamldebug-numeric-arg arg))))
(define-key ocamldebug-prefix-map ,key #',fun))))

(def-ocamldebug "step" "\C-s" "Step one source line with display.")
(def-ocamldebug "step" "\C-s" "Step one event forward.")
(def-ocamldebug "backstep" "\C-k" "Step one event backward.")
(def-ocamldebug "run" "\C-r" "Run the program.")
(def-ocamldebug "reverse" "\C-v" "Run the program in reverse.")
(def-ocamldebug "last" "\C-l" "Go to latest time in execution history.")
Expand All @@ -196,7 +213,8 @@ representation is simply concatenated with the COMMAND."
(def-ocamldebug "close" "\C-c" "Close the current module." "%m")
(def-ocamldebug "finish" "\C-f" "Finish executing current function.")
(def-ocamldebug "print" "\C-p" "Print value of symbol at point." "%e")
(def-ocamldebug "next" "\C-n" "Step one source line (skip functions)")
(def-ocamldebug "display" "\C-d" "Display value of symbol at point." "%e")
(def-ocamldebug "next" "\C-n" "Step one event forward (skip functions)")
(def-ocamldebug "up" "<" "Go up N stack frames (numeric arg) with display")
(def-ocamldebug "down" ">" "Go down N stack frames (numeric arg) with display")
(def-ocamldebug "break" "\C-b" "Set breakpoint at current line."
Expand Down Expand Up @@ -349,8 +367,7 @@ buffer, then try to obtain the time from context around point."
(match-string 1 ocamldebug-filter-accumulator))
(setq ocamldebug-filter-accumulator
(substring ocamldebug-filter-accumulator (1- (match-end 0)))))
(when (string-match comint-prompt-regexp
ocamldebug-filter-accumulator)
(when (string-match comint-prompt-regexp ocamldebug-filter-accumulator)
(setq ocamldebug-delete-output (or ocamldebug-delete-output 'fail))
(setq ocamldebug-filter-accumulator ""))
(if (string-match "\n\\(.*\\)\\'" ocamldebug-filter-accumulator)
Expand Down Expand Up @@ -403,7 +420,7 @@ around point."
(with-current-buffer ocamldebug-current-buffer
(let ((proc (get-buffer-process (current-buffer)))
(ocamldebug-filter-function #'ocamldebug-delete-filter)
ocamldebug-delete-output)
(ocamldebug-delete-output))
(ocamldebug-call-1 "info break")
(while (not (and ocamldebug-delete-output
(zerop (length
Expand All @@ -421,14 +438,12 @@ around point."
(concat ocamldebug-filter-accumulator string))
(while (string-match "\\(\n\\|\\`\\)\\(.+\\)\n"
ocamldebug-filter-accumulator)
(setq ocamldebug-complete-list
(cons (match-string 2 ocamldebug-filter-accumulator)
ocamldebug-complete-list))
(push (match-string 2 ocamldebug-filter-accumulator)
ocamldebug-complete-list)
(setq ocamldebug-filter-accumulator
(substring ocamldebug-filter-accumulator
(1- (match-end 0)))))
(when (string-match comint-prompt-regexp
ocamldebug-filter-accumulator)
(when (string-match comint-prompt-regexp ocamldebug-filter-accumulator)
(setq ocamldebug-complete-list
(or ocamldebug-complete-list 'fail))
(setq ocamldebug-filter-accumulator ""))
Expand All @@ -439,15 +454,14 @@ around point."

(defun ocamldebug-complete ()
"Perform completion on the ocamldebug command preceding point."
(declare (obsolete completion-at-point "24.1"))
(interactive)
(let* ((capf-data (ocamldebug-capf))
(command-word (buffer-substring (nth 0 capf-data) (nth 1 capf-data))))
(completion-in-region (nth 0 capf-data) (nth 1 capf-data)
(sort (all-completions command-word (nth 2 capf-data))
#'string-lessp))))

(make-obsolete 'ocamldebug-complete 'completion-at-point "24.1")

(defun ocamldebug-capf ()
;; FIXME: Use an `end' after point when applicable.
(let* ((end (point))
Expand Down Expand Up @@ -497,19 +511,20 @@ separated and possibly quoted as they would be passed on the
command line).")

;;;###autoload
(defun ocamldebug (pgm-path)
(defun ocamldebug (file)
"Run ocamldebug on program FILE in buffer *ocamldebug-FILE*.
The directory containing FILE becomes the initial working directory
and source-file directory for ocamldebug. If you wish to change this, use
the ocamldebug commands `cd DIR' and `directory'."
(interactive "fRun ocamldebug on file: ")
(setq pgm-path (expand-file-name pgm-path))
(let* ((file (file-name-nondirectory pgm-path))
(setq file (expand-file-name file))
(let* ((dir (file-name-directory file))
(file (file-name-nondirectory file))
(name (concat "ocamldebug-" file))
(buffer-name (concat "*" name "*")))
(pop-to-buffer buffer-name)
(unless (comint-check-proc buffer-name)
(setq default-directory (file-name-directory pgm-path))
(setq default-directory dir)
(setq ocamldebug-debuggee-args
(read-from-minibuffer (format "Args for %s: " file)
ocamldebug-debuggee-args))
Expand All @@ -519,18 +534,19 @@ the ocamldebug commands `cd DIR' and `directory'."
(message "Current directory is %s" default-directory)
(let* ((args (tuareg--split-args ocamldebug-debuggee-args))
(cmdlist (tuareg--split-args ocamldebug-command-name))
(cmdlist (mapcar #'substitute-in-file-name cmdlist)))
(apply #'make-comint name
(car cmdlist)
nil
"-emacs" "-cd" default-directory
(append (cdr cmdlist) (cons pgm-path args)))
(set-process-filter (get-buffer-process (current-buffer))
#'ocamldebug-filter)
(set-process-sentinel (get-buffer-process (current-buffer))
#'ocamldebug-sentinel)
(ocamldebug-mode)))
(ocamldebug-set-buffer)))
(cmdlist (mapcar #'substitute-in-file-name cmdlist))
(buf
(apply #'make-comint name
(car cmdlist)
nil
"-emacs" "-cd" default-directory
(append (cdr cmdlist) (cons file args))))
(proc (get-buffer-process buf)))
(with-current-buffer buf
(set-process-filter proc #'ocamldebug-filter)
(set-process-sentinel proc #'ocamldebug-sentinel)
(ocamldebug-mode))))
(ocamldebug-set-buffer)))

;;;###autoload
(defalias 'camldebug #'ocamldebug)
Expand All @@ -545,7 +561,7 @@ the ocamldebug commands `cd DIR' and `directory'."
(defun ocamldebug-marker-filter (string)
(setq ocamldebug-filter-accumulator
(concat ocamldebug-filter-accumulator string))
(let ((output "") begin)
(let ((output "") (begin))
;; Process all the complete markers in this chunk.
(while (setq begin
(string-match
Expand Down Expand Up @@ -664,7 +680,7 @@ the ocamldebug commands `cd DIR' and `directory'."

(defun ocamldebug-display-frame ()
"Find, obey and delete the last filename-and-line marker from OCaml debugger.
The marker looks like \\032\\032FILENAME:CHARACTER\\n.
The marker looks like \\032\\032Mfilename:startchar:endchar:beforeflag\\n.
Obeying it means displaying in another window the specified file and line."
(interactive)
(ocamldebug-set-buffer)
Expand All @@ -684,7 +700,7 @@ Obeying it means displaying in another window the specified file and line."
(let* ((pop-up-windows t)
(buffer (find-file-noselect true-file))
(window (display-buffer buffer t))
spos epos pos)
(spos) (epos) (pos))
(with-current-buffer buffer
(save-restriction
(widen)
Expand All @@ -695,7 +711,7 @@ Obeying it means displaying in another window the specified file and line."
(filepos-to-bufferpos echar 'approximate)
(+ (point-min) echar)))
(setq pos (if kind spos epos))
(ocamldebug-set-current-event spos epos pos (current-buffer) kind))
(ocamldebug-set-current-event spos epos (current-buffer) kind))
(cond ((or (< pos (point-min)) (> pos (point-max)))
(widen)
(goto-char pos))))
Expand All @@ -710,7 +726,7 @@ Obeying it means displaying in another window the specified file and line."
(delete-overlay ocamldebug-overlay-under))
(setq overlay-arrow-position nil)))

(defun ocamldebug-set-current-event (spos epos pos buffer before)
(defun ocamldebug-set-current-event (spos epos buffer before)
(if window-system
(if before
(progn
Expand All @@ -720,10 +736,10 @@ Obeying it means displaying in another window the specified file and line."
(move-overlay ocamldebug-overlay-event (1- epos) epos buffer)
(move-overlay ocamldebug-overlay-under spos (1- epos) buffer))
(with-current-buffer buffer
(goto-char pos)
(goto-char (if before spos epos))
(beginning-of-line)
(move-marker ocamldebug-event-marker (point))
(setq overlay-arrow-position ocamldebug-event-marker))))
(setq-local overlay-arrow-position ocamldebug-event-marker))))

;;; Miscellaneous.

Expand Down Expand Up @@ -768,12 +784,10 @@ Dune wrapping means that a file `foo.ml' belonging to a dune library
and a file `bar.ml' containing `module Foo = Bar__Foo' will be generated.
See also https://dune.readthedocs.io/en/latest/dune-files.html

(for now only understands dune files with a single library stanza)"
\(for now only understands dune files with a single library stanza)"
(let ((mod
(substring
filename
(string-match "\\([^/]*\\)\\.ml$" filename)
(match-end 1)))
(substring filename (string-match "\\([^/]*\\)\\.ml$" filename)
(match-end 1)))
(dune (expand-file-name "dune" (file-name-directory filename))))
(if (file-exists-p dune)
(let* ((contents (ocamldebug--read-from-file dune))
Expand Down
4 changes: 2 additions & 2 deletions tuareg.el
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
;;; tuareg.el --- OCaml mode -*- coding: utf-8; lexical-binding:t -*-

;; Copyright (C) 1997-2006 Albert Cohen, all rights reserved.
;; Copyright (C) 2011-2023 Free Software Foundation, Inc.
;; Copyright (C) 2011-2025 Free Software Foundation, Inc.
;; Copyright (C) 2009-2010 Jane Street Holding, LLC.

;; Author: Albert Cohen <Albert.Cohen@inria.fr>
Expand Down Expand Up @@ -371,7 +371,7 @@ Valid names are `browse-url', `browse-url-firefox', etc."
(tuareg--obsolete-face-var tuareg-font-lock-constructor-face)

(defface tuareg-font-lock-label-face
'((t (:inherit font-lock-constant-face keep)))
'((t (:inherit font-lock-constant-face))) ;; keep?
"Face description for labels."
:group 'tuareg-faces)
(tuareg--obsolete-face-var tuareg-font-lock-label-face)
Expand Down