From: Andreas Rottmann Subject: Show R6RS exceptions in a reasonable way in the debugger * module/ice-9/boot-9.scm (exception-printer, set-exception-printer!): New procedures, implementing the exception printer registry. * module/system/repl/error-handling.scm (error-string): Replaced with `print-exception' procedure which makes use of the exception printer registry. Call sites adjusted. * module/rnrs/exceptions.scm (exception-printer, format-condition, format-simple-condition): New procedures implementing an exception printer for R6RS exceptions. Register the exception printer for the `r6rs:exception' key. --- module/ice-9/boot-9.scm | 15 ++++++ module/rnrs/exceptions.scm | 83 ++++++++++++++++++++++++++++++++- module/system/repl/error-handling.scm | 50 +++++++++++--------- 3 files changed, 123 insertions(+), 25 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 29e2cd7..23b3123 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -197,6 +197,21 @@ If there is no handler at all, Guile prints an error and then exits." (apply (exception-handler) key args))))) +;; Procedures for looking up and registering exception printers. Hide +;; the shared state in a lexical contour. Note that this is a +;; Guile-internal API, and should not be used outside of Guile itself. + +(define exception-printer #f) +(define set-exception-printer! #f) + +(let ((exception-printers '())) + (set! exception-printer + (lambda (key) + (assq-ref exception-printers key))) + (set! set-exception-printer! + (lambda (key proc) + (set! exception-printers (acons key proc exception-printers))))) + ;;; {R4RS compliance} diff --git a/module/rnrs/exceptions.scm b/module/rnrs/exceptions.scm index ff4049b..95d01df 100644 --- a/module/rnrs/exceptions.scm +++ b/module/rnrs/exceptions.scm @@ -1,6 +1,6 @@ ;;; exceptions.scm --- The R6RS exceptions library -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -20,9 +20,19 @@ (library (rnrs exceptions (6)) (export guard with-exception-handler raise raise-continuable) (import (rnrs base (6)) + (rnrs control (6)) (rnrs conditions (6)) (rnrs records procedural (6)) - (only (guile) with-throw-handler *unspecified* @@)) + (rnrs records inspection (6)) + (only (guile) + format + newline + display + filter + set-exception-printer! + with-throw-handler + *unspecified* + @@)) (define raise (@@ (rnrs records procedural) r6rs-raise)) (define raise-continuable @@ -64,4 +74,73 @@ (guard0 (variable cond-clause ... (else else-clause ...)) . body)) ((_ (variable cond-clause ...) . body) (guard0 (variable cond-clause ... (else (raise variable))) . body)))) + + ;;; Exception printing + + (define (exception-printer port key args punt) + (cond ((and (= 1 (length args)) + (raise-object-wrapper? (car args))) + (let ((obj (raise-object-wrapper-obj (car args)))) + (cond ((condition? obj) + (display "ERROR: R6RS exception:\n" port) + (format-condition port obj)) + (else + (format port "ERROR: R6RS exception: `~s'" obj))))) + (else + (punt)))) + + (define (format-condition port condition) + (let ((components (simple-conditions condition))) + (if (null? components) + (format port "Empty condition object") + (let loop ((i 1) (components components)) + (cond ((pair? components) + (format port " ~a. " i) + (format-simple-condition port (car components)) + (when (pair? (cdr components)) + (newline port)) + (loop (+ i 1) (cdr components)))))))) + + (define (format-simple-condition port condition) + (define (print-rtd-fields rtd field-names) + (let ((n-fields (vector-length field-names))) + (do ((i 0 (+ i 1))) + ((>= i n-fields)) + (format port " ~a: ~s" + (vector-ref field-names i) + ((record-accessor rtd i) condition)) + (unless (= i (- n-fields 1)) + (newline port))))) + (let ((condition-name (record-type-name (record-rtd condition)))) + (let loop ((rtd (record-rtd condition)) + (rtd.fields-list '()) + (n-fields 0)) + (cond (rtd + (let ((field-names (record-type-field-names rtd))) + (loop (record-type-parent rtd) + (cons (cons rtd field-names) rtd.fields-list) + (+ n-fields (vector-length field-names))))) + (else + (let ((rtd.fields-list + (filter (lambda (rtd.fields) + (not (zero? (vector-length (cdr rtd.fields))))) + (reverse rtd.fields-list)))) + (case n-fields + ((0) (format port "~a" condition-name)) + ((1) (format port "~a: ~s" + condition-name + ((record-accessor (caar rtd.fields-list) 0) + condition))) + (else + (format port "~a:\n" condition-name) + (let loop ((lst rtd.fields-list)) + (when (pair? lst) + (let ((rtd.fields (car lst))) + (print-rtd-fields (car rtd.fields) (cdr rtd.fields)) + (when (pair? (cdr lst)) + (newline port)) + (loop (cdr lst))))))))))))) + + (set-exception-printer! 'r6rs:exception exception-printer) + ) diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm index 7d30bf0..a875496 100644 --- a/module/system/repl/error-handling.scm +++ b/module/system/repl/error-handling.scm @@ -1,6 +1,6 @@ ;;; Error handling in the REPL -;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc. ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -33,16 +33,18 @@ ;;; Error handling via repl debugging ;;; -(define (error-string stack key args) - (pmatch args - ((,subr ,msg ,args . ,rest) - (guard (> (vector-length stack) 0)) - (with-output-to-string - (lambda () - (display-error (vector-ref stack 0) (current-output-port) - subr msg args rest)))) - (else - (format #f "Throw to key `~a' with args `~s'." key args)))) +(define (print-exception port frame key args) + (define (print-default) + (pmatch args + ((,subr ,msg ,args . ,rest) + (display-error frame port subr msg args rest)) + (else + (format port "ERROR: Throw to key `~a' with args `~s'." key args)))) + (cond ((exception-printer key) + => (lambda (printer) + (printer port key args print-default))) + (else + (print-default)))) (define* (call-with-error-handling thunk #:key (on-error 'debug) (post-error 'catch) @@ -107,17 +109,12 @@ (if (memq key pass-keys) (apply throw key args) (begin - (pmatch args - ((,subr ,msg ,args . ,rest) - (with-saved-ports - (lambda () - (run-hook before-error-hook) - (display-error #f err subr msg args rest) - (run-hook after-error-hook) - (force-output err)))) - (else - (format err "\nERROR: uncaught throw to `~a', args: ~a\n" - key args))) + (with-saved-ports + (lambda () + (run-hook before-error-hook) + (print-exception err #f key args) + (run-hook after-error-hook) + (force-output err))) (if #f #f))))) ((catch) (lambda (key . args) @@ -145,7 +142,14 @@ ;; And one more frame, because %start-stack invoking ;; the start-stack thunk has its own frame too. 0 (and tag 1))) - (error-msg (error-string stack key args)) + (error-msg + (call-with-output-string + (lambda (port) + (print-exception port + (and (< 0 (vector-length stack)) + (vector-ref stack 0)) + key + args)))) (debug (make-debug stack 0 error-msg #f))) (with-saved-ports (lambda () -- tg: (9d427b2..) t/r6rs-exception-print (depends on: master)