Partial support for stack trace display.

7 files changed, 175 insertions, 85 deletions

diff --git a/elisp/geiser-autodoc.el b/elisp/geiser-autodoc.el
index 3c23b32..7460aa1 100644
--- a/elisp/geiser-autodoc.el
+++ b/elisp/geiser-autodoc.el
@@ -75,8 +75,7 @@ when `geiser-autodoc-display-module-p' is on."
                                            (cdr pr))
         (setq geiser-autodoc--last-funs funs)
         (geiser-eval--send
-         `(:eval ((:ge arguments)
-                  ,@(mapcar (lambda (f) (list 'quote (car f))) funs)))
+         `(:eval ((:ge arguments) ,@(mapcar (lambda (f) (list 'quote (car f))) funs)))
          'geiser-autodoc--function-args-cont)
         ""))))
 
@@ -84,12 +83,9 @@ when `geiser-autodoc-display-module-p' is on."
   (let ((result (geiser-eval--retort-result ret)))
     (when (and result (listp result))
       (setq geiser-autodoc--last result)
-      (eldoc-message
-       (geiser-autodoc--fun-args-str (car result)
-                                     (cdr result)
-                                     (or (cdr (assoc (car result)
-                                                     geiser-autodoc--last-funs))
-                                         0))))))
+      (let* ((pos (or (cdr (assoc (car result) geiser-autodoc--last-funs)) 0))
+             (msg (geiser-autodoc--fun-args-str (car result) (cdr result) pos)))
+        (when msg (eldoc-message msg))))))
 
 (defun geiser-autodoc--insert (sym current pos)
   (let ((str (format "%s" sym)))
@@ -100,34 +96,35 @@ when `geiser-autodoc-display-module-p' is on."
     (insert str)))
 
 (defun geiser-autodoc--fun-args-str (fun args pos)
-  (save-current-buffer
-    (set-buffer (geiser-syntax--font-lock-buffer))
-    (erase-buffer)
-    (let* ((current 0)
-           (module (and geiser-autodoc-display-module-p
-                        (cdr (assoc 'module args))))
-           (fun (if module
-                    (format geiser-autodoc-procedure-name-format module fun)
-                  fun)))
-      (insert "(")
-      (geiser-autodoc--insert fun current pos)
-      (dolist (arg (cdr (assoc 'required args)))
+  (when fun
+    (save-current-buffer
+      (set-buffer (geiser-syntax--font-lock-buffer))
+      (erase-buffer)
+      (let* ((current 0)
+             (module (and geiser-autodoc-display-module-p
+                          (cdr (assoc 'module args))))
+             (fun (if module
+                      (format geiser-autodoc-procedure-name-format module fun)
+                    fun)))
+        (insert "(")
+        (geiser-autodoc--insert fun current pos)
+        (dolist (arg (cdr (assoc 'required args)))
+          (setq current (1+ current))
+          (insert " ")
+          (geiser-autodoc--insert arg current pos))
         (setq current (1+ current))
-        (insert " ")
-        (geiser-autodoc--insert arg current pos))
-      (setq current (1+ current))
-      (when (cdr (assoc 'optional args))
-        (when (> pos current) (setq current pos))
-        (insert " . ")
-        (geiser-autodoc--insert (cdr (assoc 'optional args)) current pos))
-      (insert ")")
-      (buffer-string))))
+        (when (cdr (assoc 'optional args))
+          (when (> pos current) (setq current pos))
+          (insert " . ")
+          (geiser-autodoc--insert (cdr (assoc 'optional args)) current pos))
+        (insert ")")
+        (buffer-string)))))
 
 
 ;;; Autodoc function:
 
 (defun geiser-autodoc--eldoc-function ()
-  (geiser-autodoc--function-args (geiser-syntax--enclosing-form-data)))
+  (or (geiser-autodoc--function-args (geiser-syntax--enclosing-form-data)) ""))
 
 
 ;;; Autodoc mode:
diff --git a/elisp/geiser-compile.el b/elisp/geiser-compile.el
index 82200a5..8b4a4db 100644
--- a/elisp/geiser-compile.el
+++ b/elisp/geiser-compile.el
@@ -24,20 +24,11 @@
 
 ;;; Code:
 
+(require 'geiser-debug)
 (require 'geiser-eval)
-(require 'geiser-popup)
 (require 'geiser-base)
 
 
-;;; Compilation buffer:
-
-(define-derived-mode geiser-compile-mode compilation-mode "Geiser Compilation"
-  "Major mode showing the results of compiling or loading scheme files.
-\{geiser-compile-mode-keymap}")
-
-(geiser-popup--define compile "*Geiser compilation*" geiser-compile-mode)
-
-
 ;;; Auxiliary functions:
 
 (defun geiser-compile--buffer/path (&optional path)
@@ -49,25 +40,10 @@
       (cons buffer path))))
 
 (defun geiser-compile--display-result (title ret)
-  (let ((err (geiser-eval--retort-error ret))
-        (output (geiser-eval--retort-output ret)))
-    (geiser-compile--with-buffer
-      (erase-buffer)
-      (insert title)
-      (newline)
-      (when output
-        (insert output)
-        (newline))
-      (when err
-        (insert "\n" (geiser-eval--error-msg err) "\n"))
-      (goto-char (point-min)))
-    (if (not err)
-        (message "%s %s" title (if (> 0 (length output))
-                                   (geiser--chomp output)
-                                 (or (geiser-eval--retort-result ret)
-                                     "OK!")))
-      (message "")
-      (geiser-compile--pop-to-buffer))))
+  (if (not (geiser-eval--retort-error ret))
+      (message "%s %s" title (or (geiser-eval--retort-result ret) "OK!"))
+    (message "")
+    (geiser-debug--display-retort title ret)))
 
 (defun geiser-compile--file-op (path compile-p msg)
   (let* ((b/p (geiser-compile--buffer/path path))
diff --git a/elisp/geiser-debug.el b/elisp/geiser-debug.el
new file mode 100644
index 0000000..c32c895
--- /dev/null
+++ b/elisp/geiser-debug.el
@@ -0,0 +1,96 @@
+;; geiser-debug.el -- displaying debug information
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Mon Feb 23, 2009 22:34
+
+;; 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 3 of the License, 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Comentary:
+
+;; Buffer and associated mode for displaying results of evaluations
+;; and compilations.
+
+;;; Code:
+
+(require 'geiser-eval)
+(require 'geiser-popup)
+(require 'geiser-base)
+
+
+;;; Debug buffer mode:
+
+(defvar geiser-debug-mode-map
+  (let ((map (make-keymap)))
+    (suppress-keymap map)
+    (define-key map "g" 'geiser-debug-goto-error)
+    (define-key map "\C-c\C-c" 'geiser-debug-goto-error)
+    (define-key map "n" 'next-line)
+    (define-key map "p" 'previous-line)
+    map))
+
+(define-derived-mode geiser-debug-mode compilation-mode "Geiser Dbg"
+  "A major mode for displaying Scheme compilation and evaluation results.
+\\{geiser-debug-mode-map}")
+
+
+;;; Buffer for displaying evaluation results:
+
+(geiser-popup--define debug "*Geiser dbg*" geiser-debug-mode)
+
+
+;;; Displaying retorts
+
+(defun geiser-debug--display-retort (what ret)
+  (let* ((err (geiser-eval--retort-error ret))
+         (output (geiser-eval--retort-output ret))
+         (stack (geiser-eval--retort-stack ret))
+         (step 2)
+         (indent step))
+    (when err
+      (geiser-debug--with-buffer
+        (erase-buffer)
+        (insert what)
+        (newline 2)
+        (insert (geiser-eval--error-str err) "\n\n")
+        (when output (insert output "\n\n"))
+        (dolist (f (reverse (cdr stack)))
+          (geiser-debug--display-stack-frame f indent)
+          (setq indent (+ step indent)))
+        (goto-char (point-min)))
+      (geiser-debug--pop-to-buffer))))
+
+(defsubst geiser-debug--frame-proc (frame) (cdr (assoc 'procedure frame)))
+(defsubst geiser-debug--frame-desc (frame) (cdr (assoc 'description frame)))
+(defsubst geiser-debug--frame-source (frame) (cdr (assoc 'source frame)))
+(defsubst geiser-debug--frame-source-file (src) (car src))
+(defsubst geiser-debug--frame-source-line (src) (or (cadr src) 1))
+(defsubst geiser-debug--frame-source-column (src) (or (caddr src) 0))
+
+(defun geiser-debug--display-stack-frame (frame offset)
+  (let ((procedure (geiser-debug--frame-proc frame))
+        (source (geiser-debug--frame-source frame))
+        (description (geiser-debug--frame-desc frame)))
+    (if source
+        (insert (format "%s:%s:%s\n"
+                        (geiser-debug--frame-source-file source)
+                        (geiser-debug--frame-source-line source)
+                        (geiser-debug--frame-source-column source)))
+      (insert "In expression:\n"))
+    (insert (format "%s%s\n" (make-string offset ?\ ) description))))
+
+
+(provide 'geiser-debug)
+;;; geiser-debug.el ends here
diff --git a/elisp/geiser-eval.el b/elisp/geiser-eval.el
index 785f441..09f12da 100644
--- a/elisp/geiser-eval.el
+++ b/elisp/geiser-eval.el
@@ -125,6 +125,7 @@
 (defsubst geiser-eval--retort-result (ret) (cdr (assoc 'result ret)))
 (defsubst geiser-eval--retort-output (ret) (cdr (assoc 'output ret)))
 (defsubst geiser-eval--retort-error (ret) (cdr (assoc 'error ret)))
+(defsubst geiser-eval--retort-stack (ret) (cdr (assoc 'stack ret)))
 
 (defsubst geiser-eval--error-key (err) (cdr (assoc 'key err)))
 (defsubst geiser-eval--error-subr (err) (cdr (assoc 'subr err)))
diff --git a/elisp/geiser-mode.el b/elisp/geiser-mode.el
index 3c2f1a9..e308c07 100644
--- a/elisp/geiser-mode.el
+++ b/elisp/geiser-mode.el
@@ -30,8 +30,8 @@
 (require 'geiser-completion)
 (require 'geiser-edit)
 (require 'geiser-autodoc)
+(require 'geiser-debug)
 (require 'geiser-eval)
-(require 'geiser-popup)
 (require 'geiser-custom)
 (require 'geiser-base)
 
@@ -57,19 +57,6 @@
 
 ;;; Auxiliary functions:
 
-(geiser-popup--define mode "*Geiser evaluation results*" scheme-mode)
-
-(defun geiser-eval--display-error (err output)
-  (if (not output)
-      (message (geiser-eval--error-str err))
-    (geiser-mode--with-buffer
-      (erase-buffer)
-      (insert ";; " (geiser-eval--error-str err))
-      (newline 2)
-      (insert output)
-      (newline))
-    (geiser-mode--pop-to-buffer)))
-
 (defun geiser-eval--send-region (compile start end and-go)
   (let* ((str (buffer-substring-no-properties start end))
          (code `(,(if compile :comp :eval) (:scm ,str)))
@@ -81,7 +68,7 @@
       (goto-char (point-max)))
     (if (not err)
         (message (format "=> %s" (geiser-eval--retort-result ret)))
-      (geiser-eval--display-error err (geiser-eval--retort-output ret)))))
+      (geiser-debug--display-retort str ret))))
 
 
 ;;; Evaluation commands:
diff --git a/scheme/guile/geiser/emacs.scm b/scheme/guile/geiser/emacs.scm
index b9e2d67..90e03dd 100644
--- a/scheme/guile/geiser/emacs.scm
+++ b/scheme/guile/geiser/emacs.scm
@@ -38,6 +38,8 @@
                ge:module-location)
   #:use-module (srfi srfi-1)
   #:use-module (system base compile)
+  #:use-module (system vm program)
+  #:use-module (ice-9 debugger utils)
   #:use-module ((geiser introspection) :renamer (symbol-prefix-proc 'ge:)))
 
 (define (make-result result output)
@@ -49,11 +51,41 @@
 
 (define (parse-stack stack)
   (if stack
-      (list
-       (with-output-to-string
-         (lambda () (display-backtrace stack (current-output-port)))))
+      (map (lambda (n) (parse-frame (stack-ref stack n)))
+           (iota (stack-length stack)))
       '()))
 
+(define (parse-frame frame)
+  (list (cons 'frame (frame-number frame))
+        (cons 'procedure (or (and (frame-procedure? frame)
+                                  (procedure-name (frame-procedure frame)))
+                             '()))
+        (cons 'source (or (frame->source-position frame) '()))
+        (cons 'description (with-output-to-string
+                             (lambda ()
+                               (if (frame-procedure? frame)
+                                   (write-frame-short/application frame)
+                                   (write-frame-short/expression frame)))))))
+
+(define (frame->source-position frame)
+  (let ((source (if (frame-procedure? frame)
+                    (or (frame-source frame)
+                        (let ((proc (frame-procedure frame)))
+                          (and proc
+                               (procedure? proc)
+                               (procedure-source proc))))
+                    (frame-source frame))))
+    (and source
+         (cond ((string? (source-property source 'filename))
+                (list (source-property source 'filename)
+                      (+ 1 (source-property source 'line))
+                      (source-property source 'column)))
+               ((and (pair? source) (list? (cadr source)))
+                (list (caadr source)
+                      (+ 1 (caddr source))
+                      (cdddr source)))
+               (else #f)))))
+
 (define (parse-error key . args)
   (let* ((len (length args))
          (subr (and (> len 0) (first args)))
@@ -119,6 +151,6 @@ SUBR, MSG and REST."
 
 (define (ge:load-file path)
   "Load file, given its full @var{path}."
-  (evaluate `(compile-and-load ,path) '(geiser emacs) eval))
+  (evaluate `(load ,path) '(geiser emacs) eval))
 
 ;;; emacs.scm ends here
diff --git a/scheme/guile/geiser/introspection.scm b/scheme/guile/geiser/introspection.scm
index 29d059b..ca6afae 100644
--- a/scheme/guile/geiser/introspection.scm
+++ b/scheme/guile/geiser/introspection.scm
@@ -64,13 +64,14 @@
         (else #f)))
 
 (define (symbol-module sym)
-  (call/cc
-   (lambda (k)
-     (apropos-fold (lambda (module name var init)
-                     (if (eq? name sym) (k (module-name module)) init))
-                   #f
-                   (symbol->string sym)
-                   (apropos-fold-accessible (current-module))))))
+  (and sym
+       (call/cc
+        (lambda (k)
+          (apropos-fold (lambda (module name var init)
+                          (if (eq? name sym) (k (module-name module)) init))
+                        #f
+                        (symbol->string sym)
+                        (apropos-fold-accessible (current-module)))))))
 
 (define (program-args program)
   (let* ((arity (program-arity program))