[PATCH] Initial GUD integration support.

[Jan Nieuwenhuizen]

Hi!

I'm trying to resurrect and finish my Emacs' Grand Unified Debugger
(GUD) integration patch, but I cannot get latest Guile master's debugger
to respect breakpoints?

This patch mainly tries to have Guile use GNU style error messages when
printing backtraces.  Meanwhile, the Emacs side of thes patches has been
integrated so that should be easier to test now.

With attached patch, try:

$ meta/guile -L ../examples

GNU Guile 2.1.4
Copyright (C) 1995-2016 Free Software Foundation, Inc.

Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
This program is free software, and you are welcome to redistribute it
under certain conditions; type `,show c' for details.

Enter `,help' for help.
scheme@(guile-user)> ,m (gud-break)
;;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0
;;;       or pass the --no-auto-compile argument to disable.
;;; compiling ../examples/gud-break.scm
;;; compiled 
/home/janneke/src/guile/build/cache/guile/ccache/2.2-LE-8-3.9/home/janneke/src/guile/examples/gud-break.scm.go
scheme@(gud-break)> ,br main
Trap 0: Breakpoint at #<procedure main args>.
scheme@(gud-break)> (main)
((line . 35) (column . 29) (filename . gud-break.scm)):hello world
set: a=1
set: b=2
set: c=3
set: d=4
((line . 50) (column . 30) (filename . gud-break.scm)):leaving...
((line . 51) (column . 31) (filename . gud-break.scm)):goodbye world
scheme@(gud-break)> ,break-at /home/janneke/src/guile/examples/gud-break.scm 36

;;; WARNING (no instructions found for 
/home/janneke/src/guile/examples/gud-break.scm : 35)
Trap 1: Breakpoint at /home/janneke/src/guile/examples/gud-break.scm:36.
scheme@(gud-break)> (main)
((line . 35) (column . 29) (filename . gud-break.scm)):hello world
set: a=1
set: b=2
set: c=3
set: d=4
((line . 50) (column . 30) (filename . gud-break.scm)):leaving...
((line . 51) (column . 31) (filename . gud-break.scm)):goodbye world
scheme@(gud-break)>

Greetings,
Jan

>From 0b220974b0288a0de1d892b7111165ce609033b1 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <address@hidden>
Date: Tue, 5 Aug 2014 12:34:09 +0200
Subject: [PATCH] Initial GUD integration support.

* examples/gud-break.scm: New example; showing initial GUD
integration.
* module/system/repl/debug.scm (debug-prompt): New procedure;
gdb-like debug prompt.  Experimental!
* module/system/repl/error-handling.scm (call-with-error-handling):
* module/system/repl/command.scm (step, step-instruction, next)
(next-instruction): Use it.
---
 examples/gud-break.scm                | 56 ++++++++++++++++++++++++
 module/system/repl/command.scm        |  8 ++--
 module/system/repl/debug.scm          | 80 +++++++++++++++++++++++++++++++++++
 module/system/repl/error-handling.scm |  3 +-
 4 files changed, 142 insertions(+), 5 deletions(-)
 create mode 100644 examples/gud-break.scm

