From 4608da2ac8d4bafa7b8acbd7a097e32e5eb2f764 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.

---
 geiser/emacs.scm | 40 ++++++++++++++++++++++++++++++++++++----
 1 file changed, 36 insertions(+), 4 deletions(-)

(limited to 'geiser/emacs.scm')

diff --git a/geiser/emacs.scm b/geiser/emacs.scm
index b9e2d67..90e03dd 100644
--- a/geiser/emacs.scm
+++ b/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
-- 
cgit v1.2.3