From 641449ca6073648d5722d1a552d3a5245d523e48 Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Tue, 24 Feb 2009 02:18:28 +0100
Subject: Partial support for stack trace display.

---
 scheme/guile/geiser/emacs.scm         | 40 +++++++++++++++++++++++++++++++----
 scheme/guile/geiser/introspection.scm | 15 +++++++------
 2 files changed, 44 insertions(+), 11 deletions(-)

(limited to 'scheme')

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))
-- 
cgit v1.2.3