[Guile-commits] 08/08: (wip) give a handle into format used in exceptions

[Daniel Llorens]

lloda pushed a commit to branch wip-exception-truncate
in repository guile.

commit 3b518ccca9f0b0a134a31caf9329254e79299179
Author: Daniel Llorens 
Date:   Tue Feb 7 12:42:20 2017 +0100

(wip) give a handle into format used in exceptions
---
 module/ice-9/boot-9.scm | 43 +++
 1 file changed, 23 insertions(+), 20 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a70cd11..a090013 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -333,6 +333,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
@@ -770,7 +771,7 @@ information is unavailable."
((not (car args)) 1)
(else 0
  (else
-  (format (current-error-port) "guile: uncaught throw to ~a: ~a\n"
+  (exception-format (current-error-port) "guile: uncaught throw to ~a: 
~a\n"
   key args)
   (primitive-exit 1
 
@@ -873,8 +874,8 @@ for key @var{k}, then invoke @var{thunk}."
   (let ((filename (or (cadr source) ""))
 (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)
@@ -883,7 +884,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)
@@ -892,7 +893,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
@@ -902,7 +903,9 @@ 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 `~a`: `~a' with args [~s]"
+   key k args)))
   (newline port)
   (force-output port
 
@@ -916,38 +919,38 @@ for key @var{k}, then invoke @var{thunk}."
 (apply (case-lambda
  ((subr msg args . rest)
   (if subr
-  (format port "In procedure ~a: " subr))
-  (apply format port msg (or args '(
+  (exception-format port "In procedure ~a: " subr))
+  (apply exception-format port msg (or args '(
  (_ (default-printer)))
args))
 
   (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" 

[Guile-commits] 08/08: (wip) give a handle into format used in exceptions

[Daniel Llorens]

lloda pushed a commit to branch wip-exception-truncate
in repository guile.

commit 61ccc726598c38c8f9fb774fed830e643243551f
Author: Daniel Llorens 
Date:   Tue Feb 7 12:42:20 2017 +0100

(wip) give a handle into format used in exceptions
---
 module/ice-9/boot-9.scm | 43 +++
 1 file changed, 23 insertions(+), 20 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a70cd11..a090013 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -333,6 +333,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
@@ -770,7 +771,7 @@ information is unavailable."
((not (car args)) 1)
(else 0
  (else
-  (format (current-error-port) "guile: uncaught throw to ~a: ~a\n"
+  (exception-format (current-error-port) "guile: uncaught throw to ~a: 
~a\n"
   key args)
   (primitive-exit 1
 
@@ -873,8 +874,8 @@ for key @var{k}, then invoke @var{thunk}."
   (let ((filename (or (cadr source) ""))
 (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)
@@ -883,7 +884,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)
@@ -892,7 +893,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
@@ -902,7 +903,9 @@ 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 `~a`: `~a' with args [~s]"
+   key k args)))
   (newline port)
   (force-output port
 
@@ -916,38 +919,38 @@ for key @var{k}, then invoke @var{thunk}."
 (apply (case-lambda
  ((subr msg args . rest)
   (if subr
-  (format port "In procedure ~a: " subr))
-  (apply format port msg (or args '(
+  (exception-format port "In procedure ~a: " subr))
+  (apply exception-format port msg (or args '(
  (_ (default-printer)))
args))
 
   (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" 

[Guile-commits] 08/08: (wip) give a handle into format used in exceptions

[Daniel Llorens]

lloda pushed a commit to branch wip-exception-truncate
in repository guile.

commit da01a6404fb6599d06f1a362b315efa2dc63f5b3
Author: Daniel Llorens 
Date:   Tue Feb 7 12:42:20 2017 +0100

(wip) give a handle into format used in exceptions
---
 module/ice-9/boot-9.scm | 43 +++
 1 file changed, 23 insertions(+), 20 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a70cd11..a090013 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -333,6 +333,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
@@ -770,7 +771,7 @@ information is unavailable."
((not (car args)) 1)
(else 0
  (else
-  (format (current-error-port) "guile: uncaught throw to ~a: ~a\n"
+  (exception-format (current-error-port) "guile: uncaught throw to ~a: 
~a\n"
   key args)
   (primitive-exit 1
 
@@ -873,8 +874,8 @@ for key @var{k}, then invoke @var{thunk}."
   (let ((filename (or (cadr source) ""))
 (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)
@@ -883,7 +884,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)
@@ -892,7 +893,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
@@ -902,7 +903,9 @@ 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 `~a`: `~a' with args [~s]"
+   key k args)))
   (newline port)
   (force-output port
 
@@ -916,38 +919,38 @@ for key @var{k}, then invoke @var{thunk}."
 (apply (case-lambda
  ((subr msg args . rest)
   (if subr
-  (format port "In procedure ~a: " subr))
-  (apply format port msg (or args '(
+  (exception-format port "In procedure ~a: " subr))
+  (apply exception-format port msg (or args '(
  (_ (default-printer)))
args))
 
   (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" 

[Guile-commits] 08/08: (wip) give a handle into format used in exceptions

[Daniel Llorens]

lloda pushed a commit to branch wip-exception-truncate
in repository guile.

commit 2ca7955983cb2475fbee1cebba5eb1ac48faced3
Author: Daniel Llorens 
Date:   Tue Feb 7 12:42:20 2017 +0100

(wip) give a handle into format used in exceptions
---
 module/ice-9/boot-9.scm | 43 +++
 1 file changed, 23 insertions(+), 20 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a70cd11..a090013 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -333,6 +333,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
@@ -770,7 +771,7 @@ information is unavailable."
((not (car args)) 1)
(else 0
  (else
-  (format (current-error-port) "guile: uncaught throw to ~a: ~a\n"
+  (exception-format (current-error-port) "guile: uncaught throw to ~a: 
~a\n"
   key args)
   (primitive-exit 1
 
@@ -873,8 +874,8 @@ for key @var{k}, then invoke @var{thunk}."
   (let ((filename (or (cadr source) ""))
 (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)
@@ -883,7 +884,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)
@@ -892,7 +893,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
@@ -902,7 +903,9 @@ 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 `~a`: `~a' with args [~s]"
+   key k args)))
   (newline port)
   (force-output port
 
@@ -916,38 +919,38 @@ for key @var{k}, then invoke @var{thunk}."
 (apply (case-lambda
  ((subr msg args . rest)
   (if subr
-  (format port "In procedure ~a: " subr))
-  (apply format port msg (or args '(
+  (exception-format port "In procedure ~a: " subr))
+  (apply exception-format port msg (or args '(
  (_ (default-printer)))
args))
 
   (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" 

[Guile-commits] 08/08: (wip) give a handle into format used in exceptions

[Daniel Llorens]

lloda pushed a commit to branch wip-exception-truncate
in repository guile.

commit e100132db224c0321f896cb67ce2d717f0ecdd87
Author: Daniel Llorens 
Date:   Tue Feb 7 12:42:20 2017 +0100

(wip) give a handle into format used in exceptions
---
 module/ice-9/boot-9.scm | 43 +++
 1 file changed, 23 insertions(+), 20 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 2777672..03f1362 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -330,6 +330,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
@@ -767,7 +768,7 @@ information is unavailable."
((not (car args)) 1)
(else 0
  (else
-  (format (current-error-port) "guile: uncaught throw to ~a: ~a\n"
+  (exception-format (current-error-port) "guile: uncaught throw to ~a: 
~a\n"
   key args)
   (primitive-exit 1
 
@@ -870,8 +871,8 @@ for key @var{k}, then invoke @var{thunk}."
   (let ((filename (or (cadr source) ""))
 (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)
@@ -880,7 +881,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)
@@ -889,7 +890,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
@@ -899,7 +900,9 @@ 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 `~a`: `~a' with args [~s]"
+   key k args)))
   (newline port)
   (force-output port
 
@@ -913,38 +916,38 @@ for key @var{k}, then invoke @var{thunk}."
 (apply (case-lambda
  ((subr msg args . rest)
   (if subr
-  (format port "In procedure ~a: " subr))
-  (apply format port msg (or args '(
+  (exception-format port "In procedure ~a: " subr))
+  (apply exception-format port msg (or args '(
  (_ (default-printer)))
args))
 
   (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" 

[Guile-commits] 08/08: (wip) give a handle into format used in exceptions

[Daniel Llorens]

lloda pushed a commit to branch wip-exception-truncate
in repository guile.

commit b0d9386a43709c1859c41ab31747c0d3ed58dabc
Author: Daniel Llorens 
Date:   Tue Feb 7 12:42:20 2017 +0100

(wip) give a handle into format used in exceptions
---
 module/ice-9/boot-9.scm | 43 +++
 1 file changed, 23 insertions(+), 20 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 229d917..5e1b98f 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -339,6 +339,7 @@ a-cont
 ;; 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
@@ -770,7 +771,7 @@ information is unavailable."
((not (car args)) 1)
(else 0
  (else
-  (format (current-error-port) "guile: uncaught throw to ~a: ~a\n"
+  (exception-format (current-error-port) "guile: uncaught throw to ~a: 
~a\n"
   key args)
   (primitive-exit 1
 
@@ -873,8 +874,8 @@ for key @var{k}, then invoke @var{thunk}."
   (let ((filename (or (cadr source) ""))
 (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)
@@ -883,7 +884,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)
@@ -892,7 +893,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
@@ -902,7 +903,9 @@ 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 `~a`: `~a' with args [~s]"
+   key k args)))
   (newline port)
   (force-output port
 
@@ -916,38 +919,38 @@ for key @var{k}, then invoke @var{thunk}."
 (apply (case-lambda
  ((subr msg args . rest)
   (if subr
-  (format port "In procedure ~a: " subr))
-  (apply format port msg (or args '(
+  (exception-format port "In procedure ~a: " subr))
+  (apply exception-format port msg (or args '(
  (_ (default-printer)))
args))
 
   (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