From 098070ce89f21d692261fe49d07319ee1d7fdd66 Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Sat, 5 Jun 2010 23:55:14 +0200
Subject: Racket: providing error contexts
---
elisp/geiser-debug.el | 2 +-
scheme/racket/geiser/eval.rkt | 26 +++++++++++++++++++++++---
2 files changed, 24 insertions(+), 4 deletions(-)
diff --git a/elisp/geiser-debug.el b/elisp/geiser-debug.el
index fa30506..ad55d0b 100644
--- a/elisp/geiser-debug.el
+++ b/elisp/geiser-debug.el
@@ -67,7 +67,7 @@ non-null value.")
(erase-buffer)
(insert what)
(newline 2)
- (when res
+ (when (and res (not err))
(insert res)
(newline 2))
(unless (geiser-debug--display-error impl module key output)
diff --git a/scheme/racket/geiser/eval.rkt b/scheme/racket/geiser/eval.rkt
index e0bcffa..db50ded 100644
--- a/scheme/racket/geiser/eval.rkt
+++ b/scheme/racket/geiser/eval.rkt
@@ -30,9 +30,28 @@
(define (exn-key e)
(vector-ref (struct->vector e) 0))
+(define current-marks (make-parameter (current-continuation-marks)))
+
+(define (get-real-context e)
+ (let ((ec (continuation-mark-set->context (exn-continuation-marks e)))
+ (cc (continuation-mark-set->context (current-marks))))
+ (filter-not (lambda (c) (member c cc)) ec)))
+
+(define (display-exn-context c)
+ (define (maybe-display p x) (when x (display p) (display x)) x)
+ (when (and (pair? c) (cdr c))
+ (let ((sloc (cdr c)))
+ (and (maybe-display "" (srcloc-source sloc))
+ (maybe-display ":" (srcloc-line sloc))
+ (maybe-display ":" (srcloc-column sloc)))
+ (maybe-display ": " (car c))
+ (newline))))
+
(define (set-last-error e)
(set! last-result `((error (key . ,(exn-key e)))))
- (display (exn-message e)))
+ (display (exn-message e))
+ (newline) (newline)
+ (for-each display-exn-context (get-real-context e)))
(define (write-value v)
(with-output-to-string
@@ -46,8 +65,9 @@
(let ((output
(with-output-to-string
(lambda ()
- (with-handlers ((exn? set-last-error))
- (call-with-values thunk set-last-result))))))
+ (parameterize ((current-marks (current-continuation-marks)))
+ (with-handlers ((exn? set-last-error))
+ (call-with-values thunk set-last-result)))))))
(append last-result `((output . ,output)))))
(define (eval-in form spec lang)
--
cgit v1.2.3