Initial GUD integration for Guile

Initial GUD integration for Guile

[Jan Nieuwenhuizen]

From Jan Nieuwenhuizen <janneke@gnu.org> # This line is ignored.
Subject: Initial GUD support for Guile
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Hi,

Here is an experimental patch for Guile to support GUD integration.  It
features a more friendly (more gdb-like) debug prompt for breakpoints
and stepping.  It has some rough edges, hopefully I overlooked some
simple things that can help clean it up.

Following is also its counterpart, a patch for Emacs' Grand Unified
Debugger (GUD).

I'm including gud-break.c that matches examples/gud-break.scm for
GUD (guile/gdb) operation comparison.

What do you think?

(There are of course more goodies to wish for after we can agree upon an
 initial integration).

Greetings, Jan




--- gud-break.c
/*
  Comparing GDB/GUD with experimental Guile/GUD support for Guile REPL
  gcc -g --std=c99 -o gud-break gud-break.c 
  gdb gud-break, or using GUD: M-x gdb RET gud-break RET
  b main
  r
  n
  RET # repeats last command: `n'
  ...
*/
#include <stdio.h>

int
main ()
{
  fprintf (stderr, "%s:%d:hello world\n", __FILE__, __LINE__);
  {
    int a;
    int b;
    a = 1;
    fprintf (stderr, "set: a=%d\n", a);
    b = 2;
    fprintf (stderr, "set: b=%d\n", b);
    {
      int c;
      int d;
      c = 3;
      fprintf (stderr, "set: c=%d\n", c);
      d = 4;
      fprintf (stderr, "set: d=%d\n", d);
    }
    fprintf (stderr, "%s:%d:leaving...\n", __FILE__, __LINE__);
  }
  fprintf (stderr, "%s:%d:goodbye world\n", __FILE__, __LINE__);
}
--- end

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

[PATCH] Initial GUD integration support.

[Jan Nieuwenhuizen]

	* 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          | 62 +++++++++++++++++++++++++++++++++++
 module/system/repl/error-handling.scm |  3 +-
 4 files changed, 124 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..8378a0c
--- /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
+;; ,r
+;; ,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 62bc297..3999c5e 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -740,7 +740,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)))
@@ -750,7 +750,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)))
@@ -760,7 +760,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)))
@@ -770,7 +770,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 300145d..5e47d19 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -24,6 +24,7 @@
   #:use-module (system base language)
   #:use-module (system vm vm)
   #:use-module (system vm frame)
+  #:use-module (ice-9 and-let-star)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 pretty-print)
   #:use-module (ice-9 format)
@@ -32,6 +33,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 frame->module
             stack->vector narrow-stack->vector
