[PATCH] Let (format) used in exceptions be overriden

[d***@bluewin.ch]

From: Daniel Llorens <***@bluewin.ch>

* module/ice-9/boot-9.scm (exception-format): new variable. Globally
replace uses of (format) by (exception-format).
---
module/ice-9/boot-9.scm | 52 ++++++++++++++++++++++++++-----------------------
1 file changed, 28 insertions(+), 24 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 802ca7735..b4d91c350 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -340,6 +340,10 @@ a-cont

(define format simple-format)

+;; let format used in exceptions be overriden.
+
+(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
(define string-any
@@ -736,7 +740,7 @@ information is unavailable."
((integer? (car args)) (car args))
((not (car args)) 1)
(else 0))))
- (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" key args)
+ (exception-format (current-error-port) "guile: uncaught throw to ~a: ~a\n" key args)
(primitive-exit 1))

(let ((catch-key (exception-handler-catch-key handler))
@@ -862,8 +866,8 @@ for key @var{k}, then invoke @var{thunk}."
(let ((filename (or (cadr source) "<unnamed port>"))
(line (caddr source))
(col (cdddr source)))
- (format port "~a:~a:~a: " filename (1+ line) col))
- (format port "ERROR: "))))
+ (exception-format port "~a:~a:~a: " filename (1+ line) col))
+ (exception-format port "ERROR: "))))

(set! set-exception-printer!
(lambda (key proc)
@@ -872,7 +876,7 @@ for key @var{k}, then invoke @var{thunk}."
(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)
@@ -881,7 +885,7 @@ for key @var{k}, then invoke @var{thunk}."
(lambda () (frame-procedure-name frame))
(lambda _ #f))))
(when name
- (format port "In procedure ~a:\n" name))))
+ (exception-format port "In procedure ~a:\n" name))))

(print-location frame port)
(catch #t
@@ -891,7 +895,7 @@ for key @var{k}, then invoke @var{thunk}."
(printer port key args default-printer)
(default-printer))))
(lambda (k . args)
- (format port "Error while printing exception.")))
+ (exception-format port "Error while printing exception.")))
(newline port)
(force-output port))))

@@ -905,7 +909,7 @@ for key @var{k}, then invoke @var{thunk}."
(apply (case-lambda
((subr msg args . rest)
(if subr
- (format port "In procedure ~a: " subr))
+ (exception-format port "In procedure ~a: " subr))
(apply format port msg (or args '())))
(_ (default-printer)))
args))
@@ -913,30 +917,30 @@ for key @var{k}, then invoke @var{thunk}."
(define (syntax-error-printer port key args default-printer)
(apply (case-lambda
((who what where form subform . extra)
- (format port "Syntax error:\n")
+ (exception-format port "Syntax error:\n")
(if where
(let ((file (or (assq-ref where 'filename) "unknown file"))
(line (and=> (assq-ref where 'line) 1+))
(col (assq-ref where 'column)))
- (format port "~a:~a:~a: " file line col))
- (format port "unknown location: "))
+ (exception-format port "~a:~a:~a: " file line col))
+ (exception-format port "unknown location: "))
(if who
- (format port "~a: " who))
- (format port "~a" what)
+ (exception-format port "~a: " who))
+ (exception-format port "~a" what)
(if subform
- (format port " in subform ~s of ~s" subform form)
+ (exception-format port " in subform ~s of ~s" subform form)
(if form
- (format port " in form ~s" form))))
+ (exception-format port " in form ~s" form))))
(_ (default-printer)))
args))

(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))))
+ (exception-format port "In procedure getaddrinfo: ~a" (gai-strerror (car args))))

