From 772cc05b1fe481a43be4c17c90ed3788cf37d2a6 Mon Sep 17 00:00:00 2001 From: David Pirotte Date: Wed, 13 Dec 2017 00:43:30 -0200 Subject: [PATCH 2/2] Allowing exception printers user customization * module/ice-9/boot-9.scm (exception-format, dispatch-exception, exception-printers, scm-error-printer, syntax-error-printer, keyword-error-printer, getaddrinfo-error-printer, false-if-exception, make-record-type): Instead of using 'format', let's define a specific format binding for exception printers, to allow its user customization. --- module/ice-9/boot-9.scm | 46 ++++++++++++++++++++++++++-------------------- 1 file changed, 26 insertions(+), 20 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 751a3bcd1..cbbedac15 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -326,6 +326,10 @@ If returning early, return the return value of F." (define format simple-format) +;; instead of using the above, let's define a specific format binding +;; for exception printers, to allow its user customization. +(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 @@ -762,7 +766,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)))) @@ -865,8 +869,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) @@ -875,7 +879,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) @@ -884,7 +888,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)))) (catch #t (lambda () @@ -893,7 +897,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)))) @@ -907,38 +913,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 (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) @@ -1066,11 +1072,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))))) @@ -1229,7 +1235,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) -- 2.15.1