summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDaniel Llorens <lloda@sarc.name>2020-01-03 12:08:48 +0100
committerDaniel Llorens <lloda@sarc.name>2024-12-02 13:23:26 +0100
commited5e37caa00a4f36ebea71abb38b3af7706fc3ec (patch)
tree77fd4c45182e7b49c1c944a4b8a0ff618e76d2ae
parentbb7154fb800eb410fb7cc4c353975787353f2246 (diff)
downloadguile-ed5e37caa00a4f36ebea71abb38b3af7706fc3ec.tar.gz
Provide a hook for the exception printerwip-exception-truncate
-rw-r--r--module/ice-9/boot-9.scm15
1 files changed, 9 insertions, 6 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 04f84215c..656456a9f 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -329,6 +329,7 @@ If returning early, return the return value of F."
;; let format alias simple-format until the more complete version is loaded
(define format simple-format)
+(define exception-format simple-format)
;; this is scheme wrapping the C code so the final pred call is a tail call,
;; per SRFI-13 spec
@@ -1895,7 +1896,7 @@ non-locally, that exit determines the continuation."
(set! print-exception
(lambda (port frame key args)
(define (default-printer)
- (format port "Throw to key `~a' with args `~s'." key args))
+ (exception-format port "Throw to key `~a' with args `~s'." key args))
(when frame
(print-location frame port)
@@ -1913,7 +1914,9 @@ non-locally, that exit determines the continuation."
(printer port key args default-printer)
(default-printer))))
(lambda (k . args)
- (format port "Error while printing exception.")))
+ (exception-format
+ port "Error while printing exception `~a`: `~a' with args [~s]"
+ key k args)))
(newline port)
(force-output port))))
@@ -1928,7 +1931,7 @@ non-locally, that exit determines the continuation."
((subr msg args . rest)
(if subr
(format port "In procedure ~a: " subr))
- (apply format port msg (or args '())))
+ (apply exception-format port msg (or args '())))
(_ (default-printer)))
args))
@@ -1955,7 +1958,7 @@ non-locally, that exit determines the continuation."
(define (keyword-error-printer port key args default-printer)
(let ((message (cadr args))
(faulty (car (cadddr args)))) ; I won't do it again, I promise.
- (format port "~a: ~s" message faulty)))
+ (exception-format port "~a: ~s" message faulty)))
(define (getaddrinfo-error-printer port key args default-printer)
(format port "In procedure getaddrinfo: ~a" (gai-strerror (car args))))
@@ -2172,11 +2175,11 @@ non-locally, that exit determines the continuation."
(lambda (key . args)
(for-each (lambda (s)
(if (not (string-null? s))
- (format (current-warning-port) ";;; ~a\n" s)))
+ (exception-format (current-warning-port) ";;; ~a\n" s)))
(string-split
(call-with-output-string
(lambda (port)
- (format port template arg ...)
+ (exception-format port template arg ...)
(print-exception port #f key args)))
#\newline))
#f)))))