From 73c8e10e31336b2d1232d833a96b45d1e21c2324 Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Thu, 2 Sep 2010 06:17:08 +0200
Subject: Racket: better stack traces using errortrace
---
elisp/geiser-racket.el | 9 +++++++++
scheme/racket/geiser.rkt | 2 ++
scheme/racket/geiser/eval.rkt | 26 +++++---------------------
3 files changed, 16 insertions(+), 21 deletions(-)
diff --git a/elisp/geiser-racket.el b/elisp/geiser-racket.el
index dcff4cc..d876714 100644
--- a/elisp/geiser-racket.el
+++ b/elisp/geiser-racket.el
@@ -158,6 +158,14 @@ This function uses `geiser-racket-init-file' if it exists."
"path:\"?\\([^>\"\n]+\\)\"?>"
"module: \"\\([^>\"\n]+\\)\""))
+(defconst geiser-racket--geiser-file-rx
+ "^/[^:\n\"]*/geiser/[^:\n\"]*:")
+
+(defun geiser-racket--purge-trace ()
+ (save-excursion
+ (while (re-search-forward geiser-racket--geiser-file-rx nil t)
+ (kill-whole-line))))
+
(defun geiser-racket--find-files (rx)
(save-excursion
(while (re-search-forward rx nil t)
@@ -179,6 +187,7 @@ This function uses `geiser-racket-init-file' if it exists."
(when key
(let ((end (point)))
(goto-char p)
+ (geiser-racket--purge-trace)
(mapc 'geiser-racket--find-files geiser-racket--file-rxs)
(goto-char end)
(newline)))))
diff --git a/scheme/racket/geiser.rkt b/scheme/racket/geiser.rkt
index 45d1289..1ab7983 100644
--- a/scheme/racket/geiser.rkt
+++ b/scheme/racket/geiser.rkt
@@ -17,6 +17,8 @@
"Racket version 5.0 or better required (found ~a)"
(version)))
+(require errortrace)
+
(require geiser/user)
;;; geiser.rkt ends here
diff --git a/scheme/racket/geiser/eval.rkt b/scheme/racket/geiser/eval.rkt
index de53728..f2cf39f 100644
--- a/scheme/racket/geiser/eval.rkt
+++ b/scheme/racket/geiser/eval.rkt
@@ -19,6 +19,7 @@
make-repl-reader)
(require geiser/enter geiser/modules geiser/autodoc)
+(require errortrace/errortrace-lib)
(define last-result (void))
@@ -30,28 +31,12 @@
(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))
(newline) (newline)
- (for-each display-exn-context (get-real-context e)))
+ (parameterize ([error-context-display-depth 10])
+ (print-error-trace (current-output-port) e)))
(define (write-value v)
(with-output-to-string
@@ -65,9 +50,8 @@
(let ([output
(with-output-to-string
(lambda ()
- (parameterize ([current-marks (current-continuation-marks)])
- (with-handlers ([exn? set-last-error])
- (call-with-values thunk set-last-result)))))])
+ (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