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

[daniel . llorens]

From: Daniel Llorens <address@hidden>

* 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))
-- 
2.11.0