diff --git a/examples/gud-break.scm b/examples/gud-break.scm
new file mode 100644
index 0000000..dbef6f3
--- /dev/null
+++ b/examples/gud-break.scm
@@ -0,0 +1,56 @@
+#! /bin/sh
+# -*-scheme-*-
+exec guile -e main -s "$0" "$@"
+!#
+;; Experimental GUD support for Guile REPL
+;; Find a gud.el that you want to patch, e.g.
+;;     zcat /usr/share/emacs/24.3/lisp/progmodes/gud.el.gz > ~/.emacs.d/gud.el
+;; or
+;;     M-x find-function gdb RET
+;;     C-x C-w ~/.emacs.d/gud.el RET
+;; Patch it
+;;     patch ~/.emacs.d/gud.el < 
0001-Initial-Guile-REPL-guiler-debugger-support-for-GUD.patch
+;; M-x load-library ~/.emacs.d/gud.el RET
+;; M-x guiler RET
+;; ,m gud-break
+;; ,br main
+;; (main)
+;; ,n
+;; ,n # no easy RET shortcut yet
+;;
+;; And see |> marker in Emac's left margin track the program's execution.
+
+(read-set! keywords 'prefix)
+
+(define (main . args)
+  (eval '(main (command-line)) (resolve-module '(gud-break))))
+
+(define-module (gud-break)
+  :export (main))
+
+(define (stderr fmt . args)
+  (apply format (cons (current-error-port) (cons* fmt args)))
+  (force-output (current-error-port)))
+
+(define (main . args) 
+  (stderr "~a:hello world\n" (current-source-location))
+  (let
+      ((a #f)
+       (b #f))
+    (set! a 1)
+    (stderr "set: a=~a\n" a)
+    (set! b 2)
+    (stderr "set: b=~a\n" b)
+    (let
+        ((c #f)
+         (d #f))
+      (set! c 3)
+      (stderr "set: c=~a\n" c)
+      (set! d 4)
+      (stderr "set: d=~a\n" d))
+    (stderr "~a:leaving...\n" (current-source-location)))
+  (stderr "~a:goodbye world\n" (current-source-location)))
+
+
+
+
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index acb18e0..6be9ba3 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -735,7 +735,7 @@ Resume execution, breaking when the current frame finishes."
 Step until control reaches a different source location.
 
 Step until control reaches a different source location."
-  (let ((msg (format #f "Step into ~a" cur)))
+  (let ((msg (debug-prompt cur)))
     (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
                                   #:into? #t #:instruction? #f)
     (throw 'quit)))
@@ -745,7 +745,7 @@ Step until control reaches a different source location."
 Step until control reaches a different instruction.
 
 Step until control reaches a different VM instruction."
-  (let ((msg (format #f "Step into ~a" cur)))
+  (let ((msg (debug-prompt cur)))
     (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
                                   #:into? #t #:instruction? #t)
     (throw 'quit)))
@@ -755,7 +755,7 @@ Step until control reaches a different VM instruction."
 Step until control reaches a different source location in the current frame.
 
 Step until control reaches a different source location in the current frame."
-  (let ((msg (format #f "Step into ~a" cur)))
+  (let ((msg (debug-prompt cur)))
     (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
                                   #:into? #f #:instruction? #f)
     (throw 'quit)))
@@ -765,7 +765,7 @@ Step until control reaches a different source location in 
the current frame."
 Step until control reaches a different instruction in the current frame.
 
 Step until control reaches a different VM instruction in the current frame."
-  (let ((msg (format #f "Step into ~a" cur)))
+  (let ((msg (debug-prompt cur)))
     (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
                                   #:into? #f #:instruction? #t)
     (throw 'quit)))
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index 55062d7..90e4724 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -27,6 +27,7 @@
   #:use-module (system vm debug)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 and-let-star)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 pretty-print)
   #:use-module ((system vm inspect) #:select ((inspect . %inspect)))
@@ -34,6 +35,7 @@
   #:export (<debug>
             make-debug debug?
             debug-frames debug-index debug-error-message
+            debug-prompt
             terminal-width
             print-registers print-locals print-frame print-frames
             stack->vector narrow-stack->vector
@@ -164,6 +166,84 @@
             (lp (+ i inc)
                 (frame-source frame)))))))
 
+(define *source-alist* '())
+(define (source-add file-name source)
+  (set! *source-alist* (assoc-set! *source-alist* file-name source))
+  source)
+
+(define (read-source-file file-name)
+  (or (assoc-ref *source-alist* file-name)
+      (and-let* ((source (with-input-from-file file-name read-string))
+                 (lines (string-split source #\newline)))
+                (source-add file-name lines))))
+
+(define (fs-find-file file-name)
+  (if (file-exists? file-name) 
+      file-name
+      (%search-load-path file-name)))
+
+(define (relative-file-name file-name)
+  (let ((cwd (getcwd)))
+    (if (and file-name (string-prefix? cwd file-name))
+        (string-drop file-name (1+ (string-length cwd)))
+        file-name)))
+
+(define (source-code file-name line-number)
+  (or (and-let* ((file-name file-name)
+                 (line-number line-number)
+                 (lines (read-source-file file-name)))
+                (list-ref lines line-number))
+      ""))
+
+(define *last-source* #f)
+(define* (debug-prompt frame #:optional (last-source *last-source*) (message 
""))
+  "A gdb,pydb-like debug prompt."
+  (define (source:pretty-file source)
+    (if source
+        (or (source:file source) "current input")
+        "unknown file"))
+  (let* ((source (frame-source frame))
+         (file (source:pretty-file source))
+         (file-name (relative-file-name (fs-find-file file)))
+         (line (and=> source source:line))
+         (col (and=> source source:column))
+         (code (source-code file-name line))
+         (line-column (format #f "~a~a" (if line (1+ line) "") 
+                              (if col (format #f ":~a" col) ""))))
+    (set! *last-source* source)
+    (string-append
+     (if (and file (not (equal? file (source:pretty-file last-source))))
+         (format #f "~&~a:~a:~a~&" file-name line-column message) ;;GNU 
standard!
+         ;;(format #f "~&In ~a:~a~&" file-name message) ;;or awkward Guile 
convention?
+         "")
+     (format #f "~&~10a~a" line-column code))))
+
+;; Ideally here we would have something much more syntactic, in that a set! to 
a
+;; local var that is not settable would raise an error, and export etc forms
+;; would modify the module in question: but alack, this is what we have now.
+;; Patches welcome!
+(define (frame->module frame)
+  (let ((proc (frame-procedure frame)))
+    (if #f
+        ;; FIXME: program-module does not exist.
+        (let* ((mod (or (program-module proc) (current-module)))
+               (mod* (make-module)))
+          (module-use! mod* mod)
+          (for-each
+           (lambda (binding)
+             (let* ((x (frame-local-ref frame (binding-slot binding)))
+                    (var (if (variable? x) x (make-variable x))))
+               (format #t
+                       "~:[Read-only~;Mutable~] local variable ~a = ~70:@y\n"
+                       (not (variable? x))
+                       (binding-name binding)
+                       (if (variable-bound? var) (variable-ref var) var))
+               (module-add! mod* (binding-name binding) var)))
+           (frame-bindings frame))
+          mod*)
+        (current-module))))
+
+
 (define (stack->vector stack)
   (let* ((len (stack-length stack))
          (v (make-vector len)))
diff --git a/module/system/repl/error-handling.scm 
b/module/system/repl/error-handling.scm
index 94a9f2a..1777854 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -80,7 +80,8 @@
                (begin
                  (format #t "~a~%" error-msg)
                  (format #t "Entering a new prompt.  ")
-                 (format #t "Type `,bt' for a backtrace or `,q' to 
continue.\n")))
+                 (format #t "Type `,bt' for a backtrace or `,q' to 
continue.\n")
+                 (format #t "~a~&" (debug-prompt frame #f))))
            ((@ (system repl repl) start-repl) #:debug debug)))))
 
     (define (null-trap-handler frame trap-idx trap-name)
-- 
2.9.3

-- 
Jan Nieuwenhuizen <address@hidden> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar®  http://AvatarAcademy.nl