From: Andreas Rottmann Subject: Show R6RS exceptions in a reasonable way in the debugger * module/system/repl/error-handling/r6rs.scm: New module, containing a formatter for R6RS exception. * module/system/repl/error-handling.scm (error-string): Treat throws to `r6rs:exception' specially, calling out to `display-exception' from the above module. Use `module-ref' and `resolve-module' for referring to that procedure to make this a runtime-only dependency. * module/Makefile.am (SYSTEM_SOURCES): Add module/system/repl/error-handling/r6rs.scm. --- module/Makefile.am | 1 + module/system/repl/error-handling.scm | 25 +++++--- module/system/repl/error-handling/r6rs.scm | 93 ++++++++++++++++++++++++++++ 3 files changed, 111 insertions(+), 8 deletions(-) diff --git a/module/Makefile.am b/module/Makefile.am index 8086d82..3112760 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -323,6 +323,7 @@ SYSTEM_SOURCES = \ system/xref.scm \ system/repl/debug.scm \ system/repl/error-handling.scm \ + system/repl/error-handling/r6rs.scm \ system/repl/common.scm \ system/repl/command.scm \ system/repl/repl.scm \ diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm index 737eadf..619601f 100644 --- a/module/system/repl/error-handling.scm +++ b/module/system/repl/error-handling.scm @@ -34,15 +34,24 @@ ;;; (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)))) + (case key + ((r6rs:exception) + (let ((display-exception + (module-ref (resolve-module '(system repl error-handling r6rs)) + 'display-exception))) + (call-with-output-string + (lambda (port) + (display-exception stack port (car args)))))) (else - (format #f "Throw to key `~a' with args `~s'." 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* (call-with-error-handling thunk #:key (on-error 'debug) (post-error 'catch) diff --git a/module/system/repl/error-handling/r6rs.scm b/module/system/repl/error-handling/r6rs.scm new file mode 100644 index 0000000..200fead --- /dev/null +++ b/module/system/repl/error-handling/r6rs.scm @@ -0,0 +1,93 @@ +;;; REPL error handling support for R6RS + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU Lesser General Public License as +;; published by the Free Software Foundation; either version 3 of the +;; License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(define-module (system repl error-handling r6rs) + #:export (display-exception) + #:use-module ((rnrs control) #:select (when unless)) + #:use-module (rnrs records procedural) + #:use-module (rnrs records inspection) + #:use-module (rnrs conditions)) + +(define raise-object-wrapper-obj + (@@ (rnrs records procedural) raise-object-wrapper-obj)) + +(define (display-exception stack port wrapper) + (let ((obj (raise-object-wrapper-obj wrapper)) + (frame (and (< 0 (vector-length stack)) (vector-ref stack 0)))) + (cond ((condition? obj) + (display-error frame port #f + "R6RS exception:\n~a" + (list (call-with-output-string + (lambda (port) + (format-condition port obj)))) + '())) + (else + (display-error frame port #f + "R6RS exception: `~s'" (list obj) '()))))) + +(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))))))))))))) + -- tg: (fe15364..) t/r6rs-exception-print (depends on: master)