summaryrefslogtreecommitdiff
path: root/scheme
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2010-06-05 23:55:14 +0200
committerJose Antonio Ortega Ruiz <jao@gnu.org>2010-06-05 23:55:14 +0200
commit098070ce89f21d692261fe49d07319ee1d7fdd66 (patch)
tree235387f6403c0374577723d8b7d20fc5bd7d2f50 /scheme
parentfe69f305ea550c9822f280e574ba3d80dd3e3d0a (diff)
downloadgeiser-guile-098070ce89f21d692261fe49d07319ee1d7fdd66.tar.gz
geiser-guile-098070ce89f21d692261fe49d07319ee1d7fdd66.tar.bz2
Racket: providing error contexts
Diffstat (limited to 'scheme')
-rw-r--r--scheme/racket/geiser/eval.rkt26
1 files changed, 23 insertions, 3 deletions
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)