(set-exception-printer! 'goops-error scm-error-printer)
(set-exception-printer! 'host-not-found scm-error-printer)
@@ -1064,11 +1068,11 @@ VALUE."
(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)))))
@@ -1227,7 +1231,7 @@ VALUE."
(if (= (length args) nfields)
(apply make-struct rtd 0 args)
(scm-error 'wrong-number-of-args
- (format #f "make-~a" type-name)
+ (exception-format #f "make-~a" type-name)
"Wrong number of arguments" '() #f)))))))))

(define (default-record-printer s p)
@@ -3586,7 +3590,7 @@ but it fails to load."
#f))

(define (warn module name int1 val1 int2 val2 var val)
- (format (current-warning-port)
+ (exception-format (current-warning-port)
"WARNING: ~A: `~A' imported from both ~A and ~A\n"
(module-name module)
name
@@ -3608,7 +3612,7 @@ but it fails to load."
(define (warn-override-core module name int1 val1 int2 val2 var val)
(and (eq? int1 the-scm-module)
(begin
- (format (current-warning-port)
+ (exception-format (current-warning-port)
"WARNING: ~A: imported module ~A overrides core binding `~A'\n"
(module-name module)
(module-name int2)
@@ -3780,15 +3784,15 @@ when none is available, reading FILE-NAME with READER."
(load-thunk-from-file go-file-name)
(begin
(when gostat
- (format (current-warning-port)
+ (exception-format (current-warning-port)
";;; note: source file ~a\n;;; newer than compiled ~a\n"
name go-file-name))
(cond
(%load-should-auto-compile
(%warn-auto-compilation-enabled)
- (format (current-warning-port) ";;; compiling ~a\n" name)
+ (exception-format (current-warning-port) ";;; compiling ~a\n" name)
(let ((cfn (compile name)))
- (format (current-warning-port) ";;; compiled ~a\n" cfn)
+ (exception-format (current-warning-port) ";;; compiled ~a\n" cfn)
(load-thunk-from-file cfn)))
(else #f)))))
#:warning "WARNING: compilation of ~a failed:\n" name))

[Mark H Weaver]

Hi Daniel,

Post by d***@bluewin.ch
* module/ice-9/boot-9.scm (exception-format): new variable. Globally
replace uses of (format) by (exception-format).

What's the rationale for this proposed change?

All but one of the occurrences of 'format' that you replaced had a
literal (i.e. constant) format string that only uses the escapes
supported by 'simple-format', so I'm not sure why you need those to be
overridden.

The only occurrence with a non-literal format string that you changed is
in 'false-if-exception', in the case when the #:warning keyword is
passed by the user along with a template string and arguments.

In general, I'd like to strongly discourage the practice of modifying
global variables to swap in extended variants of widely used procedures
such as format. That method breaks down badly when two different
modules try to extend core functionality in different ways.

If you want to make 'false-if-exception' extensible, I would prefer to
instead provide a third syntax that allows the user to pass a custom
'format' procedure.

What do you think?

Regards,
Mark

[Daniel Llorens]

Post by Mark H Weaver

Post by d***@bluewin.ch
replace uses of (format) by (exception-format).

What's the rationale for this proposed change?
...

Hi Mark,

I don't know how that just ended on guile-devel. It's part of a patch series I sent last year and I don't remember reposting it. However, now that we're here...

I agree with your comments, this patch is a crude hack. I am not proposing it for inclusion in Guile. However the issue that prompted that patch is still outstanding. I depend on the patch myself to be able to use Guile.

The original post is here:

https://lists.gnu.org/archive/html/guile-devel/2017-02/msg00009.html

Here's a thread some time later:

https://lists.gnu.org/archive/html/guile-devel/2017-03/msg00053.html

There's a related bug:

https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29684

There's a further related bug:

https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29669

I believe the latter bug is solved with repl-option-set!. That's undocumented (and perhaps not very friendly). ,o print is kind of documented (https://www.gnu.org/software/guile/manual/html_node/System-Commands.html), although an example would be useful there.

I didn't see an equivalent for exception messages. I saw Ludovic's mention of set-exception-printer! (undocumented) and tbh I haven't tried to see if that could work. I haven't looked into customizing current-error-port either.

Now I think that printing truncated output by default (for either repl output or exception printers) would be better than the current situation. If the user wants to check the full objects in the error message they can always backtrace, and not every object has a useful representation anyway. truncated-print has bad performance cases, but those should be fixable.

But I don't think it's reasonable to format ~a an arbitrary object at the exception site.

Regards

Daniel

Post by Mark H Weaver
All but one of the occurrences of 'format' that you replaced had a
literal (i.e. constant) format string that only uses the escapes
supported by 'simple-format', so I'm not sure why you need those to be
overridden.
The only occurrence with a non-literal format string that you changed is
in 'false-if-exception', in the case when the #:warning keyword is
passed by the user along with a template string and arguments.
In general, I'd like to strongly discourage the practice of modifying
global variables to swap in extended variants of widely used procedures
such as format. That method breaks down badly when two different
modules try to extend core functionality in different ways.
If you want to make 'false-if-exception' extensible, I would prefer to
instead provide a third syntax that allows the user to pass a custom
'format' procedure.
What do you think?
Regards,
Mark