From a585a046ddc523cb69977c856f3386d8bb65c325 Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Sat, 21 Feb 2009 02:45:30 +0100
Subject: Capture backtrace. Fix load/compile from Emacs.

---
 elisp/geiser-compile.el       |  2 +-
 scheme/guile/geiser/emacs.scm | 21 ++++++++++++++++-----
 2 files changed, 17 insertions(+), 6 deletions(-)

diff --git a/elisp/geiser-compile.el b/elisp/geiser-compile.el
index 2c51425..ee6c5f8 100644
--- a/elisp/geiser-compile.el
+++ b/elisp/geiser-compile.el
@@ -76,7 +76,7 @@
          (msg (format "%s %s ..." msg path)))
     (message msg)
     (geiser-compile--display-result
-     msg (geiser-eval--send/wait `(:eval ((:ge ,op) ,path) (geiser eval))))))
+     msg (geiser-eval--send/wait `(:eval ((:ge ,op) ,path) (geiser emacs))))))
 
 
 ;;; User commands:
diff --git a/scheme/guile/geiser/emacs.scm b/scheme/guile/geiser/emacs.scm
index 382958d..d5e245b 100644
--- a/scheme/guile/geiser/emacs.scm
+++ b/scheme/guile/geiser/emacs.scm
@@ -37,16 +37,25 @@
                ge:module-children
                ge:module-location)
   #:use-module (srfi srfi-1)
+  #:use-module (system base compile)
   #:use-module ((geiser introspection) :renamer (symbol-prefix-proc 'ge:)))
 
 (define (write-result result output)
   (write (list (cons 'result result) (cons 'output output)))
   (newline))
 
-(define (write-error key . args)
-  (write (list (cons 'error (apply parse-error (cons key args)))))
+(define (write-error key args stack)
+  (write (list (cons 'error (apply parse-error (cons key args)))
+               (cons 'stack (parse-stack stack))))
   (newline))
 
+(define (parse-stack stack)
+  (if stack
+      (list
+       (with-output-to-string
+         (lambda () (display-backtrace stack (current-output-port)))))
+      '()))
+
 (define (parse-error key . args)
   (let* ((len (length args))
          (subr (and (> len 0) (first args)))
@@ -58,10 +67,11 @@
           (cons 'msg (if msg (apply format (cons #f (cons msg margs))) '()))
           (cons 'rest (or rest '())))))
 
-(define (evaluate form module evaluator)
+(define (evaluate form module-name evaluator)
   (let ((module (or (and (list? module-name)
                          (resolve-module module-name))
-                    (current-module))))
+                    (current-module)))
+        (captured-stack #f))
     (catch #t
       (lambda ()
         (let ((result #f))
@@ -69,7 +79,8 @@
                           (lambda ()
                             (set! result (evaluator form module))))))
             (write-result result output))))
-      write-error)))
+      (lambda (key . args) (write-error key args captured-stack))
+      (lambda (key . args) (set! captured-stack (make-stack #t))))))
 
 (define (eval-compile form module)
   (save-module-excursion
-- 
cgit v1.2.3