diff options
| -rw-r--r-- | geiser-chez.el | 21 | ||||
| -rw-r--r-- | src/geiser/geiser.ss | 47 |
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))) |