summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2009-02-21 04:22:07 +0100
committerJose Antonio Ortega Ruiz <jao@gnu.org>2009-02-21 04:22:07 +0100
commit612c7390fc3ff78ac9b0b10b83304095cfceccd5 (patch)
tree171732c34a0b1a1ae14b7620788880c01c29c2b6
parenta585a046ddc523cb69977c856f3386d8bb65c325 (diff)
downloadgeiser-chez-612c7390fc3ff78ac9b0b10b83304095cfceccd5.tar.gz
geiser-chez-612c7390fc3ff78ac9b0b10b83304095cfceccd5.tar.bz2
Better stack delimitation: include only frames relevant to the eval'd expression.
-rw-r--r--scheme/guile/geiser/emacs.scm38
1 files changed, 21 insertions, 17 deletions
diff --git a/scheme/guile/geiser/emacs.scm b/scheme/guile/geiser/emacs.scm
index d5e245b..147af7c 100644
--- a/scheme/guile/geiser/emacs.scm
+++ b/scheme/guile/geiser/emacs.scm
@@ -40,14 +40,12 @@
#: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 (make-result result output)
+ (list (cons 'result result) (cons 'output output)))
-(define (write-error key args stack)
- (write (list (cons 'error (apply parse-error (cons key args)))
- (cons 'stack (parse-stack stack))))
- (newline))
+(define (make-error key args stack)
+ (list (cons 'error (apply parse-error (cons key args)))
+ (cons 'stack (parse-stack stack))))
(define (parse-stack stack)
(if stack
@@ -71,16 +69,22 @@
(let ((module (or (and (list? module-name)
(resolve-module module-name))
(current-module)))
- (captured-stack #f))
- (catch #t
- (lambda ()
- (let ((result #f))
- (let ((output (with-output-to-string
- (lambda ()
- (set! result (evaluator form module))))))
- (write-result result output))))
- (lambda (key . args) (write-error key args captured-stack))
- (lambda (key . args) (set! captured-stack (make-stack #t))))))
+ (result #f)
+ (captured-stack #f)
+ (error #f))
+ (let ((output
+ (with-output-to-string
+ (lambda ()
+ (set! result
+ (catch #t
+ (lambda ()
+ (start-stack 'id (evaluator form module)))
+ (lambda (key . args)
+ (set! error (make-error key args captured-stack)))
+ (lambda (key . args)
+ (set! captured-stack (make-stack #t 2 2)))))))))
+ (write (or error (make-result result output)))
+ (newline))))
(define (eval-compile form module)
(save-module-excursion