[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: Provide a hook for the exception printer
From: |
Daniel Llorens |
Subject: |
[Guile-commits] 02/02: Provide a hook for the exception printer |
Date: |
Fri, 7 Feb 2020 05:20:22 -0500 (EST) |
lloda pushed a commit to branch wip-exception-truncate
in repository guile.
commit 52b878ced53da93f4a3ef7cf0d31d0e05e93d0af
Author: Daniel Llorens <address@hidden>
AuthorDate: Fri Jan 3 12:08:48 2020 +0100
Provide a hook for the exception printer
---
module/ice-9/boot-9.scm | 53 ++++++++++++++++++++++++++-----------------------
1 file changed, 28 insertions(+), 25 deletions(-)
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 39efcb5..397b872 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -322,6 +322,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
@@ -1019,7 +1020,7 @@ VALUE."
(if (= (length args) nfields)
(apply make-struct/no-tail rtd 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)
@@ -1840,8 +1841,8 @@ non-locally, that exit determines the continuation."
(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)
@@ -1850,7 +1851,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)
@@ -1859,7 +1860,7 @@ non-locally, that exit determines the continuation."
(lambda () (frame-procedure-name frame))
(lambda _ #f))))
(when name
- (format port "In procedure ~a:\n" name))))
+ (exception-format port "In procedure ~a:\n" name))))
(catch #t
(lambda ()
@@ -1868,7 +1869,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))))
@@ -1882,38 +1885,38 @@ non-locally, that exit determines the continuation."
(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 (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)
@@ -2127,11 +2130,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)))))
@@ -4096,7 +4099,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
@@ -4118,7 +4121,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)
@@ -4291,15 +4294,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))
@@ -4372,7 +4375,7 @@ when none is available, reading FILE-NAME with READER."
(dir (and (string? file) (dirname file))))
;; A module that uses `load' is not declarative.
(when (module-declarative? (current-module))
- (format (current-warning-port)
+ (exception-format (current-warning-port)
"WARNING: Use of `load' in declarative module ~A. ~A\n"
(module-name (current-module))
"Add #:declarative? #f to your define-module invocation.")