@@ -160,6 +162,66 @@
             (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* (gulp-port #:optional (port current-input-port)) 
+  (or (and-let* ((result (read-delimited "" port))
+                 ((string? result)))
+                result)
+      ""))
+
+(define (gulp-file file-name)
+  (gulp-port (open-input-file (format #f "~a" file-name))))
+
+(define (read-source-file file-name)
+  (or (assoc-ref *source-alist* file-name)
+      (and-let* ((source (gulp-file file-name))
+                 (lines (string-split source #\newline)))
+                (source-add file-name lines))))
+
+(define (fs-find-file file-name)
+  (let loop ((path (cons "." %load-path )))
+    (if (null? path)
+        #f
+        (let* ((dir (car path)) 
+               (fs-file-name (string-join (list dir file-name) "/")))
+          (if (file-exists? fs-file-name)
+              fs-file-name
+              (loop (cdr path)))))))
+
+(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 (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.
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)
-- 
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar®  http://AvatarAcademy.nl  

[PATCH] Initial Guile REPL (guiler) debugger support for GUD.

[Jan Nieuwenhuizen]

	* progmodes/gud.el (guiler): New function.  Starts the Guile REPL;
	add Guile debugger support for GUD.
---
 lisp/ChangeLog        |  5 +++
 lisp/progmodes/gud.el | 89 ++++++++++++++++++++++++++++++++++++++++++++++++---
 2 files changed, 89 insertions(+), 5 deletions(-)

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index b6f16ea..b3da957 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,8 @@
+2014-08-05  Jan Nieuwenhuizen  <janneke@gnu.org>
+
+	* progmodes/gud.el (guiler): New function.  Starts the Guile REPL;
+	add Guile debugger support for GUD.
+
 2014-08-03  Paul Eggert  <eggert@cs.ucla.edu>
 
 	Don't mishandle year-9999 dates (Bug#18176).
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index c6fc944..fd57e62 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -34,7 +34,8 @@
 ;; and added a menu. Brian D. Carlstrom <bdc@ai.mit.edu> combined the IRIX
 ;; kluge with the gud-xdb-directories hack producing gud-dbx-directories.
 ;; Derek L. Davies <ddavies@world.std.com> added support for jdb (Java
-;; debugger.)
+;; debugger.)  Jan Nieuwenhuizen added support for the Guile REPL (Guile
+;; debugger).
 
 ;;; Code:
 
@@ -140,7 +141,7 @@ Used to gray out relevant toolbar icons.")
 			       (display-graphic-p)
 			       (fboundp 'x-show-tip))
 		  :visible (memq gud-minor-mode
-				'(gdbmi dbx sdb xdb pdb))
+				'(gdbmi guiler dbx sdb xdb pdb))
 	          :button (:toggle . gud-tooltip-mode))
     ([refresh]	"Refresh" . gud-refresh)
     ([run]	menu-item "Run" gud-run
@@ -170,11 +171,11 @@ Used to gray out relevant toolbar icons.")
     ([up]	menu-item "Up Stack" gud-up
 		  :enable (not gud-running)
 		  :visible (memq gud-minor-mode
-				 '(gdbmi gdb dbx xdb jdb pdb)))
+				 '(gdbmi gdb guiler dbx xdb jdb pdb)))
     ([down]	menu-item "Down Stack" gud-down
 		  :enable (not gud-running)
 		  :visible (memq gud-minor-mode
-				 '(gdbmi gdb dbx xdb jdb pdb)))
+				 '(gdbmi gdb guiler dbx xdb jdb pdb)))
     ([pp]	menu-item "Print S-expression" gud-pp
                   :enable (and (not gud-running)
 				  (bound-and-true-p gdb-active-process))
@@ -195,7 +196,7 @@ Used to gray out relevant toolbar icons.")
     ([finish]	menu-item "Finish Function" gud-finish
                   :enable (not gud-running)
 		  :visible (memq gud-minor-mode
-				 '(gdbmi gdb xdb jdb pdb)))
+				 '(gdbmi gdb guiler xdb jdb pdb)))
     ([stepi]	menu-item "Step Instruction" gud-stepi
                   :enable (not gud-running)
 		  :visible (memq gud-minor-mode '(gdbmi gdb dbx)))
@@ -1704,6 +1705,83 @@ and source-file directory for your debugger."
   (run-hooks 'pdb-mode-hook))
 \f
 ;; ======================================================================
+;; Guile REPL (guiler) functions
+
+;; History of argument lists passed to guiler.
+(defvar gud-guiler-history nil)
+
+(defvar gud-guiler-lastfile nil)
+
+(defun gud-guiler-marker-filter (string)
+  (setq gud-marker-acc (if gud-marker-acc (concat gud-marker-acc string) string))
+
+  (let ((start 0))
+    (while
+	(cond
+	 ((string-match "^In \\(.*\\):" gud-marker-acc start)
+          (setq gud-guiler-lastfile (match-string 1 gud-marker-acc)))
+	 ((string-match "^\\([^:\n]+\\):\\([0-9]+\\):\\([0-9]+\\):[^\n]*"
+			gud-marker-acc start)
+          (setq gud-guiler-lastfile (match-string 1 gud-marker-acc))
+          (setq gud-last-frame
+                (cons gud-guiler-lastfile
+                      (string-to-number (match-string 2 gud-marker-acc)))))
+	 ((string-match "^[ ]*\\([0-9]+\\):\\([0-9]+\\)  [^\n]*"
+			gud-marker-acc start)
+          (if gud-guiler-lastfile
+              (setq gud-last-frame
+                    (cons gud-guiler-lastfile
+                          (string-to-number (match-string 1 gud-marker-acc))))))
+	 ((string-match comint-prompt-regexp gud-marker-acc start) t)
+         ((string= (substring gud-marker-acc start) "") nil)
+         (t nil))
+      (setq start (match-end 0)))
+
+    ;; Search for the last incomplete line in this chunk
+    (while (string-match "\n" gud-marker-acc start)
+      (setq start (match-end 0)))
+
+    ;; If we have an incomplete line, store it in gud-marker-acc.
+    (setq gud-marker-acc (substring gud-marker-acc (or start 0))))
+  string)
+
+
+(defcustom gud-guiler-command-name "guile"
+  "File name for executing the Guile debugger.
+This should be an executable on your path, or an absolute file name."
+  :type 'string
+  :group 'gud)
+
+;;;###autoload
+(defun guiler (command-line)
+  "Run guiler on program FILE in buffer `*gud-FILE*'.
+The directory containing FILE becomes the initial working directory
+and source-file directory for your debugger."
+  (interactive
+   (list (gud-query-cmdline 'guiler)))
+
+  (gud-common-init command-line nil 'gud-guiler-marker-filter)
+  (set (make-local-variable 'gud-minor-mode) 'guiler)
+
+;; FIXME: absolute file-names are not grokked yet by Guile's ,break-at-source
+;; and relative file names only when relative to %load-path.
+;;  (gud-def gud-break  ",break-at-source %d%f %l"  "\C-b" "Set breakpoint at current line.")
+  (gud-def gud-break  ",break-at-source %f %l"  "\C-b" "Set breakpoint at current line.")
+;; FIXME: remove breakpoint with file-line not yet supported by Guile
+;;  (gud-def gud-remove ",delete ---> %d%f:%l"  "\C-d" "Remove breakpoint at current line")
+  (gud-def gud-step   ",step"         "\C-s" "Step one source line with display.")
+  (gud-def gud-next   ",next"         "\C-n" "Step one line (skip functions).")
+;;  (gud-def gud-cont   "continue"     "\C-r" "Continue with display.")
+  (gud-def gud-finish ",finish"       "\C-f" "Finish executing current function.")
+  (gud-def gud-up     ",up"           "<" "Up one stack frame.")
+  (gud-def gud-down   ",down"         ">" "Down one stack frame.")
+  (gud-def gud-print  "%e"            "\C-p" "Evaluate Guile expression at point.")
+
+  (setq comint-prompt-regexp "^scheme@([^>]+> ")
+  (setq paragraph-start comint-prompt-regexp)
+  (run-hooks 'guiler-mode-hook))
+\f
+;; ======================================================================
 ;;
 ;; JDB support.
 ;;
@@ -3450,6 +3528,7 @@ With arg, dereference expr if ARG is positive, otherwise do not dereference."
   "Return a suitable command to print the expression EXPR."
   (pcase gud-minor-mode
     (`gdbmi (concat "-data-evaluate-expression \"" expr "\""))
+    (`guiler expr)
     (`dbx (concat "print " expr))
     ((or `xdb `pdb) (concat "p " expr))
     (`sdb (concat expr "/"))))
-- 
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar®  http://AvatarAcademy.nl  

Re: Initial GUD integration for Guile

[Jan Nieuwenhuizen]

[-- Attachment #1: Type: text/plain, Size: 204 bytes --]

Jan Nieuwenhuizen writes:

After chatting with davexunit and seeing a remark from Andy,
here's a somewhat less clueless version.

Worries about sources-alist, *last-source* etc remain...

Greetings, Jan


[-- Attachment #2: 0001-Initial-GUD-integration-support.patch --]
[-- Type: text/x-diff, Size: 8490 bytes --]

From 7ce14e739ba2ada7bc1e46a9821ae6c83871b14c Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
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          | 48 ++++++++++++++++++++++++++++++
 module/system/repl/error-handling.scm |  3 +-
 4 files changed, 110 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..8378a0c
--- /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
+;; ,r
+;; ,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 62bc297..3999c5e 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -740,7 +740,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)))
@@ -750,7 +750,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)))
@@ -760,7 +760,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)))
@@ -770,7 +770,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 300145d..c6b796d 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -24,6 +24,7 @@
   #:use-module (system base language)
   #:use-module (system vm vm)
   #:use-module (system vm frame)
+  #:use-module (ice-9 and-let-star)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 pretty-print)
   #:use-module (ice-9 format)
@@ -32,6 +33,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 frame->module
             stack->vector narrow-stack->vector
@@ -160,6 +162,52 @@
             (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 (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 (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.
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)
-- 
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar®  http://AvatarAcademy.nl  


[-- Attachment #3: Type: text/plain, Size: 154 bytes --]


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

Re: [PATCH] Initial Guile REPL (guiler) debugger support for GUD.

[Stefan Monnier]

> 	* progmodes/gud.el (guiler): New function.  Starts the Guile REPL;
> 	add Guile debugger support for GUD.

Looks OK, tho please use the new `setq-local' when setting variables
buffer-locally.


        Stefan

Re: [PATCH] Initial Guile REPL (guiler) debugger support for GUD.

[Jan Nieuwenhuizen]

[-- Attachment #1: Type: text/plain, Size: 320 bytes --]

Stefan Monnier writes:

>> 	* progmodes/gud.el (guiler): New function.  Starts the Guile REPL;
>> 	add Guile debugger support for GUD.
>
> Looks OK, 

That's great, we're going to guile support in GUD!

> tho please use the new `setq-local' when setting variables
> buffer-locally.

New patch attached.

Greetings, Jan


[-- Attachment #2: 0001-Initial-Guile-REPL-guiler-debugger-support-for-GUD.patch --]
[-- Type: text/x-diff, Size: 7013 bytes --]

From 3db1acfeb281f6fbbc8df19164b7f313e37b81ee Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Mon, 4 Aug 2014 11:15:59 +0200
Subject: [PATCH] Initial Guile REPL (guiler) debugger support for GUD.

	* lisp/progmodes/gud.el (guiler): New function.  Starts the
	Guile REPL; add Guile debugger support for GUD.
---
 lisp/ChangeLog        |  5 +++
 lisp/progmodes/gud.el | 89 ++++++++++++++++++++++++++++++++++++++++++++++++---
 2 files changed, 89 insertions(+), 5 deletions(-)

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index b6f16ea..b3da957 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,8 @@
+2014-08-05  Jan Nieuwenhuizen  <janneke@gnu.org>
+
+	* progmodes/gud.el (guiler): New function.  Starts the Guile REPL;
+	add Guile debugger support for GUD.
+
 2014-08-03  Paul Eggert  <eggert@cs.ucla.edu>
 
 	Don't mishandle year-9999 dates (Bug#18176).
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index c6fc944..09085f7 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -34,7 +34,8 @@
 ;; and added a menu. Brian D. Carlstrom <bdc@ai.mit.edu> combined the IRIX
 ;; kluge with the gud-xdb-directories hack producing gud-dbx-directories.
 ;; Derek L. Davies <ddavies@world.std.com> added support for jdb (Java
-;; debugger.)
+;; debugger.)  Jan Nieuwenhuizen added support for the Guile REPL (Guile
+;; debugger).
 
 ;;; Code:
 
@@ -140,7 +141,7 @@ Used to gray out relevant toolbar icons.")
 			       (display-graphic-p)
 			       (fboundp 'x-show-tip))
 		  :visible (memq gud-minor-mode
-				'(gdbmi dbx sdb xdb pdb))
+				'(gdbmi guiler dbx sdb xdb pdb))
 	          :button (:toggle . gud-tooltip-mode))
     ([refresh]	"Refresh" . gud-refresh)
     ([run]	menu-item "Run" gud-run
@@ -170,11 +171,11 @@ Used to gray out relevant toolbar icons.")
     ([up]	menu-item "Up Stack" gud-up
 		  :enable (not gud-running)
 		  :visible (memq gud-minor-mode
-				 '(gdbmi gdb dbx xdb jdb pdb)))
+				 '(gdbmi gdb guiler dbx xdb jdb pdb)))
     ([down]	menu-item "Down Stack" gud-down
 		  :enable (not gud-running)
 		  :visible (memq gud-minor-mode
-				 '(gdbmi gdb dbx xdb jdb pdb)))
+				 '(gdbmi gdb guiler dbx xdb jdb pdb)))
     ([pp]	menu-item "Print S-expression" gud-pp
                   :enable (and (not gud-running)
 				  (bound-and-true-p gdb-active-process))
@@ -195,7 +196,7 @@ Used to gray out relevant toolbar icons.")
     ([finish]	menu-item "Finish Function" gud-finish
                   :enable (not gud-running)
 		  :visible (memq gud-minor-mode
-				 '(gdbmi gdb xdb jdb pdb)))
+				 '(gdbmi gdb guiler xdb jdb pdb)))
     ([stepi]	menu-item "Step Instruction" gud-stepi
                   :enable (not gud-running)
 		  :visible (memq gud-minor-mode '(gdbmi gdb dbx)))
@@ -1704,6 +1705,83 @@ and source-file directory for your debugger."
   (run-hooks 'pdb-mode-hook))
 \f
 ;; ======================================================================
+;; Guile REPL (guiler) functions
+
+;; History of argument lists passed to guiler.
+(defvar gud-guiler-history nil)
+
+(defvar gud-guiler-lastfile nil)
+
+(defun gud-guiler-marker-filter (string)
+  (setq gud-marker-acc (if gud-marker-acc (concat gud-marker-acc string) string))
+
+  (let ((start 0))
+    (while
+	(cond
+	 ((string-match "^In \\(.*\\):" gud-marker-acc start)
+          (setq gud-guiler-lastfile (match-string 1 gud-marker-acc)))
+	 ((string-match "^\\([^:\n]+\\):\\([0-9]+\\):\\([0-9]+\\):[^\n]*"
+			gud-marker-acc start)
+          (setq gud-guiler-lastfile (match-string 1 gud-marker-acc))
+          (setq gud-last-frame
+                (cons gud-guiler-lastfile
+                      (string-to-number (match-string 2 gud-marker-acc)))))
+	 ((string-match "^[ ]*\\([0-9]+\\):\\([0-9]+\\)  [^\n]*"
+			gud-marker-acc start)
+          (if gud-guiler-lastfile
+              (setq gud-last-frame
+                    (cons gud-guiler-lastfile
+                          (string-to-number (match-string 1 gud-marker-acc))))))
+	 ((string-match comint-prompt-regexp gud-marker-acc start) t)
+         ((string= (substring gud-marker-acc start) "") nil)
+         (t nil))
+      (setq start (match-end 0)))
+
+    ;; Search for the last incomplete line in this chunk
+    (while (string-match "\n" gud-marker-acc start)
+      (setq start (match-end 0)))
+
+    ;; If we have an incomplete line, store it in gud-marker-acc.
+    (setq gud-marker-acc (substring gud-marker-acc (or start 0))))
+  string)
+
+
+(defcustom gud-guiler-command-name "guile"
+  "File name for executing the Guile debugger.
+This should be an executable on your path, or an absolute file name."
+  :type 'string
+  :group 'gud)
+
+;;;###autoload
+(defun guiler (command-line)
+  "Run guiler on program FILE in buffer `*gud-FILE*'.
+The directory containing FILE becomes the initial working directory
+and source-file directory for your debugger."
+  (interactive
+   (list (gud-query-cmdline 'guiler)))
+
+  (gud-common-init command-line nil 'gud-guiler-marker-filter)
+  (setq-local gud-minor-mode 'guiler)
+
+;; FIXME: absolute file-names are not grokked yet by Guile's ,break-at-source
+;; and relative file names only when relative to %load-path.
+;;  (gud-def gud-break  ",break-at-source %d%f %l"  "\C-b" "Set breakpoint at current line.")
+  (gud-def gud-break  ",break-at-source %f %l"  "\C-b" "Set breakpoint at current line.")
+;; FIXME: remove breakpoint with file-line not yet supported by Guile
+;;  (gud-def gud-remove ",delete ---> %d%f:%l"  "\C-d" "Remove breakpoint at current line")
+  (gud-def gud-step   ",step"         "\C-s" "Step one source line with display.")
+  (gud-def gud-next   ",next"         "\C-n" "Step one line (skip functions).")
+;;  (gud-def gud-cont   "continue"     "\C-r" "Continue with display.")
+  (gud-def gud-finish ",finish"       "\C-f" "Finish executing current function.")
+  (gud-def gud-up     ",up"           "<" "Up one stack frame.")
+  (gud-def gud-down   ",down"         ">" "Down one stack frame.")
+  (gud-def gud-print  "%e"            "\C-p" "Evaluate Guile expression at point.")
+
+  (setq comint-prompt-regexp "^scheme@([^>]+> ")
+  (setq paragraph-start comint-prompt-regexp)
+  (run-hooks 'guiler-mode-hook))
+\f
+;; ======================================================================
 ;;
 ;; JDB support.
 ;;
@@ -3450,6 +3528,7 @@ With arg, dereference expr if ARG is positive, otherwise do not dereference."
   "Return a suitable command to print the expression EXPR."
   (pcase gud-minor-mode
     (`gdbmi (concat "-data-evaluate-expression \"" expr "\""))
+    (`guiler expr)
     (`dbx (concat "print " expr))
     ((or `xdb `pdb) (concat "p " expr))
     (`sdb (concat expr "/"))))
-- 
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar®  http://AvatarAcademy.nl  


[-- Attachment #3: Type: text/plain, Size: 154 bytes --]


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