summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--geiser-chez.el21
-rw-r--r--src/geiser/geiser.ss47
2 files changed, 40 insertions, 28 deletions
diff --git a/geiser-chez.el b/geiser-chez.el
index ef9f29a..9491a65 100644
--- a/geiser-chez.el
+++ b/geiser-chez.el
@@ -65,10 +65,6 @@ host."
(define-obsolete-variable-alias 'geiser-chez-debug-on-exception-p
'geiser-chez-debug-on-exception "0.18")
-(geiser-custom--defcustom geiser-chez-show-error-on-debug t
- "Whether to issue a `show condition' command upon entering the debugger."
- :type 'boolean)
-
(defconst geiser-chez-minimum-version "9.4")
;;; REPL support
@@ -183,15 +179,24 @@ Return its local name."
(geiser-repl-switch nil 'chez)
(compilation-forget-errors)
(geiser-repl--send "(debug)")
- (when geiser-chez-show-error-on-debug (geiser-repl--send "s"))
t))
(defun geiser-chez--display-error (_module key msg)
"Display an error found during evaluation with the given KEY and message MSG."
- (when (stringp msg)
- (save-excursion (insert msg))
+ (when msg
+ (save-excursion
+ (insert (car msg))
+ (when-let (loc (cdr msg))
+ (let ((file (cdr (assoc "file" loc)))
+ (line (or (cdr (assoc "line" loc)) ""))
+ (col (or (cdr (assoc "column" loc)) (cdr (assoc "char" loc))))
+ (name (cdr (assoc "name" loc))))
+ (insert "\n\n" file (format ":%s" line))
+ (when col (insert (format ":%s" col)))
+ (when name (insert (format " (%s)" name))))
+ (insert "\n")))
(geiser-edit--buttonize-files)
- (not (zerop (length msg)))))
+ t))
;;; Keywords and syntax
diff --git a/src/geiser/geiser.ss b/src/geiser/geiser.ss
index 0d3928c..f040413 100644
--- a/src/geiser/geiser.ss
+++ b/src/geiser/geiser.ss
@@ -37,6 +37,25 @@
(print-vector-length #t))
(as-string (pretty-print x))))
+ (define (code-location obj)
+ (let* ((i (inspect/object obj))
+ (c (and i (i 'code))))
+ (if c
+ (let ((name `("name" . ,(or (c 'name) (write-to-string obj)))))
+ (call-with-values (lambda () (c 'source-path))
+ (case-lambda
+ ((path line col)
+ `(,name ("file" . ,path) ("line" . ,line) ("column" . ,col)))
+ ((path char)
+ `((,name) ("file" . ,path) ("char" . ,char)))
+ (() #f))))
+ #f)))
+
+ (define (condition-location c)
+ (let ((finder (make-object-finder procedure? c (collect-maximum-generation))))
+ (let loop ((obj (finder)))
+ (if obj (or (code-location (car obj)) (loop (finder))) '()))))
+
(define (call-with-result thunk)
(let ((output-string (open-output-string)))
(write
@@ -45,11 +64,12 @@
(with-exception-handler
(lambda (e)
(debug-condition e) ; save the condition for the debugger
- (k `((result "")
- (output . ,(get-output-string output-string))
- (debug 1)
- (error (key . condition)
- (msg . ,(as-string (display-condition e)))))))
+ (let ((loc (or (condition-location e) '()))
+ (desc (as-string (display-condition e))))
+ (k `((result "")
+ (output . ,(get-output-string output-string))
+ (error (key . condition)
+ (msg . ,(cons desc loc)))))))
(lambda ()
(call-with-values
(lambda ()
@@ -242,21 +262,8 @@
(else (map id-autodoc ids))))
(define (geiser:symbol-location id)
- (let* ([b (try-eval id)]
- [c (and (not (eq? not-found b))
- ((inspect/object b) 'code))])
- (if c
- (call-with-values (lambda () (c 'source-path))
- (lambda (path line . col)
- (let ((line (if (null? col) '() line))
- (char (if (null? col) line '()))
- (col (if (null? col) '() (car col))))
- `(("name" . ,(c 'name))
- ("file" . ,path)
- ("line" . ,line)
- ("column" . ,col)
- ("char" . ,char)))))
- '())))
+ (let ([b (try-eval id)])
+ (or (and (not (eq? not-found b)) (code-location b)) '())))
(define (geiser:module-location id)
(let ((obj (library-object-filename id)))